package Site::Util; ###### Site-wide utilities
###	$Id: Util.pm,v 1.7 2003/05/09 19:32:14 steve Exp $

### Site::Util provides file- and directory-manipulation utilities.

BEGIN {
    use Exporter();
    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $cvsid = '$Id: Util.pm,v 1.7 2003/05/09 19:32:14 steve Exp $ ';
    $cvsid =~ /,v ([0-9]+.[0-9]+)/;
    $VERSION=$1;
    @ISA = qw(Exporter);
    
    
    @EXPORT = ( # Commonly-used, simple utilities.
		qw(&getFile &getFirstLine &putFile &getDirectory &parentPath
		   &linkifyPath &entityEncode
		   &splitQuery &readConfig ),
		);

}

use AMP::Tagset;



##########################################################################
### 
### Path Manipulation:
###

### expandIndexPath($path)
#	expand ...//... constructs in $path
#
# === really need to test for possible one-level directory ===
# === top level is two-level; others should be one-level
#
sub expandIndexPath {
    my ($path) = @_;
    my $p = "$path";
    $p =~ s|//(.)(.)|/$1/$1$2/$1$2|;
    return $p;
}


##########################################################################
### 
### Initialization:
###


### readConfig($hash, $CF, $pfx) -> hash
#	Read the site configuration file.
#	It is in name = value format, essentially the same as a 
#	Java properties properties file.
sub readConfig {
    my ($hash, $cf, $pfx) = (@_);
    $hash = {} unless ref $hash;
    $pfx = "" unless $pfx;

    if (open(IN, $cf)) {
	while (<IN>) { 
	    next if /^[;\#]/;	# ignore comments
	    # === ignore " # .*$"
	    next unless /^[ \t]*([^ \t=]+)[ \t]*=[ \t]*(.*)$/;
	    $hash->{$pfx . $1} = $2;
	}
    }
    return $hash;
}


##########################################################################
### 
### Utilities:
###

sub getFile {
    my ($fp) = (@_);
    my $s = '';
    if (open(IN, $fp)) {
	while (<IN>) { 
	    $s .= $_;
	}
    }
    return $s;
}


### getFirstLine($pathname)
#	Suck in the first line of a file
#	Return undefined if it doesn't exist.
sub getFirstLine {
    my ($fn) = (@_);
    my $s;
    if (open(IN, $fn)) {
	while (<IN>) { $s = $_;  last;}
	close IN;
    }
    $s =~ s/[\n\r]//gs;
    return $s;
}


### putFile($pathname, $string) 
#	print a string into a file.  If the file was a symlink,
#	remove it to ensure that we don't clobber the original.
sub putFile {
    my ($fn, $s) = (@_);
    if (-l $fn) { unlink($fn); }
    if (open(OUT, ">$fn")) {
	print OUT $s;
	print OUT "\n" unless $s =~ /\n$/s;
	close OUT;
	return 1;
    }
    return 0;
}

### getDirectory($pathname)
#	Return a list of the files in a directory as an array
sub getDirectory {
    my ($dir) = (@_);
    if (!opendir(DIR, "$dir")) { return ''; } 
    my @files = sort readdir(DIR);
    closedir(DIR);
    return @files;
}

sub parentPath {
    my ($path) = @_;
    if ($path =~ m|^(.*)/[^/]+/?$|) { return "$1"; }
    else { return "/"; }
}

sub fileName {
    my ($path) = @_;
    if ($path =~ m|/([^/]+)/?$|) { return "$1"; }
    else { return ""; }
}

sub baseName {
    my ($path) = @_;
    my $fn = fileName($path);
    $fn =~ s|(\.[^./]*)?$||;
    return $fn;
}

### linkifyPath($path, $sep)
#	Make the given path into a sequence of links to its components.
#	The links are separated by $sep (default "/"). 
sub linkifyPath {
    my ($path, $sep) = (@_);
    my $result = '';
    my $pfx = '';

    while ($path =~ s|^(/+)([^/]+)/(.)|/$3| ) {
	$result .= $sep? $sep : $1;
	$result .= "<a href='$pfx$1$2/'>$2</a>";
	$pfx .= $1 . $2;
    }
    return $result . $path;
}


### splitQuery() => hash
#	split the query string (in $ENV{QUERY_STRING})
#	and returns a hash of the individual name=value pairs
#
#	All values are URLdecoded, which is wrong in general but OK for us.  
#	Names with no value (booleans) are paired with themsleves, SGML style.
#
#	This is an alternative to CGI that works better with old browsers
#	and hand-coded stuff that occasionally puts names without values
#	into the query string.  It's a bad idea in general.
#
sub splitQuery {
    my ($q, $u, $v);
    my @query = split(/\&/, $ENV{QUERY_STRING});
    my $query = {};
    foreach $q (@query) {
	if ($q =~ /^([a-zA-Z0-9_]+)=([-a-zA-Z0-9.\[\]\/\@:_+?%&~]*)$/) {
	    $u = $1;
	    $v = $2;
	    $v =~ s/\+/ /g;
	    $v =~ s/%(\w\w)/sprintf("%c", hex($1))/ge; # URL decode
	} elsif ($q =~ /^([a-zA-Z0-9_]+)$/) {
	    $u = $1;
	    $v = $1;
	} else {
	    $q =~ /^([a-zA-Z0-9_]+)=(.*)$/;
	    $u = $1;
	    $v = $2;
	}
	$query->{$u} = $v;
    }
    return $query;
}


##########################################################################
# Encode/decode:
##########################################################################


### urlEncode($string) 
#	encode $string for use as a URL, with %xx escapes for 
#	special characters.
sub urlEncode {
    my $v = shift;
    $v =~ s/([^- a-zA-Z0-9\/._\&\#\?:])/'%'.sprintf("%02x", ord($1))/ge;
    $v =~ s/ /+/g;
    return $v;
}

# urlEncodeFile(filename)
#	encode a filename using URL encoding -- encodes &, # and ?, which 
#	are normally left alone because they're significant in URL's.
sub urlEncodeFile {
    my $v = shift;
    $v =~ s/([^- a-zA-Z0-9\/._])/'%'.sprintf("%02x", ord($1))/ge;
    $v =~ s/ /+/g;
    return $v;
}

sub urlDecode {
    my $v = shift;
    $v =~ s/\+/ /g;
    $v =~ s/%(\w\w)/sprintf("%c", hex($1))/ge; # URL decode
    return $v;
}


sub entityEncode {
    my ($str) = (@_);
    $str =~ s/\&/\&amp;/gs;
    $str =~ s/\</\&lt;/gs;
    $str =~ s/\>/\&gt;/gs;
    return $str;
}

sub entityDecode {
    my $s = shift;

    $s =~ s/\&lt;/\</igs;
    $s =~ s/\&gt;/\>/igs;
    $s =~ s/\&amp;/\&/igs;

    return $s;
}

### headerEncode($s) 
#	encode $s (iff necessary) for use in a mail (subject) header. 
#	Uses rfc2047 encoding for UTF-8 if $s contains non-ASCII characters. 
#	Selects Q coding if $s is more than 50% ASCII
#
#  ===	see MIME::Words for the *right* way to do this!
#
sub headerEncode {
    my $s = trim(shift);
    my ($len, $n) = (length($s), 0);
    for (my $i=0; $i < $len; ++ $i) {
	my $c = substr($s, $i, 1);
	++ $n if ord($c) > 127;
	$x .= "," . ord($c);
    }
    if ($n == 0) { return $s; }
    elsif ($n <= $len/2) { return "=?UTF-8?Q?" . qEncode($s) . "?="; }
    else { return "=?UTF-8?B?" . bEncode($s) . "?="; }
}

sub qEncode {
    my $in = shift;
    my $out = '';
    my $specials = '()"?_=';	# for the general case: '()<>@,;:"/[]?.=_';
    
    my ($len, $n) = (length($in), 0);
    for (my $i=0; $i < $len; ++ $i) {
	my $c = substr($in, $i, 1);
	if ($c eq ' ') { $out .= "_"; }
	elsif (ord($c) > 127 || $specials =~ /$c/) { 
	    $out .= '=' . sprintf("%02x", ord($c)); }
	else { $out .= $c; }
    }
    return $out;
}

sub bEncode {
    my $in = shift;

    # === should really tag lines separately, but instead we squash them.
    # === a second argument of null would take care of this.
    return squash(MIME::Base64::encode($in));
}


##########################################################################
# text:
##########################################################################


### squash($s) 
#	Remove all whitespace, including newlines, from $s
sub squash {
    my $s = shift;
    $s =~ s/[ \t\n\r]*//gs;
    $s;
}

### trim($s)
#	Remove leading and trailing whitespace and newlines from $s
sub trim {
    my $s = shift;
    $s =~ s/^[ \t\n\r]*//s;	
    $s =~ s/[ \t\n\r]*$//s;	
    $s;
}

### wrapWords($text, $width) 
#	Wrap $text on word boundaries (spaces or tabs) whenever the line 
#	length is > 0 and adding the word would make the line length
#	exceed $width (72 default).  Leave long words alone.
sub wrapWords {
    my ($t, $n) = (@_);
    $n = 72 unless $n > 0;
    my $result = '';
    my $ll = 0;			# current line length
    my $in = 1;			# true in indentation at beginning of line

    while ($t) {
	if ($t =~ s/^([\r\n]+)//s) { $result .= $1; $ll = 0; $in = 1; }
	elsif ($t =~ s/^( )//) { 
	    if ($ll > $n) { $result .= "\n"; $ll = 0; $t =~ s/^ +//; }
	    else          { $result .= $1; $ll += 1; }
	}
	elsif ($t =~ s/^(\t)//){ 
	    if ($ll > $n) { $result .= "\n"; $ll = 0; }
	    else          { $result .= $1; $ll = ($ll + 8) % 8; }
	}
	elsif ($t =~ s/^([^ \t\r\n]+)//) { 
	    if (! $in && $ll + length($1) > $n) { 
		$result .= "\n"; $ll = 0;
	    }
	    $result .= $1; $ll += length($1); $in = 0;
	}
    }
    return $result;
}


###########################################################################
'Package loaded';
