Index: /main/trunk/greenstone2/perllib/cpan/Bundle/LWP.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/Bundle/LWP.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/Bundle/LWP.pm	(revision 27181)
@@ -0,0 +1,44 @@
+package Bundle::LWP;
+
+$VERSION = "5.835";
+
+1;
+
+__END__
+
+=head1 NAME
+
+Bundle::LWP - install all libwww-perl related modules
+
+=head1 SYNOPSIS
+
+ perl -MCPAN -e 'install Bundle::LWP'
+
+=head1 CONTENTS
+
+MIME::Base64       - Used in authentication headers
+
+Digest::MD5        - Needed to do Digest authentication
+
+URI 1.10           - There are URIs everywhere
+
+Net::FTP 2.58      - If you want ftp://-support
+
+HTML::Tagset       - Needed by HTML::Parser
+
+HTML::Parser       - Needed by HTML::HeadParser
+
+HTML::HeadParser   - To get the correct $res->base
+
+LWP                - The reason why you need the modules above
+
+=head1 DESCRIPTION
+
+This bundle defines all prerequisite modules for libwww-perl.  Bundles
+have special meaning for the CPAN module.  When you install the bundle
+module all modules mentioned in L</CONTENTS> will be installed
+instead.
+
+=head1 SEE ALSO
+
+L<CPAN/Bundles>
Index: /main/trunk/greenstone2/perllib/cpan/File/Listing.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/File/Listing.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/File/Listing.pm	(revision 27181)
@@ -0,0 +1,412 @@
+package File::Listing;
+
+sub Version { $VERSION; }
+$VERSION = "5.837";
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(parse_dir);
+
+use strict;
+
+use Carp ();
+use HTTP::Date qw(str2time);
+
+
+
+sub parse_dir ($;$$$)
+{
+   my($dir, $tz, $fstype, $error) = @_;
+
+   $fstype ||= 'unix';
+   $fstype = "File::Listing::" . lc $fstype;
+
+   my @args = $_[0];
+   push(@args, $tz) if(@_ >= 2);
+   push(@args, $error) if(@_ >= 4);
+
+   $fstype->parse(@args);
+}
+
+
+sub line { Carp::croak("Not implemented yet"); }
+sub init { } # Dummy sub
+
+
+sub file_mode ($)
+{
+    # This routine was originally borrowed from Graham Barr's
+    # Net::FTP package.
+
+    local $_ = shift;
+    my $mode = 0;
+    my($type,$ch);
+
+    s/^(.)// and $type = $1;
+
+    while (/(.)/g) {
+	$mode <<= 1;
+	$mode |= 1 if $1 ne "-" &&
+		      $1 ne 'S' &&
+		      $1 ne 't' &&
+		      $1 ne 'T';
+    }
+
+    $type eq "d" and $mode |= 0040000 or	# Directory
+      $type eq "l" and $mode |= 0120000 or	# Symbolic Link
+	$mode |= 0100000;			# Regular File
+
+    $mode |= 0004000 if /^...s....../i;
+    $mode |= 0002000 if /^......s.../i;
+    $mode |= 0001000 if /^.........t/i;
+
+    $mode;
+}
+
+
+sub parse
+{
+   my($pkg, $dir, $tz, $error) = @_;
+
+   # First let's try to determine what kind of dir parameter we have
+   # received.  We allow both listings, reference to arrays and
+   # file handles to read from.
+
+   if (ref($dir) eq 'ARRAY') {
+       # Already splitted up
+   }
+   elsif (ref($dir) eq 'GLOB') {
+       # A file handle
+   }
+   elsif (ref($dir)) {
+      Carp::croak("Illegal argument to parse_dir()");
+   }
+   elsif ($dir =~ /^\*\w+(::\w+)+$/) {
+      # This scalar looks like a file handle, so we assume it is
+   }
+   else {
+      # A normal scalar listing
+      $dir = [ split(/\n/, $dir) ];
+   }
+
+   $pkg->init();
+
+   my @files = ();
+   if (ref($dir) eq 'ARRAY') {
+       for (@$dir) {
+	   push(@files, $pkg->line($_, $tz, $error));
+       }
+   }
+   else {
+       local($_);
+       while (<$dir>) {
+	   chomp;
+	   push(@files, $pkg->line($_, $tz, $error));
+       }
+   }
+   wantarray ? @files : \@files;
+}
+
+
+
+package File::Listing::unix;
+
+use HTTP::Date qw(str2time);
+
+# A place to remember current directory from last line parsed.
+use vars qw($curdir @ISA);
+
+@ISA = qw(File::Listing);
+
+
+
+sub init
+{
+    $curdir = '';
+}
+
+
+sub line
+{
+    shift; # package name
+    local($_) = shift;
+    my($tz, $error) = @_;
+
+    s/\015//g;
+    #study;
+
+    my ($kind, $size, $date, $name);
+    if (($kind, $size, $date, $name) =
+	/^([\-FlrwxsStTdD]{10})                   # Type and permission bits
+	 .*                                       # Graps
+	 \D(\d+)                                  # File size
+	 \s+                                      # Some space
+	 (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2})  # Date
+	 \s+                                      # Some more space
+	 (.*)$                                    # File name
+	/x )
+
+    {
+	return if $name eq '.' || $name eq '..';
+	$name = "$curdir/$name" if length $curdir;
+	my $type = '?';
+	if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) {
+	    $name = $1;
+	    $type = "l $2";
+	}
+	elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file
+	    $type = 'f';
+	}
+	elsif ($kind =~ /^[dD]/) {
+	    $type = 'd';
+	    $size = undef;  # Don't believe the reported size
+	}
+	return [$name, $type, $size, str2time($date, $tz), 
+              File::Listing::file_mode($kind)];
+
+    }
+    elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) {
+	my $dir = $1;
+	return () if $dir eq '.';
+	$curdir = $dir;
+	return ();
+    }
+    elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
+	return ();
+    }
+    elsif (/not found/    || # OSF1, HPUX, and SunOS return
+             # "$file not found"
+             /No such file/ || # IRIX returns
+             # "UX:ls: ERROR: Cannot access $file: No such file or directory"
+                               # Solaris returns
+             # "$file: No such file or directory"
+             /cannot find/     # Windows NT returns
+             # "The system cannot find the path specified."
+             ) {
+	return () unless defined $error;
+	&$error($_) if ref($error) eq 'CODE';
+	warn "Error: $_\n" if $error eq 'warn';
+	return ();
+    }
+    elsif ($_ eq '') {       # AIX, and Linux return nothing
+	return () unless defined $error;
+	&$error("No such file or directory") if ref($error) eq 'CODE';
+	warn "Warning: No such file or directory\n" if $error eq 'warn';
+	return ();
+    }
+    else {
+        # parse failed, check if the dosftp parse understands it
+        File::Listing::dosftp->init();
+        return(File::Listing::dosftp->line($_,$tz,$error));
+    }
+
+}
+
+
+
+package File::Listing::dosftp;
+
+use HTTP::Date qw(str2time);
+
+# A place to remember current directory from last line parsed.
+use vars qw($curdir @ISA);
+
+@ISA = qw(File::Listing);
+
+
+
+sub init
+{
+    $curdir = '';
+}
+
+
+sub line
+{
+    shift; # package name
+    local($_) = shift;
+    my($tz, $error) = @_;
+
+    s/\015//g;
+
+    my ($date, $size_or_dir, $name, $size);
+
+    # 02-05-96  10:48AM                 1415 src.slf
+    # 09-10-96  09:18AM       <DIR>          sl_util
+    if (($date, $size_or_dir, $name) =
+        /^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM)         # Date and time info
+         \s+                                      # Some space
+         (<\w{3}>|\d+)                            # Dir or Size
+         \s+                                      # Some more space
+         (.+)$                                    # File name
+        /x )
+    {
+	return if $name eq '.' || $name eq '..';
+	$name = "$curdir/$name" if length $curdir;
+	my $type = '?';
+	if ($size_or_dir eq '<DIR>') {
+	    $type = "d";
+            $size = ""; # directories have no size in the pc listing
+        }
+        else {
+	    $type = 'f';
+            $size = $size_or_dir;
+	}
+	return [$name, $type, $size, str2time($date, $tz), undef];
+    }
+    else {
+	return () unless defined $error;
+	&$error($_) if ref($error) eq 'CODE';
+	warn "Can't parse: $_\n" if $error eq 'warn';
+	return ();
+    }
+
+}
+
+
+
+package File::Listing::vms;
+@File::Listing::vms::ISA = qw(File::Listing);
+
+package File::Listing::netware;
+@File::Listing::netware::ISA = qw(File::Listing);
+
+
+
+package File::Listing::apache;
+
+use vars qw(@ISA);
+
+@ISA = qw(File::Listing);
+
+
+sub init { }
+
+
+sub line {
+    shift; # package name
+    local($_) = shift;
+    my($tz, $error) = @_; # ignored for now...
+
+    if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) {
+	my($filename, $filesize) = ($1, $7);
+	my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6);
+	if ($m =~ /^\d+$/) {
+	    ($d,$y) = ($y,$d) # iso date
+	}
+	else {
+	    $m = _monthabbrev_number($m);
+	}
+
+	$filesize = 0 if $filesize eq '-';
+	if ($filesize =~ s/k$//i) {
+	    $filesize *= 1024;
+	}
+	elsif ($filesize =~ s/M$//) {
+	    $filesize *= 1024*1024;
+	}
+	elsif ($filesize =~ s/G$//) {
+	    $filesize *= 1024*1024*1024;
+	}
+	$filesize = int $filesize;
+
+	require Time::Local;
+	my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y)-1900);
+	my $filetype = ($filename =~ s|/$|| ? "d" : "f");
+	return [$filename, $filetype, $filesize, $filetime, undef];
+    }
+
+    return ();
+}
+
+
+sub _guess_year {
+    my $y = shift;
+    if ($y >= 90) {
+	$y = 1900+$y;
+    }
+    elsif ($y < 100) {
+	$y = 2000+$y;
+    }
+    $y;
+}
+
+
+sub _monthabbrev_number {
+    my $mon = shift;
+    +{'Jan' => 1,
+      'Feb' => 2,
+      'Mar' => 3,
+      'Apr' => 4,
+      'May' => 5,
+      'Jun' => 6,
+      'Jul' => 7,
+      'Aug' => 8,
+      'Sep' => 9,
+      'Oct' => 10,
+      'Nov' => 11,
+      'Dec' => 12,
+     }->{$mon};
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::Listing - parse directory listing
+
+=head1 SYNOPSIS
+
+ use File::Listing qw(parse_dir);
+ $ENV{LANG} = "C";  # dates in non-English locales not supported
+ for (parse_dir(`ls -l`)) {
+     ($name, $type, $size, $mtime, $mode) = @$_;
+     next if $type ne 'f'; # plain file
+     #...
+ }
+
+ # directory listing can also be read from a file
+ open(LISTING, "zcat ls-lR.gz|");
+ $dir = parse_dir(\*LISTING, '+0000');
+
+=head1 DESCRIPTION
+
+This module exports a single function called parse_dir(), which can be
+used to parse directory listings.
+
+The first parameter to parse_dir() is the directory listing to parse.
+It can be a scalar, a reference to an array of directory lines or a
+glob representing a filehandle to read the directory listing from.
+
+The second parameter is the time zone to use when parsing time stamps
+in the listing. If this value is undefined, then the local time zone is
+assumed.
+
+The third parameter is the type of listing to assume.  Currently
+supported formats are 'unix', 'apache' and 'dosftp'.  The default
+value 'unix'.  Ideally, the listing type should be determined
+automatically.
+
+The fourth parameter specifies how unparseable lines should be treated.
+Values can be 'ignore', 'warn' or a code reference.  Warn means that
+the perl warn() function will be called.  If a code reference is
+passed, then this routine will be called and the return value from it
+will be incorporated in the listing.  The default is 'ignore'.
+
+Only the first parameter is mandatory.
+
+The return value from parse_dir() is a list of directory entries.  In
+a scalar context the return value is a reference to the list.  The
+directory entries are represented by an array consisting of [
+$filename, $filetype, $filesize, $filetime, $filemode ].  The
+$filetype value is one of the letters 'f', 'd', 'l' or '?'.  The
+$filetime value is the seconds since Jan 1, 1970.  The
+$filemode is a bitmask like the mode returned by stat().
+
+=head1 CREDITS
+
+Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and
+Net::FTP's parse_dir (Graham Barr).
Index: /main/trunk/greenstone2/perllib/cpan/HTML/Form.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTML/Form.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/HTML/Form.pm	(revision 27181)
@@ -0,0 +1,1551 @@
+package HTML::Form;
+
+use strict;
+use URI;
+use Carp ();
+
+use vars qw($VERSION $Encode_available);
+$VERSION = "5.829";
+
+eval { require Encode };
+$Encode_available = !$@;
+
+my %form_tags = map {$_ => 1} qw(input textarea button select option);
+
+my %type2class = (
+ text     => "TextInput",
+ password => "TextInput",
+ hidden   => "TextInput",
+ textarea => "TextInput",
+
+ "reset"  => "IgnoreInput",
+
+ radio    => "ListInput",
+ checkbox => "ListInput",
+ option   => "ListInput",
+
+ button   => "SubmitInput",
+ submit   => "SubmitInput",
+ image    => "ImageInput",
+ file     => "FileInput",
+
+ keygen   => "KeygenInput",
+);
+
+=head1 NAME
+
+HTML::Form - Class that represents an HTML form element
+
+=head1 SYNOPSIS
+
+ use HTML::Form;
+ $form = HTML::Form->parse($html, $base_uri);
+ $form->value(query => "Perl");
+
+ use LWP::UserAgent;
+ $ua = LWP::UserAgent->new;
+ $response = $ua->request($form->click);
+
+=head1 DESCRIPTION
+
+Objects of the C<HTML::Form> class represents a single HTML
+C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance.  A form consists of a
+sequence of inputs that usually have names, and which can take on
+various values.  The state of a form can be tweaked and it can then be
+asked to provide C<HTTP::Request> objects that can be passed to the
+request() method of C<LWP::UserAgent>.
+
+The following methods are available:
+
+=over 4
+
+=item @forms = HTML::Form->parse( $html_document, $base_uri )
+
+=item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )
+
+=item @forms = HTML::Form->parse( $response, %opt )
+
+The parse() class method will parse an HTML document and build up
+C<HTML::Form> objects for each <form> element found.  If called in scalar
+context only returns the first <form>.  Returns an empty list if there
+are no forms to be found.
+
+The required arguments is the HTML document to parse ($html_document) and the
+URI used to retrieve the document ($base_uri).  The base URI is needed to resolve
+relative action URIs.  The provided HTML document should be a Unicode string
+(or US-ASCII).
+
+By default HTML::Form assumes that the original document was UTF-8 encoded and
+thus encode forms that don't specify an explict I<accept-charset> as UTF-8.
+The charset assumed can be overridden by providing the C<charset> option to
+parse().  It's a good idea to be explict about this parameter as well, thus
+the recommended simplest invocation becomes:
+
+    my @forms = HTML::Form->parse(
+        Encode::decode($encoding, $html_document_bytes),
+        base => $base_uri,
+	charset => $encoding,
+    );
+
+If the document was retrieved with LWP then the response object provide methods
+to obtain a proper value for C<base> and C<charset>:
+
+    my $ua = LWP::UserAgent->new;
+    my $response = $ua->get("http://www.example.com/form.html");
+    my @forms = HTML::Form->parse($response->decoded_content,
+	base => $response->base,
+	charset => $response->content_charset,
+    );
+
+In fact, the parse() method can parse from an C<HTTP::Response> object
+directly, so the example above can be more conveniently written as:
+
+    my $ua = LWP::UserAgent->new;
+    my $response = $ua->get("http://www.example.com/form.html");
+    my @forms = HTML::Form->parse($response);
+
+Note that any object that implements a decoded_content(), base() and
+content_charset() method with similar behaviour as C<HTTP::Response> will do.
+
+Additional options might be passed in to control how the parse method
+behaves.  The following are all the options currently recognized:
+
+=over
+
+=item C<< base => $uri >>
+
+This is the URI used to retrive the original document.  This option is not optional ;-)
+
+=item C<< charset => $str >>
+
+Specify what charset the original document was encoded in.  This is used as
+the default for accept_charset.  If not provided this defaults to "UTF-8".
+
+=item C<< verbose => $bool >>
+
+Warn (print messages to STDERR) about any bad HTML form constructs found.
+You can trap these with $SIG{__WARN__}.
+
+=item C<< strict => $bool >>
+
+Initialize any form objects with the given strict attribute.
+
+=back
+
+=cut
+
+sub parse
+{
+    my $class = shift;
+    my $html = shift;
+    unshift(@_, "base") if @_ == 1;
+    my %opt = @_;
+
+    require HTML::TokeParser;
+    my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
+    die "Failed to create HTML::TokeParser object" unless $p;
+
+    my $base_uri = delete $opt{base};
+    my $charset = delete $opt{charset};
+    my $strict = delete $opt{strict};
+    my $verbose = delete $opt{verbose};
+
+    if ($^W) {
+	Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
+    }
+
+    unless (defined $base_uri) {
+	if (ref($html)) {
+	    $base_uri = $html->base;
+	}
+	else {
+	    Carp::croak("HTML::Form::parse: No \$base_uri provided");
+	}
+    }
+    unless (defined $charset) {
+	if (ref($html) and $html->can("content_charset")) {
+	    $charset = $html->content_charset;
+	}
+	unless ($charset) {
+	    $charset = "UTF-8";
+	}
+    }
+
+    my @forms;
+    my $f;  # current form
+
+    my %openselect; # index to the open instance of a select
+
+    while (my $t = $p->get_tag) {
+	my($tag,$attr) = @$t;
+	if ($tag eq "form") {
+	    my $action = delete $attr->{'action'};
+	    $action = "" unless defined $action;
+	    $action = URI->new_abs($action, $base_uri);
+	    $f = $class->new($attr->{'method'},
+			     $action,
+			     $attr->{'enctype'});
+            $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
+	    $f->{default_charset} = $charset;
+	    $f->{attr} = $attr;
+	    $f->strict(1) if $strict;
+            %openselect = ();
+	    push(@forms, $f);
+	    my(%labels, $current_label);
+	    while (my $t = $p->get_tag) {
+		my($tag, $attr) = @$t;
+		last if $tag eq "/form";
+
+		# if we are inside a label tag, then keep
+		# appending any text to the current label
+		if(defined $current_label) {
+		    $current_label = join " ",
+		        grep { defined and length }
+		        $current_label,
+		        $p->get_phrase;
+		}
+
+		if ($tag eq "input") {
+		    $attr->{value_name} =
+		        exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
+			defined $current_label                            ?  $current_label      :
+		        $p->get_phrase;
+		}
+
+		if ($tag eq "label") {
+		    $current_label = $p->get_phrase;
+		    $labels{ $attr->{for} } = $current_label
+		        if exists $attr->{for};
+		}
+		elsif ($tag eq "/label") {
+		    $current_label = undef;
+		}
+		elsif ($tag eq "input") {
+		    my $type = delete $attr->{type} || "text";
+		    $f->push_input($type, $attr, $verbose);
+		}
+                elsif ($tag eq "button") {
+                    my $type = delete $attr->{type} || "submit";
+                    $f->push_input($type, $attr, $verbose);
+                }
+		elsif ($tag eq "textarea") {
+		    $attr->{textarea_value} = $attr->{value}
+		        if exists $attr->{value};
+		    my $text = $p->get_text("/textarea");
+		    $attr->{value} = $text;
+		    $f->push_input("textarea", $attr, $verbose);
+		}
+		elsif ($tag eq "select") {
+		    # rename attributes reserved to come for the option tag
+		    for ("value", "value_name") {
+			$attr->{"select_$_"} = delete $attr->{$_}
+			    if exists $attr->{$_};
+		    }
+		    # count this new select option separately
+		    my $name = $attr->{name};
+		    $name = "" unless defined $name;
+		    $openselect{$name}++;
+
+		    while ($t = $p->get_tag) {
+			my $tag = shift @$t;
+			last if $tag eq "/select";
+			next if $tag =~ m,/?optgroup,;
+			next if $tag eq "/option";
+			if ($tag eq "option") {
+			    my %a = %{$t->[0]};
+			    # rename keys so they don't clash with %attr
+			    for (keys %a) {
+				next if $_ eq "value";
+				$a{"option_$_"} = delete $a{$_};
+			    }
+			    while (my($k,$v) = each %$attr) {
+				$a{$k} = $v;
+			    }
+			    $a{value_name} = $p->get_trimmed_text;
+			    $a{value} = delete $a{value_name}
+				unless defined $a{value};
+			    $a{idx} = $openselect{$name};
+			    $f->push_input("option", \%a, $verbose);
+			}
+			else {
+			    warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
+			    if ($tag eq "/form" ||
+				$tag eq "input" ||
+				$tag eq "textarea" ||
+				$tag eq "select" ||
+				$tag eq "keygen")
+			    {
+				# MSIE implictly terminate the <select> here, so we
+				# try to do the same.  Actually the MSIE behaviour
+				# appears really strange:  <input> and <textarea>
+				# do implictly close, but not <select>, <keygen> or
+				# </form>.
+				my $type = ($tag =~ s,^/,,) ? "E" : "S";
+				$p->unget_token([$type, $tag, @$t]);
+				last;
+			    }
+			}
+		    }
+		}
+		elsif ($tag eq "keygen") {
+		    $f->push_input("keygen", $attr, $verbose);
+		}
+	    }
+	}
+	elsif ($form_tags{$tag}) {
+	    warn("<$tag> outside <form> in $base_uri\n") if $verbose;
+	}
+    }
+    for (@forms) {
+	$_->fixup;
+    }
+
+    wantarray ? @forms : $forms[0];
+}
+
+sub new {
+    my $class = shift;
+    my $self = bless {}, $class;
+    $self->{method} = uc(shift  || "GET");
+    $self->{action} = shift  || Carp::croak("No action defined");
+    $self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
+    $self->{accept_charset} = "UNKNOWN";
+    $self->{default_charset} = "UTF-8";
+    $self->{inputs} = [@_];
+    $self;
+}
+
+
+sub push_input
+{
+    my($self, $type, $attr, $verbose) = @_;
+    $type = lc $type;
+    my $class = $type2class{$type};
+    unless ($class) {
+	Carp::carp("Unknown input type '$type'") if $verbose;
+	$class = "TextInput";
+    }
+    $class = "HTML::Form::$class";
+    my @extra;
+    push(@extra, readonly => 1) if $type eq "hidden";
+    push(@extra, strict => 1) if $self->{strict};
+    if ($type eq "file" && exists $attr->{value}) {
+	# it's not safe to trust the value set by the server
+	# the user always need to explictly set the names of files to upload
+	$attr->{orig_value} = delete $attr->{value};
+    }
+    delete $attr->{type}; # don't confuse the type argument
+    my $input = $class->new(type => $type, %$attr, @extra);
+    $input->add_to_form($self);
+}
+
+
+=item $method = $form->method
+
+=item $form->method( $new_method )
+
+This method is gets/sets the I<method> name used for the
+C<HTTP::Request> generated.  It is a string like "GET" or "POST".
+
+=item $action = $form->action
+
+=item $form->action( $new_action )
+
+This method gets/sets the URI which we want to apply the request
+I<method> to.
+
+=item $enctype = $form->enctype
+
+=item $form->enctype( $new_enctype )
+
+This method gets/sets the encoding type for the form data.  It is a
+string like "application/x-www-form-urlencoded" or "multipart/form-data".
+
+=item $accept = $form->accept_charset
+
+=item $form->accept_charset( $new_accept )
+
+This method gets/sets the list of charset encodings that the server processing
+the form accepts. Current implementation supports only one-element lists.
+Default value is "UNKNOWN" which we interpret as a request to use document
+charset as specified by the 'charset' parameter of the parse() method. To
+encode character strings you should have modern perl with Encode module. On
+older perls the setting of this attribute has no effect.
+
+=cut
+
+BEGIN {
+    # Set up some accesor
+    for (qw(method action enctype accept_charset)) {
+	my $m = $_;
+	no strict 'refs';
+	*{$m} = sub {
+	    my $self = shift;
+	    my $old = $self->{$m};
+	    $self->{$m} = shift if @_;
+	    $old;
+	};
+    }
+    *uri = \&action;  # alias
+}
+
+=item $value = $form->attr( $name )
+
+=item $form->attr( $name, $new_value )
+
+This method give access to the original HTML attributes of the <form> tag.
+The $name should always be passed in lower case.
+
+Example:
+
+   @f = HTML::Form->parse( $html, $foo );
+   @f = grep $_->attr("id") eq "foo", @f;
+   die "No form named 'foo' found" unless @f;
+   $foo = shift @f;
+
+=cut
+
+sub attr {
+    my $self = shift;
+    my $name = shift;
+    return undef unless defined $name;
+
+    my $old = $self->{attr}{$name};
+    $self->{attr}{$name} = shift if @_;
+    return $old;
+}
+
+=item $bool = $form->strict
+
+=item $form->strict( $bool )
+
+Gets/sets the strict attribute of a form.  If the strict is turned on
+the methods that change values of the form will croak if you try to
+set illegal values or modify readonly fields.  The default is not to be strict.
+
+=cut
+
+sub strict {
+    my $self = shift;
+    my $old = $self->{strict};
+    if (@_) {
+	$self->{strict} = shift;
+	for my $input (@{$self->{inputs}}) {
+	    $input->strict($self->{strict});
+	}
+    }
+    return $old;
+}
+
+
+=item @inputs = $form->inputs
+
+This method returns the list of inputs in the form.  If called in
+scalar context it returns the number of inputs contained in the form.
+See L</INPUTS> for what methods are available for the input objects
+returned.
+
+=cut
+
+sub inputs
+{
+    my $self = shift;
+    @{$self->{'inputs'}};
+}
+
+
+=item $input = $form->find_input( $selector )
+
+=item $input = $form->find_input( $selector, $type )
+
+=item $input = $form->find_input( $selector, $type, $index )
+
+This method is used to locate specific inputs within the form.  All
+inputs that match the arguments given are returned.  In scalar context
+only the first is returned, or C<undef> if none match.
+
+If $selector is specified, then the input's name, id, class attribute must
+match.  A selector prefixed with '#' must match the id attribute of the input.
+A selector prefixed with '.' matches the class attribute.  A selector prefixed
+with '^' or with no prefix matches the name attribute.
+
+If $type is specified, then the input must have the specified type.
+The following type names are used: "text", "password", "hidden",
+"textarea", "file", "image", "submit", "radio", "checkbox" and "option".
+
+The $index is the sequence number of the input matched where 1 is the
+first.  If combined with $name and/or $type then it select the I<n>th
+input with the given name and/or type.
+
+=cut
+
+sub find_input
+{
+    my($self, $name, $type, $no) = @_;
+    if (wantarray) {
+	my @res;
+	my $c;
+	for (@{$self->{'inputs'}}) {
+	    next if defined($name) && !$_->selected($name);
+	    next if $type && $type ne $_->{type};
+	    $c++;
+	    next if $no && $no != $c;
+	    push(@res, $_);
+	}
+	return @res;
+	
+    }
+    else {
+	$no ||= 1;
+	for (@{$self->{'inputs'}}) {
+	    next if defined($name) && !$_->selected($name);
+	    next if $type && $type ne $_->{type};
+	    next if --$no;
+	    return $_;
+	}
+	return undef;
+    }
+}
+
+sub fixup
+{
+    my $self = shift;
+    for (@{$self->{'inputs'}}) {
+	$_->fixup;
+    }
+}
+
+
+=item $value = $form->value( $selector )
+
+=item $form->value( $selector, $new_value )
+
+The value() method can be used to get/set the value of some input.  If
+strict is enabled and no input has the indicated name, then this method will croak.
+
+If multiple inputs have the same name, only the first one will be
+affected.
+
+The call:
+
+    $form->value('foo')
+
+is basically a short-hand for:
+
+    $form->find_input('foo')->value;
+
+=cut
+
+sub value
+{
+    my $self = shift;
+    my $key  = shift;
+    my $input = $self->find_input($key);
+    unless ($input) {
+	Carp::croak("No such field '$key'") if $self->{strict};
+	return undef unless @_;
+	$input = $self->push_input("text", { name => $key, value => "" });
+    }
+    local $Carp::CarpLevel = 1;
+    $input->value(@_);
+}
+
+=item @names = $form->param
+
+=item @values = $form->param( $name )
+
+=item $form->param( $name, $value, ... )
+
+=item $form->param( $name, \@values )
+
+Alternative interface to examining and setting the values of the form.
+
+If called without arguments then it returns the names of all the
+inputs in the form.  The names will not repeat even if multiple inputs
+have the same name.  In scalar context the number of different names
+is returned.
+
+If called with a single argument then it returns the value or values
+of inputs with the given name.  If called in scalar context only the
+first value is returned.  If no input exists with the given name, then
+C<undef> is returned.
+
+If called with 2 or more arguments then it will set values of the
+named inputs.  This form will croak if no inputs have the given name
+or if any of the values provided does not fit.  Values can also be
+provided as a reference to an array.  This form will allow unsetting
+all values with the given name as well.
+
+This interface resembles that of the param() function of the CGI
+module.
+
+=cut
+
+sub param {
+    my $self = shift;
+    if (@_) {
+        my $name = shift;
+        my @inputs;
+        for ($self->inputs) {
+            my $n = $_->name;
+            next if !defined($n) || $n ne $name;
+            push(@inputs, $_);
+        }
+
+        if (@_) {
+            # set
+            die "No '$name' parameter exists" unless @inputs;
+	    my @v = @_;
+	    @v = @{$v[0]} if @v == 1 && ref($v[0]);
+            while (@v) {
+                my $v = shift @v;
+                my $err;
+                for my $i (0 .. @inputs-1) {
+                    eval {
+                        $inputs[$i]->value($v);
+                    };
+                    unless ($@) {
+                        undef($err);
+                        splice(@inputs, $i, 1);
+                        last;
+                    }
+                    $err ||= $@;
+                }
+                die $err if $err;
+            }
+
+	    # the rest of the input should be cleared
+	    for (@inputs) {
+		$_->value(undef);
+	    }
+        }
+        else {
+            # get
+            my @v;
+            for (@inputs) {
+		if (defined(my $v = $_->value)) {
+		    push(@v, $v);
+		}
+            }
+            return wantarray ? @v : $v[0];
+        }
+    }
+    else {
+        # list parameter names
+        my @n;
+        my %seen;
+        for ($self->inputs) {
+            my $n = $_->name;
+            next if !defined($n) || $seen{$n}++;
+            push(@n, $n);
+        }
+        return @n;
+    }
+}
+
+
+=item $form->try_others( \&callback )
+
+This method will iterate over all permutations of unvisited enumerated
+values (<select>, <radio>, <checkbox>) and invoke the callback for
+each.  The callback is passed the $form as argument.  The return value
+from the callback is ignored and the try_others() method itself does
+not return anything.
+
+=cut
+
+sub try_others
+{
+    my($self, $cb) = @_;
+    my @try;
+    for (@{$self->{'inputs'}}) {
+	my @not_tried_yet = $_->other_possible_values;
+	next unless @not_tried_yet;
+	push(@try, [\@not_tried_yet, $_]);
+    }
+    return unless @try;
+    $self->_try($cb, \@try, 0);
+}
+
+sub _try
+{
+    my($self, $cb, $try, $i) = @_;
+    for (@{$try->[$i][0]}) {
+	$try->[$i][1]->value($_);
+	&$cb($self);
+	$self->_try($cb, $try, $i+1) if $i+1 < @$try;
+    }
+}
+
+
+=item $request = $form->make_request
+
+Will return an C<HTTP::Request> object that reflects the current setting
+of the form.  You might want to use the click() method instead.
+
+=cut
+
+sub make_request
+{
+    my $self = shift;
+    my $method  = uc $self->{'method'};
+    my $uri     = $self->{'action'};
+    my $enctype = $self->{'enctype'};
+    my @form    = $self->form;
+
+    my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset} : $self->accept_charset;
+    if ($Encode_available) {
+        foreach my $fi (@form) {
+            $fi = Encode::encode($charset, $fi) unless ref($fi);
+        }
+    }
+
+    if ($method eq "GET") {
+	require HTTP::Request;
+	$uri = URI->new($uri, "http");
+	$uri->query_form(@form);
+	return HTTP::Request->new(GET => $uri);
+    }
+    elsif ($method eq "POST") {
+	require HTTP::Request::Common;
+	return HTTP::Request::Common::POST($uri, \@form,
+					   Content_Type => $enctype);
+    }
+    else {
+	Carp::croak("Unknown method '$method'");
+    }
+}
+
+
+=item $request = $form->click
+
+=item $request = $form->click( $selector )
+
+=item $request = $form->click( $x, $y )
+
+=item $request = $form->click( $selector, $x, $y )
+
+Will "click" on the first clickable input (which will be of type
+C<submit> or C<image>).  The result of clicking is an C<HTTP::Request>
+object that can then be passed to C<LWP::UserAgent> if you want to
+obtain the server response.
+
+If a $selector is specified, we will click on the first clickable input
+matching the selector, and the method will croak if no matching clickable
+input is found.  If $selector is I<not> specified, then it
+is ok if the form contains no clickable inputs.  In this case the
+click() method returns the same request as the make_request() method
+would do.  See description of the find_input() method above for how
+the $selector is specified.
+
+If there are multiple clickable inputs with the same name, then there
+is no way to get the click() method of the C<HTML::Form> to click on
+any but the first.  If you need this you would have to locate the
+input with find_input() and invoke the click() method on the given
+input yourself.
+
+A click coordinate pair can also be provided, but this only makes a
+difference if you clicked on an image.  The default coordinate is
+(1,1).  The upper-left corner of the image is (0,0), but some badly
+coded CGI scripts are known to not recognize this.  Therefore (1,1) was
+selected as a safer default.
+
+=cut
+
+sub click
+{
+    my $self = shift;
+    my $name;
+    $name = shift if (@_ % 2) == 1;  # odd number of arguments
+
+    # try to find first submit button to activate
+    for (@{$self->{'inputs'}}) {
+        next unless $_->can("click");
+        next if $name && !$_->selected($name);
+	next if $_->disabled;
+	return $_->click($self, @_);
+    }
+    Carp::croak("No clickable input with name $name") if $name;
+    $self->make_request;
+}
+
+
+=item @kw = $form->form
+
+Returns the current setting as a sequence of key/value pairs.  Note
+that keys might be repeated, which means that some values might be
+lost if the return values are assigned to a hash.
+
+In scalar context this method returns the number of key/value pairs
+generated.
+
+=cut
+
+sub form
+{
+    my $self = shift;
+    map { $_->form_name_value($self) } @{$self->{'inputs'}};
+}
+
+
+=item $form->dump
+
+Returns a textual representation of current state of the form.  Mainly
+useful for debugging.  If called in void context, then the dump is
+printed on STDERR.
+
+=cut
+
+sub dump
+{
+    my $self = shift;
+    my $method  = $self->{'method'};
+    my $uri     = $self->{'action'};
+    my $enctype = $self->{'enctype'};
+    my $dump = "$method $uri";
+    $dump .= " ($enctype)"
+	if $enctype ne "application/x-www-form-urlencoded";
+    $dump .= " [$self->{attr}{name}]"
+    	if exists $self->{attr}{name};
+    $dump .= "\n";
+    for ($self->inputs) {
+	$dump .= "  " . $_->dump . "\n";
+    }
+    print STDERR $dump unless defined wantarray;
+    $dump;
+}
+
+
+#---------------------------------------------------
+package HTML::Form::Input;
+
+=back
+
+=head1 INPUTS
+
+An C<HTML::Form> objects contains a sequence of I<inputs>.  References to
+the inputs can be obtained with the $form->inputs or $form->find_input
+methods.
+
+Note that there is I<not> a one-to-one correspondence between input
+I<objects> and E<lt>inputE<gt> I<elements> in the HTML document.  An
+input object basically represents a name/value pair, so when multiple
+HTML elements contribute to the same name/value pair in the submitted
+form they are combined.
+
+The input elements that are mapped one-to-one are "text", "textarea",
+"password", "hidden", "file", "image", "submit" and "checkbox".  For
+the "radio" and "option" inputs the story is not as simple: All
+E<lt>input type="radio"E<gt> elements with the same name will
+contribute to the same input radio object.  The number of radio input
+objects will be the same as the number of distinct names used for the
+E<lt>input type="radio"E<gt> elements.  For a E<lt>selectE<gt> element
+without the C<multiple> attribute there will be one input object of
+type of "option".  For a E<lt>select multipleE<gt> element there will
+be one input object for each contained E<lt>optionE<gt> element.  Each
+one of these option objects will have the same name.
+
+The following methods are available for the I<input> objects:
+
+=over 4
+
+=cut
+
+sub new
+{
+    my $class = shift;
+    my $self = bless {@_}, $class;
+    $self;
+}
+
+sub add_to_form
+{
+    my($self, $form) = @_;
+    push(@{$form->{'inputs'}}, $self);
+    $self;
+}
+
+sub strict {
+    my $self = shift;
+    my $old = $self->{strict};
+    if (@_) {
+	$self->{strict} = shift;
+    }
+    $old;
+}
+
+sub fixup {}
+
+
+=item $input->type
+
+Returns the type of this input.  The type is one of the following
+strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
+"radio", "checkbox" or "option".
+
+=cut
+
+sub type
+{
+    shift->{type};
+}
+
+=item $name = $input->name
+
+=item $input->name( $new_name )
+
+This method can be used to get/set the current name of the input.
+
+=item $input->id
+
+=item $input->class
+
+These methods can be used to get/set the current id or class attribute for the input.
+
+=item $input->selected( $selector )
+
+Returns TRUE if the given selector matched the input.  See the description of
+the find_input() method above for a description of the selector syntax.
+
+=item $value = $input->value
+
+=item $input->value( $new_value )
+
+This method can be used to get/set the current value of an
+input.
+
+If strict is enabled and the input only can take an enumerated list of values,
+then it is an error to try to set it to something else and the method will
+croak if you try.
+
+You will also be able to set the value of read-only inputs, but a
+warning will be generated if running under C<perl -w>.
+
+=cut
+
+sub name
+{
+    my $self = shift;
+    my $old = $self->{name};
+    $self->{name} = shift if @_;
+    $old;
+}
+
+sub id
+{
+    my $self = shift;
+    my $old = $self->{id};
+    $self->{id} = shift if @_;
+    $old;
+}
+
+sub class
+{
+    my $self = shift;
+    my $old = $self->{class};
+    $self->{class} = shift if @_;
+    $old;
+}
+
+sub selected {
+    my($self, $sel) = @_;
+    return undef unless defined $sel;
+    my $attr =
+        $sel =~ s/^\^// ? "name"  :
+        $sel =~ s/^#//  ? "id"    :
+        $sel =~ s/^\.// ? "class" :
+	                  "name";
+    return 0 unless defined $self->{$attr};
+    return $self->{$attr} eq $sel;
+}
+
+sub value
+{
+    my $self = shift;
+    my $old = $self->{value};
+    $self->{value} = shift if @_;
+    $old;
+}
+
+=item $input->possible_values
+
+Returns a list of all values that an input can take.  For inputs that
+do not have discrete values, this returns an empty list.
+
+=cut
+
+sub possible_values
+{
+    return;
+}
+
+=item $input->other_possible_values
+
+Returns a list of all values not tried yet.
+
+=cut
+
+sub other_possible_values
+{
+    return;
+}
+
+=item $input->value_names
+
+For some inputs the values can have names that are different from the
+values themselves.  The number of names returned by this method will
+match the number of values reported by $input->possible_values.
+
+When setting values using the value() method it is also possible to
+use the value names in place of the value itself.
+
+=cut
+
+sub value_names {
+    return
+}
+
+=item $bool = $input->readonly
+
+=item $input->readonly( $bool )
+
+This method is used to get/set the value of the readonly attribute.
+You are allowed to modify the value of readonly inputs, but setting
+the value will generate some noise when warnings are enabled.  Hidden
+fields always start out readonly.
+
+=cut
+
+sub readonly {
+    my $self = shift;
+    my $old = $self->{readonly};
+    $self->{readonly} = shift if @_;
+    $old;
+}
+
+=item $bool = $input->disabled
+
+=item $input->disabled( $bool )
+
+This method is used to get/set the value of the disabled attribute.
+Disabled inputs do not contribute any key/value pairs for the form
+value.
+
+=cut
+
+sub disabled {
+    my $self = shift;
+    my $old = $self->{disabled};
+    $self->{disabled} = shift if @_;
+    $old;
+}
+
+=item $input->form_name_value
+
+Returns a (possible empty) list of key/value pairs that should be
+incorporated in the form value from this input.
+
+=cut
+
+sub form_name_value
+{
+    my $self = shift;
+    my $name = $self->{'name'};
+    return unless defined $name;
+    return if $self->disabled;
+    my $value = $self->value;
+    return unless defined $value;
+    return ($name => $value);
+}
+
+sub dump
+{
+    my $self = shift;
+    my $name = $self->name;
+    $name = "<NONAME>" unless defined $name;
+    my $value = $self->value;
+    $value = "<UNDEF>" unless defined $value;
+    my $dump = "$name=$value";
+
+    my $type = $self->type;
+
+    $type .= " disabled" if $self->disabled;
+    $type .= " readonly" if $self->readonly;
+    return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};
+
+    my @menu;
+    my $i = 0;
+    for (@{$self->{menu}}) {
+	my $opt = $_->{value};
+	$opt = "<UNDEF>" unless defined $opt;
+	$opt .= "/$_->{name}"
+	    if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
+	substr($opt,0,0) = "-" if $_->{disabled};
+	if (exists $self->{current} && $self->{current} == $i) {
+	    substr($opt,0,0) = "!" unless $_->{seen};
+	    substr($opt,0,0) = "*";
+	}
+	else {
+	    substr($opt,0,0) = ":" if $_->{seen};
+	}
+	push(@menu, $opt);
+	$i++;
+    }
+
+    return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
+}
+
+
+#---------------------------------------------------
+package HTML::Form::TextInput;
+@HTML::Form::TextInput::ISA=qw(HTML::Form::Input);
+
+#input/text
+#input/password
+#input/hidden
+#textarea
+
+sub value
+{
+    my $self = shift;
+    my $old = $self->{value};
+    $old = "" unless defined $old;
+    if (@_) {
+        Carp::croak("Input '$self->{name}' is readonly")
+	    if $self->{strict} && $self->{readonly};
+        my $new = shift;
+        my $n = exists $self->{maxlength} ? $self->{maxlength} : undef;
+        Carp::croak("Input '$self->{name}' has maxlength '$n'")
+	    if $self->{strict} && defined($n) && defined($new) && length($new) > $n;
+	$self->{value} = $new;
+    }
+    $old;
+}
+
+#---------------------------------------------------
+package HTML::Form::IgnoreInput;
+@HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);
+
+#input/button
+#input/reset
+
+sub value { return }
+
+
+#---------------------------------------------------
+package HTML::Form::ListInput;
+@HTML::Form::ListInput::ISA=qw(HTML::Form::Input);
+
+#select/option   (val1, val2, ....)
+#input/radio     (undef, val1, val2,...)
+#input/checkbox  (undef, value)
+#select-multiple/option (undef, value)
+
+sub new
+{
+    my $class = shift;
+    my $self = $class->SUPER::new(@_);
+
+    my $value = delete $self->{value};
+    my $value_name = delete $self->{value_name};
+    my $type = $self->{type};
+
+    if ($type eq "checkbox") {
+	$value = "on" unless defined $value;
+	$self->{menu} = [
+	    { value => undef, name => "off", },
+            { value => $value, name => $value_name, },
+        ];
+	$self->{current} = (delete $self->{checked}) ? 1 : 0;
+	;
+    }
+    else {
+	$self->{option_disabled}++
+	    if $type eq "radio" && delete $self->{disabled};
+	$self->{menu} = [
+            {value => $value, name => $value_name},
+        ];
+	my $checked = $self->{checked} || $self->{option_selected};
+	delete $self->{checked};
+	delete $self->{option_selected};
+	if (exists $self->{multiple}) {
+	    unshift(@{$self->{menu}}, { value => undef, name => "off"});
+	    $self->{current} = $checked ? 1 : 0;
+	}
+	else {
+	    $self->{current} = 0 if $checked;
+	}
+    }
+    $self;
+}
+
+sub add_to_form
+{
+    my($self, $form) = @_;
+    my $type = $self->type;
+
+    return $self->SUPER::add_to_form($form)
+	if $type eq "checkbox";
+
+    if ($type eq "option" && exists $self->{multiple}) {
+	$self->{disabled} ||= delete $self->{option_disabled};
+	return $self->SUPER::add_to_form($form);
+    }
+
+    die "Assert" if @{$self->{menu}} != 1;
+    my $m = $self->{menu}[0];
+    $m->{disabled}++ if delete $self->{option_disabled};
+
+    my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
+    return $self->SUPER::add_to_form($form) unless $prev;
+
+    # merge menues
+    $prev->{current} = @{$prev->{menu}} if exists $self->{current};
+    push(@{$prev->{menu}}, $m);
+}
+
+sub fixup
+{
+    my $self = shift;
+    if ($self->{type} eq "option" && !(exists $self->{current})) {
+	$self->{current} = 0;
+    }
+    $self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
+}
+
+sub disabled
+{
+    my $self = shift;
+    my $type = $self->type;
+
+    my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
+    if (@_) {
+	my $v = shift;
+	$self->{disabled} = $v;
+        for (@{$self->{menu}}) {
+            $_->{disabled} = $v;
+        }
+    }
+    return $old;
+}
+
+sub _menu_all_disabled {
+    for (@_) {
+	return 0 unless $_->{disabled};
+    }
+    return 1;
+}
+
+sub value
+{
+    my $self = shift;
+    my $old;
+    $old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
+    $old = $self->{value} if exists $self->{value};
+    if (@_) {
+	my $i = 0;
+	my $val = shift;
+	my $cur;
+	my $disabled;
+	for (@{$self->{menu}}) {
+	    if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
+		(!defined($val) && !defined($_->{value}))
+	       )
+	    {
+		$cur = $i;
+		$disabled = $_->{disabled};
+		last unless $disabled;
+	    }
+	    $i++;
+	}
+	if (!(defined $cur) || $disabled) {
+	    if (defined $val) {
+		# try to search among the alternative names as well
+		my $i = 0;
+		my $cur_ignorecase;
+		my $lc_val = lc($val);
+		for (@{$self->{menu}}) {
+		    if (defined $_->{name}) {
+			if ($val eq $_->{name}) {
+			    $disabled = $_->{disabled};
+			    $cur = $i;
+			    last unless $disabled;
+			}
+			if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
+			    $cur_ignorecase = $i;
+			}
+		    }
+		    $i++;
+		}
+		unless (defined $cur) {
+		    $cur = $cur_ignorecase;
+		    if (defined $cur) {
+			$disabled = $self->{menu}[$cur]{disabled};
+		    }
+		    elsif ($self->{strict}) {
+			my $n = $self->name;
+		        Carp::croak("Illegal value '$val' for field '$n'");
+		    }
+		}
+	    }
+	    elsif ($self->{strict}) {
+		my $n = $self->name;
+	        Carp::croak("The '$n' field can't be unchecked");
+	    }
+	}
+	if ($self->{strict} && $disabled) {
+	    my $n = $self->name;
+	    Carp::croak("The value '$val' has been disabled for field '$n'");
+	}
+	if (defined $cur) {
+	    $self->{current} = $cur;
+	    $self->{menu}[$cur]{seen}++;
+	    delete $self->{value};
+	}
+	else {
+	    $self->{value} = $val;
+	    delete $self->{current};
+	}
+    }
+    $old;
+}
+
+=item $input->check
+
+Some input types represent toggles that can be turned on/off.  This
+includes "checkbox" and "option" inputs.  Calling this method turns
+this input on without having to know the value name.  If the input is
+already on, then nothing happens.
+
+This has the same effect as:
+
+    $input->value($input->possible_values[1]);
+
+The input can be turned off with:
+
+    $input->value(undef);
+
+=cut
+
+sub check
+{
+    my $self = shift;
+    $self->{current} = 1;
+    $self->{menu}[1]{seen}++;
+}
+
+sub possible_values
+{
+    my $self = shift;
+    map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
+}
+
+sub other_possible_values
+{
+    my $self = shift;
+    map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
+}
+
+sub value_names {
+    my $self = shift;
+    my @names;
+    for (@{$self->{menu}}) {
+	my $n = $_->{name};
+	$n = $_->{value} unless defined $n;
+	push(@names, $n);
+    }
+    @names;
+}
+
+
+#---------------------------------------------------
+package HTML::Form::SubmitInput;
+@HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);
+
+#input/image
+#input/submit
+
+=item $input->click($form, $x, $y)
+
+Some input types (currently "submit" buttons and "images") can be
+clicked to submit the form.  The click() method returns the
+corresponding C<HTTP::Request> object.
+
+=cut
+
+sub click
+{
+    my($self,$form,$x,$y) = @_;
+    for ($x, $y) { $_ = 1 unless defined; }
+    local($self->{clicked}) = [$x,$y];
+    return $form->make_request;
+}
+
+sub form_name_value
+{
+    my $self = shift;
+    return unless $self->{clicked};
+    return $self->SUPER::form_name_value(@_);
+}
+
+
+#---------------------------------------------------
+package HTML::Form::ImageInput;
+@HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);
+
+sub form_name_value
+{
+    my $self = shift;
+    my $clicked = $self->{clicked};
+    return unless $clicked;
+    return if $self->{disabled};
+    my $name = $self->{name};
+    $name = (defined($name) && length($name)) ? "$name." : "";
+    return ("${name}x" => $clicked->[0],
+	    "${name}y" => $clicked->[1]
+	   );
+}
+
+#---------------------------------------------------
+package HTML::Form::FileInput;
+@HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);
+
+=back
+
+If the input is of type C<file>, then it has these additional methods:
+
+=over 4
+
+=item $input->file
+
+This is just an alias for the value() method.  It sets the filename to
+read data from.
+
+For security reasons this field will never be initialized from the parsing
+of a form.  This prevents the server from triggering stealth uploads of
+arbitrary files from the client machine.
+
+=cut
+
+sub file {
+    my $self = shift;
+    $self->value(@_);
+}
+
+=item $filename = $input->filename
+
+=item $input->filename( $new_filename )
+
+This get/sets the filename reported to the server during file upload.
+This attribute defaults to the value reported by the file() method.
+
+=cut
+
+sub filename {
+    my $self = shift;
+    my $old = $self->{filename};
+    $self->{filename} = shift if @_;
+    $old = $self->file unless defined $old;
+    $old;
+}
+
+=item $content = $input->content
+
+=item $input->content( $new_content )
+
+This get/sets the file content provided to the server during file
+upload.  This method can be used if you do not want the content to be
+read from an actual file.
+
+=cut
+
+sub content {
+    my $self = shift;
+    my $old = $self->{content};
+    $self->{content} = shift if @_;
+    $old;
+}
+
+=item @headers = $input->headers
+
+=item input->headers($key => $value, .... )
+
+This get/set additional header fields describing the file uploaded.
+This can for instance be used to set the C<Content-Type> reported for
+the file.
+
+=cut
+
+sub headers {
+    my $self = shift;
+    my $old = $self->{headers} || [];
+    $self->{headers} = [@_] if @_;
+    @$old;
+}
+
+sub form_name_value {
+    my($self, $form) = @_;
+    return $self->SUPER::form_name_value($form)
+	if $form->method ne "POST" ||
+	   $form->enctype ne "multipart/form-data";
+
+    my $name = $self->name;
+    return unless defined $name;
+    return if $self->{disabled};
+
+    my $file = $self->file;
+    my $filename = $self->filename;
+    my @headers = $self->headers;
+    my $content = $self->content;
+    if (defined $content) {
+	$filename = $file unless defined $filename;
+	$file = undef;
+	unshift(@headers, "Content" => $content);
+    }
+    elsif (!defined($file) || length($file) == 0) {
+	return;
+    }
+
+    # legacy (this used to be the way to do it)
+    if (ref($file) eq "ARRAY") {
+	my $f = shift @$file;
+	my $fn = shift @$file;
+	push(@headers, @$file);
+	$file = $f;
+	$filename = $fn unless defined $filename;
+    }
+
+    return ($name => [$file, $filename, @headers]);
+}
+
+package HTML::Form::KeygenInput;
+@HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);
+
+sub challenge {
+    my $self = shift;
+    return $self->{challenge};
+}
+
+sub keytype {
+    my $self = shift;
+    return lc($self->{keytype} || 'rsa');
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 SEE ALSO
+
+L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2008 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/HTTP/Cookies.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Cookies.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Cookies.pm	(revision 27181)
@@ -0,0 +1,781 @@
+package HTTP::Cookies;
+
+use strict;
+use HTTP::Date qw(str2time parse_date time2str);
+use HTTP::Headers::Util qw(_split_header_words join_header_words);
+
+use vars qw($VERSION $EPOCH_OFFSET);
+$VERSION = "5.837";
+
+# Legacy: because "use "HTTP::Cookies" used be the ONLY way
+#  to load the class HTTP::Cookies::Netscape.
+require HTTP::Cookies::Netscape;
+
+$EPOCH_OFFSET = 0;  # difference from Unix epoch
+if ($^O eq "MacOS") {
+    require Time::Local;
+    $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
+}
+
+# A HTTP::Cookies object is a hash.  The main attribute is the
+# COOKIES 3 level hash:  $self->{COOKIES}{$domain}{$path}{$key}.
+
+sub new
+{
+    my $class = shift;
+    my $self = bless {
+	COOKIES => {},
+    }, $class;
+    my %cnf = @_;
+    for (keys %cnf) {
+	$self->{lc($_)} = $cnf{$_};
+    }
+    $self->load;
+    $self;
+}
+
+
+sub add_cookie_header
+{
+    my $self = shift;
+    my $request = shift || return;
+    my $url = $request->uri;
+    my $scheme = $url->scheme;
+    unless ($scheme =~ /^https?\z/) {
+	return;
+    }
+
+    my $domain = _host($request, $url);
+    $domain = "$domain.local" unless $domain =~ /\./;
+    my $secure_request = ($scheme eq "https");
+    my $req_path = _url_path($url);
+    my $req_port = $url->port;
+    my $now = time();
+    _normalize_path($req_path) if $req_path =~ /%/;
+
+    my @cval;    # cookie values for the "Cookie" header
+    my $set_ver;
+    my $netscape_only = 0; # An exact domain match applies to any cookie
+
+    while ($domain =~ /\./) {
+        # Checking $domain for cookies"
+	my $cookies = $self->{COOKIES}{$domain};
+	next unless $cookies;
+	if ($self->{delayload} && defined($cookies->{'//+delayload'})) {
+	    my $cookie_data = $cookies->{'//+delayload'}{'cookie'};
+	    delete $self->{COOKIES}{$domain};
+	    $self->load_cookie($cookie_data->[1]);
+	    $cookies = $self->{COOKIES}{$domain};
+	    next unless $cookies;  # should not really happen
+	}
+
+	# Want to add cookies corresponding to the most specific paths
+	# first (i.e. longest path first)
+	my $path;
+	for $path (sort {length($b) <=> length($a) } keys %$cookies) {
+	    if (index($req_path, $path) != 0) {
+		next;
+	    }
+
+	    my($key,$array);
+	    while (($key,$array) = each %{$cookies->{$path}}) {
+		my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
+		if ($secure && !$secure_request) {
+		    next;
+		}
+		if ($expires && $expires < $now) {
+		    next;
+		}
+		if ($port) {
+		    my $found;
+		    if ($port =~ s/^_//) {
+			# The corresponding Set-Cookie attribute was empty
+			$found++ if $port eq $req_port;
+			$port = "";
+		    }
+		    else {
+			my $p;
+			for $p (split(/,/, $port)) {
+			    $found++, last if $p eq $req_port;
+			}
+		    }
+		    unless ($found) {
+			next;
+		    }
+		}
+		if ($version > 0 && $netscape_only) {
+		    next;
+		}
+
+		# set version number of cookie header.
+	        # XXX: What should it be if multiple matching
+                #      Set-Cookie headers have different versions themselves
+		if (!$set_ver++) {
+		    if ($version >= 1) {
+			push(@cval, "\$Version=$version");
+		    }
+		    elsif (!$self->{hide_cookie2}) {
+			$request->header(Cookie2 => '$Version="1"');
+		    }
+		}
+
+		# do we need to quote the value
+		if ($val =~ /\W/ && $version) {
+		    $val =~ s/([\\\"])/\\$1/g;
+		    $val = qq("$val");
+		}
+
+		# and finally remember this cookie
+		push(@cval, "$key=$val");
+		if ($version >= 1) {
+		    push(@cval, qq(\$Path="$path"))     if $path_spec;
+		    push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
+		    if (defined $port) {
+			my $p = '$Port';
+			$p .= qq(="$port") if length $port;
+			push(@cval, $p);
+		    }
+		}
+
+	    }
+        }
+
+    } continue {
+	# Try with a more general domain, alternately stripping
+	# leading name components and leading dots.  When this
+	# results in a domain with no leading dot, it is for
+	# Netscape cookie compatibility only:
+	#
+	# a.b.c.net	Any cookie
+	# .b.c.net	Any cookie
+	# b.c.net	Netscape cookie only
+	# .c.net	Any cookie
+
+	if ($domain =~ s/^\.+//) {
+	    $netscape_only = 1;
+	}
+	else {
+	    $domain =~ s/[^.]*//;
+	    $netscape_only = 0;
+	}
+    }
+
+    if (@cval) {
+	if (my $old = $request->header("Cookie")) {
+	    unshift(@cval, $old);
+	}
+	$request->header(Cookie => join("; ", @cval));
+    }
+
+    $request;
+}
+
+
+sub extract_cookies
+{
+    my $self = shift;
+    my $response = shift || return;
+
+    my @set = _split_header_words($response->_header("Set-Cookie2"));
+    my @ns_set = $response->_header("Set-Cookie");
+
+    return $response unless @set || @ns_set;  # quick exit
+
+    my $request = $response->request;
+    my $url = $request->uri;
+    my $req_host = _host($request, $url);
+    $req_host = "$req_host.local" unless $req_host =~ /\./;
+    my $req_port = $url->port;
+    my $req_path = _url_path($url);
+    _normalize_path($req_path) if $req_path =~ /%/;
+
+    if (@ns_set) {
+	# The old Netscape cookie format for Set-Cookie
+	# http://curl.haxx.se/rfc/cookie_spec.html
+	# can for instance contain an unquoted "," in the expires
+	# field, so we have to use this ad-hoc parser.
+	my $now = time();
+
+	# Build a hash of cookies that was present in Set-Cookie2
+	# headers.  We need to skip them if we also find them in a
+	# Set-Cookie header.
+	my %in_set2;
+	for (@set) {
+	    $in_set2{$_->[0]}++;
+	}
+
+	my $set;
+	for $set (@ns_set) {
+            $set =~ s/^\s+//;
+	    my @cur;
+	    my $param;
+	    my $expires;
+	    my $first_param = 1;
+	    for $param (split(/;\s*/, $set)) {
+                next unless length($param);
+		my($k,$v) = split(/\s*=\s*/, $param, 2);
+		if (defined $v) {
+		    $v =~ s/\s+$//;
+		    #print "$k => $v\n";
+		}
+		else {
+		    $k =~ s/\s+$//;
+		    #print "$k => undef";
+		}
+		if (!$first_param && lc($k) eq "expires") {
+		    my $etime = str2time($v);
+		    if (defined $etime) {
+			push(@cur, "Max-Age" => $etime - $now);
+			$expires++;
+		    }
+		    else {
+			# parse_date can deal with years outside the range of time_t,
+			my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v);
+			if ($year) {
+			    my $thisyear = (gmtime)[5] + 1900;
+			    if ($year < $thisyear) {
+				push(@cur, "Max-Age" => -1);  # any negative value will do
+				$expires++;
+			    }
+			    elsif ($year >= $thisyear + 10) {
+				# the date is at least 10 years into the future, just replace
+				# it with something approximate
+				push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60);
+				$expires++;
+			    }
+			}
+		    }
+		}
+                elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) {
+                    # ignore
+                }
+		else {
+		    push(@cur, $k => $v);
+		}
+		$first_param = 0;
+	    }
+            next unless @cur;
+	    next if $in_set2{$cur[0]};
+
+#	    push(@cur, "Port" => $req_port);
+	    push(@cur, "Discard" => undef) unless $expires;
+	    push(@cur, "Version" => 0);
+	    push(@cur, "ns-cookie" => 1);
+	    push(@set, \@cur);
+	}
+    }
+
+  SET_COOKIE:
+    for my $set (@set) {
+	next unless @$set >= 2;
+
+	my $key = shift @$set;
+	my $val = shift @$set;
+
+	my %hash;
+	while (@$set) {
+	    my $k = shift @$set;
+	    my $v = shift @$set;
+	    my $lc = lc($k);
+	    # don't loose case distinction for unknown fields
+	    $k = $lc if $lc =~ /^(?:discard|domain|max-age|
+                                    path|port|secure|version)$/x;
+	    if ($k eq "discard" || $k eq "secure") {
+		$v = 1 unless defined $v;
+	    }
+	    next if exists $hash{$k};  # only first value is significant
+	    $hash{$k} = $v;
+	};
+
+	my %orig_hash = %hash;
+	my $version   = delete $hash{version};
+	$version = 1 unless defined($version);
+	my $discard   = delete $hash{discard};
+	my $secure    = delete $hash{secure};
+	my $maxage    = delete $hash{'max-age'};
+	my $ns_cookie = delete $hash{'ns-cookie'};
+
+	# Check domain
+	my $domain  = delete $hash{domain};
+	$domain = lc($domain) if defined $domain;
+	if (defined($domain)
+	    && $domain ne $req_host && $domain ne ".$req_host") {
+	    if ($domain !~ /\./ && $domain ne "local") {
+		next SET_COOKIE;
+	    }
+	    $domain = ".$domain" unless $domain =~ /^\./;
+	    if ($domain =~ /\.\d+$/) {
+		next SET_COOKIE;
+	    }
+	    my $len = length($domain);
+	    unless (substr($req_host, -$len) eq $domain) {
+		next SET_COOKIE;
+	    }
+	    my $hostpre = substr($req_host, 0, length($req_host) - $len);
+	    if ($hostpre =~ /\./ && !$ns_cookie) {
+		next SET_COOKIE;
+	    }
+	}
+	else {
+	    $domain = $req_host;
+	}
+
+	my $path = delete $hash{path};
+	my $path_spec;
+	if (defined $path && $path ne '') {
+	    $path_spec++;
+	    _normalize_path($path) if $path =~ /%/;
+	    if (!$ns_cookie &&
+                substr($req_path, 0, length($path)) ne $path) {
+		next SET_COOKIE;
+	    }
+	}
+	else {
+	    $path = $req_path;
+	    $path =~ s,/[^/]*$,,;
+	    $path = "/" unless length($path);
+	}
+
+	my $port;
+	if (exists $hash{port}) {
+	    $port = delete $hash{port};
+	    if (defined $port) {
+		$port =~ s/\s+//g;
+		my $found;
+		for my $p (split(/,/, $port)) {
+		    unless ($p =~ /^\d+$/) {
+			next SET_COOKIE;
+		    }
+		    $found++ if $p eq $req_port;
+		}
+		unless ($found) {
+		    next SET_COOKIE;
+		}
+	    }
+	    else {
+		$port = "_$req_port";
+	    }
+	}
+	$self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
+	    if $self->set_cookie_ok(\%orig_hash);
+    }
+
+    $response;
+}
+
+sub set_cookie_ok
+{
+    1;
+}
+
+
+sub set_cookie
+{
+    my $self = shift;
+    my($version,
+       $key, $val, $path, $domain, $port,
+       $path_spec, $secure, $maxage, $discard, $rest) = @_;
+
+    # path and key can not be empty (key can't start with '$')
+    return $self if !defined($path) || $path !~ m,^/, ||
+	            !defined($key)  || $key  =~ m,^\$,;
+
+    # ensure legal port
+    if (defined $port) {
+	return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
+    }
+
+    my $expires;
+    if (defined $maxage) {
+	if ($maxage <= 0) {
+	    delete $self->{COOKIES}{$domain}{$path}{$key};
+	    return $self;
+	}
+	$expires = time() + $maxage;
+    }
+    $version = 0 unless defined $version;
+
+    my @array = ($version, $val,$port,
+		 $path_spec,
+		 $secure, $expires, $discard);
+    push(@array, {%$rest}) if defined($rest) && %$rest;
+    # trim off undefined values at end
+    pop(@array) while !defined $array[-1];
+
+    $self->{COOKIES}{$domain}{$path}{$key} = \@array;
+    $self;
+}
+
+
+sub save
+{
+    my $self = shift;
+    my $file = shift || $self->{'file'} || return;
+    local(*FILE);
+    open(FILE, ">$file") or die "Can't open $file: $!";
+    print FILE "#LWP-Cookies-1.0\n";
+    print FILE $self->as_string(!$self->{ignore_discard});
+    close(FILE);
+    1;
+}
+
+
+sub load
+{
+    my $self = shift;
+    my $file = shift || $self->{'file'} || return;
+    local(*FILE, $_);
+    local $/ = "\n";  # make sure we got standard record separator
+    open(FILE, $file) or return;
+    my $magic = <FILE>;
+    unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) {
+	warn "$file does not seem to contain cookies";
+	return;
+    }
+    while (<FILE>) {
+	next unless s/^Set-Cookie3:\s*//;
+	chomp;
+	my $cookie;
+	for $cookie (_split_header_words($_)) {
+	    my($key,$val) = splice(@$cookie, 0, 2);
+	    my %hash;
+	    while (@$cookie) {
+		my $k = shift @$cookie;
+		my $v = shift @$cookie;
+		$hash{$k} = $v;
+	    }
+	    my $version   = delete $hash{version};
+	    my $path      = delete $hash{path};
+	    my $domain    = delete $hash{domain};
+	    my $port      = delete $hash{port};
+	    my $expires   = str2time(delete $hash{expires});
+
+	    my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
+	    my $secure    = exists $hash{secure};    delete $hash{secure};
+	    my $discard   = exists $hash{discard};   delete $hash{discard};
+
+	    my @array =	($version,$val,$port,
+			 $path_spec,$secure,$expires,$discard);
+	    push(@array, \%hash) if %hash;
+	    $self->{COOKIES}{$domain}{$path}{$key} = \@array;
+	}
+    }
+    close(FILE);
+    1;
+}
+
+
+sub revert
+{
+    my $self = shift;
+    $self->clear->load;
+    $self;
+}
+
+
+sub clear
+{
+    my $self = shift;
+    if (@_ == 0) {
+	$self->{COOKIES} = {};
+    }
+    elsif (@_ == 1) {
+	delete $self->{COOKIES}{$_[0]};
+    }
+    elsif (@_ == 2) {
+	delete $self->{COOKIES}{$_[0]}{$_[1]};
+    }
+    elsif (@_ == 3) {
+	delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
+    }
+    else {
+	require Carp;
+        Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
+    }
+    $self;
+}
+
+
+sub clear_temporary_cookies
+{
+    my($self) = @_;
+
+    $self->scan(sub {
+        if($_[9] or        # "Discard" flag set
+           not $_[8]) {    # No expire field?
+            $_[8] = -1;            # Set the expire/max_age field
+            $self->set_cookie(@_); # Clear the cookie
+        }
+      });
+}
+
+
+sub DESTROY
+{
+    my $self = shift;
+    local($., $@, $!, $^E, $?);
+    $self->save if $self->{'autosave'};
+}
+
+
+sub scan
+{
+    my($self, $cb) = @_;
+    my($domain,$path,$key);
+    for $domain (sort keys %{$self->{COOKIES}}) {
+	for $path (sort keys %{$self->{COOKIES}{$domain}}) {
+	    for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
+		my($version,$val,$port,$path_spec,
+		   $secure,$expires,$discard,$rest) =
+		       @{$self->{COOKIES}{$domain}{$path}{$key}};
+		$rest = {} unless defined($rest);
+		&$cb($version,$key,$val,$path,$domain,$port,
+		     $path_spec,$secure,$expires,$discard,$rest);
+	    }
+	}
+    }
+}
+
+
+sub as_string
+{
+    my($self, $skip_discard) = @_;
+    my @res;
+    $self->scan(sub {
+	my($version,$key,$val,$path,$domain,$port,
+	   $path_spec,$secure,$expires,$discard,$rest) = @_;
+	return if $discard && $skip_discard;
+	my @h = ($key, $val);
+	push(@h, "path", $path);
+	push(@h, "domain" => $domain);
+	push(@h, "port" => $port) if defined $port;
+	push(@h, "path_spec" => undef) if $path_spec;
+	push(@h, "secure" => undef) if $secure;
+	push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
+	push(@h, "discard" => undef) if $discard;
+	my $k;
+	for $k (sort keys %$rest) {
+	    push(@h, $k, $rest->{$k});
+	}
+	push(@h, "version" => $version);
+	push(@res, "Set-Cookie3: " . join_header_words(\@h));
+    });
+    join("\n", @res, "");
+}
+
+sub _host
+{
+    my($request, $url) = @_;
+    if (my $h = $request->header("Host")) {
+	$h =~ s/:\d+$//;  # might have a port as well
+	return lc($h);
+    }
+    return lc($url->host);
+}
+
+sub _url_path
+{
+    my $url = shift;
+    my $path;
+    if($url->can('epath')) {
+       $path = $url->epath;    # URI::URL method
+    }
+    else {
+       $path = $url->path;           # URI::_generic method
+    }
+    $path = "/" unless length $path;
+    $path;
+}
+
+sub _normalize_path  # so that plain string compare can be used
+{
+    my $x;
+    $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
+	         $x = uc($1);
+                 $x eq "2F" || $x eq "25" ? "%$x" :
+                                            pack("C", hex($x));
+              /eg;
+    $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Cookies - HTTP cookie jars
+
+=head1 SYNOPSIS
+
+  use HTTP::Cookies;
+  $cookie_jar = HTTP::Cookies->new(
+    file => "$ENV{'HOME'}/lwp_cookies.dat",
+    autosave => 1,
+  );
+
+  use LWP;
+  my $browser = LWP::UserAgent->new;
+  $browser->cookie_jar($cookie_jar);
+
+Or for an empty and temporary cookie jar:
+
+  use LWP;
+  my $browser = LWP::UserAgent->new;
+  $browser->cookie_jar( {} );
+
+=head1 DESCRIPTION
+
+This class is for objects that represent a "cookie jar" -- that is, a
+database of all the HTTP cookies that a given LWP::UserAgent object
+knows about.
+
+Cookies are a general mechanism which server side connections can use
+to both store and retrieve information on the client side of the
+connection.  For more information about cookies refer to
+<URL:http://curl.haxx.se/rfc/cookie_spec.html> and
+<URL:http://www.cookiecentral.com/>.  This module also implements the
+new style cookies described in I<RFC 2965>.
+The two variants of cookies are supposed to be able to coexist happily.
+
+Instances of the class I<HTTP::Cookies> are able to store a collection
+of Set-Cookie2: and Set-Cookie: headers and are able to use this
+information to initialize Cookie-headers in I<HTTP::Request> objects.
+The state of a I<HTTP::Cookies> object can be saved in and restored from
+files.
+
+=head1 METHODS
+
+The following methods are provided:
+
+=over 4
+
+=item $cookie_jar = HTTP::Cookies->new
+
+The constructor takes hash style parameters.  The following
+parameters are recognized:
+
+  file:            name of the file to restore cookies from and save cookies to
+  autosave:        save during destruction (bool)
+  ignore_discard:  save even cookies that are requested to be discarded (bool)
+  hide_cookie2:    do not add Cookie2 header to requests
+
+Future parameters might include (not yet implemented):
+
+  max_cookies               300
+  max_cookies_per_domain    20
+  max_cookie_size           4096
+
+  no_cookies   list of domain names that we never return cookies to
+
+=item $cookie_jar->add_cookie_header( $request )
+
+The add_cookie_header() method will set the appropriate Cookie:-header
+for the I<HTTP::Request> object given as argument.  The $request must
+have a valid url attribute before this method is called.
+
+=item $cookie_jar->extract_cookies( $response )
+
+The extract_cookies() method will look for Set-Cookie: and
+Set-Cookie2: headers in the I<HTTP::Response> object passed as
+argument.  Any of these headers that are found are used to update
+the state of the $cookie_jar.
+
+=item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest )
+
+The set_cookie() method updates the state of the $cookie_jar.  The
+$key, $val, $domain, $port and $path arguments are strings.  The
+$path_spec, $secure, $discard arguments are boolean values. The $maxage
+value is a number indicating number of seconds that this cookie will
+live.  A value <= 0 will delete this cookie.  %rest defines
+various other attributes like "Comment" and "CommentURL".
+
+=item $cookie_jar->save
+
+=item $cookie_jar->save( $file )
+
+This method file saves the state of the $cookie_jar to a file.
+The state can then be restored later using the load() method.  If a
+filename is not specified we will use the name specified during
+construction.  If the attribute I<ignore_discard> is set, then we
+will even save cookies that are marked to be discarded.
+
+The default is to save a sequence of "Set-Cookie3" lines.
+"Set-Cookie3" is a proprietary LWP format, not known to be compatible
+with any browser.  The I<HTTP::Cookies::Netscape> sub-class can
+be used to save in a format compatible with Netscape.
+
+=item $cookie_jar->load
+
+=item $cookie_jar->load( $file )
+
+This method reads the cookies from the file and adds them to the
+$cookie_jar.  The file must be in the format written by the save()
+method.
+
+=item $cookie_jar->revert
+
+This method empties the $cookie_jar and re-loads the $cookie_jar
+from the last save file.
+
+=item $cookie_jar->clear
+
+=item $cookie_jar->clear( $domain )
+
+=item $cookie_jar->clear( $domain, $path )
+
+=item $cookie_jar->clear( $domain, $path, $key )
+
+Invoking this method without arguments will empty the whole
+$cookie_jar.  If given a single argument only cookies belonging to
+that domain will be removed.  If given two arguments, cookies
+belonging to the specified path within that domain are removed.  If
+given three arguments, then the cookie with the specified key, path
+and domain is removed.
+
+=item $cookie_jar->clear_temporary_cookies
+
+Discard all temporary cookies. Scans for all cookies in the jar
+with either no expire field or a true C<discard> flag. To be
+called when the user agent shuts down according to RFC 2965.
+
+=item $cookie_jar->scan( \&callback )
+
+The argument is a subroutine that will be invoked for each cookie
+stored in the $cookie_jar.  The subroutine will be invoked with
+the following arguments:
+
+  0  version
+  1  key
+  2  val
+  3  path
+  4  domain
+  5  port
+  6  path_spec
+  7  secure
+  8  expires
+  9  discard
+ 10  hash
+
+=item $cookie_jar->as_string
+
+=item $cookie_jar->as_string( $skip_discardables )
+
+The as_string() method will return the state of the $cookie_jar
+represented as a sequence of "Set-Cookie3" header lines separated by
+"\n".  If $skip_discardables is TRUE, it will not return lines for
+cookies with the I<Discard> attribute.
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Cookies::Netscape>, L<HTTP::Cookies::Microsoft>
+
+=head1 COPYRIGHT
+
+Copyright 1997-2002 Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
Index: /main/trunk/greenstone2/perllib/cpan/HTTP/Cookies/Microsoft.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Cookies/Microsoft.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Cookies/Microsoft.pm	(revision 27181)
@@ -0,0 +1,329 @@
+package HTTP::Cookies::Microsoft;
+
+use strict;
+
+use vars qw(@ISA $VERSION);
+
+$VERSION = "5.821";
+
+require HTTP::Cookies;
+@ISA=qw(HTTP::Cookies);
+
+sub load_cookies_from_file
+{
+	my ($file) = @_;
+	my @cookies;
+	my ($key, $value, $domain_path, $flags, $lo_expire, $hi_expire);
+	my ($lo_create, $hi_create, $sep);
+
+	open(COOKIES, $file) || return;
+
+	while ($key = <COOKIES>)
+	{
+		chomp($key);
+		chomp($value     = <COOKIES>);
+		chomp($domain_path= <COOKIES>);
+		chomp($flags     = <COOKIES>);		# 0x0001 bit is for secure
+		chomp($lo_expire = <COOKIES>);
+		chomp($hi_expire = <COOKIES>);
+		chomp($lo_create = <COOKIES>);
+		chomp($hi_create = <COOKIES>);
+		chomp($sep       = <COOKIES>);
+
+		if (!defined($key) || !defined($value) || !defined($domain_path) ||
+			!defined($flags) || !defined($hi_expire) || !defined($lo_expire) ||
+			!defined($hi_create) || !defined($lo_create) || !defined($sep) ||
+			($sep ne '*'))
+		{
+			last;
+		}
+
+		if ($domain_path =~ /^([^\/]+)(\/.*)$/)
+		{
+			my $domain = $1;
+			my $path = $2;
+
+			push(@cookies, {KEY => $key, VALUE => $value, DOMAIN => $domain,
+					PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire,
+					LOXP => $lo_expire, HICREATE => $hi_create,
+					LOCREATE => $lo_create});
+		}
+	}
+
+	return \@cookies;
+}
+
+sub get_user_name
+{
+	use Win32;
+	use locale;
+	my $user = lc(Win32::LoginName());
+
+	return $user;
+}
+
+# MSIE stores create and expire times as Win32 FILETIME,
+# which is 64 bits of 100 nanosecond intervals since Jan 01 1601
+#
+# But Cookies code expects time in 32-bit value expressed
+# in seconds since Jan 01 1970
+#
+sub epoch_time_offset_from_win32_filetime
+{
+	my ($high, $low) = @_;
+
+	#--------------------------------------------------------
+	# USEFUL CONSTANT
+	#--------------------------------------------------------
+	# 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME
+	#
+	# 100 nanosecond intervals == 0.1 microsecond intervals
+	
+	my $filetime_low32_1970 = 0xd53e8000;
+	my $filetime_high32_1970 = 0x019db1de;
+
+	#------------------------------------
+	# ALGORITHM
+	#------------------------------------
+	# To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970:
+	#
+	# 1. Adjust 100 nanosecond intervals to Jan 01 1970 base
+	# 2. Divide by 10 to get to microseconds (1/millionth second)
+	# 3. Divide by 1000000 (10 ^ 6) to get to seconds
+	#
+	# We can combine Step 2 & 3 into one divide.
+	#
+	# After much trial and error, I came up with the following code which
+	# avoids using Math::BigInt or floating pt, but still gives correct answers
+
+	# If the filetime is before the epoch, return 0
+	if (($high < $filetime_high32_1970) ||
+	    (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970)))
+    	{
+		return 0;
+	}
+
+	# Can't multiply by 0x100000000, (1 << 32),
+	# without Perl issuing an integer overflow warning
+	#
+	# So use two multiplies by 0x10000 instead of one multiply by 0x100000000
+	#
+	# The result is the same.
+	#
+	my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970;
+	my $time = (($high * 0x10000) * 0x10000) + $low;
+
+	$time -= $date1970;
+	$time /= 10000000;
+
+	return $time;
+}
+
+sub load_cookie
+{
+	my($self, $file) = @_;
+        my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
+	my $cookie_data;
+
+        if (-f $file)
+        {
+		# open the cookie file and get the data
+		$cookie_data = load_cookies_from_file($file);
+
+		foreach my $cookie (@{$cookie_data})
+		{
+			my $secure = ($cookie->{FLAGS} & 1) != 0;
+			my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP});
+
+			$self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE}, 
+					  $cookie->{PATH}, $cookie->{DOMAIN}, undef,
+					  0, $secure, $expires-$now, 0);
+		}
+	}
+}
+
+sub load
+{
+	my($self, $cookie_index) = @_;
+	my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
+	my $cookie_dir = '';
+	my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'});
+	my $user_name = get_user_name();
+	my $data;
+
+	$cookie_index ||= $self->{'file'} || return;
+	if ($cookie_index =~ /[\\\/][^\\\/]+$/)
+	{
+		$cookie_dir = $` . "\\";
+	}
+
+	local(*INDEX, $_);
+
+	open(INDEX, $cookie_index) || return;
+	binmode(INDEX);
+	if (256 != read(INDEX, $data, 256))
+	{
+		warn "$cookie_index file is not large enough";
+		close(INDEX);
+		return;
+	}
+
+	# Cookies' index.dat file starts with 32 bytes of signature
+	# followed by an offset to the first record, stored as a little-endian DWORD
+	my ($sig, $size) = unpack('a32 V', $data);
+	
+	if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || # check that sig is valid (only tested in IE6.0)
+		(0x4000 != $size))
+	{
+		warn "$cookie_index ['$sig' $size] does not seem to contain cookies";
+		close(INDEX);
+		return;
+	}
+
+	if (0 == seek(INDEX, $size, 0)) # move the file ptr to start of the first record
+	{
+		close(INDEX);
+		return;
+	}
+
+	# Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes)
+	# so read in two 0x80 byte sectors and adjust if not a Cookie.
+	while (256 == read(INDEX, $data, 256))
+	{
+		# each record starts with a 4-byte signature
+		# and a count (little-endian DWORD) of 0x80 byte sectors for the record
+		($sig, $size) = unpack('a4 V', $data);
+
+		# Cookies are found in 'URL ' records
+		if ('URL ' ne $sig)
+		{
+			# skip over uninteresting record: I've seen 'HASH' and 'LEAK' records
+			if (($sig eq 'HASH') || ($sig eq 'LEAK'))
+			{
+				# '-2' takes into account the two 0x80 byte sectors we've just read in
+				if (($size > 0) && ($size != 2))
+				{
+				    if (0 == seek(INDEX, ($size-2)*0x80, 1))
+				    {
+					    # Seek failed. Something's wrong. Gonna stop.
+					    last;
+				    }
+				}
+			}
+			next;
+		}
+
+		#$REMOVE Need to check if URL records in Cookies' index.dat will
+		#        ever use more than two 0x80 byte sectors
+		if ($size > 2)
+		{
+			my $more_data = ($size-2)*0x80;
+
+			if ($more_data != read(INDEX, $data, $more_data, 256))
+			{
+				last;
+			}
+		}
+
+                (my $user_name2 = $user_name) =~ s/ /_/g;
+		if ($data =~ /Cookie\:\Q$user_name\E\@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)\@[\x21-\xFF]+\.txt)/)
+		{
+			my $cookie_file = $cookie_dir . $2; # form full pathname
+
+			if (!$delay_load)
+			{
+				$self->load_cookie($cookie_file);
+			}
+			else
+			{
+				my $domain = $1;
+
+				# grab only the domain name, drop everything from the first dir sep on
+				if ($domain =~ m{[\\/]})
+				{
+					$domain = $`;
+				}
+
+				# set the delayload cookie for this domain with 
+				# the cookie_file as cookie for later-loading info
+				$self->set_cookie(undef, 'cookie', $cookie_file,
+						      '//+delayload', $domain, undef,
+						      0, 0, $now+86400, 0);
+			}
+		}
+	}
+
+	close(INDEX);
+
+	1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Cookies::Microsoft - access to Microsoft cookies files
+
+=head1 SYNOPSIS
+
+ use LWP;
+ use HTTP::Cookies::Microsoft;
+ use Win32::TieRegistry(Delimiter => "/");
+ my $cookies_dir = $Registry->
+      {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"};
+
+ $cookie_jar = HTTP::Cookies::Microsoft->new(
+                   file     => "$cookies_dir\\index.dat",
+                   'delayload' => 1,
+               );
+ my $browser = LWP::UserAgent->new;
+ $browser->cookie_jar( $cookie_jar );
+
+=head1 DESCRIPTION
+
+This is a subclass of C<HTTP::Cookies> which
+loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE)
+cookie files.
+
+See the documentation for L<HTTP::Cookies>.
+
+=head1 METHODS
+
+The following methods are provided:
+
+=over 4
+
+=item $cookie_jar = HTTP::Cookies::Microsoft->new;
+
+The constructor takes hash style parameters. In addition
+to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft
+recognizes the following:
+
+  delayload:       delay loading of cookie data until a request
+                   is actually made. This results in faster
+                   runtime unless you use most of the cookies
+                   since only the domain's cookie data
+                   is loaded on demand.
+
+=back
+
+=head1 CAVEATS
+
+Please note that the code DOESN'T support saving to the MSIE
+cookie file format.
+
+=head1 AUTHOR
+
+Johnny Lee <typo_pl@hotmail.com>
+
+=head1 COPYRIGHT
+
+Copyright 2002 Johnny Lee
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
Index: /main/trunk/greenstone2/perllib/cpan/HTTP/Cookies/Netscape.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Cookies/Netscape.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Cookies/Netscape.pm	(revision 27181)
@@ -0,0 +1,114 @@
+package HTTP::Cookies::Netscape;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+$VERSION = "5.832";
+
+require HTTP::Cookies;
+@ISA=qw(HTTP::Cookies);
+
+sub load
+{
+    my($self, $file) = @_;
+    $file ||= $self->{'file'} || return;
+    local(*FILE, $_);
+    local $/ = "\n";  # make sure we got standard record separator
+    my @cookies;
+    open(FILE, $file) || return;
+    my $magic = <FILE>;
+    unless ($magic =~ /^\#(?: Netscape)? HTTP Cookie File/) {
+	warn "$file does not look like a netscape cookies file" if $^W;
+	close(FILE);
+	return;
+    }
+    my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
+    while (<FILE>) {
+	next if /^\s*\#/;
+	next if /^\s*$/;
+	tr/\n\r//d;
+	my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
+	$secure = ($secure eq "TRUE");
+	$self->set_cookie(undef,$key,$val,$path,$domain,undef,
+			  0,$secure,$expires-$now, 0);
+    }
+    close(FILE);
+    1;
+}
+
+sub save
+{
+    my($self, $file) = @_;
+    $file ||= $self->{'file'} || return;
+    local(*FILE, $_);
+    open(FILE, ">$file") || return;
+
+    # Use old, now broken link to the old cookie spec just in case something
+    # else (not us!) requires the comment block exactly this way.
+    print FILE <<EOT;
+# Netscape HTTP Cookie File
+# http://www.netscape.com/newsref/std/cookie_spec.html
+# This is a generated file!  Do not edit.
+
+EOT
+
+    my $now = time - $HTTP::Cookies::EPOCH_OFFSET;
+    $self->scan(sub {
+	my($version,$key,$val,$path,$domain,$port,
+	   $path_spec,$secure,$expires,$discard,$rest) = @_;
+	return if $discard && !$self->{ignore_discard};
+	$expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
+	return if $now > $expires;
+	$secure = $secure ? "TRUE" : "FALSE";
+	my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
+	print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
+    });
+    close(FILE);
+    1;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+HTTP::Cookies::Netscape - access to Netscape cookies files
+
+=head1 SYNOPSIS
+
+ use LWP;
+ use HTTP::Cookies::Netscape;
+ $cookie_jar = HTTP::Cookies::Netscape->new(
+   file => "c:/program files/netscape/users/ZombieCharity/cookies.txt",
+ );
+ my $browser = LWP::UserAgent->new;
+ $browser->cookie_jar( $cookie_jar );
+
+=head1 DESCRIPTION
+
+This is a subclass of C<HTTP::Cookies> that reads (and optionally
+writes) Netscape/Mozilla cookie files.
+
+See the documentation for L<HTTP::Cookies>.
+
+=head1 CAVEATS
+
+Please note that the Netscape/Mozilla cookie file format can't store
+all the information available in the Set-Cookie2 headers, so you will
+probably lose some information if you save in this format.
+
+At time of writing, this module seems to work fine with Mozilla      
+Phoenix/Firebird.
+
+=head1 SEE ALSO
+
+L<HTTP::Cookies::Microsoft>
+
+=head1 COPYRIGHT
+
+Copyright 2002-2003 Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/HTTP/Daemon.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Daemon.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Daemon.pm	(revision 27181)
@@ -0,0 +1,903 @@
+package HTTP::Daemon;
+
+use strict;
+use vars qw($VERSION @ISA $PROTO $DEBUG);
+
+$VERSION = "5.827";
+
+use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
+@ISA=qw(IO::Socket::INET);
+
+$PROTO = "HTTP/1.1";
+
+
+sub new
+{
+    my($class, %args) = @_;
+    $args{Listen} ||= 5;
+    $args{Proto}  ||= 'tcp';
+    return $class->SUPER::new(%args);
+}
+
+
+sub accept
+{
+    my $self = shift;
+    my $pkg = shift || "HTTP::Daemon::ClientConn";
+    my ($sock, $peer) = $self->SUPER::accept($pkg);
+    if ($sock) {
+        ${*$sock}{'httpd_daemon'} = $self;
+        return wantarray ? ($sock, $peer) : $sock;
+    }
+    else {
+        return;
+    }
+}
+
+
+sub url
+{
+    my $self = shift;
+    my $url = $self->_default_scheme . "://";
+    my $addr = $self->sockaddr;
+    if (!$addr || $addr eq INADDR_ANY) {
+ 	require Sys::Hostname;
+ 	$url .= lc Sys::Hostname::hostname();
+    }
+    else {
+	$url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
+    }
+    my $port = $self->sockport;
+    $url .= ":$port" if $port != $self->_default_port;
+    $url .= "/";
+    $url;
+}
+
+
+sub _default_port {
+    80;
+}
+
+
+sub _default_scheme {
+    "http";
+}
+
+
+sub product_tokens
+{
+    "libwww-perl-daemon/$HTTP::Daemon::VERSION";
+}
+
+
+
+package HTTP::Daemon::ClientConn;
+
+use vars qw(@ISA $DEBUG);
+use IO::Socket ();
+@ISA=qw(IO::Socket::INET);
+*DEBUG = \$HTTP::Daemon::DEBUG;
+
+use HTTP::Request  ();
+use HTTP::Response ();
+use HTTP::Status;
+use HTTP::Date qw(time2str);
+use LWP::MediaTypes qw(guess_media_type);
+use Carp ();
+
+my $CRLF = "\015\012";   # "\r\n" is not portable
+my $HTTP_1_0 = _http_version("HTTP/1.0");
+my $HTTP_1_1 = _http_version("HTTP/1.1");
+
+
+sub get_request
+{
+    my($self, $only_headers) = @_;
+    if (${*$self}{'httpd_nomore'}) {
+        $self->reason("No more requests from this connection");
+	return;
+    }
+
+    $self->reason("");
+    my $buf = ${*$self}{'httpd_rbuf'};
+    $buf = "" unless defined $buf;
+
+    my $timeout = $ {*$self}{'io_socket_timeout'};
+    my $fdset = "";
+    vec($fdset, $self->fileno, 1) = 1;
+    local($_);
+
+  READ_HEADER:
+    while (1) {
+	# loop until we have the whole header in $buf
+	$buf =~ s/^(?:\015?\012)+//;  # ignore leading blank lines
+	if ($buf =~ /\012/) {  # potential, has at least one line
+	    if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
+		if ($buf =~ /\015?\012\015?\012/) {
+		    last READ_HEADER;  # we have it
+		}
+		elsif (length($buf) > 16*1024) {
+		    $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
+		    $self->reason("Very long header");
+		    return;
+		}
+	    }
+	    else {
+		last READ_HEADER;  # HTTP/0.9 client
+	    }
+	}
+	elsif (length($buf) > 16*1024) {
+	    $self->send_error(414); # REQUEST_URI_TOO_LARGE
+	    $self->reason("Very long first line");
+	    return;
+	}
+	print STDERR "Need more data for complete header\n" if $DEBUG;
+	return unless $self->_need_more($buf, $timeout, $fdset);
+    }
+    if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
+	${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
+	$self->send_error(400);  # BAD_REQUEST
+	$self->reason("Bad request line: $buf");
+	return;
+    }
+    my $method = $1;
+    my $uri = $2;
+    my $proto = $3 || "HTTP/0.9";
+    $uri = "http://$uri" if $method eq "CONNECT";
+    $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
+    my $r = HTTP::Request->new($method, $uri);
+    $r->protocol($proto);
+    ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
+    ${*$self}{'httpd_head'} = ($method eq "HEAD");
+
+    if ($proto >= $HTTP_1_0) {
+	# we expect to find some headers
+	my($key, $val);
+      HEADER:
+	while ($buf =~ s/^([^\012]*)\012//) {
+	    $_ = $1;
+	    s/\015$//;
+	    if (/^([^:\s]+)\s*:\s*(.*)/) {
+		$r->push_header($key, $val) if $key;
+		($key, $val) = ($1, $2);
+	    }
+	    elsif (/^\s+(.*)/) {
+		$val .= " $1";
+	    }
+	    else {
+		last HEADER;
+	    }
+	}
+	$r->push_header($key, $val) if $key;
+    }
+
+    my $conn = $r->header('Connection');
+    if ($proto >= $HTTP_1_1) {
+	${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
+    }
+    else {
+	${*$self}{'httpd_nomore'}++ unless $conn &&
+                                           lc($conn) =~ /\bkeep-alive\b/;
+    }
+
+    if ($only_headers) {
+	${*$self}{'httpd_rbuf'} = $buf;
+        return $r;
+    }
+
+    # Find out how much content to read
+    my $te  = $r->header('Transfer-Encoding');
+    my $ct  = $r->header('Content-Type');
+    my $len = $r->header('Content-Length');
+
+    # Act on the Expect header, if it's there
+    for my $e ( $r->header('Expect') ) {
+        if( lc($e) eq '100-continue' ) {
+            $self->send_status_line(100);
+            $self->send_crlf;
+        }
+        else {
+            $self->send_error(417);
+            $self->reason("Unsupported Expect header value");
+            return;
+        }
+    }
+
+    if ($te && lc($te) eq 'chunked') {
+	# Handle chunked transfer encoding
+	my $body = "";
+      CHUNK:
+	while (1) {
+	    print STDERR "Chunked\n" if $DEBUG;
+	    if ($buf =~ s/^([^\012]*)\012//) {
+		my $chunk_head = $1;
+		unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
+		    $self->send_error(400);
+		    $self->reason("Bad chunk header $chunk_head");
+		    return;
+		}
+		my $size = hex($1);
+		last CHUNK if $size == 0;
+
+		my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
+		# must read until we have a complete chunk
+		while ($missing > 0) {
+		    print STDERR "Need $missing more bytes\n" if $DEBUG;
+		    my $n = $self->_need_more($buf, $timeout, $fdset);
+		    return unless $n;
+		    $missing -= $n;
+		}
+		$body .= substr($buf, 0, $size);
+		substr($buf, 0, $size+2) = '';
+
+	    }
+	    else {
+		# need more data in order to have a complete chunk header
+		return unless $self->_need_more($buf, $timeout, $fdset);
+	    }
+	}
+	$r->content($body);
+
+	# pretend it was a normal entity body
+	$r->remove_header('Transfer-Encoding');
+	$r->header('Content-Length', length($body));
+
+	my($key, $val);
+      FOOTER:
+	while (1) {
+	    if ($buf !~ /\012/) {
+		# need at least one line to look at
+		return unless $self->_need_more($buf, $timeout, $fdset);
+	    }
+	    else {
+		$buf =~ s/^([^\012]*)\012//;
+		$_ = $1;
+		s/\015$//;
+		if (/^([\w\-]+)\s*:\s*(.*)/) {
+		    $r->push_header($key, $val) if $key;
+		    ($key, $val) = ($1, $2);
+		}
+		elsif (/^\s+(.*)/) {
+		    $val .= " $1";
+		}
+		elsif (!length) {
+		    last FOOTER;
+		}
+		else {
+		    $self->reason("Bad footer syntax");
+		    return;
+		}
+	    }
+	}
+	$r->push_header($key, $val) if $key;
+
+    }
+    elsif ($te) {
+	$self->send_error(501); 	# Unknown transfer encoding
+	$self->reason("Unknown transfer encoding '$te'");
+	return;
+
+    }
+    elsif ($len) {
+	# Plain body specified by "Content-Length"
+	my $missing = $len - length($buf);
+	while ($missing > 0) {
+	    print "Need $missing more bytes of content\n" if $DEBUG;
+	    my $n = $self->_need_more($buf, $timeout, $fdset);
+	    return unless $n;
+	    $missing -= $n;
+	}
+	if (length($buf) > $len) {
+	    $r->content(substr($buf,0,$len));
+	    substr($buf, 0, $len) = '';
+	}
+	else {
+	    $r->content($buf);
+	    $buf='';
+	}
+    }
+    elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
+	# Handle multipart content type
+	my $boundary = "$CRLF--$2--";
+	my $index;
+	while (1) {
+	    $index = index($buf, $boundary);
+	    last if $index >= 0;
+	    # end marker not yet found
+	    return unless $self->_need_more($buf, $timeout, $fdset);
+	}
+	$index += length($boundary);
+	$r->content(substr($buf, 0, $index));
+	substr($buf, 0, $index) = '';
+
+    }
+    ${*$self}{'httpd_rbuf'} = $buf;
+
+    $r;
+}
+
+
+sub _need_more
+{
+    my $self = shift;
+    #my($buf,$timeout,$fdset) = @_;
+    if ($_[1]) {
+	my($timeout, $fdset) = @_[1,2];
+	print STDERR "select(,,,$timeout)\n" if $DEBUG;
+	my $n = select($fdset,undef,undef,$timeout);
+	unless ($n) {
+	    $self->reason(defined($n) ? "Timeout" : "select: $!");
+	    return;
+	}
+    }
+    print STDERR "sysread()\n" if $DEBUG;
+    my $n = sysread($self, $_[0], 2048, length($_[0]));
+    $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
+    $n;
+}
+
+
+sub read_buffer
+{
+    my $self = shift;
+    my $old = ${*$self}{'httpd_rbuf'};
+    if (@_) {
+	${*$self}{'httpd_rbuf'} = shift;
+    }
+    $old;
+}
+
+
+sub reason
+{
+    my $self = shift;
+    my $old = ${*$self}{'httpd_reason'};
+    if (@_) {
+        ${*$self}{'httpd_reason'} = shift;
+    }
+    $old;
+}
+
+
+sub proto_ge
+{
+    my $self = shift;
+    ${*$self}{'httpd_client_proto'} >= _http_version(shift);
+}
+
+
+sub _http_version
+{
+    local($_) = shift;
+    return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
+    $1 * 1000 + $2;
+}
+
+
+sub antique_client
+{
+    my $self = shift;
+    ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
+}
+
+
+sub force_last_request
+{
+    my $self = shift;
+    ${*$self}{'httpd_nomore'}++;
+}
+
+sub head_request
+{
+    my $self = shift;
+    ${*$self}{'httpd_head'};
+}
+
+
+sub send_status_line
+{
+    my($self, $status, $message, $proto) = @_;
+    return if $self->antique_client;
+    $status  ||= RC_OK;
+    $message ||= status_message($status) || "";
+    $proto   ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
+    print $self "$proto $status $message$CRLF";
+}
+
+
+sub send_crlf
+{
+    my $self = shift;
+    print $self $CRLF;
+}
+
+
+sub send_basic_header
+{
+    my $self = shift;
+    return if $self->antique_client;
+    $self->send_status_line(@_);
+    print $self "Date: ", time2str(time), $CRLF;
+    my $product = $self->daemon->product_tokens;
+    print $self "Server: $product$CRLF" if $product;
+}
+
+
+sub send_header
+{
+    my $self = shift;
+    while (@_) {
+	my($k, $v) = splice(@_, 0, 2);
+	$v = "" unless defined($v);
+	print $self "$k: $v$CRLF";
+    }
+}
+
+
+sub send_response
+{
+    my $self = shift;
+    my $res = shift;
+    if (!ref $res) {
+	$res ||= RC_OK;
+	$res = HTTP::Response->new($res, @_);
+    }
+    my $content = $res->content;
+    my $chunked;
+    unless ($self->antique_client) {
+	my $code = $res->code;
+	$self->send_basic_header($code, $res->message, $res->protocol);
+	if ($code =~ /^(1\d\d|[23]04)$/) {
+	    # make sure content is empty
+	    $res->remove_header("Content-Length");
+	    $content = "";
+	}
+	elsif ($res->request && $res->request->method eq "HEAD") {
+	    # probably OK
+	}
+	elsif (ref($content) eq "CODE") {
+	    if ($self->proto_ge("HTTP/1.1")) {
+		$res->push_header("Transfer-Encoding" => "chunked");
+		$chunked++;
+	    }
+	    else {
+		$self->force_last_request;
+	    }
+	}
+	elsif (length($content)) {
+	    $res->header("Content-Length" => length($content));
+	}
+	else {
+	    $self->force_last_request;
+            $res->header('connection','close'); 
+	}
+	print $self $res->headers_as_string($CRLF);
+	print $self $CRLF;  # separates headers and content
+    }
+    if ($self->head_request) {
+	# no content
+    }
+    elsif (ref($content) eq "CODE") {
+	while (1) {
+	    my $chunk = &$content();
+	    last unless defined($chunk) && length($chunk);
+	    if ($chunked) {
+		printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
+	    }
+	    else {
+		print $self $chunk;
+	    }
+	}
+	print $self "0$CRLF$CRLF" if $chunked;  # no trailers either
+    }
+    elsif (length $content) {
+	print $self $content;
+    }
+}
+
+
+sub send_redirect
+{
+    my($self, $loc, $status, $content) = @_;
+    $status ||= RC_MOVED_PERMANENTLY;
+    Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
+    $self->send_basic_header($status);
+    my $base = $self->daemon->url;
+    $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
+    $loc = $loc->abs($base);
+    print $self "Location: $loc$CRLF";
+    if ($content) {
+	my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
+	print $self "Content-Type: $ct$CRLF";
+    }
+    print $self $CRLF;
+    print $self $content if $content && !$self->head_request;
+    $self->force_last_request;  # no use keeping the connection open
+}
+
+
+sub send_error
+{
+    my($self, $status, $error) = @_;
+    $status ||= RC_BAD_REQUEST;
+    Carp::croak("Status '$status' is not an error") unless is_error($status);
+    my $mess = status_message($status);
+    $error  ||= "";
+    $mess = <<EOT;
+<title>$status $mess</title>
+<h1>$status $mess</h1>
+$error
+EOT
+    unless ($self->antique_client) {
+        $self->send_basic_header($status);
+        print $self "Content-Type: text/html$CRLF";
+	print $self "Content-Length: " . length($mess) . $CRLF;
+        print $self $CRLF;
+    }
+    print $self $mess unless $self->head_request;
+    $status;
+}
+
+
+sub send_file_response
+{
+    my($self, $file) = @_;
+    if (-d $file) {
+	$self->send_dir($file);
+    }
+    elsif (-f _) {
+	# plain file
+	local(*F);
+	sysopen(F, $file, 0) or 
+	  return $self->send_error(RC_FORBIDDEN);
+	binmode(F);
+	my($ct,$ce) = guess_media_type($file);
+	my($size,$mtime) = (stat _)[7,9];
+	unless ($self->antique_client) {
+	    $self->send_basic_header;
+	    print $self "Content-Type: $ct$CRLF";
+	    print $self "Content-Encoding: $ce$CRLF" if $ce;
+	    print $self "Content-Length: $size$CRLF" if $size;
+	    print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
+	    print $self $CRLF;
+	}
+	$self->send_file(\*F) unless $self->head_request;
+	return RC_OK;
+    }
+    else {
+	$self->send_error(RC_NOT_FOUND);
+    }
+}
+
+
+sub send_dir
+{
+    my($self, $dir) = @_;
+    $self->send_error(RC_NOT_FOUND) unless -d $dir;
+    $self->send_error(RC_NOT_IMPLEMENTED);
+}
+
+
+sub send_file
+{
+    my($self, $file) = @_;
+    my $opened = 0;
+    local(*FILE);
+    if (!ref($file)) {
+	open(FILE, $file) || return undef;
+	binmode(FILE);
+	$file = \*FILE;
+	$opened++;
+    }
+    my $cnt = 0;
+    my $buf = "";
+    my $n;
+    while ($n = sysread($file, $buf, 8*1024)) {
+	last if !$n;
+	$cnt += $n;
+	print $self $buf;
+    }
+    close($file) if $opened;
+    $cnt;
+}
+
+
+sub daemon
+{
+    my $self = shift;
+    ${*$self}{'httpd_daemon'};
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Daemon - a simple http server class
+
+=head1 SYNOPSIS
+
+  use HTTP::Daemon;
+  use HTTP::Status;
+
+  my $d = HTTP::Daemon->new || die;
+  print "Please contact me at: <URL:", $d->url, ">\n";
+  while (my $c = $d->accept) {
+      while (my $r = $c->get_request) {
+	  if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
+              # remember, this is *not* recommended practice :-)
+	      $c->send_file_response("/etc/passwd");
+	  }
+	  else {
+	      $c->send_error(RC_FORBIDDEN)
+	  }
+      }
+      $c->close;
+      undef($c);
+  }
+
+=head1 DESCRIPTION
+
+Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
+listen on a socket for incoming requests. The C<HTTP::Daemon> is a
+subclass of C<IO::Socket::INET>, so you can perform socket operations
+directly on it too.
+
+The accept() method will return when a connection from a client is
+available.  The returned value will be an C<HTTP::Daemon::ClientConn>
+object which is another C<IO::Socket::INET> subclass.  Calling the
+get_request() method on this object will read data from the client and
+return an C<HTTP::Request> object.  The ClientConn object also provide
+methods to send back various responses.
+
+This HTTP daemon does not fork(2) for you.  Your application, i.e. the
+user of the C<HTTP::Daemon> is responsible for forking if that is
+desirable.  Also note that the user is responsible for generating
+responses that conform to the HTTP/1.1 protocol.
+
+The following methods of C<HTTP::Daemon> are new (or enhanced) relative
+to the C<IO::Socket::INET> base class:
+
+=over 4
+
+=item $d = HTTP::Daemon->new
+
+=item $d = HTTP::Daemon->new( %opts )
+
+The constructor method takes the same arguments as the
+C<IO::Socket::INET> constructor, but unlike its base class it can also
+be called without any arguments.  The daemon will then set up a listen
+queue of 5 connections and allocate some random port number.
+
+A server that wants to bind to some specific address on the standard
+HTTP port will be constructed like this:
+
+  $d = HTTP::Daemon->new(
+           LocalAddr => 'www.thisplace.com',
+           LocalPort => 80,
+       );
+
+See L<IO::Socket::INET> for a description of other arguments that can
+be used configure the daemon during construction.
+
+=item $c = $d->accept
+
+=item $c = $d->accept( $pkg )
+
+=item ($c, $peer_addr) = $d->accept
+
+This method works the same the one provided by the base class, but it
+returns an C<HTTP::Daemon::ClientConn> reference by default.  If a
+package name is provided as argument, then the returned object will be
+blessed into the given class.  It is probably a good idea to make that
+class a subclass of C<HTTP::Daemon::ClientConn>.
+
+The accept method will return C<undef> if timeouts have been enabled
+and no connection is made within the given time.  The timeout() method
+is described in L<IO::Socket>.
+
+In list context both the client object and the peer address will be
+returned; see the description of the accept method L<IO::Socket> for
+details.
+
+=item $d->url
+
+Returns a URL string that can be used to access the server root.
+
+=item $d->product_tokens
+
+Returns the name that this server will use to identify itself.  This
+is the string that is sent with the C<Server> response header.  The
+main reason to have this method is that subclasses can override it if
+they want to use another product name.
+
+The default is the string "libwww-perl-daemon/#.##" where "#.##" is
+replaced with the version number of this module.
+
+=back
+
+The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
+subclass. Instances of this class are returned by the accept() method
+of C<HTTP::Daemon>.  The following methods are provided:
+
+=over 4
+
+=item $c->get_request
+
+=item $c->get_request( $headers_only )
+
+This method reads data from the client and turns it into an
+C<HTTP::Request> object which is returned.  It returns C<undef>
+if reading fails.  If it fails, then the C<HTTP::Daemon::ClientConn>
+object ($c) should be discarded, and you should not try call this
+method again on it.  The $c->reason method might give you some
+information about why $c->get_request failed.
+
+The get_request() method will normally not return until the whole
+request has been received from the client.  This might not be what you
+want if the request is an upload of a large file (and with chunked
+transfer encoding HTTP can even support infinite request messages -
+uploading live audio for instance).  If you pass a TRUE value as the
+$headers_only argument, then get_request() will return immediately
+after parsing the request headers and you are responsible for reading
+the rest of the request content.  If you are going to call
+$c->get_request again on the same connection you better read the
+correct number of bytes.
+
+=item $c->read_buffer
+
+=item $c->read_buffer( $new_value )
+
+Bytes read by $c->get_request, but not used are placed in the I<read
+buffer>.  The next time $c->get_request is called it will consume the
+bytes in this buffer before reading more data from the network
+connection itself.  The read buffer is invalid after $c->get_request
+has failed.
+
+If you handle the reading of the request content yourself you need to
+empty this buffer before you read more and you need to place
+unconsumed bytes here.  You also need this buffer if you implement
+services like I<101 Switching Protocols>.
+
+This method always returns the old buffer content and can optionally
+replace the buffer content if you pass it an argument.
+
+=item $c->reason
+
+When $c->get_request returns C<undef> you can obtain a short string
+describing why it happened by calling $c->reason.
+
+=item $c->proto_ge( $proto )
+
+Return TRUE if the client announced a protocol with version number
+greater or equal to the given argument.  The $proto argument can be a
+string like "HTTP/1.1" or just "1.1".
+
+=item $c->antique_client
+
+Return TRUE if the client speaks the HTTP/0.9 protocol.  No status
+code and no headers should be returned to such a client.  This should
+be the same as !$c->proto_ge("HTTP/1.0").
+
+=item $c->head_request
+
+Return TRUE if the last request was a C<HEAD> request.  No content
+body must be generated for these requests.
+
+=item $c->force_last_request
+
+Make sure that $c->get_request will not try to read more requests off
+this connection.  If you generate a response that is not self
+delimiting, then you should signal this fact by calling this method.
+
+This attribute is turned on automatically if the client announces
+protocol HTTP/1.0 or worse and does not include a "Connection:
+Keep-Alive" header.  It is also turned on automatically when HTTP/1.1
+or better clients send the "Connection: close" request header.
+
+=item $c->send_status_line
+
+=item $c->send_status_line( $code )
+
+=item $c->send_status_line( $code, $mess )
+
+=item $c->send_status_line( $code, $mess, $proto )
+
+Send the status line back to the client.  If $code is omitted 200 is
+assumed.  If $mess is omitted, then a message corresponding to $code
+is inserted.  If $proto is missing the content of the
+$HTTP::Daemon::PROTO variable is used.
+
+=item $c->send_crlf
+
+Send the CRLF sequence to the client.
+
+=item $c->send_basic_header
+
+=item $c->send_basic_header( $code )
+
+=item $c->send_basic_header( $code, $mess )
+
+=item $c->send_basic_header( $code, $mess, $proto )
+
+Send the status line and the "Date:" and "Server:" headers back to
+the client.  This header is assumed to be continued and does not end
+with an empty CRLF line.
+
+See the description of send_status_line() for the description of the
+accepted arguments.
+
+=item $c->send_header( $field, $value )
+
+=item $c->send_header( $field1, $value1, $field2, $value2, ... )
+
+Send one or more header lines.
+
+=item $c->send_response( $res )
+
+Write a C<HTTP::Response> object to the
+client as a response.  We try hard to make sure that the response is
+self delimiting so that the connection can stay persistent for further
+request/response exchanges.
+
+The content attribute of the C<HTTP::Response> object can be a normal
+string or a subroutine reference.  If it is a subroutine, then
+whatever this callback routine returns is written back to the
+client as the response content.  The routine will be called until it
+return an undefined or empty value.  If the client is HTTP/1.1 aware
+then we will use chunked transfer encoding for the response.
+
+=item $c->send_redirect( $loc )
+
+=item $c->send_redirect( $loc, $code )
+
+=item $c->send_redirect( $loc, $code, $entity_body )
+
+Send a redirect response back to the client.  The location ($loc) can
+be an absolute or relative URL. The $code must be one the redirect
+status codes, and defaults to "301 Moved Permanently"
+
+=item $c->send_error
+
+=item $c->send_error( $code )
+
+=item $c->send_error( $code, $error_message )
+
+Send an error response back to the client.  If the $code is missing a
+"Bad Request" error is reported.  The $error_message is a string that
+is incorporated in the body of the HTML entity body.
+
+=item $c->send_file_response( $filename )
+
+Send back a response with the specified $filename as content.  If the
+file is a directory we try to generate an HTML index of it.
+
+=item $c->send_file( $filename )
+
+=item $c->send_file( $fd )
+
+Copy the file to the client.  The file can be a string (which
+will be interpreted as a filename) or a reference to an C<IO::Handle>
+or glob.
+
+=item $c->daemon
+
+Return a reference to the corresponding C<HTTP::Daemon> object.
+
+=back
+
+=head1 SEE ALSO
+
+RFC 2616
+
+L<IO::Socket::INET>, L<IO::Socket>
+
+=head1 COPYRIGHT
+
+Copyright 1996-2003, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
Index: /main/trunk/greenstone2/perllib/cpan/HTTP/Negotiate.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Negotiate.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Negotiate.pm	(revision 27181)
@@ -0,0 +1,529 @@
+package HTTP::Negotiate;
+
+$VERSION = "5.835";
+sub Version { $VERSION; }
+
+require 5.002;
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(choose);
+
+require HTTP::Headers;
+
+$DEBUG = 0;
+
+sub choose ($;$)
+{
+    my($variants, $request) = @_;
+    my(%accept);
+
+    unless (defined $request) {
+	# Create a request object from the CGI environment variables
+	$request = HTTP::Headers->new;
+	$request->header('Accept', $ENV{HTTP_ACCEPT})
+	  if $ENV{HTTP_ACCEPT};
+	$request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
+	  if $ENV{HTTP_ACCEPT_CHARSET};
+	$request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
+	  if $ENV{HTTP_ACCEPT_ENCODING};
+	$request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
+	  if $ENV{HTTP_ACCEPT_LANGUAGE};
+    }
+
+    # Get all Accept values from the request.  Build a hash initialized
+    # like this:
+    #
+    #   %accept = ( type =>     { 'audio/*'     => { q => 0.2, mbx => 20000 },
+    #                             'audio/basic' => { q => 1 },
+    #                           },
+    #               language => { 'no'          => { q => 1 },
+    #                           }
+    #             );
+
+    $request->scan(sub {
+	my($key, $val) = @_;
+
+	my $type;
+	if ($key =~ s/^Accept-//) {
+	    $type = lc($key);
+	}
+	elsif ($key eq "Accept") {
+	    $type = "type";
+	}
+	else {
+	    return;
+	}
+
+	$val =~ s/\s+//g;
+	my $default_q = 1;
+	for my $name (split(/,/, $val)) {
+	    my(%param, $param);
+	    if ($name =~ s/;(.*)//) {
+		for $param (split(/;/, $1)) {
+		    my ($pk, $pv) = split(/=/, $param, 2);
+		    $param{lc $pk} = $pv;
+		}
+	    }
+	    $name = lc $name;
+	    if (defined $param{'q'}) {
+		$param{'q'} = 1 if $param{'q'} > 1;
+		$param{'q'} = 0 if $param{'q'} < 0;
+	    }
+	    else {
+		$param{'q'} = $default_q;
+
+		# This makes sure that the first ones are slightly better off
+		# and therefore more likely to be chosen.
+		$default_q -= 0.0001;
+	    }
+	    $accept{$type}{$name} = \%param;
+	}
+    });
+
+    # Check if any of the variants specify a language.  We do this
+    # because it influences how we treat those without (they default to
+    # 0.5 instead of 1).
+    my $any_lang = 0;
+    for $var (@$variants) {
+	if ($var->[5]) {
+	    $any_lang = 1;
+	    last;
+	}
+    }
+
+    if ($DEBUG) {
+	print "Negotiation parameters in the request\n";
+	for $type (keys %accept) {
+	    print " $type:\n";
+	    for $name (keys %{$accept{$type}}) {
+		print "    $name\n";
+		for $pv (keys %{$accept{$type}{$name}}) {
+		    print "      $pv = $accept{$type}{$name}{$pv}\n";
+		}
+	    }
+	}
+    }
+
+    my @Q = ();  # This is where we collect the results of the
+		 # quality calculations
+
+    # Calculate quality for all the variants that are available.
+    for (@$variants) {
+	my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
+	$qs = 1 unless defined $qs;
+        $ct = '' unless defined $ct;
+	$bs = 0 unless defined $bs;
+	$lang = lc($lang) if $lang; # lg tags are always case-insensitive
+	if ($DEBUG) {
+	    print "\nEvaluating $id (ct='$ct')\n";
+	    printf "  qs   = %.3f\n", $qs;
+	    print  "  enc  = $enc\n"  if $enc && !ref($enc);
+	    print  "  enc  = @$enc\n" if $enc && ref($enc);
+	    print  "  cs   = $cs\n"   if $cs;
+	    print  "  lang = $lang\n" if $lang;
+	    print  "  bs   = $bs\n"   if $bs;
+	}
+
+	# Calculate encoding quality
+	my $qe = 1;
+	# If the variant has no assigned Content-Encoding, or if no
+	# Accept-Encoding field is present, then the value assigned
+	# is "qe=1".  If *all* of the variant's content encodings
+	# are listed in the Accept-Encoding field, then the value
+	# assigned is "qw=1".  If *any* of the variant's content
+	# encodings are not listed in the provided Accept-Encoding
+	# field, then the value assigned is "qe=0"
+	if (exists $accept{'encoding'} && $enc) {
+	    my @enc = ref($enc) ? @$enc : ($enc);
+	    for (@enc) {
+		print "Is encoding $_ accepted? " if $DEBUG;
+		unless(exists $accept{'encoding'}{$_}) {
+		    print "no\n" if $DEBUG;
+		    $qe = 0;
+		    last;
+		}
+		else {
+		    print "yes\n" if $DEBUG;
+		}
+	    }
+	}
+
+	# Calculate charset quality
+	my $qc  = 1;
+	# If the variant's media-type has no charset parameter,
+	# or the variant's charset is US-ASCII, or if no Accept-Charset
+	# field is present, then the value assigned is "qc=1".  If the
+	# variant's charset is listed in the Accept-Charset field,
+	# then the value assigned is "qc=1.  Otherwise, if the variant's
+	# charset is not listed in the provided Accept-Encoding field,
+	# then the value assigned is "qc=0".
+	if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) {
+	    $qc = 0 unless $accept{'charset'}{$cs};
+	}
+
+	# Calculate language quality
+	my $ql  = 1;
+	if ($lang && exists $accept{'language'}) {
+	    my @lang = ref($lang) ? @$lang : ($lang);
+	    # If any of the variant's content languages are listed
+	    # in the Accept-Language field, the the value assigned is
+	    # the largest of the "q" parameter values for those language
+	    # tags.
+	    my $q = undef;
+	    for (@lang) {
+		next unless exists $accept{'language'}{$_};
+		my $this_q = $accept{'language'}{$_}{'q'};
+		$q = $this_q unless defined $q;
+		$q = $this_q if $this_q > $q;
+	    }
+	    if(defined $q) {
+	        $DEBUG and print " -- Exact language match at q=$q\n";
+	    }
+	    else {
+		# If there was no exact match and at least one of
+		# the Accept-Language field values is a complete
+		# subtag prefix of the content language tag(s), then
+		# the "q" parameter value of the largest matching
+		# prefix is used.
+		$DEBUG and print " -- No exact language match\n";
+		my $selected = undef;
+		for $al (keys %{ $accept{'language'} }) {
+		    if (index($al, "$lang-") == 0) {
+		        # $lang starting with $al isn't enough, or else
+		        #  Accept-Language: hu (Hungarian) would seem
+		        #  to accept a document in hup (Hupa)
+		        $DEBUG and print " -- $al ISA $lang\n";
+			$selected = $al unless defined $selected;
+			$selected = $al if length($al) > length($selected);
+		    }
+		    else {
+		        $DEBUG and print " -- $lang  isn't a $al\n";
+		    }
+		}
+		$q = $accept{'language'}{$selected}{'q'} if $selected;
+
+		# If none of the variant's content language tags or
+		# tag prefixes are listed in the provided
+		# Accept-Language field, then the value assigned
+		# is "ql=0.001"
+		$q = 0.001 unless defined $q;
+	    }
+	    $ql = $q;
+	}
+	else {
+	    $ql = 0.5 if $any_lang && exists $accept{'language'};
+	}
+
+	my $q   = 1;
+	my $mbx = undef;
+	# If no Accept field is given, then the value assigned is "q=1".
+	# If at least one listed media range matches the variant's media
+	# type, then the "q" parameter value assigned to the most specific
+	# of those matched is used (e.g. "text/html;version=3.0" is more
+	# specific than "text/html", which is more specific than "text/*",
+	# which in turn is more specific than "*/*"). If not media range
+	# in the provided Accept field matches the variant's media type,
+	# then the value assigned is "q=0".
+	if (exists $accept{'type'} && $ct) {
+	    # First we clean up our content-type
+	    $ct =~ s/\s+//g;
+	    my $params = "";
+	    $params = $1 if $ct =~ s/;(.*)//;
+	    my($type, $subtype) = split("/", $ct, 2);
+	    my %param = ();
+	    for $param (split(/;/, $params)) {
+		my($pk,$pv) = split(/=/, $param, 2);
+		$param{$pk} = $pv;
+	    }
+
+	    my $sel_q = undef;
+	    my $sel_mbx = undef;
+	    my $sel_specificness = 0;
+
+	    ACCEPT_TYPE:
+	    for $at (keys %{ $accept{'type'} }) {
+		print "Consider $at...\n" if $DEBUG;
+		my($at_type, $at_subtype) = split("/", $at, 2);
+		# Is it a match on the type
+		next if $at_type    ne '*' && $at_type    ne $type;
+		next if $at_subtype ne '*' && $at_subtype ne $subtype;
+		my $specificness = 0;
+		$specificness++ if $at_type ne '*';
+		$specificness++ if $at_subtype ne '*';
+		# Let's see if content-type parameters also match
+		while (($pk, $pv) = each %param) {
+		    print "Check if $pk = $pv is true\n" if $DEBUG;
+		    next unless exists $accept{'type'}{$at}{$pk};
+		    next ACCEPT_TYPE
+		      unless $accept{'type'}{$at}{$pk} eq $pv;
+		    print "yes it is!!\n" if $DEBUG;
+		    $specificness++;
+		}
+		print "Hurray, type match with specificness = $specificness\n"
+		  if $DEBUG;
+
+		if (!defined($sel_q) || $sel_specificness < $specificness) {
+		    $sel_q   = $accept{'type'}{$at}{'q'};
+		    $sel_mbx = $accept{'type'}{$at}{'mbx'};
+		    $sel_specificness = $specificness;
+		}
+	    }
+	    $q   = $sel_q || 0;
+	    $mbx = $sel_mbx;
+	}
+
+	my $Q;
+	if (!defined($mbx) || $mbx >= $bs) {
+	    $Q = $qs * $qe * $qc * $ql * $q;
+	}
+	else {
+	    $Q = 0;
+	    print "Variant's size is too large ==> Q=0\n" if $DEBUG;
+	}
+
+	if ($DEBUG) {
+	    $mbx = "undef" unless defined $mbx;
+	    printf "Q=%.4f", $Q;
+	    print "  (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
+	}
+
+	push(@Q, [$id, $Q, $bs]);
+    }
+
+
+    @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q;
+
+    return @Q if wantarray;
+    return undef unless @Q;
+    return undef if $Q[0][1] == 0;
+    $Q[0][0];
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+HTTP::Negotiate - choose a variant to serve
+
+=head1 SYNOPSIS
+
+ use HTTP::Negotiate qw(choose);
+
+ #  ID       QS     Content-Type   Encoding Char-Set        Lang   Size
+ $variants =
+  [['var1',  1.000, 'text/html',   undef,   'iso-8859-1',   'en',   3000],
+   ['var2',  0.950, 'text/plain',  'gzip',  'us-ascii',     'no',    400],
+   ['var3',  0.3,   'image/gif',   undef,   undef,          undef, 43555],
+  ];
+
+ @preferred = choose($variants, $request_headers);
+ $the_one   = choose($variants);
+
+=head1 DESCRIPTION
+
+This module provides a complete implementation of the HTTP content
+negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps>
+chapter 12.  Content negotiation allows for the selection of a
+preferred content representation based upon attributes of the
+negotiable variants and the value of the various Accept* header fields
+in the request.
+
+The variants are ordered by preference by calling the function
+choose().
+
+The first parameter is reference to an array of the variants to
+choose among.
+Each element in this array is an array with the values [$id, $qs,
+$content_type, $content_encoding, $charset, $content_language,
+$content_length] whose meanings are described
+below. The $content_encoding and $content_language can be either a
+single scalar value or an array reference if there are several values.
+
+The second optional parameter is either a HTTP::Headers or a HTTP::Request
+object which is searched for "Accept*" headers.  If this
+parameter is missing, then the accept specification is initialized
+from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET,
+HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE.
+
+In an array context, choose() returns a list of [variant
+identifier, calculated quality, size] tuples.  The values are sorted by
+quality, highest quality first.  If the calculated quality is the same
+for two variants, then they are sorted by size (smallest first). I<E.g.>:
+
+  (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]);
+
+Note that also zero quality variants are included in the return list
+even if these should never be served to the client.
+
+In a scalar context, it returns the identifier of the variant with the
+highest score or C<undef> if none have non-zero quality.
+
+If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of
+noise is generated on STDOUT during evaluation of choose().
+
+=head1 VARIANTS
+
+A variant is described by a list of the following values.  If the
+attribute does not make sense or is unknown for a variant, then use
+C<undef> instead.
+
+=over 3
+
+=item identifier
+
+This is a string that you use as the name for the variant.  This
+identifier for the preferred variants returned by choose().
+
+=item qs
+
+This is a number between 0.000 and 1.000 that describes the "source
+quality".  This is what F<draft-ietf-http-v11-spec-00.ps> says about this
+value:
+
+Source quality is measured by the content provider as representing the
+amount of degradation from the original source.  For example, a
+picture in JPEG form would have a lower qs when translated to the XBM
+format, and much lower qs when translated to an ASCII-art
+representation.  Note, however, that this is a function of the source
+- an original piece of ASCII-art may degrade in quality if it is
+captured in JPEG form.  The qs values should be assigned to each
+variant by the content provider; if no qs value has been assigned, the
+default is generally "qs=1".
+
+=item content-type
+
+This is the media type of the variant.  The media type does not
+include a charset attribute, but might contain other parameters.
+Examples are:
+
+  text/html
+  text/html;version=2.0
+  text/plain
+  image/gif
+  image/jpg
+
+=item content-encoding
+
+This is one or more content encodings that has been applied to the
+variant.  The content encoding is generally used as a modifier to the
+content media type.  The most common content encodings are:
+
+  gzip
+  compress
+
+=item content-charset
+
+This is the character set used when the variant contains text.
+The charset value should generally be C<undef> or one of these:
+
+  us-ascii
+  iso-8859-1 ... iso-8859-9
+  iso-2022-jp
+  iso-2022-jp-2
+  iso-2022-kr
+  unicode-1-1
+  unicode-1-1-utf-7
+  unicode-1-1-utf-8
+
+=item content-language
+
+This describes one or more languages that are used in the variant.
+Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A
+language is in this context a natural language spoken, written, or
+otherwise conveyed by human beings for communication of information to
+other human beings.  Computer languages are explicitly excluded.
+
+The language tags are defined by RFC 3066.  Examples
+are:
+
+  no               Norwegian
+  en               International English
+  en-US            US English
+  en-cockney
+
+=item content-length
+
+This is the number of bytes used to represent the content.
+
+=back
+
+=head1 ACCEPT HEADERS
+
+The following Accept* headers can be used for describing content
+preferences in a request (This description is an edited extract from
+F<draft-ietf-http-v11-spec-00.ps>):
+
+=over 3
+
+=item Accept
+
+This header can be used to indicate a list of media ranges which are
+acceptable as a response to the request.  The "*" character is used to
+group media types into ranges, with "*/*" indicating all media types
+and "type/*" indicating all subtypes of that type.
+
+The parameter q is used to indicate the quality factor, which
+represents the user's preference for that range of media types.  The
+parameter mbx gives the maximum acceptable size of the response
+content. The default values are: q=1 and mbx=infinity. If no Accept
+header is present, then the client accepts all media types with q=1.
+
+For example:
+
+  Accept: audio/*;q=0.2;mbx=200000, audio/basic
+
+would mean: "I prefer audio/basic (of any size), but send me any audio
+type if it is the best available after an 80% mark-down in quality and
+its size is less than 200000 bytes"
+
+
+=item Accept-Charset
+
+Used to indicate what character sets are acceptable for the response.
+The "us-ascii" character set is assumed to be acceptable for all user
+agents.  If no Accept-Charset field is given, the default is that any
+charset is acceptable.  Example:
+
+  Accept-Charset: iso-8859-1, unicode-1-1
+
+
+=item Accept-Encoding
+
+Restricts the Content-Encoding values which are acceptable in the
+response.  If no Accept-Encoding field is present, the server may
+assume that the client will accept any content encoding.  An empty
+Accept-Encoding means that no content encoding is acceptable.  Example:
+
+  Accept-Encoding: compress, gzip
+
+
+=item Accept-Language
+
+This field is similar to Accept, but restricts the set of natural
+languages that are preferred in a response.  Each language may be
+given an associated quality value which represents an estimate of the
+user's comprehension of that language.  For example:
+
+  Accept-Language: no, en-gb;q=0.8, de;q=0.55
+
+would mean: "I prefer Norwegian, but will accept British English (with
+80% comprehension) or German (with 55% comprehension).
+
+=back
+
+
+=head1 COPYRIGHT
+
+Copyright 1996,2001 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/Net/HTTP.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/Net/HTTP.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/Net/HTTP.pm	(revision 27181)
@@ -0,0 +1,279 @@
+package Net::HTTP;
+
+use strict;
+use vars qw($VERSION @ISA $SOCKET_CLASS);
+
+$VERSION = "5.834";
+unless ($SOCKET_CLASS) {
+    eval { require IO::Socket::INET } || require IO::Socket;
+    $SOCKET_CLASS = "IO::Socket::INET";
+}
+require Net::HTTP::Methods;
+require Carp;
+
+@ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods');
+
+sub new {
+    my $class = shift;
+    Carp::croak("No Host option provided") unless @_;
+    $class->SUPER::new(@_);
+}
+
+sub configure {
+    my($self, $cnf) = @_;
+    $self->http_configure($cnf);
+}
+
+sub http_connect {
+    my($self, $cnf) = @_;
+    $self->SUPER::configure($cnf);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::HTTP - Low-level HTTP connection (client)
+
+=head1 SYNOPSIS
+
+ use Net::HTTP;
+ my $s = Net::HTTP->new(Host => "www.perl.com") || die $@;
+ $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0");
+ my($code, $mess, %h) = $s->read_response_headers;
+
+ while (1) {
+    my $buf;
+    my $n = $s->read_entity_body($buf, 1024);
+    die "read failed: $!" unless defined $n;
+    last unless $n;
+    print $buf;
+ }
+
+=head1 DESCRIPTION
+
+The C<Net::HTTP> class is a low-level HTTP client.  An instance of the
+C<Net::HTTP> class represents a connection to an HTTP server.  The
+HTTP protocol is described in RFC 2616.  The C<Net::HTTP> class
+supports C<HTTP/1.0> and C<HTTP/1.1>.
+
+C<Net::HTTP> is a sub-class of C<IO::Socket::INET>.  You can mix the
+methods described below with reading and writing from the socket
+directly.  This is not necessary a good idea, unless you know what you
+are doing.
+
+The following methods are provided (in addition to those of
+C<IO::Socket::INET>):
+
+=over
+
+=item $s = Net::HTTP->new( %options )
+
+The C<Net::HTTP> constructor method takes the same options as
+C<IO::Socket::INET>'s as well as these:
+
+  Host:            Initial host attribute value
+  KeepAlive:       Initial keep_alive attribute value
+  SendTE:          Initial send_te attribute_value
+  HTTPVersion:     Initial http_version attribute value
+  PeerHTTPVersion: Initial peer_http_version attribute value
+  MaxLineLength:   Initial max_line_length attribute value
+  MaxHeaderLines:  Initial max_header_lines attribute value
+
+The C<Host> option is also the default for C<IO::Socket::INET>'s
+C<PeerAddr>.  The C<PeerPort> defaults to 80 if not provided.
+
+The C<Listen> option provided by C<IO::Socket::INET>'s constructor
+method is not allowed.
+
+If unable to connect to the given HTTP server then the constructor
+returns C<undef> and $@ contains the reason.  After a successful
+connect, a C<Net:HTTP> object is returned.
+
+=item $s->host
+
+Get/set the default value of the C<Host> header to send.  The $host
+must not be set to an empty string (or C<undef>) for HTTP/1.1.
+
+=item $s->keep_alive
+
+Get/set the I<keep-alive> value.  If this value is TRUE then the
+request will be sent with headers indicating that the server should try
+to keep the connection open so that multiple requests can be sent.
+
+The actual headers set will depend on the value of the C<http_version>
+and C<peer_http_version> attributes.
+
+=item $s->send_te
+
+Get/set the a value indicating if the request will be sent with a "TE"
+header to indicate the transfer encodings that the server can choose to
+use.  The list of encodings announced as accepted by this client depends
+on availability of the following modules: C<Compress::Raw::Zlib> for
+I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>.
+
+=item $s->http_version
+
+Get/set the HTTP version number that this client should announce.
+This value can only be set to "1.0" or "1.1".  The default is "1.1".
+
+=item $s->peer_http_version
+
+Get/set the protocol version number of our peer.  This value will
+initially be "1.0", but will be updated by a successful
+read_response_headers() method call.
+
+=item $s->max_line_length
+
+Get/set a limit on the length of response line and response header
+lines.  The default is 8192.  A value of 0 means no limit.
+
+=item $s->max_header_length
+
+Get/set a limit on the number of header lines that a response can
+have.  The default is 128.  A value of 0 means no limit.
+
+=item $s->format_request($method, $uri, %headers, [$content])
+
+Format a request message and return it as a string.  If the headers do
+not include a C<Host> header, then a header is inserted with the value
+of the C<host> attribute.  Headers like C<Connection> and
+C<Keep-Alive> might also be added depending on the status of the
+C<keep_alive> attribute.
+
+If $content is given (and it is non-empty), then a C<Content-Length>
+header is automatically added unless it was already present.
+
+=item $s->write_request($method, $uri, %headers, [$content])
+
+Format and send a request message.  Arguments are the same as for
+format_request().  Returns true if successful.
+
+=item $s->format_chunk( $data )
+
+Returns the string to be written for the given chunk of data.  
+
+=item $s->write_chunk($data)
+
+Will write a new chunk of request entity body data.  This method
+should only be used if the C<Transfer-Encoding> header with a value of
+C<chunked> was sent in the request.  Note, writing zero-length data is
+a no-op.  Use the write_chunk_eof() method to signal end of entity
+body data.
+
+Returns true if successful.
+
+=item $s->format_chunk_eof( %trailers )
+
+Returns the string to be written for signaling EOF when a
+C<Transfer-Encoding> of C<chunked> is used.
+
+=item $s->write_chunk_eof( %trailers )
+
+Will write eof marker for chunked data and optional trailers.  Note
+that trailers should not really be used unless is was signaled
+with a C<Trailer> header.
+
+Returns true if successful.
+
+=item ($code, $mess, %headers) = $s->read_response_headers( %opts )
+
+Read response headers from server and return it.  The $code is the 3
+digit HTTP status code (see L<HTTP::Status>) and $mess is the textual
+message that came with it.  Headers are then returned as key/value
+pairs.  Since key letter casing is not normalized and the same key can
+even occur multiple times, assigning these values directly to a hash
+is not wise.  Only the $code is returned if this method is called in
+scalar context.
+
+As a side effect this method updates the 'peer_http_version'
+attribute.
+
+Options might be passed in as key/value pairs.  There are currently
+only two options supported; C<laxed> and C<junk_out>.
+
+The C<laxed> option will make read_response_headers() more forgiving
+towards servers that have not learned how to speak HTTP properly.  The
+C<laxed> option is a boolean flag, and is enabled by passing in a TRUE
+value.  The C<junk_out> option can be used to capture bad header lines
+when C<laxed> is enabled.  The value should be an array reference.
+Bad header lines will be pushed onto the array.
+
+The C<laxed> option must be specified in order to communicate with
+pre-HTTP/1.0 servers that don't describe the response outcome or the
+data they send back with a header block.  For these servers
+peer_http_version is set to "0.9" and this method returns (200,
+"Assumed OK").
+
+The method will raise an exception (die) if the server does not speak
+proper HTTP or if the C<max_line_length> or C<max_header_length>
+limits are reached.  If the C<laxed> option is turned on and
+C<max_line_length> and C<max_header_length> checks are turned off,
+then no exception will be raised and this method will always
+return a response code.
+
+=item $n = $s->read_entity_body($buf, $size);
+
+Reads chunks of the entity body content.  Basically the same interface
+as for read() and sysread(), but the buffer offset argument is not
+supported yet.  This method should only be called after a successful
+read_response_headers() call.
+
+The return value will be C<undef> on read errors, 0 on EOF, -1 if no data
+could be returned this time, otherwise the number of bytes assigned
+to $buf.  The $buf is set to "" when the return value is -1.
+
+You normally want to retry this call if this function returns either
+-1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>).  EINTR
+can happen if the application catches signals and EAGAIN can happen if
+you made the socket non-blocking.
+
+This method will raise exceptions (die) if the server does not speak
+proper HTTP.  This can only happen when reading chunked data.
+
+=item %headers = $s->get_trailers
+
+After read_entity_body() has returned 0 to indicate end of the entity
+body, you might call this method to pick up any trailers.
+
+=item $s->_rbuf
+
+Get/set the read buffer content.  The read_response_headers() and
+read_entity_body() methods use an internal buffer which they will look
+for data before they actually sysread more from the socket itself.  If
+they read too much, the remaining data will be left in this buffer.
+
+=item $s->_rbuf_length
+
+Returns the number of bytes in the read buffer.  This should always be
+the same as:
+
+    length($s->_rbuf)
+
+but might be more efficient.
+
+=back
+
+=head1 SUBCLASSING
+
+The read_response_headers() and read_entity_body() will invoke the
+sysread() method when they need more data.  Subclasses might want to
+override this method to control how reading takes place.
+
+The object itself is a glob.  Subclasses should avoid using hash key
+names prefixed with C<http_> and C<io_>.
+
+=head1 SEE ALSO
+
+L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB>
+
+=head1 COPYRIGHT
+
+Copyright 2001-2003 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/Net/HTTP/Methods.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/Net/HTTP/Methods.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/Net/HTTP/Methods.pm	(revision 27181)
@@ -0,0 +1,593 @@
+package Net::HTTP::Methods;
+
+require 5.005;  # 4-arg substr
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = "5.834";
+
+my $CRLF = "\015\012";   # "\r\n" is not portable
+
+*_bytes = defined(&utf8::downgrade) ?
+    sub {
+        unless (utf8::downgrade($_[0], 1)) {
+            require Carp;
+            Carp::croak("Wide character in HTTP request (bytes required)");
+        }
+        return $_[0];
+    }
+    :
+    sub {
+        return $_[0];
+    };
+
+
+sub new {
+    my $class = shift;
+    unshift(@_, "Host") if @_ == 1;
+    my %cnf = @_;
+    require Symbol;
+    my $self = bless Symbol::gensym(), $class;
+    return $self->http_configure(\%cnf);
+}
+
+sub http_configure {
+    my($self, $cnf) = @_;
+
+    die "Listen option not allowed" if $cnf->{Listen};
+    my $explict_host = (exists $cnf->{Host});
+    my $host = delete $cnf->{Host};
+    my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
+    if (!$peer) {
+	die "No Host option provided" unless $host;
+	$cnf->{PeerAddr} = $peer = $host;
+    }
+
+    if ($peer =~ s,:(\d+)$,,) {
+	$cnf->{PeerPort} = int($1);  # always override
+    }
+    if (!$cnf->{PeerPort}) {
+	$cnf->{PeerPort} = $self->http_default_port;
+    }
+
+    if (!$explict_host) {
+	$host = $peer;
+	$host =~ s/:.*//;
+    }
+    if ($host && $host !~ /:/) {
+	my $p = $cnf->{PeerPort};
+	$host .= ":$p" if $p != $self->http_default_port;
+    }
+
+    $cnf->{Proto} = 'tcp';
+
+    my $keep_alive = delete $cnf->{KeepAlive};
+    my $http_version = delete $cnf->{HTTPVersion};
+    $http_version = "1.1" unless defined $http_version;
+    my $peer_http_version = delete $cnf->{PeerHTTPVersion};
+    $peer_http_version = "1.0" unless defined $peer_http_version;
+    my $send_te = delete $cnf->{SendTE};
+    my $max_line_length = delete $cnf->{MaxLineLength};
+    $max_line_length = 8*1024 unless defined $max_line_length;
+    my $max_header_lines = delete $cnf->{MaxHeaderLines};
+    $max_header_lines = 128 unless defined $max_header_lines;
+
+    return undef unless $self->http_connect($cnf);
+
+    $self->host($host);
+    $self->keep_alive($keep_alive);
+    $self->send_te($send_te);
+    $self->http_version($http_version);
+    $self->peer_http_version($peer_http_version);
+    $self->max_line_length($max_line_length);
+    $self->max_header_lines($max_header_lines);
+
+    ${*$self}{'http_buf'} = "";
+
+    return $self;
+}
+
+sub http_default_port {
+    80;
+}
+
+# set up property accessors
+for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
+    my $prop_name = "http_" . $method;
+    no strict 'refs';
+    *$method = sub {
+	my $self = shift;
+	my $old = ${*$self}{$prop_name};
+	${*$self}{$prop_name} = shift if @_;
+	return $old;
+    };
+}
+
+# we want this one to be a bit smarter
+sub http_version {
+    my $self = shift;
+    my $old = ${*$self}{'http_version'};
+    if (@_) {
+	my $v = shift;
+	$v = "1.0" if $v eq "1";  # float
+	unless ($v eq "1.0" or $v eq "1.1") {
+	    require Carp;
+	    Carp::croak("Unsupported HTTP version '$v'");
+	}
+	${*$self}{'http_version'} = $v;
+    }
+    $old;
+}
+
+sub format_request {
+    my $self = shift;
+    my $method = shift;
+    my $uri = shift;
+
+    my $content = (@_ % 2) ? pop : "";
+
+    for ($method, $uri) {
+	require Carp;
+	Carp::croak("Bad method or uri") if /\s/ || !length;
+    }
+
+    push(@{${*$self}{'http_request_method'}}, $method);
+    my $ver = ${*$self}{'http_version'};
+    my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
+
+    my @h;
+    my @connection;
+    my %given = (host => 0, "content-length" => 0, "te" => 0);
+    while (@_) {
+	my($k, $v) = splice(@_, 0, 2);
+	my $lc_k = lc($k);
+	if ($lc_k eq "connection") {
+	    $v =~ s/^\s+//;
+	    $v =~ s/\s+$//;
+	    push(@connection, split(/\s*,\s*/, $v));
+	    next;
+	}
+	if (exists $given{$lc_k}) {
+	    $given{$lc_k}++;
+	}
+	push(@h, "$k: $v");
+    }
+
+    if (length($content) && !$given{'content-length'}) {
+	push(@h, "Content-Length: " . length($content));
+    }
+
+    my @h2;
+    if ($given{te}) {
+	push(@connection, "TE") unless grep lc($_) eq "te", @connection;
+    }
+    elsif ($self->send_te && gunzip_ok()) {
+	# gzip is less wanted since the IO::Uncompress::Gunzip interface for
+	# it does not really allow chunked decoding to take place easily.
+	push(@h2, "TE: deflate,gzip;q=0.3");
+	push(@connection, "TE");
+    }
+
+    unless (grep lc($_) eq "close", @connection) {
+	if ($self->keep_alive) {
+	    if ($peer_ver eq "1.0") {
+		# from looking at Netscape's headers
+		push(@h2, "Keep-Alive: 300");
+		unshift(@connection, "Keep-Alive");
+	    }
+	}
+	else {
+	    push(@connection, "close") if $ver ge "1.1";
+	}
+    }
+    push(@h2, "Connection: " . join(", ", @connection)) if @connection;
+    unless ($given{host}) {
+	my $h = ${*$self}{'http_host'};
+	push(@h2, "Host: $h") if $h;
+    }
+
+    return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content));
+}
+
+
+sub write_request {
+    my $self = shift;
+    $self->print($self->format_request(@_));
+}
+
+sub format_chunk {
+    my $self = shift;
+    return $_[0] unless defined($_[0]) && length($_[0]);
+    return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
+}
+
+sub write_chunk {
+    my $self = shift;
+    return 1 unless defined($_[0]) && length($_[0]);
+    $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF));
+}
+
+sub format_chunk_eof {
+    my $self = shift;
+    my @h;
+    while (@_) {
+	push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
+    }
+    return _bytes(join("", "0$CRLF", @h, $CRLF));
+}
+
+sub write_chunk_eof {
+    my $self = shift;
+    $self->print($self->format_chunk_eof(@_));
+}
+
+
+sub my_read {
+    die if @_ > 3;
+    my $self = shift;
+    my $len = $_[1];
+    for (${*$self}{'http_buf'}) {
+	if (length) {
+	    $_[0] = substr($_, 0, $len, "");
+	    return length($_[0]);
+	}
+	else {
+	    return $self->sysread($_[0], $len);
+	}
+    }
+}
+
+
+sub my_readline {
+    my $self = shift;
+    my $what = shift;
+    for (${*$self}{'http_buf'}) {
+	my $max_line_length = ${*$self}{'http_max_line_length'};
+	my $pos;
+	while (1) {
+	    # find line ending
+	    $pos = index($_, "\012");
+	    last if $pos >= 0;
+	    die "$what line too long (limit is $max_line_length)"
+		if $max_line_length && length($_) > $max_line_length;
+
+	    # need to read more data to find a line ending
+          READ:
+            {
+                my $n = $self->sysread($_, 1024, length);
+                unless (defined $n) {
+                    redo READ if $!{EINTR};
+                    if ($!{EAGAIN}) {
+                        # Hmm, we must be reading from a non-blocking socket
+                        # XXX Should really wait until this socket is readable,...
+                        select(undef, undef, undef, 0.1);  # but this will do for now
+                        redo READ;
+                    }
+                    # if we have already accumulated some data let's at least
+                    # return that as a line
+                    die "$what read failed: $!" unless length;
+                }
+                unless ($n) {
+                    return undef unless length;
+                    return substr($_, 0, length, "");
+                }
+            }
+	}
+	die "$what line too long ($pos; limit is $max_line_length)"
+	    if $max_line_length && $pos > $max_line_length;
+
+	my $line = substr($_, 0, $pos+1, "");
+	$line =~ s/(\015?\012)\z// || die "Assert";
+	return wantarray ? ($line, $1) : $line;
+    }
+}
+
+
+sub _rbuf {
+    my $self = shift;
+    if (@_) {
+	for (${*$self}{'http_buf'}) {
+	    my $old;
+	    $old = $_ if defined wantarray;
+	    $_ = shift;
+	    return $old;
+	}
+    }
+    else {
+	return ${*$self}{'http_buf'};
+    }
+}
+
+sub _rbuf_length {
+    my $self = shift;
+    return length ${*$self}{'http_buf'};
+}
+
+
+sub _read_header_lines {
+    my $self = shift;
+    my $junk_out = shift;
+
+    my @headers;
+    my $line_count = 0;
+    my $max_header_lines = ${*$self}{'http_max_header_lines'};
+    while (my $line = my_readline($self, 'Header')) {
+	if ($line =~ /^(\S+?)\s*:\s*(.*)/s) {
+	    push(@headers, $1, $2);
+	}
+	elsif (@headers && $line =~ s/^\s+//) {
+	    $headers[-1] .= " " . $line;
+	}
+	elsif ($junk_out) {
+	    push(@$junk_out, $line);
+	}
+	else {
+	    die "Bad header: '$line'\n";
+	}
+	if ($max_header_lines) {
+	    $line_count++;
+	    if ($line_count >= $max_header_lines) {
+		die "Too many header lines (limit is $max_header_lines)";
+	    }
+	}
+    }
+    return @headers;
+}
+
+
+sub read_response_headers {
+    my($self, %opt) = @_;
+    my $laxed = $opt{laxed};
+
+    my($status, $eol) = my_readline($self, 'Status');
+    unless (defined $status) {
+	die "Server closed connection without sending any data back";
+    }
+
+    my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
+    if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
+	die "Bad response status line: '$status'" unless $laxed;
+	# assume HTTP/0.9
+	${*$self}{'http_peer_http_version'} = "0.9";
+	${*$self}{'http_status'} = "200";
+	substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || "");
+	return 200 unless wantarray;
+	return (200, "Assumed OK");
+    };
+
+    ${*$self}{'http_peer_http_version'} = $peer_ver;
+    ${*$self}{'http_status'} = $code;
+
+    my $junk_out;
+    if ($laxed) {
+	$junk_out = $opt{junk_out} || [];
+    }
+    my @headers = $self->_read_header_lines($junk_out);
+
+    # pick out headers that read_entity_body might need
+    my @te;
+    my $content_length;
+    for (my $i = 0; $i < @headers; $i += 2) {
+	my $h = lc($headers[$i]);
+	if ($h eq 'transfer-encoding') {
+	    my $te = $headers[$i+1];
+	    $te =~ s/^\s+//;
+	    $te =~ s/\s+$//;
+	    push(@te, $te) if length($te);
+	}
+	elsif ($h eq 'content-length') {
+	    # ignore bogus and overflow values
+	    if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) {
+		$content_length = $1;
+	    }
+	}
+    }
+    ${*$self}{'http_te'} = join(",", @te);
+    ${*$self}{'http_content_length'} = $content_length;
+    ${*$self}{'http_first_body'}++;
+    delete ${*$self}{'http_trailers'};
+    return $code unless wantarray;
+    return ($code, $message, @headers);
+}
+
+
+sub read_entity_body {
+    my $self = shift;
+    my $buf_ref = \$_[0];
+    my $size = $_[1];
+    die "Offset not supported yet" if $_[2];
+
+    my $chunked;
+    my $bytes;
+
+    if (${*$self}{'http_first_body'}) {
+	${*$self}{'http_first_body'} = 0;
+	delete ${*$self}{'http_chunked'};
+	delete ${*$self}{'http_bytes'};
+	my $method = shift(@{${*$self}{'http_request_method'}});
+	my $status = ${*$self}{'http_status'};
+	if ($method eq "HEAD") {
+	    # this response is always empty regardless of other headers
+	    $bytes = 0;
+	}
+	elsif (my $te = ${*$self}{'http_te'}) {
+	    my @te = split(/\s*,\s*/, lc($te));
+	    die "Chunked must be last Transfer-Encoding '$te'"
+		unless pop(@te) eq "chunked";
+
+	    for (@te) {
+		if ($_ eq "deflate" && inflate_ok()) {
+		    #require Compress::Raw::Zlib;
+		    my ($i, $status) = Compress::Raw::Zlib::Inflate->new();
+		    die "Can't make inflator: $status" unless $i;
+		    $_ = sub { my $out; $i->inflate($_[0], \$out); $out }
+		}
+		elsif ($_ eq "gzip" && gunzip_ok()) {
+		    #require IO::Uncompress::Gunzip;
+		    my @buf;
+		    $_ = sub {
+			push(@buf, $_[0]);
+			return "" unless $_[1];
+			my $input = join("", @buf);
+			my $output;
+			IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0)
+			    or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
+			return \$output;
+		    };
+		}
+		elsif ($_ eq "identity") {
+		    $_ = sub { $_[0] };
+		}
+		else {
+		    die "Can't handle transfer encoding '$te'";
+		}
+	    }
+
+	    @te = reverse(@te);
+
+	    ${*$self}{'http_te2'} = @te ? \@te : "";
+	    $chunked = -1;
+	}
+	elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
+	    $bytes = $content_length;
+	}
+        elsif ($status =~ /^(?:1|[23]04)/) {
+            # RFC 2616 says that these responses should always be empty
+            # but that does not appear to be true in practice [RT#17907]
+            $bytes = 0;
+        }
+	else {
+	    # XXX Multi-Part types are self delimiting, but RFC 2616 says we
+	    # only has to deal with 'multipart/byteranges'
+
+	    # Read until EOF
+	}
+    }
+    else {
+	$chunked = ${*$self}{'http_chunked'};
+	$bytes   = ${*$self}{'http_bytes'};
+    }
+
+    if (defined $chunked) {
+	# The state encoded in $chunked is:
+	#   $chunked == 0:   read CRLF after chunk, then chunk header
+        #   $chunked == -1:  read chunk header
+	#   $chunked > 0:    bytes left in current chunk to read
+
+	if ($chunked <= 0) {
+	    my $line = my_readline($self, 'Entity body');
+	    if ($chunked == 0) {
+		die "Missing newline after chunk data: '$line'"
+		    if !defined($line) || $line ne "";
+		$line = my_readline($self, 'Entity body');
+	    }
+	    die "EOF when chunk header expected" unless defined($line);
+	    my $chunk_len = $line;
+	    $chunk_len =~ s/;.*//;  # ignore potential chunk parameters
+	    unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
+		die "Bad chunk-size in HTTP response: $line";
+	    }
+	    $chunked = hex($1);
+	    if ($chunked == 0) {
+		${*$self}{'http_trailers'} = [$self->_read_header_lines];
+		$$buf_ref = "";
+
+		my $n = 0;
+		if (my $transforms = delete ${*$self}{'http_te2'}) {
+		    for (@$transforms) {
+			$$buf_ref = &$_($$buf_ref, 1);
+		    }
+		    $n = length($$buf_ref);
+		}
+
+		# in case somebody tries to read more, make sure we continue
+		# to return EOF
+		delete ${*$self}{'http_chunked'};
+		${*$self}{'http_bytes'} = 0;
+
+		return $n;
+	    }
+	}
+
+	my $n = $chunked;
+	$n = $size if $size && $size < $n;
+	$n = my_read($self, $$buf_ref, $n);
+	return undef unless defined $n;
+
+	${*$self}{'http_chunked'} = $chunked - $n;
+
+	if ($n > 0) {
+	    if (my $transforms = ${*$self}{'http_te2'}) {
+		for (@$transforms) {
+		    $$buf_ref = &$_($$buf_ref, 0);
+		}
+		$n = length($$buf_ref);
+		$n = -1 if $n == 0;
+	    }
+	}
+	return $n;
+    }
+    elsif (defined $bytes) {
+	unless ($bytes) {
+	    $$buf_ref = "";
+	    return 0;
+	}
+	my $n = $bytes;
+	$n = $size if $size && $size < $n;
+	$n = my_read($self, $$buf_ref, $n);
+	return undef unless defined $n;
+	${*$self}{'http_bytes'} = $bytes - $n;
+	return $n;
+    }
+    else {
+	# read until eof
+	$size ||= 8*1024;
+	return my_read($self, $$buf_ref, $size);
+    }
+}
+
+sub get_trailers {
+    my $self = shift;
+    @{${*$self}{'http_trailers'} || []};
+}
+
+BEGIN {
+my $gunzip_ok;
+my $inflate_ok;
+
+sub gunzip_ok {
+    return $gunzip_ok if defined $gunzip_ok;
+
+    # Try to load IO::Uncompress::Gunzip.
+    local $@;
+    local $SIG{__DIE__};
+    $gunzip_ok = 0;
+
+    eval {
+	require IO::Uncompress::Gunzip;
+	$gunzip_ok++;
+    };
+
+    return $gunzip_ok;
+}
+
+sub inflate_ok {
+    return $inflate_ok if defined $inflate_ok;
+
+    # Try to load Compress::Raw::Zlib.
+    local $@;
+    local $SIG{__DIE__};
+    $inflate_ok = 0;
+
+    eval {
+	require Compress::Raw::Zlib;
+	$inflate_ok++;
+    };
+
+    return $inflate_ok;
+}
+
+} # BEGIN
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/Net/HTTP/NB.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/Net/HTTP/NB.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/Net/HTTP/NB.pm	(revision 27181)
@@ -0,0 +1,105 @@
+package Net::HTTP::NB;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+$VERSION = "5.810";
+
+require Net::HTTP;
+@ISA=qw(Net::HTTP);
+
+sub sysread {
+    my $self = $_[0];
+    if (${*$self}{'httpnb_read_count'}++) {
+	${*$self}{'http_buf'} = ${*$self}{'httpnb_save'};
+	die "Multi-read\n";
+    }
+    my $buf;
+    my $offset = $_[3] || 0;
+    my $n = sysread($self, $_[1], $_[2], $offset);
+    ${*$self}{'httpnb_save'} .= substr($_[1], $offset);
+    return $n;
+}
+
+sub read_response_headers {
+    my $self = shift;
+    ${*$self}{'httpnb_read_count'} = 0;
+    ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
+    my @h = eval { $self->SUPER::read_response_headers(@_) };
+    if ($@) {
+	return if $@ eq "Multi-read\n";
+	die;
+    }
+    return @h;
+}
+
+sub read_entity_body {
+    my $self = shift;
+    ${*$self}{'httpnb_read_count'} = 0;
+    ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
+    # XXX I'm not so sure this does the correct thing in case of
+    # transfer-encoding tranforms
+    my $n = eval { $self->SUPER::read_entity_body(@_); };
+    if ($@) {
+	$_[0] = "";
+	return -1;
+    }
+    return $n;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::HTTP::NB - Non-blocking HTTP client
+
+=head1 SYNOPSIS
+
+ use Net::HTTP::NB;
+ my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@;
+ $s->write_request(GET => "/");
+
+ use IO::Select;
+ my $sel = IO::Select->new($s);
+
+ READ_HEADER: {
+    die "Header timeout" unless $sel->can_read(10);
+    my($code, $mess, %h) = $s->read_response_headers;
+    redo READ_HEADER unless $code;
+ }
+
+ while (1) {
+    die "Body timeout" unless $sel->can_read(10);
+    my $buf;
+    my $n = $s->read_entity_body($buf, 1024);
+    last unless $n;
+    print $buf;
+ }
+
+=head1 DESCRIPTION
+
+Same interface as C<Net::HTTP> but it will never try multiple reads
+when the read_response_headers() or read_entity_body() methods are
+invoked.  This make it possible to multiplex multiple Net::HTTP::NB
+using select without risk blocking.
+
+If read_response_headers() did not see enough data to complete the
+headers an empty list is returned.
+
+If read_entity_body() did not see new entity data in its read
+the value -1 is returned.
+
+=head1 SEE ALSO
+
+L<Net::HTTP>
+
+=head1 COPYRIGHT
+
+Copyright 2001 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/Net/HTTPS.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/Net/HTTPS.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/Net/HTTPS.pm	(revision 27181)
@@ -0,0 +1,59 @@
+package Net::HTTPS;
+
+use strict;
+use vars qw($VERSION $SSL_SOCKET_CLASS @ISA);
+
+$VERSION = "5.819";
+
+# Figure out which SSL implementation to use
+if ($SSL_SOCKET_CLASS) {
+    # somebody already set it
+}
+elsif ($Net::SSL::VERSION) {
+    $SSL_SOCKET_CLASS = "Net::SSL";
+}
+elsif ($IO::Socket::SSL::VERSION) {
+    $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded
+}
+else {
+    eval { require Net::SSL; };     # from Crypt-SSLeay
+    if ($@) {
+	my $old_errsv = $@;
+	eval {
+	    require IO::Socket::SSL;
+	};
+	if ($@) {
+	    $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g;
+	    die $old_errsv . $@;
+	}
+	$SSL_SOCKET_CLASS = "IO::Socket::SSL";
+    }
+    else {
+	$SSL_SOCKET_CLASS = "Net::SSL";
+    }
+}
+
+require Net::HTTP::Methods;
+
+@ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods');
+
+sub configure {
+    my($self, $cnf) = @_;
+    $self->http_configure($cnf);
+}
+
+sub http_connect {
+    my($self, $cnf) = @_;
+    $self->SUPER::configure($cnf);
+}
+
+sub http_default_port {
+    443;
+}
+
+# The underlying SSLeay classes fails to work if the socket is
+# placed in non-blocking mode.  This override of the blocking
+# method makes sure it stays the way it was created.
+sub blocking { }  # noop
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/WWW/RobotRules.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/WWW/RobotRules.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/WWW/RobotRules.pm	(revision 27181)
@@ -0,0 +1,445 @@
+package WWW::RobotRules;
+
+$VERSION = "5.832";
+sub Version { $VERSION; }
+
+use strict;
+use URI ();
+
+
+
+sub new {
+    my($class, $ua) = @_;
+
+    # This ugly hack is needed to ensure backwards compatibility.
+    # The "WWW::RobotRules" class is now really abstract.
+    $class = "WWW::RobotRules::InCore" if $class eq "WWW::RobotRules";
+
+    my $self = bless { }, $class;
+    $self->agent($ua);
+    $self;
+}
+
+
+sub parse {
+    my($self, $robot_txt_uri, $txt, $fresh_until) = @_;
+    $robot_txt_uri = URI->new("$robot_txt_uri");
+    my $netloc = $robot_txt_uri->host . ":" . $robot_txt_uri->port;
+
+    $self->clear_rules($netloc);
+    $self->fresh_until($netloc, $fresh_until || (time + 365*24*3600));
+
+    my $ua;
+    my $is_me = 0;		# 1 iff this record is for me
+    my $is_anon = 0;		# 1 iff this record is for *
+    my $seen_disallow = 0;      # watch for missing record separators
+    my @me_disallowed = ();	# rules disallowed for me
+    my @anon_disallowed = ();	# rules disallowed for *
+
+    # blank lines are significant, so turn CRLF into LF to avoid generating
+    # false ones
+    $txt =~ s/\015\012/\012/g;
+
+    # split at \012 (LF) or \015 (CR) (Mac text files have just CR for EOL)
+    for(split(/[\012\015]/, $txt)) {
+
+	# Lines containing only a comment are discarded completely, and
+        # therefore do not indicate a record boundary.
+	next if /^\s*\#/;
+
+	s/\s*\#.*//;        # remove comments at end-of-line
+
+	if (/^\s*$/) {	    # blank line
+	    last if $is_me; # That was our record. No need to read the rest.
+	    $is_anon = 0;
+	    $seen_disallow = 0;
+	}
+        elsif (/^\s*User-Agent\s*:\s*(.*)/i) {
+	    $ua = $1;
+	    $ua =~ s/\s+$//;
+
+	    if ($seen_disallow) {
+		# treat as start of a new record
+		$seen_disallow = 0;
+		last if $is_me; # That was our record. No need to read the rest.
+		$is_anon = 0;
+	    }
+
+	    if ($is_me) {
+		# This record already had a User-agent that
+		# we matched, so just continue.
+	    }
+	    elsif ($ua eq '*') {
+		$is_anon = 1;
+	    }
+	    elsif($self->is_me($ua)) {
+		$is_me = 1;
+	    }
+	}
+	elsif (/^\s*Disallow\s*:\s*(.*)/i) {
+	    unless (defined $ua) {
+		warn "RobotRules <$robot_txt_uri>: Disallow without preceding User-agent\n" if $^W;
+		$is_anon = 1;  # assume that User-agent: * was intended
+	    }
+	    my $disallow = $1;
+	    $disallow =~ s/\s+$//;
+	    $seen_disallow = 1;
+	    if (length $disallow) {
+		my $ignore;
+		eval {
+		    my $u = URI->new_abs($disallow, $robot_txt_uri);
+		    $ignore++ if $u->scheme ne $robot_txt_uri->scheme;
+		    $ignore++ if lc($u->host) ne lc($robot_txt_uri->host);
+		    $ignore++ if $u->port ne $robot_txt_uri->port;
+		    $disallow = $u->path_query;
+		    $disallow = "/" unless length $disallow;
+		};
+		next if $@;
+		next if $ignore;
+	    }
+
+	    if ($is_me) {
+		push(@me_disallowed, $disallow);
+	    }
+	    elsif ($is_anon) {
+		push(@anon_disallowed, $disallow);
+	    }
+	}
+        elsif (/\S\s*:/) {
+             # ignore
+        }
+	else {
+	    warn "RobotRules <$robot_txt_uri>: Malformed record: <$_>\n" if $^W;
+	}
+    }
+
+    if ($is_me) {
+	$self->push_rules($netloc, @me_disallowed);
+    }
+    else {
+	$self->push_rules($netloc, @anon_disallowed);
+    }
+}
+
+
+#
+# Returns TRUE if the given name matches the
+# name of this robot
+#
+sub is_me {
+    my($self, $ua_line) = @_;
+    my $me = $self->agent;
+
+    # See whether my short-name is a substring of the
+    #  "User-Agent: ..." line that we were passed:
+
+    if(index(lc($me), lc($ua_line)) >= 0) {
+      return 1;
+    }
+    else {
+      return '';
+    }
+}
+
+
+sub allowed {
+    my($self, $uri) = @_;
+    $uri = URI->new("$uri");
+
+    return 1 unless $uri->scheme eq 'http' or $uri->scheme eq 'https';
+     # Robots.txt applies to only those schemes.
+
+    my $netloc = $uri->host . ":" . $uri->port;
+
+    my $fresh_until = $self->fresh_until($netloc);
+    return -1 if !defined($fresh_until) || $fresh_until < time;
+
+    my $str = $uri->path_query;
+    my $rule;
+    for $rule ($self->rules($netloc)) {
+	return 1 unless length $rule;
+	return 0 if index($str, $rule) == 0;
+    }
+    return 1;
+}
+
+
+# The following methods must be provided by the subclass.
+sub agent;
+sub visit;
+sub no_visits;
+sub last_visits;
+sub fresh_until;
+sub push_rules;
+sub clear_rules;
+sub rules;
+sub dump;
+
+
+
+package WWW::RobotRules::InCore;
+
+use vars qw(@ISA);
+@ISA = qw(WWW::RobotRules);
+
+
+
+sub agent {
+    my ($self, $name) = @_;
+    my $old = $self->{'ua'};
+    if ($name) {
+        # Strip it so that it's just the short name.
+        # I.e., "FooBot"                                      => "FooBot"
+        #       "FooBot/1.2"                                  => "FooBot"
+        #       "FooBot/1.2 [http://foobot.int; foo@bot.int]" => "FooBot"
+
+	$name = $1 if $name =~ m/(\S+)/; # get first word
+	$name =~ s!/.*!!;  # get rid of version
+	unless ($old && $old eq $name) {
+	    delete $self->{'loc'}; # all old info is now stale
+	    $self->{'ua'} = $name;
+	}
+    }
+    $old;
+}
+
+
+sub visit {
+    my($self, $netloc, $time) = @_;
+    return unless $netloc;
+    $time ||= time;
+    $self->{'loc'}{$netloc}{'last'} = $time;
+    my $count = \$self->{'loc'}{$netloc}{'count'};
+    if (!defined $$count) {
+	$$count = 1;
+    }
+    else {
+	$$count++;
+    }
+}
+
+
+sub no_visits {
+    my ($self, $netloc) = @_;
+    $self->{'loc'}{$netloc}{'count'};
+}
+
+
+sub last_visit {
+    my ($self, $netloc) = @_;
+    $self->{'loc'}{$netloc}{'last'};
+}
+
+
+sub fresh_until {
+    my ($self, $netloc, $fresh_until) = @_;
+    my $old = $self->{'loc'}{$netloc}{'fresh'};
+    if (defined $fresh_until) {
+	$self->{'loc'}{$netloc}{'fresh'} = $fresh_until;
+    }
+    $old;
+}
+
+
+sub push_rules {
+    my($self, $netloc, @rules) = @_;
+    push (@{$self->{'loc'}{$netloc}{'rules'}}, @rules);
+}
+
+
+sub clear_rules {
+    my($self, $netloc) = @_;
+    delete $self->{'loc'}{$netloc}{'rules'};
+}
+
+
+sub rules {
+    my($self, $netloc) = @_;
+    if (defined $self->{'loc'}{$netloc}{'rules'}) {
+	return @{$self->{'loc'}{$netloc}{'rules'}};
+    }
+    else {
+	return ();
+    }
+}
+
+
+sub dump
+{
+    my $self = shift;
+    for (keys %$self) {
+	next if $_ eq 'loc';
+	print "$_ = $self->{$_}\n";
+    }
+    for (keys %{$self->{'loc'}}) {
+	my @rules = $self->rules($_);
+	print "$_: ", join("; ", @rules), "\n";
+    }
+}
+
+
+1;
+
+__END__
+
+
+# Bender: "Well, I don't have anything else
+#          planned for today.  Let's get drunk!"
+
+=head1 NAME
+
+WWW::RobotRules - database of robots.txt-derived permissions
+
+=head1 SYNOPSIS
+
+ use WWW::RobotRules;
+ my $rules = WWW::RobotRules->new('MOMspider/1.0');
+
+ use LWP::Simple qw(get);
+
+ {
+   my $url = "http://some.place/robots.txt";
+   my $robots_txt = get $url;
+   $rules->parse($url, $robots_txt) if defined $robots_txt;
+ }
+
+ {
+   my $url = "http://some.other.place/robots.txt";
+   my $robots_txt = get $url;
+   $rules->parse($url, $robots_txt) if defined $robots_txt;
+ }
+
+ # Now we can check if a URL is valid for those servers
+ # whose "robots.txt" files we've gotten and parsed:
+ if($rules->allowed($url)) {
+     $c = get $url;
+     ...
+ }
+
+=head1 DESCRIPTION
+
+This module parses F</robots.txt> files as specified in
+"A Standard for Robot Exclusion", at
+<http://www.robotstxt.org/wc/norobots.html>
+Webmasters can use the F</robots.txt> file to forbid conforming
+robots from accessing parts of their web site.
+
+The parsed files are kept in a WWW::RobotRules object, and this object
+provides methods to check if access to a given URL is prohibited.  The
+same WWW::RobotRules object can be used for one or more parsed
+F</robots.txt> files on any number of hosts.
+
+The following methods are provided:
+
+=over 4
+
+=item $rules = WWW::RobotRules->new($robot_name)
+
+This is the constructor for WWW::RobotRules objects.  The first
+argument given to new() is the name of the robot.
+
+=item $rules->parse($robot_txt_url, $content, $fresh_until)
+
+The parse() method takes as arguments the URL that was used to
+retrieve the F</robots.txt> file, and the contents of the file.
+
+=item $rules->allowed($uri)
+
+Returns TRUE if this robot is allowed to retrieve this URL.
+
+=item $rules->agent([$name])
+
+Get/set the agent name. NOTE: Changing the agent name will clear the robots.txt
+rules and expire times out of the cache.
+
+=back
+
+=head1 ROBOTS.TXT
+
+The format and semantics of the "/robots.txt" file are as follows
+(this is an edited abstract of
+<http://www.robotstxt.org/wc/norobots.html>):
+
+The file consists of one or more records separated by one or more
+blank lines. Each record contains lines of the form
+
+  <field-name>: <value>
+
+The field name is case insensitive.  Text after the '#' character on a
+line is ignored during parsing.  This is used for comments.  The
+following <field-names> can be used:
+
+=over 3
+
+=item User-Agent
+
+The value of this field is the name of the robot the record is
+describing access policy for.  If more than one I<User-Agent> field is
+present the record describes an identical access policy for more than
+one robot. At least one field needs to be present per record.  If the
+value is '*', the record describes the default access policy for any
+robot that has not not matched any of the other records.
+
+The I<User-Agent> fields must occur before the I<Disallow> fields.  If a
+record contains a I<User-Agent> field after a I<Disallow> field, that
+constitutes a malformed record.  This parser will assume that a blank
+line should have been placed before that I<User-Agent> field, and will
+break the record into two.  All the fields before the I<User-Agent> field
+will constitute a record, and the I<User-Agent> field will be the first
+field in a new record.
+
+=item Disallow
+
+The value of this field specifies a partial URL that is not to be
+visited. This can be a full path, or a partial path; any URL that
+starts with this value will not be retrieved
+
+=back
+
+Unrecognized records are ignored.
+
+=head1 ROBOTS.TXT EXAMPLES
+
+The following example "/robots.txt" file specifies that no robots
+should visit any URL starting with "/cyberworld/map/" or "/tmp/":
+
+  User-agent: *
+  Disallow: /cyberworld/map/ # This is an infinite virtual URL space
+  Disallow: /tmp/ # these will soon disappear
+
+This example "/robots.txt" file specifies that no robots should visit
+any URL starting with "/cyberworld/map/", except the robot called
+"cybermapper":
+
+  User-agent: *
+  Disallow: /cyberworld/map/ # This is an infinite virtual URL space
+
+  # Cybermapper knows where to go.
+  User-agent: cybermapper
+  Disallow:
+
+This example indicates that no robots should visit this site further:
+
+  # go away
+  User-agent: *
+  Disallow: /
+
+This is an example of a malformed robots.txt file.
+
+  # robots.txt for ancientcastle.example.com
+  # I've locked myself away.
+  User-agent: *
+  Disallow: /
+  # The castle is your home now, so you can go anywhere you like.
+  User-agent: Belle
+  Disallow: /west-wing/ # except the west wing!
+  # It's good to be the Prince...
+  User-agent: Beast
+  Disallow:
+
+This file is missing the required blank lines between records.
+However, the intention is clear.
+
+=head1 SEE ALSO
+
+L<LWP::RobotUA>, L<WWW::RobotRules::AnyDBM_File>
Index: /main/trunk/greenstone2/perllib/cpan/WWW/RobotRules/AnyDBM_File.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/WWW/RobotRules/AnyDBM_File.pm	(revision 27181)
+++ /main/trunk/greenstone2/perllib/cpan/WWW/RobotRules/AnyDBM_File.pm	(revision 27181)
@@ -0,0 +1,170 @@
+package WWW::RobotRules::AnyDBM_File;
+
+require  WWW::RobotRules;
+@ISA = qw(WWW::RobotRules);
+$VERSION = "5.835";
+
+use Carp ();
+use AnyDBM_File;
+use Fcntl;
+use strict;
+
+=head1 NAME
+
+WWW::RobotRules::AnyDBM_File - Persistent RobotRules
+
+=head1 SYNOPSIS
+
+ require WWW::RobotRules::AnyDBM_File;
+ require LWP::RobotUA;
+
+ # Create a robot useragent that uses a diskcaching RobotRules
+ my $rules = WWW::RobotRules::AnyDBM_File->new( 'my-robot/1.0', 'cachefile' );
+ my $ua = WWW::RobotUA->new( 'my-robot/1.0', 'me@foo.com', $rules );
+
+ # Then just use $ua as usual
+ $res = $ua->request($req);
+
+=head1 DESCRIPTION
+
+This is a subclass of I<WWW::RobotRules> that uses the AnyDBM_File
+package to implement persistent diskcaching of F<robots.txt> and host
+visit information.
+
+The constructor (the new() method) takes an extra argument specifying
+the name of the DBM file to use.  If the DBM file already exists, then
+you can specify undef as agent name as the name can be obtained from
+the DBM database.
+
+=cut
+
+sub new 
+{ 
+  my ($class, $ua, $file) = @_;
+  Carp::croak('WWW::RobotRules::AnyDBM_File filename required') unless $file;
+
+  my $self = bless { }, $class;
+  $self->{'filename'} = $file;
+  tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_CREAT|O_RDWR, 0640
+    or Carp::croak("Can't open $file: $!");
+  
+  if ($ua) {
+      $self->agent($ua);
+  }
+  else {
+      # Try to obtain name from DBM file
+      $ua = $self->{'dbm'}{"|ua-name|"};
+      Carp::croak("No agent name specified") unless $ua;
+  }
+
+  $self;
+}
+
+sub agent {
+    my($self, $newname) = @_;
+    my $old = $self->{'dbm'}{"|ua-name|"};
+    if (defined $newname) {
+	$newname =~ s!/?\s*\d+.\d+\s*$!!;  # loose version
+	unless ($old && $old eq $newname) {
+	# Old info is now stale.
+	    my $file = $self->{'filename'};
+	    untie %{$self->{'dbm'}};
+	    tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_TRUNC|O_RDWR, 0640;
+	    %{$self->{'dbm'}} = ();
+	    $self->{'dbm'}{"|ua-name|"} = $newname;
+	}
+    }
+    $old;
+}
+
+sub no_visits {
+    my ($self, $netloc) = @_;
+    my $t = $self->{'dbm'}{"$netloc|vis"};
+    return 0 unless $t;
+    (split(/;\s*/, $t))[0];
+}
+
+sub last_visit {
+    my ($self, $netloc) = @_;
+    my $t = $self->{'dbm'}{"$netloc|vis"};
+    return undef unless $t;
+    (split(/;\s*/, $t))[1];
+}
+
+sub fresh_until {
+    my ($self, $netloc, $fresh) = @_;
+    my $old = $self->{'dbm'}{"$netloc|exp"};
+    if ($old) {
+	$old =~ s/;.*//;  # remove cleartext
+    }
+    if (defined $fresh) {
+	$fresh .= "; " . localtime($fresh);
+	$self->{'dbm'}{"$netloc|exp"} = $fresh;
+    }
+    $old;
+}
+
+sub visit {
+    my($self, $netloc, $time) = @_;
+    $time ||= time;
+
+    my $count = 0;
+    my $old = $self->{'dbm'}{"$netloc|vis"};
+    if ($old) {
+	my $last;
+	($count,$last) = split(/;\s*/, $old);
+	$time = $last if $last > $time;
+    }
+    $count++;
+    $self->{'dbm'}{"$netloc|vis"} = "$count; $time; " . localtime($time);
+}
+
+sub push_rules {
+    my($self, $netloc, @rules) = @_;
+    my $cnt = 1;
+    $cnt++ while $self->{'dbm'}{"$netloc|r$cnt"};
+
+    foreach (@rules) {
+	$self->{'dbm'}{"$netloc|r$cnt"} = $_;
+	$cnt++;
+    }
+}
+
+sub clear_rules {
+    my($self, $netloc) = @_;
+    my $cnt = 1;
+    while ($self->{'dbm'}{"$netloc|r$cnt"}) {
+	delete $self->{'dbm'}{"$netloc|r$cnt"};
+	$cnt++;
+    }
+}
+
+sub rules {
+    my($self, $netloc) = @_;
+    my @rules = ();
+    my $cnt = 1;
+    while (1) {
+	my $rule = $self->{'dbm'}{"$netloc|r$cnt"};
+	last unless $rule;
+	push(@rules, $rule);
+	$cnt++;
+    }
+    @rules;
+}
+
+sub dump
+{
+}
+
+1;
+
+=head1 SEE ALSO
+
+L<WWW::RobotRules>, L<LWP::RobotUA>
+
+=head1 AUTHORS
+
+Hakan Ardo E<lt>hakan@munin.ub2.lu.se>, Gisle Aas E<lt>aas@sn.no>
+
+=cut
+
