Index: /main/trunk/greenstone2/perllib/cpan/Encode/Locale.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/Encode/Locale.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/Encode/Locale.pm	(revision 27174)
@@ -0,0 +1,348 @@
+package Encode::Locale;
+
+use strict;
+our $VERSION = "1.03";
+
+use base 'Exporter';
+our @EXPORT_OK = qw(
+    decode_argv env
+    $ENCODING_LOCALE $ENCODING_LOCALE_FS
+    $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT
+);
+
+use Encode ();
+use Encode::Alias ();
+
+our $ENCODING_LOCALE;
+our $ENCODING_LOCALE_FS;
+our $ENCODING_CONSOLE_IN;
+our $ENCODING_CONSOLE_OUT;
+
+sub DEBUG () { 0 }
+
+sub _init {
+    if ($^O eq "MSWin32") {
+	unless ($ENCODING_LOCALE) {
+	    # Try to obtain what the Windows ANSI code page is
+	    eval {
+		unless (defined &GetACP) {
+		    require Win32::API;
+		    Win32::API->Import('kernel32', 'int GetACP()');
+		};
+		if (defined &GetACP) {
+		    my $cp = GetACP();
+		    $ENCODING_LOCALE = "cp$cp" if $cp;
+		}
+	    };
+	}
+
+	unless ($ENCODING_CONSOLE_IN) {
+	    # If we have the Win32::Console module installed we can ask
+	    # it for the code set to use
+	    eval {
+		require Win32::Console;
+		my $cp = Win32::Console::InputCP();
+		$ENCODING_CONSOLE_IN = "cp$cp" if $cp;
+		$cp = Win32::Console::OutputCP();
+		$ENCODING_CONSOLE_OUT = "cp$cp" if $cp;
+	    };
+	    # Invoking the 'chcp' program might also work
+	    if (!$ENCODING_CONSOLE_IN && (qx(chcp) || '') =~ /^Active code page: (\d+)/) {
+		$ENCODING_CONSOLE_IN = "cp$1";
+	    }
+	}
+    }
+
+    unless ($ENCODING_LOCALE) {
+	eval {
+	    require I18N::Langinfo;
+	    $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());
+
+	    # Workaround of Encode < v2.25.  The "646" encoding  alias was
+	    # introduced in Encode-2.25, but we don't want to require that version
+	    # quite yet.  Should avoid the CPAN testers failure reported from
+	    # openbsd-4.7/perl-5.10.0 combo.
+	    $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646";
+
+	    # https://rt.cpan.org/Ticket/Display.html?id=66373
+	    $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8";
+	};
+	$ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN;
+    }
+
+    if ($^O eq "darwin") {
+	$ENCODING_LOCALE_FS ||= "UTF-8";
+    }
+
+    # final fallback
+    $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8";
+    $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE;
+    $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE;
+    $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN;
+
+    unless (Encode::find_encoding($ENCODING_LOCALE)) {
+	my $foundit;
+	if (lc($ENCODING_LOCALE) eq "gb18030") {
+	    eval {
+		require Encode::HanExtra;
+	    };
+	    if ($@) {
+		die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped";
+	    }
+	    $foundit++ if Encode::find_encoding($ENCODING_LOCALE);
+	}
+	die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped"
+	    unless $foundit;
+
+    }
+
+    # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT;
+}
+
+_init();
+Encode::Alias::define_alias(sub {
+    no strict 'refs';
+    no warnings 'once';
+    return ${"ENCODING_" . uc(shift)};
+}, "locale");
+
+sub _flush_aliases {
+    no strict 'refs';
+    for my $a (keys %Encode::Alias::Alias) {
+	if (defined ${"ENCODING_" . uc($a)}) {
+	    delete $Encode::Alias::Alias{$a};
+	    warn "Flushed alias cache for $a" if DEBUG;
+	}
+    }
+}
+
+sub reinit {
+    $ENCODING_LOCALE = shift;
+    $ENCODING_LOCALE_FS = shift;
+    $ENCODING_CONSOLE_IN = $ENCODING_LOCALE;
+    $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE;
+    _init();
+    _flush_aliases();
+}
+
+sub decode_argv {
+    die if defined wantarray;
+    for (@ARGV) {
+	$_ = Encode::decode(locale => $_, @_);
+    }
+}
+
+sub env {
+    my $k = Encode::encode(locale => shift);
+    my $old = $ENV{$k};
+    if (@_) {
+	my $v = shift;
+	if (defined $v) {
+	    $ENV{$k} = Encode::encode(locale => $v);
+	}
+	else {
+	    delete $ENV{$k};
+	}
+    }
+    return Encode::decode(locale => $old) if defined wantarray;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Encode::Locale - Determine the locale encoding
+
+=head1 SYNOPSIS
+
+  use Encode::Locale;
+  use Encode;
+
+  $string = decode(locale => $bytes);
+  $bytes = encode(locale => $string);
+
+  if (-t) {
+      binmode(STDIN, ":encoding(console_in)");
+      binmode(STDOUT, ":encoding(console_out)");
+      binmode(STDERR, ":encoding(console_out)");
+  }
+
+  # Processing file names passed in as arguments
+  my $uni_filename = decode(locale => $ARGV[0]);
+  open(my $fh, "<", encode(locale_fs => $uni_filename))
+     || die "Can't open '$uni_filename': $!";
+  binmode($fh, ":encoding(locale)");
+  ...
+
+=head1 DESCRIPTION
+
+In many applications it's wise to let Perl use Unicode for the strings it
+processes.  Most of the interfaces Perl has to the outside world are still byte
+based.  Programs therefore need to decode byte strings that enter the program
+from the outside and encode them again on the way out.
+
+The POSIX locale system is used to specify both the language conventions
+requested by the user and the preferred character set to consume and
+output.  The C<Encode::Locale> module looks up the charset and encoding (called
+a CODESET in the locale jargon) and arranges for the L<Encode> module to know
+this encoding under the name "locale".  It means bytes obtained from the
+environment can be converted to Unicode strings by calling C<<
+Encode::encode(locale => $bytes) >> and converted back again with C<<
+Encode::decode(locale => $string) >>.
+
+Where file systems interfaces pass file names in and out of the program we also
+need care.  The trend is for operating systems to use a fixed file encoding
+that don't actually depend on the locale; and this module determines the most
+appropriate encoding for file names. The L<Encode> module will know this
+encoding under the name "locale_fs".  For traditional Unix systems this will
+be an alias to the same encoding as "locale".
+
+For programs running in a terminal window (called a "Console" on some systems)
+the "locale" encoding is usually a good choice for what to expect as input and
+output.  Some systems allows us to query the encoding set for the terminal and
+C<Encode::Locale> will do that if available and make these encodings known
+under the C<Encode> aliases "console_in" and "console_out".  For systems where
+we can't determine the terminal encoding these will be aliased as the same
+encoding as "locale".  The advice is to use "console_in" for input known to
+come from the terminal and "console_out" for output known to go from the
+terminal.
+
+In addition to arranging for various Encode aliases the following functions and
+variables are provided:
+
+=over
+
+=item decode_argv( )
+
+=item decode_argv( Encode::FB_CROAK )
+
+This will decode the command line arguments to perl (the C<@ARGV> array) in-place.
+
+The function will by default replace characters that can't be decoded by
+"\x{FFFD}", the Unicode replacement character.
+
+Any argument provided is passed as CHECK to underlying Encode::decode() call.
+Pass the value C<Encode::FB_CROAK> to have the decoding croak if not all the
+command line arguments can be decoded.  See L<Encode/"Handling Malformed Data">
+for details on other options for CHECK.
+
+=item env( $uni_key )
+
+=item env( $uni_key => $uni_value )
+
+Interface to get/set environment variables.  Returns the current value as a
+Unicode string. The $uni_key and $uni_value arguments are expected to be
+Unicode strings as well.  Passing C<undef> as $uni_value deletes the
+environment variable named $uni_key.
+
+The returned value will have the characters that can't be decoded replaced by
+"\x{FFFD}", the Unicode replacement character.
+
+There is no interface to request alternative CHECK behavior as for
+decode_argv().  If you need that you need to call encode/decode yourself.
+For example:
+
+    my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK);
+    my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK);
+
+=item reinit( )
+
+=item reinit( $encoding )
+
+Reinitialize the encodings from the locale.  You want to call this function if
+you changed anything in the environment that might influence the locale.
+
+This function will croak if the determined encoding isn't recognized by
+the Encode module.
+
+With argument force $ENCODING_... variables to set to the given value.
+
+=item $ENCODING_LOCALE
+
+The encoding name determined to be suitable for the current locale.
+L<Encode> know this encoding as "locale".
+
+=item $ENCODING_LOCALE_FS
+
+The encoding name determined to be suiteable for file system interfaces
+involving file names.
+L<Encode> know this encoding as "locale_fs".
+
+=item $ENCODING_CONSOLE_IN
+
+=item $ENCODING_CONSOLE_OUT
+
+The encodings to be used for reading and writing output to the a console.
+L<Encode> know these encodings as "console_in" and "console_out".
+
+=back
+
+=head1 NOTES
+
+This table summarizes the mapping of the encodings set up
+by the C<Encode::Locale> module:
+
+  Encode      |         |              |
+  Alias       | Windows | Mac OS X     | POSIX
+  ------------+---------+--------------+------------
+  locale      | ANSI    | nl_langinfo  | nl_langinfo
+  locale_fs   | ANSI    | UTF-8        | nl_langinfo
+  console_in  | OEM     | nl_langinfo  | nl_langinfo
+  console_out | OEM     | nl_langinfo  | nl_langinfo
+
+=head2 Windows
+
+Windows has basically 2 sets of APIs.  A wide API (based on passing UTF-16
+strings) and a byte based API based a character set called ANSI.  The
+regular Perl interfaces to the OS currently only uses the ANSI APIs.
+Unfortunately ANSI is not a single character set.
+
+The encoding that corresponds to ANSI varies between different editions of
+Windows.  For many western editions of Windows ANSI corresponds to CP-1252
+which is a character set similar to ISO-8859-1.  Conceptually the ANSI
+character set is a similar concept to the POSIX locale CODESET so this module
+figures out what the ANSI code page is and make this available as
+$ENCODING_LOCALE and the "locale" Encoding alias.
+
+Windows systems also operate with another byte based character set.
+It's called the OEM code page.  This is the encoding that the Console
+takes as input and output.  It's common for the OEM code page to
+differ from the ANSI code page.
+
+=head2 Mac OS X
+
+On Mac OS X the file system encoding is always UTF-8 while the locale
+can otherwise be set up as normal for POSIX systems.
+
+File names on Mac OS X will at the OS-level be converted to
+NFD-form.  A file created by passing a NFC-filename will come
+in NFD-form from readdir().  See L<Unicode::Normalize> for details
+of NFD/NFC.
+
+Actually, Apple does not follow the Unicode NFD standard since not all
+character ranges are decomposed.  The claim is that this avoids problems with
+round trip conversions from old Mac text encodings.  See L<Encode::UTF8Mac> for
+details.
+
+=head2 POSIX (Linux and other Unixes)
+
+File systems might vary in what encoding is to be used for
+filenames.  Since this module has no way to actually figure out
+what the is correct it goes with the best guess which is to
+assume filenames are encoding according to the current locale.
+Users are advised to always specify UTF-8 as the locale charset.
+
+=head1 SEE ALSO
+
+L<I18N::Langinfo>, L<Encode>
+
+=head1 AUTHOR
+
+Copyright 2010 Gisle Aas <gisle@aas.no>.
+
+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/Config.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Config.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Config.pm	(revision 27174)
@@ -0,0 +1,436 @@
+package HTTP::Config;
+
+use strict;
+use URI;
+use vars qw($VERSION);
+
+$VERSION = "6.00";
+
+sub new {
+    my $class = shift;
+    return bless [], $class;
+}
+
+sub entries {
+    my $self = shift;
+    @$self;
+}
+
+sub empty {
+    my $self = shift;
+    not @$self;
+}
+
+sub add {
+    if (@_ == 2) {
+        my $self = shift;
+        push(@$self, shift);
+        return;
+    }
+    my($self, %spec) = @_;
+    push(@$self, \%spec);
+    return;
+}
+
+sub find2 {
+    my($self, %spec) = @_;
+    my @found;
+    my @rest;
+ ITEM:
+    for my $item (@$self) {
+        for my $k (keys %spec) {
+            if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
+                push(@rest, $item);
+                next ITEM;
+            }
+        }
+        push(@found, $item);
+    }
+    return \@found unless wantarray;
+    return \@found, \@rest;
+}
+
+sub find {
+    my $self = shift;
+    my $f = $self->find2(@_);
+    return @$f if wantarray;
+    return $f->[0];
+}
+
+sub remove {
+    my($self, %spec) = @_;
+    my($removed, $rest) = $self->find2(%spec);
+    @$self = @$rest if @$removed;
+    return @$removed;
+}
+
+my %MATCH = (
+    m_scheme => sub {
+        my($v, $uri) = @_;
+        return $uri->_scheme eq $v;  # URI known to be canonical
+    },
+    m_secure => sub {
+        my($v, $uri) = @_;
+        my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https";
+        return $secure == !!$v;
+    },
+    m_host_port => sub {
+        my($v, $uri) = @_;
+        return unless $uri->can("host_port");
+        return $uri->host_port eq $v, 7;
+    },
+    m_host => sub {
+        my($v, $uri) = @_;
+        return unless $uri->can("host");
+        return $uri->host eq $v, 6;
+    },
+    m_port => sub {
+        my($v, $uri) = @_;
+        return unless $uri->can("port");
+        return $uri->port eq $v;
+    },
+    m_domain => sub {
+        my($v, $uri) = @_;
+        return unless $uri->can("host");
+        my $h = $uri->host;
+        $h = "$h.local" unless $h =~ /\./;
+        $v = ".$v" unless $v =~ /^\./;
+        return length($v), 5 if substr($h, -length($v)) eq $v;
+        return 0;
+    },
+    m_path => sub {
+        my($v, $uri) = @_;
+        return unless $uri->can("path");
+        return $uri->path eq $v, 4;
+    },
+    m_path_prefix => sub {
+        my($v, $uri) = @_;
+        return unless $uri->can("path");
+        my $path = $uri->path;
+        my $len = length($v);
+        return $len, 3 if $path eq $v;
+        return 0 if length($path) <= $len;
+        $v .= "/" unless $v =~ m,/\z,,;
+        return $len, 3 if substr($path, 0, length($v)) eq $v;
+        return 0;
+    },
+    m_path_match => sub {
+        my($v, $uri) = @_;
+        return unless $uri->can("path");
+        return $uri->path =~ $v;
+    },
+    m_uri__ => sub {
+        my($v, $k, $uri) = @_;
+        return unless $uri->can($k);
+        return 1 unless defined $v;
+        return $uri->$k eq $v;
+    },
+    m_method => sub {
+        my($v, $uri, $request) = @_;
+        return $request && $request->method eq $v;
+    },
+    m_proxy => sub {
+        my($v, $uri, $request) = @_;
+        return $request && ($request->{proxy} || "") eq $v;
+    },
+    m_code => sub {
+        my($v, $uri, $request, $response) = @_;
+        $v =~ s/xx\z//;
+        return unless $response;
+        return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
+    },
+    m_media_type => sub {  # for request too??
+        my($v, $uri, $request, $response) = @_;
+        return unless $response;
+        return 1, 1 if $v eq "*/*";
+        my $ct = $response->content_type;
+        return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
+        return 3, 1 if $v eq "html" && $response->content_is_html;
+        return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml;
+        return 10, 1 if $v eq $ct;
+        return 0;
+    },
+    m_header__ => sub {
+        my($v, $k, $uri, $request, $response) = @_;
+        return unless $request;
+        return 1 if $request->header($k) eq $v;
+        return 1 if $response && $response->header($k) eq $v;
+        return 0;
+    },
+    m_response_attr__ => sub {
+        my($v, $k, $uri, $request, $response) = @_;
+        return unless $response;
+        return 1 if !defined($v) && exists $response->{$k};
+        return 0 unless exists $response->{$k};
+        return 1 if $response->{$k} eq $v;
+        return 0;
+    },
+);
+
+sub matching {
+    my $self = shift;
+    if (@_ == 1) {
+        if ($_[0]->can("request")) {
+            unshift(@_, $_[0]->request);
+            unshift(@_, undef) unless defined $_[0];
+        }
+        unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
+    }
+    my($uri, $request, $response) = @_;
+    $uri = URI->new($uri) unless ref($uri);
+
+    my @m;
+ ITEM:
+    for my $item (@$self) {
+        my $order;
+        for my $ikey (keys %$item) {
+            my $mkey = $ikey;
+            my $k;
+            $k = $1 if $mkey =~ s/__(.*)/__/;
+            if (my $m = $MATCH{$mkey}) {
+                #print "$ikey $mkey\n";
+                my($c, $o);
+                my @arg = (
+                    defined($k) ? $k : (),
+                    $uri, $request, $response
+                );
+                my $v = $item->{$ikey};
+                $v = [$v] unless ref($v) eq "ARRAY";
+                for (@$v) {
+                    ($c, $o) = $m->($_, @arg);
+                    #print "  - $_ ==> $c $o\n";
+                    last if $c;
+                }
+                next ITEM unless $c;
+                $order->[$o || 0] += $c;
+            }
+        }
+        $order->[7] ||= 0;
+        $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
+        push(@m, $item);
+    }
+    @m = sort { $b->{_order} cmp $a->{_order} } @m;
+    delete $_->{_order} for @m;
+    return @m if wantarray;
+    return $m[0];
+}
+
+sub add_item {
+    my $self = shift;
+    my $item = shift;
+    return $self->add(item => $item, @_);
+}
+
+sub remove_items {
+    my $self = shift;
+    return map $_->{item}, $self->remove(@_);
+}
+
+sub matching_items {
+    my $self = shift;
+    return map $_->{item}, $self->matching(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Config - Configuration for request and response objects
+
+=head1 SYNOPSIS
+
+ use HTTP::Config;
+ my $c = HTTP::Config->new;
+ $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
+ 
+ use HTTP::Request;
+ my $request = HTTP::Request->new(GET => "http://www.example.com");
+ 
+ if (my @m = $c->matching($request)) {
+    print "Yadayada\n" if $m[0]->{verbose};
+ }
+
+=head1 DESCRIPTION
+
+An C<HTTP::Config> object is a list of entries that
+can be matched against request or request/response pairs.  Its
+purpose is to hold configuration data that can be looked up given a
+request or response object.
+
+Each configuration entry is a hash.  Some keys specify matching to
+occur against attributes of request/response objects.  Other keys can
+be used to hold user data.
+
+The following methods are provided:
+
+=over 4
+
+=item $conf = HTTP::Config->new
+
+Constructs a new empty C<HTTP::Config> object and returns it.
+
+=item $conf->entries
+
+Returns the list of entries in the configuration object.
+In scalar context returns the number of entries.
+
+=item $conf->empty
+
+Return true if there are no entries in the configuration object.
+This is just a shorthand for C<< not $conf->entries >>.
+
+=item $conf->add( %matchspec, %other )
+
+=item $conf->add( \%entry )
+
+Adds a new entry to the configuration.
+You can either pass separate key/value pairs or a hash reference.
+
+=item $conf->remove( %spec )
+
+Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
+If %spec is empty this will match all entries; so it will empty the configuation object.
+
+=item $conf->matching( $uri, $request, $response )
+
+=item $conf->matching( $uri )
+
+=item $conf->matching( $request )
+
+=item $conf->matching( $response )
+
+Returns the entries that match the given $uri, $request and $response triplet.
+
+If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
+If called with a single $response object, then the request object is obtained by calling its 'request' method;
+and then the $uri is obtained as if a single $request was provided.
+
+The entries are returned with the most specific matches first.
+In scalar context returns the most specific match or C<undef> in none match.
+
+=item $conf->add_item( $item, %matchspec )
+
+=item $conf->remove_items( %spec )
+
+=item $conf->matching_items( $uri, $request, $response )
+
+Wrappers that hides the entries themselves.
+
+=back
+
+=head2 Matching
+
+The following keys on a configuration entry specify matching.  For all
+of these you can provide an array of values instead of a single value.
+The entry matches if at least one of the values in the array matches.
+
+Entries that require match against a response object attribute will never match
+unless a response object was provided.
+
+=over
+
+=item m_scheme => $scheme
+
+Matches if the URI uses the specified scheme; e.g. "http".
+
+=item m_secure => $bool
+
+If $bool is TRUE; matches if the URI uses a secure scheme.  If $bool
+is FALSE; matches if the URI does not use a secure scheme.  An example
+of a secure scheme is "https".
+
+=item m_host_port => "$hostname:$port"
+
+Matches if the URI's host_port method return the specified value.
+
+=item m_host => $hostname
+
+Matches if the URI's host method returns the specified value.
+
+=item m_port => $port
+
+Matches if the URI's port method returns the specified value.
+
+=item m_domain => ".$domain"
+
+Matches if the URI's host method return a value that within the given
+domain.  The hostname "www.example.com" will for instance match the
+domain ".com".
+
+=item m_path => $path
+
+Matches if the URI's path method returns the specified value.
+
+=item m_path_prefix => $path
+
+Matches if the URI's path is the specified path or has the specified
+path as prefix.
+
+=item m_path_match => $Regexp
+
+Matches if the regular expression matches the URI's path.  Eg. qr/\.html$/.
+
+=item m_method => $method
+
+Matches if the request method matches the specified value. Eg. "GET" or "POST".
+
+=item m_code => $digit
+
+=item m_code => $status_code
+
+Matches if the response status code matches.  If a single digit is
+specified; matches for all response status codes beginning with that digit.
+
+=item m_proxy => $url
+
+Matches if the request is to be sent to the given Proxy server.
+
+=item m_media_type => "*/*"
+
+=item m_media_type => "text/*"
+
+=item m_media_type => "html"
+
+=item m_media_type => "xhtml"
+
+=item m_media_type => "text/html"
+
+Matches if the response media type matches.
+
+With a value of "html" matches if $response->content_is_html returns TRUE.
+With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
+
+=item m_uri__I<$method> => undef
+
+Matches if the URI object provides the method.
+
+=item m_uri__I<$method> => $string
+
+Matches if the URI's $method method returns the given value.
+
+=item m_header__I<$field> => $string
+
+Matches if either the request or the response have a header $field with the given value.
+
+=item m_response_attr__I<$key> => undef
+
+=item m_response_attr__I<$key> => $string
+
+Matches if the response object has that key, or the entry has the given value.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>, L<HTTP::Request>, L<HTTP::Response>
+
+=head1 COPYRIGHT
+
+Copyright 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/Date.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Date.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Date.pm	(revision 27174)
@@ -0,0 +1,388 @@
+package HTTP::Date;
+
+$VERSION = "6.02";
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(time2str str2time);
+@EXPORT_OK = qw(parse_date time2iso time2isoz);
+
+use strict;
+require Time::Local;
+
+use vars qw(@DoW @MoY %MoY);
+@DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
+@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+@MoY{@MoY} = (1..12);
+
+my %GMT_ZONE = (GMT => 1, UTC => 1, UT => 1, Z => 1);
+
+
+sub time2str (;$)
+{
+    my $time = shift;
+    $time = time unless defined $time;
+    my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
+    sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
+	    $DoW[$wday],
+	    $mday, $MoY[$mon], $year+1900,
+	    $hour, $min, $sec);
+}
+
+
+sub str2time ($;$)
+{
+    my $str = shift;
+    return undef unless defined $str;
+
+    # fast exit for strictly conforming string
+    if ($str =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/) {
+	return eval {
+	    my $t = Time::Local::timegm($6, $5, $4, $1, $MoY{$2}-1, $3);
+	    $t < 0 ? undef : $t;
+	};
+    }
+
+    my @d = parse_date($str);
+    return undef unless @d;
+    $d[1]--;        # month
+
+    my $tz = pop(@d);
+    unless (defined $tz) {
+	unless (defined($tz = shift)) {
+	    return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
+			  my $t = Time::Local::timelocal(reverse @d) + $frac;
+			  $t < 0 ? undef : $t;
+		        };
+	}
+    }
+
+    my $offset = 0;
+    if ($GMT_ZONE{uc $tz}) {
+	# offset already zero
+    }
+    elsif ($tz =~ /^([-+])?(\d\d?):?(\d\d)?$/) {
+	$offset = 3600 * $2;
+	$offset += 60 * $3 if $3;
+	$offset *= -1 if $1 && $1 eq '-';
+    }
+    else {
+	eval { require Time::Zone } || return undef;
+	$offset = Time::Zone::tz_offset($tz);
+	return undef unless defined $offset;
+    }
+
+    return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
+		  my $t = Time::Local::timegm(reverse @d) + $frac;
+		  $t < 0 ? undef : $t - $offset;
+		};
+}
+
+
+sub parse_date ($)
+{
+    local($_) = shift;
+    return unless defined;
+
+    # More lax parsing below
+    s/^\s+//;  # kill leading space
+    s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday
+
+    my($day, $mon, $yr, $hr, $min, $sec, $tz, $ampm);
+
+    # Then we are able to check for most of the formats with this regexp
+    (($day,$mon,$yr,$hr,$min,$sec,$tz) =
+        /^
+	 (\d\d?)               # day
+	    (?:\s+|[-\/])
+	 (\w+)                 # month
+	    (?:\s+|[-\/])
+	 (\d+)                 # year
+	 (?:
+	       (?:\s+|:)       # separator before clock
+	    (\d\d?):(\d\d)     # hour:min
+	    (?::(\d\d))?       # optional seconds
+	 )?                    # optional clock
+	    \s*
+	 ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
+	    \s*
+	 (?:\(\w+\)|\w{3,})?   # ASCII representation of timezone.
+	    \s*$
+	/x)
+
+    ||
+
+    # Try the ctime and asctime format
+    (($mon, $day, $hr, $min, $sec, $tz, $yr) =
+	/^
+	 (\w{1,3})             # month
+	    \s+
+	 (\d\d?)               # day
+	    \s+
+	 (\d\d?):(\d\d)        # hour:min
+	 (?::(\d\d))?          # optional seconds
+	    \s+
+	 (?:([A-Za-z]+)\s+)?   # optional timezone
+	 (\d+)                 # year
+	    \s*$               # allow trailing whitespace
+	/x)
+
+    ||
+
+    # Then the Unix 'ls -l' date format
+    (($mon, $day, $yr, $hr, $min, $sec) =
+	/^
+	 (\w{3})               # month
+	    \s+
+	 (\d\d?)               # day
+	    \s+
+	 (?:
+	    (\d\d\d\d) |       # year
+	    (\d{1,2}):(\d{2})  # hour:min
+            (?::(\d\d))?       # optional seconds
+	 )
+	 \s*$
+       /x)
+
+    ||
+
+    # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants
+    (($yr, $mon, $day, $hr, $min, $sec, $tz) =
+	/^
+	  (\d{4})              # year
+	     [-\/]?
+	  (\d\d?)              # numerical month
+	     [-\/]?
+	  (\d\d?)              # day
+	 (?:
+	       (?:\s+|[-:Tt])  # separator before clock
+	    (\d\d?):?(\d\d)    # hour:min
+	    (?::?(\d\d(?:\.\d*)?))?  # optional seconds (and fractional)
+	 )?                    # optional clock
+	    \s*
+	 ([-+]?\d\d?:?(:?\d\d)?
+	  |Z|z)?               # timezone  (Z is "zero meridian", i.e. GMT)
+	    \s*$
+	/x)
+
+    ||
+
+    # Windows 'dir' 11-12-96  03:52PM
+    (($mon, $day, $yr, $hr, $min, $ampm) =
+        /^
+          (\d{2})                # numerical month
+             -
+          (\d{2})                # day
+             -
+          (\d{2})                # year
+             \s+
+          (\d\d?):(\d\d)([APap][Mm])  # hour:min AM or PM
+             \s*$
+        /x)
+
+    ||
+    return;  # unrecognized format
+
+    # Translate month name to number
+    $mon = $MoY{$mon} ||
+           $MoY{"\u\L$mon"} ||
+	   ($mon =~ /^\d\d?$/ && $mon >= 1 && $mon <= 12 && int($mon)) ||
+           return;
+
+    # If the year is missing, we assume first date before the current,
+    # because of the formats we support such dates are mostly present
+    # on "ls -l" listings.
+    unless (defined $yr) {
+	my $cur_mon;
+	($cur_mon, $yr) = (localtime)[4, 5];
+	$yr += 1900;
+	$cur_mon++;
+	$yr-- if $mon > $cur_mon;
+    }
+    elsif (length($yr) < 3) {
+	# Find "obvious" year
+	my $cur_yr = (localtime)[5] + 1900;
+	my $m = $cur_yr % 100;
+	my $tmp = $yr;
+	$yr += $cur_yr - $m;
+	$m -= $tmp;
+	$yr += ($m > 0) ? 100 : -100
+	    if abs($m) > 50;
+    }
+
+    # Make sure clock elements are defined
+    $hr  = 0 unless defined($hr);
+    $min = 0 unless defined($min);
+    $sec = 0 unless defined($sec);
+
+    # Compensate for AM/PM
+    if ($ampm) {
+	$ampm = uc $ampm;
+	$hr = 0 if $hr == 12 && $ampm eq 'AM';
+	$hr += 12 if $ampm eq 'PM' && $hr != 12;
+    }
+
+    return($yr, $mon, $day, $hr, $min, $sec, $tz)
+	if wantarray;
+
+    if (defined $tz) {
+	$tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/;
+    }
+    else {
+	$tz = "";
+    }
+    return sprintf("%04d-%02d-%02d %02d:%02d:%02d%s",
+		   $yr, $mon, $day, $hr, $min, $sec, $tz);
+}
+
+
+sub time2iso (;$)
+{
+    my $time = shift;
+    $time = time unless defined $time;
+    my($sec,$min,$hour,$mday,$mon,$year) = localtime($time);
+    sprintf("%04d-%02d-%02d %02d:%02d:%02d",
+	    $year+1900, $mon+1, $mday, $hour, $min, $sec);
+}
+
+
+sub time2isoz (;$)
+{
+    my $time = shift;
+    $time = time unless defined $time;
+    my($sec,$min,$hour,$mday,$mon,$year) = gmtime($time);
+    sprintf("%04d-%02d-%02d %02d:%02d:%02dZ",
+            $year+1900, $mon+1, $mday, $hour, $min, $sec);
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Date - date conversion routines
+
+=head1 SYNOPSIS
+
+ use HTTP::Date;
+
+ $string = time2str($time);    # Format as GMT ASCII time
+ $time = str2time($string);    # convert ASCII date to machine time
+
+=head1 DESCRIPTION
+
+This module provides functions that deal the date formats used by the
+HTTP protocol (and then some more).  Only the first two functions,
+time2str() and str2time(), are exported by default.
+
+=over 4
+
+=item time2str( [$time] )
+
+The time2str() function converts a machine time (seconds since epoch)
+to a string.  If the function is called without an argument or with an
+undefined argument, it will use the current time.
+
+The string returned is in the format preferred for the HTTP protocol.
+This is a fixed length subset of the format defined by RFC 1123,
+represented in Universal Time (GMT).  An example of a time stamp
+in this format is:
+
+   Sun, 06 Nov 1994 08:49:37 GMT
+
+=item str2time( $str [, $zone] )
+
+The str2time() function converts a string to machine time.  It returns
+C<undef> if the format of $str is unrecognized, otherwise whatever the
+C<Time::Local> functions can make out of the parsed time.  Dates
+before the system's epoch may not work on all operating systems.  The
+time formats recognized are the same as for parse_date().
+
+The function also takes an optional second argument that specifies the
+default time zone to use when converting the date.  This parameter is
+ignored if the zone is found in the date string itself.  If this
+parameter is missing, and the date string format does not contain any
+zone specification, then the local time zone is assumed.
+
+If the zone is not "C<GMT>" or numerical (like "C<-0800>" or
+"C<+0100>"), then the C<Time::Zone> module must be installed in order
+to get the date recognized.
+
+=item parse_date( $str )
+
+This function will try to parse a date string, and then return it as a
+list of numerical values followed by a (possible undefined) time zone
+specifier; ($year, $month, $day, $hour, $min, $sec, $tz).  The $year
+will be the full 4-digit year, and $month numbers start with 1 (for January).
+
+In scalar context the numbers are interpolated in a string of the
+"YYYY-MM-DD hh:mm:ss TZ"-format and returned.
+
+If the date is unrecognized, then the empty list is returned (C<undef> in
+scalar context).
+
+The function is able to parse the following formats:
+
+ "Wed, 09 Feb 1994 22:23:32 GMT"       -- HTTP format
+ "Thu Feb  3 17:03:55 GMT 1994"        -- ctime(3) format
+ "Thu Feb  3 00:00:00 1994",           -- ANSI C asctime() format
+ "Tuesday, 08-Feb-94 14:15:29 GMT"     -- old rfc850 HTTP format
+ "Tuesday, 08-Feb-1994 14:15:29 GMT"   -- broken rfc850 HTTP format
+
+ "03/Feb/1994:17:03:55 -0700"   -- common logfile format
+ "09 Feb 1994 22:23:32 GMT"     -- HTTP format (no weekday)
+ "08-Feb-94 14:15:29 GMT"       -- rfc850 format (no weekday)
+ "08-Feb-1994 14:15:29 GMT"     -- broken rfc850 format (no weekday)
+
+ "1994-02-03 14:15:29 -0100"    -- ISO 8601 format
+ "1994-02-03 14:15:29"          -- zone is optional
+ "1994-02-03"                   -- only date
+ "1994-02-03T14:15:29"          -- Use T as separator
+ "19940203T141529Z"             -- ISO 8601 compact format
+ "19940203"                     -- only date
+
+ "08-Feb-94"         -- old rfc850 HTTP format    (no weekday, no time)
+ "08-Feb-1994"       -- broken rfc850 HTTP format (no weekday, no time)
+ "09 Feb 1994"       -- proposed new HTTP format  (no weekday, no time)
+ "03/Feb/1994"       -- common logfile format     (no time, no offset)
+
+ "Feb  3  1994"      -- Unix 'ls -l' format
+ "Feb  3 17:03"      -- Unix 'ls -l' format
+
+ "11-15-96  03:52PM" -- Windows 'dir' format
+
+The parser ignores leading and trailing whitespace.  It also allow the
+seconds to be missing and the month to be numerical in most formats.
+
+If the year is missing, then we assume that the date is the first
+matching date I<before> current month.  If the year is given with only
+2 digits, then parse_date() will select the century that makes the
+year closest to the current date.
+
+=item time2iso( [$time] )
+
+Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted
+string representing time in the local time zone.
+
+=item time2isoz( [$time] )
+
+Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted
+string representing Universal Time.
+
+
+=back
+
+=head1 SEE ALSO
+
+L<perlfunc/time>, L<Time::Zone>
+
+=head1 COPYRIGHT
+
+Copyright 1995-1999, 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/Headers.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Headers.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Headers.pm	(revision 27174)
@@ -0,0 +1,854 @@
+package HTTP::Headers;
+
+use strict;
+use Carp ();
+
+use vars qw($VERSION $TRANSLATE_UNDERSCORE);
+$VERSION = "6.05";
+
+# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
+# as a replacement for '-' in header field names.
+$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
+
+# "Good Practice" order of HTTP message headers:
+#    - General-Headers
+#    - Request-Headers
+#    - Response-Headers
+#    - Entity-Headers
+
+my @general_headers = qw(
+    Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
+    Via Warning
+);
+
+my @request_headers = qw(
+    Accept Accept-Charset Accept-Encoding Accept-Language
+    Authorization Expect From Host
+    If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
+    Max-Forwards Proxy-Authorization Range Referer TE User-Agent
+);
+
+my @response_headers = qw(
+    Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
+    Vary WWW-Authenticate
+);
+
+my @entity_headers = qw(
+    Allow Content-Encoding Content-Language Content-Length Content-Location
+    Content-MD5 Content-Range Content-Type Expires Last-Modified
+);
+
+my %entity_header = map { lc($_) => 1 } @entity_headers;
+
+my @header_order = (
+    @general_headers,
+    @request_headers,
+    @response_headers,
+    @entity_headers,
+);
+
+# Make alternative representations of @header_order.  This is used
+# for sorting and case matching.
+my %header_order;
+my %standard_case;
+
+{
+    my $i = 0;
+    for (@header_order) {
+	my $lc = lc $_;
+	$header_order{$lc} = ++$i;
+	$standard_case{$lc} = $_;
+    }
+}
+
+
+
+sub new
+{
+    my($class) = shift;
+    my $self = bless {}, $class;
+    $self->header(@_) if @_; # set up initial headers
+    $self;
+}
+
+
+sub header
+{
+    my $self = shift;
+    Carp::croak('Usage: $h->header($field, ...)') unless @_;
+    my(@old);
+    my %seen;
+    while (@_) {
+	my $field = shift;
+        my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
+	@old = $self->_header($field, shift, $op);
+    }
+    return @old if wantarray;
+    return $old[0] if @old <= 1;
+    join(", ", @old);
+}
+
+sub clear
+{
+    my $self = shift;
+    %$self = ();
+}
+
+
+sub push_header
+{
+    my $self = shift;
+    return $self->_header(@_, 'PUSH_H') if @_ == 2;
+    while (@_) {
+	$self->_header(splice(@_, 0, 2), 'PUSH_H');
+    }
+}
+
+
+sub init_header
+{
+    Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
+    shift->_header(@_, 'INIT');
+}
+
+
+sub remove_header
+{
+    my($self, @fields) = @_;
+    my $field;
+    my @values;
+    foreach $field (@fields) {
+	$field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
+	my $v = delete $self->{lc $field};
+	push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
+    }
+    return @values;
+}
+
+sub remove_content_headers
+{
+    my $self = shift;
+    unless (defined(wantarray)) {
+	# fast branch that does not create return object
+	delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
+	return;
+    }
+
+    my $c = ref($self)->new;
+    for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
+	$c->{$f} = delete $self->{$f};
+    }
+    if (exists $self->{'::std_case'}) {
+	$c->{'::std_case'} = $self->{'::std_case'};
+    }
+    $c;
+}
+
+
+sub _header
+{
+    my($self, $field, $val, $op) = @_;
+
+    Carp::croak("Illegal field name '$field'")
+        if rindex($field, ':') > 1 || !length($field);
+
+    unless ($field =~ /^:/) {
+	$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
+	my $old = $field;
+	$field = lc $field;
+	unless($standard_case{$field} || $self->{'::std_case'}{$field}) {
+	    # generate a %std_case entry for this field
+	    $old =~ s/\b(\w)/\u$1/g;
+	    $self->{'::std_case'}{$field} = $old;
+	}
+    }
+
+    $op ||= defined($val) ? 'SET' : 'GET';
+    if ($op eq 'PUSH_H') {
+	# Like PUSH but where we don't care about the return value
+	if (exists $self->{$field}) {
+	    my $h = $self->{$field};
+	    if (ref($h) eq 'ARRAY') {
+		push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
+	    }
+	    else {
+		$self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
+	    }
+	    return;
+	}
+	$self->{$field} = $val;
+	return;
+    }
+
+    my $h = $self->{$field};
+    my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
+
+    unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
+	if (defined($val)) {
+	    my @new = ($op eq 'PUSH') ? @old : ();
+	    if (ref($val) ne 'ARRAY') {
+		push(@new, $val);
+	    }
+	    else {
+		push(@new, @$val);
+	    }
+	    $self->{$field} = @new > 1 ? \@new : $new[0];
+	}
+	elsif ($op ne 'PUSH') {
+	    delete $self->{$field};
+	}
+    }
+    @old;
+}
+
+
+sub _sorted_field_names
+{
+    my $self = shift;
+    return [ sort {
+        ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
+         $a cmp $b
+    } grep !/^::/, keys %$self ];
+}
+
+
+sub header_field_names {
+    my $self = shift;
+    return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, @{ $self->_sorted_field_names },
+	if wantarray;
+    return grep !/^::/, keys %$self;
+}
+
+
+sub scan
+{
+    my($self, $sub) = @_;
+    my $key;
+    for $key (@{ $self->_sorted_field_names }) {
+	my $vals = $self->{$key};
+	if (ref($vals) eq 'ARRAY') {
+	    my $val;
+	    for $val (@$vals) {
+		$sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $val);
+	    }
+	}
+	else {
+	    $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $vals);
+	}
+    }
+}
+
+
+sub as_string
+{
+    my($self, $endl) = @_;
+    $endl = "\n" unless defined $endl;
+
+    my @result = ();
+    for my $key (@{ $self->_sorted_field_names }) {
+	next if index($key, '_') == 0;
+	my $vals = $self->{$key};
+	if ( ref($vals) eq 'ARRAY' ) {
+	    for my $val (@$vals) {
+		my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
+		$field =~ s/^://;
+		if ( index($val, "\n") >= 0 ) {
+		    $val = _process_newline($val, $endl);
+		}
+		push @result, $field . ': ' . $val;
+	    }
+	}
+	else {
+	    my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
+	    $field =~ s/^://;
+	    if ( index($vals, "\n") >= 0 ) {
+		$vals = _process_newline($vals, $endl);
+	    }
+	    push @result, $field . ': ' . $vals;
+	}
+    }
+
+    join($endl, @result, '');
+}
+
+sub _process_newline {
+    local $_ = shift;
+    my $endl = shift;
+    # must handle header values with embedded newlines with care
+    s/\s+$//;        # trailing newlines and space must go
+    s/\n(\x0d?\n)+/\n/g;     # no empty lines
+    s/\n([^\040\t])/\n $1/g; # initial space for continuation
+    s/\n/$endl/g;    # substitute with requested line ending
+    $_;
+}
+
+
+
+if (eval { require Storable; 1 }) {
+    *clone = \&Storable::dclone;
+} else {
+    *clone = sub {
+	my $self = shift;
+	my $clone = HTTP::Headers->new;
+	$self->scan(sub { $clone->push_header(@_);} );
+	$clone;
+    };
+}
+
+
+sub _date_header
+{
+    require HTTP::Date;
+    my($self, $header, $time) = @_;
+    my($old) = $self->_header($header);
+    if (defined $time) {
+	$self->_header($header, HTTP::Date::time2str($time));
+    }
+    $old =~ s/;.*// if defined($old);
+    HTTP::Date::str2time($old);
+}
+
+
+sub date                { shift->_date_header('Date',                @_); }
+sub expires             { shift->_date_header('Expires',             @_); }
+sub if_modified_since   { shift->_date_header('If-Modified-Since',   @_); }
+sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
+sub last_modified       { shift->_date_header('Last-Modified',       @_); }
+
+# This is used as a private LWP extension.  The Client-Date header is
+# added as a timestamp to a response when it has been received.
+sub client_date         { shift->_date_header('Client-Date',         @_); }
+
+# The retry_after field is dual format (can also be a expressed as
+# number of seconds from now), so we don't provide an easy way to
+# access it until we have know how both these interfaces can be
+# addressed.  One possibility is to return a negative value for
+# relative seconds and a positive value for epoch based time values.
+#sub retry_after       { shift->_date_header('Retry-After',       @_); }
+
+sub content_type      {
+    my $self = shift;
+    my $ct = $self->{'content-type'};
+    $self->{'content-type'} = shift if @_;
+    $ct = $ct->[0] if ref($ct) eq 'ARRAY';
+    return '' unless defined($ct) && length($ct);
+    my @ct = split(/;\s*/, $ct, 2);
+    for ($ct[0]) {
+	s/\s+//g;
+	$_ = lc($_);
+    }
+    wantarray ? @ct : $ct[0];
+}
+
+sub content_type_charset {
+    my $self = shift;
+    require HTTP::Headers::Util;
+    my $h = $self->{'content-type'};
+    $h = $h->[0] if ref($h);
+    $h = "" unless defined $h;
+    my @v = HTTP::Headers::Util::split_header_words($h);
+    if (@v) {
+	my($ct, undef, %ct_param) = @{$v[0]};
+	my $charset = $ct_param{charset};
+	if ($ct) {
+	    $ct = lc($ct);
+	    $ct =~ s/\s+//;
+	}
+	if ($charset) {
+	    $charset = uc($charset);
+	    $charset =~ s/^\s+//;  $charset =~ s/\s+\z//;
+	    undef($charset) if $charset eq "";
+	}
+	return $ct, $charset if wantarray;
+	return $charset;
+    }
+    return undef, undef if wantarray;
+    return undef;
+}
+
+sub content_is_text {
+    my $self = shift;
+    return $self->content_type =~ m,^text/,;
+}
+
+sub content_is_html {
+    my $self = shift;
+    return $self->content_type eq 'text/html' || $self->content_is_xhtml;
+}
+
+sub content_is_xhtml {
+    my $ct = shift->content_type;
+    return $ct eq "application/xhtml+xml" ||
+           $ct eq "application/vnd.wap.xhtml+xml";
+}
+
+sub content_is_xml {
+    my $ct = shift->content_type;
+    return 1 if $ct eq "text/xml";
+    return 1 if $ct eq "application/xml";
+    return 1 if $ct =~ /\+xml$/;
+    return 0;
+}
+
+sub referer           {
+    my $self = shift;
+    if (@_ && $_[0] =~ /#/) {
+	# Strip fragment per RFC 2616, section 14.36.
+	my $uri = shift;
+	if (ref($uri)) {
+	    $uri = $uri->clone;
+	    $uri->fragment(undef);
+	}
+	else {
+	    $uri =~ s/\#.*//;
+	}
+	unshift @_, $uri;
+    }
+    ($self->_header('Referer', @_))[0];
+}
+*referrer = \&referer;  # on tchrist's request
+
+sub title             { (shift->_header('Title',            @_))[0] }
+sub content_encoding  { (shift->_header('Content-Encoding', @_))[0] }
+sub content_language  { (shift->_header('Content-Language', @_))[0] }
+sub content_length    { (shift->_header('Content-Length',   @_))[0] }
+
+sub user_agent        { (shift->_header('User-Agent',       @_))[0] }
+sub server            { (shift->_header('Server',           @_))[0] }
+
+sub from              { (shift->_header('From',             @_))[0] }
+sub warning           { (shift->_header('Warning',          @_))[0] }
+
+sub www_authenticate  { (shift->_header('WWW-Authenticate', @_))[0] }
+sub authorization     { (shift->_header('Authorization',    @_))[0] }
+
+sub proxy_authenticate  { (shift->_header('Proxy-Authenticate',  @_))[0] }
+sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
+
+sub authorization_basic       { shift->_basic_auth("Authorization",       @_) }
+sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
+
+sub _basic_auth {
+    require MIME::Base64;
+    my($self, $h, $user, $passwd) = @_;
+    my($old) = $self->_header($h);
+    if (defined $user) {
+	Carp::croak("Basic authorization user name can't contain ':'")
+	  if $user =~ /:/;
+	$passwd = '' unless defined $passwd;
+	$self->_header($h => 'Basic ' .
+                             MIME::Base64::encode("$user:$passwd", ''));
+    }
+    if (defined $old && $old =~ s/^\s*Basic\s+//) {
+	my $val = MIME::Base64::decode($old);
+	return $val unless wantarray;
+	return split(/:/, $val, 2);
+    }
+    return;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Headers - Class encapsulating HTTP Message headers
+
+=head1 SYNOPSIS
+
+ require HTTP::Headers;
+ $h = HTTP::Headers->new;
+
+ $h->header('Content-Type' => 'text/plain');  # set
+ $ct = $h->header('Content-Type');            # get
+ $h->remove_header('Content-Type');           # delete
+
+=head1 DESCRIPTION
+
+The C<HTTP::Headers> class encapsulates HTTP-style message headers.
+The headers consist of attribute-value pairs also called fields, which
+may be repeated, and which are printed in a particular order.  The
+field names are cases insensitive.
+
+Instances of this class are usually created as member variables of the
+C<HTTP::Request> and C<HTTP::Response> classes, internal to the
+library.
+
+The following methods are available:
+
+=over 4
+
+=item $h = HTTP::Headers->new
+
+Constructs a new C<HTTP::Headers> object.  You might pass some initial
+attribute-value pairs as parameters to the constructor.  I<E.g.>:
+
+ $h = HTTP::Headers->new(
+       Date         => 'Thu, 03 Feb 1994 00:00:00 GMT',
+       Content_Type => 'text/html; version=3.2',
+       Content_Base => 'http://www.perl.org/');
+
+The constructor arguments are passed to the C<header> method which is
+described below.
+
+=item $h->clone
+
+Returns a copy of this C<HTTP::Headers> object.
+
+=item $h->header( $field )
+
+=item $h->header( $field => $value )
+
+=item $h->header( $f1 => $v1, $f2 => $v2, ... )
+
+Get or set the value of one or more header fields.  The header field
+name ($field) is not case sensitive.  To make the life easier for perl
+users who wants to avoid quoting before the => operator, you can use
+'_' as a replacement for '-' in header names.
+
+The header() method accepts multiple ($field => $value) pairs, which
+means that you can update several fields with a single invocation.
+
+The $value argument may be a plain string or a reference to an array
+of strings for a multi-valued field. If the $value is provided as
+C<undef> then the field is removed.  If the $value is not given, then
+that header field will remain unchanged.
+
+The old value (or values) of the last of the header fields is returned.
+If no such field exists C<undef> will be returned.
+
+A multi-valued field will be returned as separate values in list
+context and will be concatenated with ", " as separator in scalar
+context.  The HTTP spec (RFC 2616) promise that joining multiple
+values in this way will not change the semantic of a header field, but
+in practice there are cases like old-style Netscape cookies (see
+L<HTTP::Cookies>) where "," is used as part of the syntax of a single
+field value.
+
+Examples:
+
+ $header->header(MIME_Version => '1.0',
+		 User_Agent   => 'My-Web-Client/0.01');
+ $header->header(Accept => "text/html, text/plain, image/*");
+ $header->header(Accept => [qw(text/html text/plain image/*)]);
+ @accepts = $header->header('Accept');  # get multiple values
+ $accepts = $header->header('Accept');  # get values as a single string
+
+=item $h->push_header( $field => $value )
+
+=item $h->push_header( $f1 => $v1, $f2 => $v2, ... )
+
+Add a new field value for the specified header field.  Previous values
+for the same field are retained.
+
+As for the header() method, the field name ($field) is not case
+sensitive and '_' can be used as a replacement for '-'.
+
+The $value argument may be a scalar or a reference to a list of
+scalars.
+
+ $header->push_header(Accept => 'image/jpeg');
+ $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
+
+=item $h->init_header( $field => $value )
+
+Set the specified header to the given value, but only if no previous
+value for that field is set.
+
+The header field name ($field) is not case sensitive and '_'
+can be used as a replacement for '-'.
+
+The $value argument may be a scalar or a reference to a list of
+scalars.
+
+=item $h->remove_header( $field, ... )
+
+This function removes the header fields with the specified names.
+
+The header field names ($field) are not case sensitive and '_'
+can be used as a replacement for '-'.
+
+The return value is the values of the fields removed.  In scalar
+context the number of fields removed is returned.
+
+Note that if you pass in multiple field names then it is generally not
+possible to tell which of the returned values belonged to which field.
+
+=item $h->remove_content_headers
+
+This will remove all the header fields used to describe the content of
+a message.  All header field names prefixed with C<Content-> fall
+into this category, as well as C<Allow>, C<Expires> and
+C<Last-Modified>.  RFC 2616 denotes these fields as I<Entity Header
+Fields>.
+
+The return value is a new C<HTTP::Headers> object that contains the
+removed headers only.
+
+=item $h->clear
+
+This will remove all header fields.
+
+=item $h->header_field_names
+
+Returns the list of distinct names for the fields present in the
+header.  The field names have case as suggested by HTTP spec, and the
+names are returned in the recommended "Good Practice" order.
+
+In scalar context return the number of distinct field names.
+
+=item $h->scan( \&process_header_field )
+
+Apply a subroutine to each header field in turn.  The callback routine
+is called with two parameters; the name of the field and a single
+value (a string).  If a header field is multi-valued, then the
+routine is called once for each value.  The field name passed to the
+callback routine has case as suggested by HTTP spec, and the headers
+will be visited in the recommended "Good Practice" order.
+
+Any return values of the callback routine are ignored.  The loop can
+be broken by raising an exception (C<die>), but the caller of scan()
+would have to trap the exception itself.
+
+=item $h->as_string
+
+=item $h->as_string( $eol )
+
+Return the header fields as a formatted MIME header.  Since it
+internally uses the C<scan> method to build the string, the result
+will use case as suggested by HTTP spec, and it will follow
+recommended "Good Practice" of ordering the header fields.  Long header
+values are not folded.
+
+The optional $eol parameter specifies the line ending sequence to
+use.  The default is "\n".  Embedded "\n" characters in header field
+values will be substituted with this line ending sequence.
+
+=back
+
+=head1 CONVENIENCE METHODS
+
+The most frequently used headers can also be accessed through the
+following convenience methods.  Most of these methods can both be used to read
+and to set the value of a header.  The header value is set if you pass
+an argument to the method.  The old header value is always returned.
+If the given header did not exist then C<undef> is returned.
+
+Methods that deal with dates/times always convert their value to system
+time (seconds since Jan 1, 1970) and they also expect this kind of
+value when the header value is set.
+
+=over 4
+
+=item $h->date
+
+This header represents the date and time at which the message was
+originated. I<E.g.>:
+
+  $h->date(time);  # set current date
+
+=item $h->expires
+
+This header gives the date and time after which the entity should be
+considered stale.
+
+=item $h->if_modified_since
+
+=item $h->if_unmodified_since
+
+These header fields are used to make a request conditional.  If the requested
+resource has (or has not) been modified since the time specified in this field,
+then the server will return a C<304 Not Modified> response instead of
+the document itself.
+
+=item $h->last_modified
+
+This header indicates the date and time at which the resource was last
+modified. I<E.g.>:
+
+  # check if document is more than 1 hour old
+  if (my $last_mod = $h->last_modified) {
+      if ($last_mod < time - 60*60) {
+	  ...
+      }
+  }
+
+=item $h->content_type
+
+The Content-Type header field indicates the media type of the message
+content. I<E.g.>:
+
+  $h->content_type('text/html');
+
+The value returned will be converted to lower case, and potential
+parameters will be chopped off and returned as a separate value if in
+an array context.  If there is no such header field, then the empty
+string is returned.  This makes it safe to do the following:
+
+  if ($h->content_type eq 'text/html') {
+     # we enter this place even if the real header value happens to
+     # be 'TEXT/HTML; version=3.0'
+     ...
+  }
+
+=item $h->content_type_charset
+
+Returns the upper-cased charset specified in the Content-Type header.  In list
+context return the lower-cased bare content type followed by the upper-cased
+charset.  Both values will be C<undef> if not specified in the header.
+
+=item $h->content_is_text
+
+Returns TRUE if the Content-Type header field indicate that the
+content is textual.
+
+=item $h->content_is_html
+
+Returns TRUE if the Content-Type header field indicate that the
+content is some kind of HTML (including XHTML).  This method can't be
+used to set Content-Type.
+
+=item $h->content_is_xhtml
+
+Returns TRUE if the Content-Type header field indicate that the
+content is XHTML.  This method can't be used to set Content-Type.
+
+=item $h->content_is_xml
+
+Returns TRUE if the Content-Type header field indicate that the
+content is XML.  This method can't be used to set Content-Type.
+
+=item $h->content_encoding
+
+The Content-Encoding header field is used as a modifier to the
+media type.  When present, its value indicates what additional
+encoding mechanism has been applied to the resource.
+
+=item $h->content_length
+
+A decimal number indicating the size in bytes of the message content.
+
+=item $h->content_language
+
+The natural language(s) of the intended audience for the message
+content.  The value is one or more language tags as defined by RFC
+1766.  Eg. "no" for some kind of Norwegian and "en-US" for English the
+way it is written in the US.
+
+=item $h->title
+
+The title of the document.  In libwww-perl this header will be
+initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element
+of HTML documents.  I<This header is no longer part of the HTTP
+standard.>
+
+=item $h->user_agent
+
+This header field is used in request messages and contains information
+about the user agent originating the request.  I<E.g.>:
+
+  $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)');
+
+=item $h->server
+
+The server header field contains information about the software being
+used by the originating server program handling the request.
+
+=item $h->from
+
+This header should contain an Internet e-mail address for the human
+user who controls the requesting user agent.  The address should be
+machine-usable, as defined by RFC822.  E.g.:
+
+  $h->from('King Kong <king@kong.com>');
+
+I<This header is no longer part of the HTTP standard.>
+
+=item $h->referer
+
+Used to specify the address (URI) of the document from which the
+requested resource address was obtained.
+
+The "Free On-line Dictionary of Computing" as this to say about the
+word I<referer>:
+
+     <World-Wide Web> A misspelling of "referrer" which
+     somehow made it into the {HTTP} standard.  A given {web
+     page}'s referer (sic) is the {URL} of whatever web page
+     contains the link that the user followed to the current
+     page.  Most browsers pass this information as part of a
+     request.
+
+     (1998-10-19)
+
+By popular demand C<referrer> exists as an alias for this method so you
+can avoid this misspelling in your programs and still send the right
+thing on the wire.
+
+When setting the referrer, this method removes the fragment from the
+given URI if it is present, as mandated by RFC2616.  Note that
+the removal does I<not> happen automatically if using the header(),
+push_header() or init_header() methods to set the referrer.
+
+=item $h->www_authenticate
+
+This header must be included as part of a C<401 Unauthorized> response.
+The field value consist of a challenge that indicates the
+authentication scheme and parameters applicable to the requested URI.
+
+=item $h->proxy_authenticate
+
+This header must be included in a C<407 Proxy Authentication Required>
+response.
+
+=item $h->authorization
+
+=item $h->proxy_authorization
+
+A user agent that wishes to authenticate itself with a server or a
+proxy, may do so by including these headers.
+
+=item $h->authorization_basic
+
+This method is used to get or set an authorization header that use the
+"Basic Authentication Scheme".  In array context it will return two
+values; the user name and the password.  In scalar context it will
+return I<"uname:password"> as a single string value.
+
+When used to set the header value, it expects two arguments.  I<E.g.>:
+
+  $h->authorization_basic($uname, $password);
+
+The method will croak if the $uname contains a colon ':'.
+
+=item $h->proxy_authorization_basic
+
+Same as authorization_basic() but will set the "Proxy-Authorization"
+header instead.
+
+=back
+
+=head1 NON-CANONICALIZED FIELD NAMES
+
+The header field name spelling is normally canonicalized including the
+'_' to '-' translation.  There are some application where this is not
+appropriate.  Prefixing field names with ':' allow you to force a
+specific spelling.  For example if you really want a header field name
+to show up as C<foo_bar> instead of "Foo-Bar", you might set it like
+this:
+
+  $h->header(":foo_bar" => 1);
+
+These field names are returned with the ':' intact for
+$h->header_field_names and the $h->scan callback, but the colons do
+not show in $h->as_string.
+
+=head1 COPYRIGHT
+
+Copyright 1995-2005 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/Headers/Auth.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Headers/Auth.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Headers/Auth.pm	(revision 27174)
@@ -0,0 +1,98 @@
+package HTTP::Headers::Auth;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "6.00";
+
+use HTTP::Headers;
+
+package HTTP::Headers;
+
+BEGIN {
+    # we provide a new (and better) implementations below
+    undef(&www_authenticate);
+    undef(&proxy_authenticate);
+}
+
+require HTTP::Headers::Util;
+
+sub _parse_authenticate
+{
+    my @ret;
+    for (HTTP::Headers::Util::split_header_words(@_)) {
+	if (!defined($_->[1])) {
+	    # this is a new auth scheme
+	    push(@ret, shift(@$_) => {});
+	    shift @$_;
+	}
+	if (@ret) {
+	    # this a new parameter pair for the last auth scheme
+	    while (@$_) {
+		my $k = shift @$_;
+		my $v = shift @$_;
+	        $ret[-1]{$k} = $v;
+	    }
+	}
+	else {
+	    # something wrong, parameter pair without any scheme seen
+	    # IGNORE
+	}
+    }
+    @ret;
+}
+
+sub _authenticate
+{
+    my $self = shift;
+    my $header = shift;
+    my @old = $self->_header($header);
+    if (@_) {
+	$self->remove_header($header);
+	my @new = @_;
+	while (@new) {
+	    my $a_scheme = shift(@new);
+	    if ($a_scheme =~ /\s/) {
+		# assume complete valid value, pass it through
+		$self->push_header($header, $a_scheme);
+	    }
+	    else {
+		my @param;
+		if (@new) {
+		    my $p = $new[0];
+		    if (ref($p) eq "ARRAY") {
+			@param = @$p;
+			shift(@new);
+		    }
+		    elsif (ref($p) eq "HASH") {
+			@param = %$p;
+			shift(@new);
+		    }
+		}
+		my $val = ucfirst(lc($a_scheme));
+		if (@param) {
+		    my $sep = " ";
+		    while (@param) {
+			my $k = shift @param;
+			my $v = shift @param;
+			if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
+			    # must quote the value
+			    $v =~ s,([\\\"]),\\$1,g;
+			    $v = qq("$v");
+			}
+			$val .= "$sep$k=$v";
+			$sep = ", ";
+		    }
+		}
+		$self->push_header($header, $val);
+	    }
+	}
+    }
+    return unless defined wantarray;
+    wantarray ? _parse_authenticate(@old) : join(", ", @old);
+}
+
+
+sub www_authenticate    { shift->_authenticate("WWW-Authenticate", @_)   }
+sub proxy_authenticate  { shift->_authenticate("Proxy-Authenticate", @_) }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/HTTP/Headers/ETag.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Headers/ETag.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Headers/ETag.pm	(revision 27174)
@@ -0,0 +1,94 @@
+package HTTP::Headers::ETag;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "6.00";
+
+require HTTP::Date;
+
+require HTTP::Headers;
+package HTTP::Headers;
+
+sub _etags
+{
+    my $self = shift;
+    my $header = shift;
+    my @old = _split_etag_list($self->_header($header));
+    if (@_) {
+	$self->_header($header => join(", ", _split_etag_list(@_)));
+    }
+    wantarray ? @old : join(", ", @old);
+}
+
+sub etag          { shift->_etags("ETag", @_); }
+sub if_match      { shift->_etags("If-Match", @_); }
+sub if_none_match { shift->_etags("If-None-Match", @_); }
+
+sub if_range {
+    # Either a date or an entity-tag
+    my $self = shift;
+    my @old = $self->_header("If-Range");
+    if (@_) {
+	my $new = shift;
+	if (!defined $new) {
+	    $self->remove_header("If-Range");
+	}
+	elsif ($new =~ /^\d+$/) {
+	    $self->_date_header("If-Range", $new);
+	}
+	else {
+	    $self->_etags("If-Range", $new);
+	}
+    }
+    return unless defined(wantarray);
+    for (@old) {
+	my $t = HTTP::Date::str2time($_);
+	$_ = $t if $t;
+    }
+    wantarray ? @old : join(", ", @old);
+}
+
+
+# Split a list of entity tag values.  The return value is a list
+# consisting of one element per entity tag.  Suitable for parsing
+# headers like C<If-Match>, C<If-None-Match>.  You might even want to
+# use it on C<ETag> and C<If-Range> entity tag values, because it will
+# normalize them to the common form.
+#
+#  entity-tag	  = [ weak ] opaque-tag
+#  weak		  = "W/"
+#  opaque-tag	  = quoted-string
+
+
+sub _split_etag_list
+{
+    my(@val) = @_;
+    my @res;
+    for (@val) {
+        while (length) {
+            my $weak = "";
+	    $weak = "W/" if s,^\s*[wW]/,,;
+            my $etag = "";
+	    if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) {
+		push(@res, "$weak$1");
+            }
+            elsif (s/^\s*,//) {
+                push(@res, qq(W/"")) if $weak;
+            }
+            elsif (s/^\s*([^,\s]+)//) {
+                $etag = $1;
+		$etag =~ s/([\"\\])/\\$1/g;
+	        push(@res, qq($weak"$etag"));
+            }
+            elsif (s/^\s+// || !length) {
+                push(@res, qq(W/"")) if $weak;
+            }
+            else {
+	 	die "This should not happen: '$_'";
+            }
+        }
+   }
+   @res;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/HTTP/Headers/Util.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Headers/Util.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Headers/Util.pm	(revision 27174)
@@ -0,0 +1,199 @@
+package HTTP::Headers::Util;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = "6.03";
+
+require Exporter;
+@ISA=qw(Exporter);
+
+@EXPORT_OK=qw(split_header_words _split_header_words join_header_words);
+
+
+
+sub split_header_words {
+    my @res = &_split_header_words;
+    for my $arr (@res) {
+	for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
+	    $arr->[$i] = lc($arr->[$i]);
+	}
+    }
+    return @res;
+}
+
+sub _split_header_words
+{
+    my(@val) = @_;
+    my @res;
+    for (@val) {
+	my @cur;
+	while (length) {
+	    if (s/^\s*(=*[^\s=;,]+)//) {  # 'token' or parameter 'attribute'
+		push(@cur, $1);
+		# a quoted value
+		if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
+		    my $val = $1;
+		    $val =~ s/\\(.)/$1/g;
+		    push(@cur, $val);
+		# some unquoted value
+		}
+		elsif (s/^\s*=\s*([^;,\s]*)//) {
+		    my $val = $1;
+		    $val =~ s/\s+$//;
+		    push(@cur, $val);
+		# no value, a lone token
+		}
+		else {
+		    push(@cur, undef);
+		}
+	    }
+	    elsif (s/^\s*,//) {
+		push(@res, [@cur]) if @cur;
+		@cur = ();
+	    }
+	    elsif (s/^\s*;// || s/^\s+//) {
+		# continue
+	    }
+	    else {
+		die "This should not happen: '$_'";
+	    }
+	}
+	push(@res, \@cur) if @cur;
+    }
+    @res;
+}
+
+
+sub join_header_words
+{
+    @_ = ([@_]) if @_ && !ref($_[0]);
+    my @res;
+    for (@_) {
+	my @cur = @$_;
+	my @attr;
+	while (@cur) {
+	    my $k = shift @cur;
+	    my $v = shift @cur;
+	    if (defined $v) {
+		if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) {
+		    $v =~ s/([\"\\])/\\$1/g;  # escape " and \
+		    $k .= qq(="$v");
+		}
+		else {
+		    # token
+		    $k .= "=$v";
+		}
+	    }
+	    push(@attr, $k);
+	}
+	push(@res, join("; ", @attr)) if @attr;
+    }
+    join(", ", @res);
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Headers::Util - Header value parsing utility functions
+
+=head1 SYNOPSIS
+
+  use HTTP::Headers::Util qw(split_header_words);
+  @values = split_header_words($h->header("Content-Type"));
+
+=head1 DESCRIPTION
+
+This module provides a few functions that helps parsing and
+construction of valid HTTP header values.  None of the functions are
+exported by default.
+
+The following functions are available:
+
+=over 4
+
+
+=item split_header_words( @header_values )
+
+This function will parse the header values given as argument into a
+list of anonymous arrays containing key/value pairs.  The function
+knows how to deal with ",", ";" and "=" as well as quoted values after
+"=".  A list of space separated tokens are parsed as if they were
+separated by ";".
+
+If the @header_values passed as argument contains multiple values,
+then they are treated as if they were a single value separated by
+comma ",".
+
+This means that this function is useful for parsing header fields that
+follow this syntax (BNF as from the HTTP/1.1 specification, but we relax
+the requirement for tokens).
+
+  headers           = #header
+  header            = (token | parameter) *( [";"] (token | parameter))
+
+  token             = 1*<any CHAR except CTLs or separators>
+  separators        = "(" | ")" | "<" | ">" | "@"
+                    | "," | ";" | ":" | "\" | <">
+                    | "/" | "[" | "]" | "?" | "="
+                    | "{" | "}" | SP | HT
+
+  quoted-string     = ( <"> *(qdtext | quoted-pair ) <"> )
+  qdtext            = <any TEXT except <">>
+  quoted-pair       = "\" CHAR
+
+  parameter         = attribute "=" value
+  attribute         = token
+  value             = token | quoted-string
+
+Each I<header> is represented by an anonymous array of key/value
+pairs.  The keys will be all be forced to lower case.
+The value for a simple token (not part of a parameter) is C<undef>.
+Syntactically incorrect headers will not necessarily be parsed as you
+would want.
+
+This is easier to describe with some examples:
+
+   split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz');
+   split_header_words('text/html; charset="iso-8859-1"');
+   split_header_words('Basic realm="\\"foo\\\\bar\\""');
+
+will return
+
+   [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
+   ['text/html' => undef, charset => 'iso-8859-1']
+   [basic => undef, realm => "\"foo\\bar\""]
+
+If you don't want the function to convert tokens and attribute keys to
+lower case you can call it as C<_split_header_words> instead (with a
+leading underscore).
+
+=item join_header_words( @arrays )
+
+This will do the opposite of the conversion done by split_header_words().
+It takes a list of anonymous arrays as arguments (or a list of
+key/value pairs) and produces a single header value.  Attribute values
+are quoted if needed.
+
+Example:
+
+   join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
+   join_header_words("text/plain" => undef, charset => "iso-8859/1");
+
+will both return the string:
+
+   text/plain; charset="iso-8859/1"
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 1997-1998, 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/Message.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Message.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Message.pm	(revision 27174)
@@ -0,0 +1,1106 @@
+package HTTP::Message;
+
+use strict;
+use vars qw($VERSION $AUTOLOAD);
+$VERSION = "6.06";
+
+require HTTP::Headers;
+require Carp;
+
+my $CRLF = "\015\012";   # "\r\n" is not portable
+unless ($HTTP::URI_CLASS) {
+    if ($ENV{PERL_HTTP_URI_CLASS}
+    &&  $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/) {
+        $HTTP::URI_CLASS = $1;
+    } else {
+        $HTTP::URI_CLASS = "URI";
+    }
+}
+eval "require $HTTP::URI_CLASS"; die $@ if $@;
+
+*_utf8_downgrade = defined(&utf8::downgrade) ?
+    sub {
+        utf8::downgrade($_[0], 1) or
+            Carp::croak("HTTP::Message content must be bytes")
+    }
+    :
+    sub {
+    };
+
+sub new
+{
+    my($class, $header, $content) = @_;
+    if (defined $header) {
+	Carp::croak("Bad header argument") unless ref $header;
+        if (ref($header) eq "ARRAY") {
+	    $header = HTTP::Headers->new(@$header);
+	}
+	else {
+	    $header = $header->clone;
+	}
+    }
+    else {
+	$header = HTTP::Headers->new;
+    }
+    if (defined $content) {
+        _utf8_downgrade($content);
+    }
+    else {
+        $content = '';
+    }
+
+    bless {
+	'_headers' => $header,
+	'_content' => $content,
+    }, $class;
+}
+
+
+sub parse
+{
+    my($class, $str) = @_;
+
+    my @hdr;
+    while (1) {
+	if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
+	    push(@hdr, $1, $2);
+	    $hdr[-1] =~ s/\r\z//;
+	}
+	elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
+	    $hdr[-1] .= "\n$1";
+	    $hdr[-1] =~ s/\r\z//;
+	}
+	else {
+	    $str =~ s/^\r?\n//;
+	    last;
+	}
+    }
+    local $HTTP::Headers::TRANSLATE_UNDERSCORE;
+    new($class, \@hdr, $str);
+}
+
+
+sub clone
+{
+    my $self  = shift;
+    my $clone = HTTP::Message->new($self->headers,
+				   $self->content);
+    $clone->protocol($self->protocol);
+    $clone;
+}
+
+
+sub clear {
+    my $self = shift;
+    $self->{_headers}->clear;
+    $self->content("");
+    delete $self->{_parts};
+    return;
+}
+
+
+sub protocol {
+    shift->_elem('_protocol',  @_);
+}
+
+sub headers {
+    my $self = shift;
+
+    # recalculation of _content might change headers, so we
+    # need to force it now
+    $self->_content unless exists $self->{_content};
+
+    $self->{_headers};
+}
+
+sub headers_as_string {
+    shift->headers->as_string(@_);
+}
+
+
+sub content  {
+
+    my $self = $_[0];
+    if (defined(wantarray)) {
+	$self->_content unless exists $self->{_content};
+	my $old = $self->{_content};
+	$old = $$old if ref($old) eq "SCALAR";
+	&_set_content if @_ > 1;
+	return $old;
+    }
+
+    if (@_ > 1) {
+	&_set_content;
+    }
+    else {
+	Carp::carp("Useless content call in void context") if $^W;
+    }
+}
+
+
+sub _set_content {
+    my $self = $_[0];
+    _utf8_downgrade($_[1]);
+    if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
+	${$self->{_content}} = $_[1];
+    }
+    else {
+	die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
+	$self->{_content} = $_[1];
+	delete $self->{_content_ref};
+    }
+    delete $self->{_parts} unless $_[2];
+}
+
+
+sub add_content
+{
+    my $self = shift;
+    $self->_content unless exists $self->{_content};
+    my $chunkref = \$_[0];
+    $chunkref = $$chunkref if ref($$chunkref);  # legacy
+
+    _utf8_downgrade($$chunkref);
+
+    my $ref = ref($self->{_content});
+    if (!$ref) {
+	$self->{_content} .= $$chunkref;
+    }
+    elsif ($ref eq "SCALAR") {
+	${$self->{_content}} .= $$chunkref;
+    }
+    else {
+	Carp::croak("Can't append to $ref content");
+    }
+    delete $self->{_parts};
+}
+
+sub add_content_utf8 {
+    my($self, $buf)  = @_;
+    utf8::upgrade($buf);
+    utf8::encode($buf);
+    $self->add_content($buf);
+}
+
+sub content_ref
+{
+    my $self = shift;
+    $self->_content unless exists $self->{_content};
+    delete $self->{_parts};
+    my $old = \$self->{_content};
+    my $old_cref = $self->{_content_ref};
+    if (@_) {
+	my $new = shift;
+	Carp::croak("Setting content_ref to a non-ref") unless ref($new);
+	delete $self->{_content};  # avoid modifying $$old
+	$self->{_content} = $new;
+	$self->{_content_ref}++;
+    }
+    $old = $$old if $old_cref;
+    return $old;
+}
+
+
+sub content_charset
+{
+    my $self = shift;
+    if (my $charset = $self->content_type_charset) {
+	return $charset;
+    }
+
+    # time to start guessing
+    my $cref = $self->decoded_content(ref => 1, charset => "none");
+
+    # Unicode BOM
+    for ($$cref) {
+	return "UTF-8"     if /^\xEF\xBB\xBF/;
+	return "UTF-32LE" if /^\xFF\xFE\x00\x00/;
+	return "UTF-32BE" if /^\x00\x00\xFE\xFF/;
+	return "UTF-16LE" if /^\xFF\xFE/;
+	return "UTF-16BE" if /^\xFE\xFF/;
+    }
+
+    if ($self->content_is_xml) {
+	# http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
+	# XML entity not accompanied by external encoding information and not
+	# in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
+	# in which the first characters must be '<?xml'
+	for ($$cref) {
+	    return "UTF-32BE" if /^\x00\x00\x00</;
+	    return "UTF-32LE" if /^<\x00\x00\x00/;
+	    return "UTF-16BE" if /^(?:\x00\s)*\x00</;
+	    return "UTF-16LE" if /^(?:\s\x00)*<\x00/;
+	    if (/^\s*(<\?xml[^\x00]*?\?>)/) {
+		if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
+		    my $enc = $2;
+		    $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
+		    return $enc if $enc;
+		}
+	    }
+	}
+	return "UTF-8";
+    }
+    elsif ($self->content_is_html) {
+	# look for <META charset="..."> or <META content="...">
+	# http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
+	require IO::HTML;
+	# Use relaxed search to match previous versions of HTTP::Message:
+	my $encoding = IO::HTML::find_charset_in($$cref, { encoding    => 1,
+	                                                   need_pragma => 0 });
+	return $encoding->mime_name if $encoding;
+    }
+    elsif ($self->content_type eq "application/json") {
+	for ($$cref) {
+	    # RFC 4627, ch 3
+	    return "UTF-32BE" if /^\x00\x00\x00./s;
+	    return "UTF-32LE" if /^.\x00\x00\x00/s;
+	    return "UTF-16BE" if /^\x00.\x00./s;
+	    return "UTF-16LE" if /^.\x00.\x00/s;
+	    return "UTF-8";
+	}
+    }
+    if ($self->content_type =~ /^text\//) {
+	for ($$cref) {
+	    if (length) {
+		return "US-ASCII" unless /[\x80-\xFF]/;
+		require Encode;
+		eval {
+		    Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC());
+		};
+		return "UTF-8" unless $@;
+		return "ISO-8859-1";
+	    }
+	}
+    }
+
+    return undef;
+}
+
+
+sub decoded_content
+{
+    my($self, %opt) = @_;
+    my $content_ref;
+    my $content_ref_iscopy;
+
+    eval {
+	$content_ref = $self->content_ref;
+	die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
+
+	if (my $h = $self->header("Content-Encoding")) {
+	    $h =~ s/^\s+//;
+	    $h =~ s/\s+$//;
+	    for my $ce (reverse split(/\s*,\s*/, lc($h))) {
+		next unless $ce;
+		next if $ce eq "identity";
+		if ($ce eq "gzip" || $ce eq "x-gzip") {
+		    require IO::Uncompress::Gunzip;
+		    my $output;
+		    IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
+			or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
+		    $content_ref = \$output;
+		    $content_ref_iscopy++;
+		}
+		elsif ($ce eq "x-bzip2" or $ce eq "bzip2") {
+		    require IO::Uncompress::Bunzip2;
+		    my $output;
+		    IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
+			or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
+		    $content_ref = \$output;
+		    $content_ref_iscopy++;
+		}
+		elsif ($ce eq "deflate") {
+		    require IO::Uncompress::Inflate;
+		    my $output;
+		    my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
+		    my $error = $IO::Uncompress::Inflate::InflateError;
+		    unless ($status) {
+			# "Content-Encoding: deflate" is supposed to mean the
+			# "zlib" format of RFC 1950, but Microsoft got that
+			# wrong, so some servers sends the raw compressed
+			# "deflate" data.  This tries to inflate this format.
+			$output = undef;
+			require IO::Uncompress::RawInflate;
+			unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
+			    $self->push_header("Client-Warning" =>
+				"Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
+			    $output = undef;
+			}
+		    }
+		    die "Can't inflate content: $error" unless defined $output;
+		    $content_ref = \$output;
+		    $content_ref_iscopy++;
+		}
+		elsif ($ce eq "compress" || $ce eq "x-compress") {
+		    die "Can't uncompress content";
+		}
+		elsif ($ce eq "base64") {  # not really C-T-E, but should be harmless
+		    require MIME::Base64;
+		    $content_ref = \MIME::Base64::decode($$content_ref);
+		    $content_ref_iscopy++;
+		}
+		elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
+		    require MIME::QuotedPrint;
+		    $content_ref = \MIME::QuotedPrint::decode($$content_ref);
+		    $content_ref_iscopy++;
+		}
+		else {
+		    die "Don't know how to decode Content-Encoding '$ce'";
+		}
+	    }
+	}
+
+	if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) {
+	    my $charset = lc(
+	        $opt{charset} ||
+		$self->content_type_charset ||
+		$opt{default_charset} ||
+		$self->content_charset ||
+		"ISO-8859-1"
+	    );
+	    if ($charset eq "none") {
+		# leave it asis
+	    }
+	    elsif ($charset eq "us-ascii" || $charset eq "iso-8859-1") {
+		if ($$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade) {
+		    unless ($content_ref_iscopy) {
+			my $copy = $$content_ref;
+			$content_ref = \$copy;
+			$content_ref_iscopy++;
+		    }
+		    utf8::upgrade($$content_ref);
+		}
+	    }
+	    else {
+		require Encode;
+		eval {
+		    $content_ref = \Encode::decode($charset, $$content_ref,
+			 ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
+		};
+		if ($@) {
+		    my $retried;
+		    if ($@ =~ /^Unknown encoding/) {
+			my $alt_charset = lc($opt{alt_charset} || "");
+			if ($alt_charset && $charset ne $alt_charset) {
+			    # Retry decoding with the alternative charset
+			    $content_ref = \Encode::decode($alt_charset, $$content_ref,
+				 ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC())
+			        unless $alt_charset eq "none";
+			    $retried++;
+			}
+		    }
+		    die unless $retried;
+		}
+		die "Encode::decode() returned undef improperly" unless defined $$content_ref;
+		if ($is_xml) {
+		    # Get rid of the XML encoding declaration if present
+		    $$content_ref =~ s/^\x{FEFF}//;
+		    if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) {
+			substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//;
+		    }
+		}
+	    }
+	}
+    };
+    if ($@) {
+	Carp::croak($@) if $opt{raise_error};
+	return undef;
+    }
+
+    return $opt{ref} ? $content_ref : $$content_ref;
+}
+
+
+sub decodable
+{
+    # should match the Content-Encoding values that decoded_content can deal with
+    my $self = shift;
+    my @enc;
+    # XXX preferably we should determine if the modules are available without loading
+    # them here
+    eval {
+        require IO::Uncompress::Gunzip;
+        push(@enc, "gzip", "x-gzip");
+    };
+    eval {
+        require IO::Uncompress::Inflate;
+        require IO::Uncompress::RawInflate;
+        push(@enc, "deflate");
+    };
+    eval {
+        require IO::Uncompress::Bunzip2;
+        push(@enc, "x-bzip2");
+    };
+    # we don't care about announcing the 'identity', 'base64' and
+    # 'quoted-printable' stuff
+    return wantarray ? @enc : join(", ", @enc);
+}
+
+
+sub decode
+{
+    my $self = shift;
+    return 1 unless $self->header("Content-Encoding");
+    if (defined(my $content = $self->decoded_content(charset => "none"))) {
+	$self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
+	$self->content($content);
+	return 1;
+    }
+    return 0;
+}
+
+
+sub encode
+{
+    my($self, @enc) = @_;
+
+    Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
+    Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;
+
+    return 1 unless @enc;  # nothing to do
+
+    my $content = $self->content;
+    for my $encoding (@enc) {
+	if ($encoding eq "identity") {
+	    # nothing to do
+	}
+	elsif ($encoding eq "base64") {
+	    require MIME::Base64;
+	    $content = MIME::Base64::encode($content);
+	}
+	elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
+	    require IO::Compress::Gzip;
+	    my $output;
+	    IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
+		or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
+	    $content = $output;
+	}
+	elsif ($encoding eq "deflate") {
+	    require IO::Compress::Deflate;
+	    my $output;
+	    IO::Compress::Deflate::deflate(\$content, \$output)
+		or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
+	    $content = $output;
+	}
+	elsif ($encoding eq "x-bzip2") {
+	    require IO::Compress::Bzip2;
+	    my $output;
+	    IO::Compress::Bzip2::bzip2(\$content, \$output)
+		or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
+	    $content = $output;
+	}
+	elsif ($encoding eq "rot13") {  # for the fun of it
+	    $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
+	}
+	else {
+	    return 0;
+	}
+    }
+    my $h = $self->header("Content-Encoding");
+    unshift(@enc, $h) if $h;
+    $self->header("Content-Encoding", join(", ", @enc));
+    $self->remove_header("Content-Length", "Content-MD5");
+    $self->content($content);
+    return 1;
+}
+
+
+sub as_string
+{
+    my($self, $eol) = @_;
+    $eol = "\n" unless defined $eol;
+
+    # The calculation of content might update the headers
+    # so we need to do that first.
+    my $content = $self->content;
+
+    return join("", $self->{'_headers'}->as_string($eol),
+		    $eol,
+		    $content,
+		    (@_ == 1 && length($content) &&
+		     $content !~ /\n\z/) ? "\n" : "",
+		);
+}
+
+
+sub dump
+{
+    my($self, %opt) = @_;
+    my $content = $self->content;
+    my $chopped = 0;
+    if (!ref($content)) {
+	my $maxlen = $opt{maxlength};
+	$maxlen = 512 unless defined($maxlen);
+	if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
+	    $chopped = length($content) - $maxlen;
+	    $content = substr($content, 0, $maxlen) . "...";
+	}
+
+	$content =~ s/\\/\\\\/g;
+	$content =~ s/\t/\\t/g;
+	$content =~ s/\r/\\r/g;
+
+	# no need for 3 digits in escape for these
+	$content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
+
+	$content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
+	$content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
+
+	# remaining whitespace
+	$content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
+	$content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
+	$content =~ s/\n\z/\\n/;
+
+	my $no_content = $opt{no_content};
+	$no_content = "(no content)" unless defined $no_content;
+	if ($content eq $no_content) {
+	    # escape our $no_content marker
+	    $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
+	}
+	elsif ($content eq "") {
+	    $content = $no_content;
+	}
+    }
+
+    my @dump;
+    push(@dump, $opt{preheader}) if $opt{preheader};
+    push(@dump, $self->{_headers}->as_string, $content);
+    push(@dump, "(+ $chopped more bytes not shown)") if $chopped;
+
+    my $dump = join("\n", @dump, "");
+    $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};
+
+    print $dump unless defined wantarray;
+    return $dump;
+}
+
+
+sub parts {
+    my $self = shift;
+    if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
+	$self->_parts;
+    }
+    my $old = $self->{_parts};
+    if (@_) {
+	my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
+	my $ct = $self->content_type || "";
+	if ($ct =~ m,^message/,) {
+	    Carp::croak("Only one part allowed for $ct content")
+		if @parts > 1;
+	}
+	elsif ($ct !~ m,^multipart/,) {
+	    $self->remove_content_headers;
+	    $self->content_type("multipart/mixed");
+	}
+	$self->{_parts} = \@parts;
+	_stale_content($self);
+    }
+    return @$old if wantarray;
+    return $old->[0];
+}
+
+sub add_part {
+    my $self = shift;
+    if (($self->content_type || "") !~ m,^multipart/,) {
+	my $p = HTTP::Message->new($self->remove_content_headers,
+				   $self->content(""));
+	$self->content_type("multipart/mixed");
+	$self->{_parts} = [];
+        if ($p->headers->header_field_names || $p->content ne "") {
+            push(@{$self->{_parts}}, $p);
+        }
+    }
+    elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
+	$self->_parts;
+    }
+
+    push(@{$self->{_parts}}, @_);
+    _stale_content($self);
+    return;
+}
+
+sub _stale_content {
+    my $self = shift;
+    if (ref($self->{_content}) eq "SCALAR") {
+	# must recalculate now
+	$self->_content;
+    }
+    else {
+	# just invalidate cache
+	delete $self->{_content};
+	delete $self->{_content_ref};
+    }
+}
+
+
+# delegate all other method calls the the headers object.
+sub AUTOLOAD
+{
+    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+
+    # We create the function here so that it will not need to be
+    # autoloaded the next time.
+    no strict 'refs';
+    *$method = sub { local $Carp::Internal{+__PACKAGE__} = 1; shift->headers->$method(@_) };
+    goto &$method;
+}
+
+
+sub DESTROY {}  # avoid AUTOLOADing it
+
+
+# Private method to access members in %$self
+sub _elem
+{
+    my $self = shift;
+    my $elem = shift;
+    my $old = $self->{$elem};
+    $self->{$elem} = $_[0] if @_;
+    return $old;
+}
+
+
+# Create private _parts attribute from current _content
+sub _parts {
+    my $self = shift;
+    my $ct = $self->content_type;
+    if ($ct =~ m,^multipart/,) {
+	require HTTP::Headers::Util;
+	my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
+	die "Assert" unless @h;
+	my %h = @{$h[0]};
+	if (defined(my $b = $h{boundary})) {
+	    my $str = $self->content;
+	    $str =~ s/\r?\n--\Q$b\E--.*//s;
+	    if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
+		$self->{_parts} = [map HTTP::Message->parse($_),
+				   split(/\r?\n--\Q$b\E\r?\n/, $str)]
+	    }
+	}
+    }
+    elsif ($ct eq "message/http") {
+	require HTTP::Request;
+	require HTTP::Response;
+	my $content = $self->content;
+	my $class = ($content =~ m,^(HTTP/.*)\n,) ?
+	    "HTTP::Response" : "HTTP::Request";
+	$self->{_parts} = [$class->parse($content)];
+    }
+    elsif ($ct =~ m,^message/,) {
+	$self->{_parts} = [ HTTP::Message->parse($self->content) ];
+    }
+
+    $self->{_parts} ||= [];
+}
+
+
+# Create private _content attribute from current _parts
+sub _content {
+    my $self = shift;
+    my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
+    if ($ct =~ m,^\s*message/,i) {
+	_set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
+	return;
+    }
+
+    require HTTP::Headers::Util;
+    my @v = HTTP::Headers::Util::split_header_words($ct);
+    Carp::carp("Multiple Content-Type headers") if @v > 1;
+    @v = @{$v[0]};
+
+    my $boundary;
+    my $boundary_index;
+    for (my @tmp = @v; @tmp;) {
+	my($k, $v) = splice(@tmp, 0, 2);
+	if ($k eq "boundary") {
+	    $boundary = $v;
+	    $boundary_index = @v - @tmp - 1;
+	    last;
+	}
+    }
+
+    my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
+
+    my $bno = 0;
+    $boundary = _boundary() unless defined $boundary;
+ CHECK_BOUNDARY:
+    {
+	for (@parts) {
+	    if (index($_, $boundary) >= 0) {
+		# must have a better boundary
+		$boundary = _boundary(++$bno);
+		redo CHECK_BOUNDARY;
+	    }
+	}
+    }
+
+    if ($boundary_index) {
+	$v[$boundary_index] = $boundary;
+    }
+    else {
+	push(@v, boundary => $boundary);
+    }
+
+    $ct = HTTP::Headers::Util::join_header_words(@v);
+    $self->{_headers}->header("Content-Type", $ct);
+
+    _set_content($self, "--$boundary$CRLF" .
+	                join("$CRLF--$boundary$CRLF", @parts) .
+			"$CRLF--$boundary--$CRLF",
+                        1);
+}
+
+
+sub _boundary
+{
+    my $size = shift || return "xYzZY";
+    require MIME::Base64;
+    my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
+    $b =~ s/[\W]/X/g;  # ensure alnum only
+    $b;
+}
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Message - HTTP style message (base class)
+
+=head1 SYNOPSIS
+
+ use base 'HTTP::Message';
+
+=head1 DESCRIPTION
+
+An C<HTTP::Message> object contains some headers and a content body.
+The following methods are available:
+
+=over 4
+
+=item $mess = HTTP::Message->new
+
+=item $mess = HTTP::Message->new( $headers )
+
+=item $mess = HTTP::Message->new( $headers, $content )
+
+This constructs a new message object.  Normally you would want
+construct C<HTTP::Request> or C<HTTP::Response> objects instead.
+
+The optional $header argument should be a reference to an
+C<HTTP::Headers> object or a plain array reference of key/value pairs.
+If an C<HTTP::Headers> object is provided then a copy of it will be
+embedded into the constructed message, i.e. it will not be owned and
+can be modified afterwards without affecting the message.
+
+The optional $content argument should be a string of bytes.
+
+=item $mess = HTTP::Message->parse( $str )
+
+This constructs a new message object by parsing the given string.
+
+=item $mess->headers
+
+Returns the embedded C<HTTP::Headers> object.
+
+=item $mess->headers_as_string
+
+=item $mess->headers_as_string( $eol )
+
+Call the as_string() method for the headers in the
+message.  This will be the same as
+
+    $mess->headers->as_string
+
+but it will make your program a whole character shorter :-)
+
+=item $mess->content
+
+=item $mess->content( $bytes )
+
+The content() method sets the raw content if an argument is given.  If no
+argument is given the content is not touched.  In either case the
+original raw content is returned.
+
+Note that the content should be a string of bytes.  Strings in perl
+can contain characters outside the range of a byte.  The C<Encode>
+module can be used to turn such strings into a string of bytes.
+
+=item $mess->add_content( $bytes )
+
+The add_content() methods appends more data bytes to the end of the
+current content buffer.
+
+=item $mess->add_content_utf8( $string )
+
+The add_content_utf8() method appends the UTF-8 bytes representing the
+string to the end of the current content buffer.
+
+=item $mess->content_ref
+
+=item $mess->content_ref( \$bytes )
+
+The content_ref() method will return a reference to content buffer string.
+It can be more efficient to access the content this way if the content
+is huge, and it can even be used for direct manipulation of the content,
+for instance:
+
+  ${$res->content_ref} =~ s/\bfoo\b/bar/g;
+
+This example would modify the content buffer in-place.
+
+If an argument is passed it will setup the content to reference some
+external source.  The content() and add_content() methods
+will automatically dereference scalar references passed this way.  For
+other references content() will return the reference itself and
+add_content() will refuse to do anything.
+
+=item $mess->content_charset
+
+This returns the charset used by the content in the message.  The
+charset is either found as the charset attribute of the
+C<Content-Type> header or by guessing.
+
+See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding>
+for details about how charset is determined.
+
+=item $mess->decoded_content( %options )
+
+Returns the content with any C<Content-Encoding> undone and for textual content
+the raw content encoded to Perl's Unicode strings.  If the C<Content-Encoding>
+or C<charset> of the message is unknown this method will fail by returning
+C<undef>.
+
+The following options can be specified.
+
+=over
+
+=item C<charset>
+
+This override the charset parameter for text content.  The value
+C<none> can used to suppress decoding of the charset.
+
+=item C<default_charset>
+
+This override the default charset guessed by content_charset() or
+if that fails "ISO-8859-1".
+
+=item C<alt_charset>
+
+If decoding fails because the charset specified in the Content-Type header
+isn't recognized by Perl's Encode module, then try decoding using this charset
+instead of failing.  The C<alt_charset> might be specified as C<none> to simply
+return the string without any decoding of charset as alternative.
+
+=item C<charset_strict>
+
+Abort decoding if malformed characters is found in the content.  By
+default you get the substitution character ("\x{FFFD}") in place of
+malformed characters.
+
+=item C<raise_error>
+
+If TRUE then raise an exception if not able to decode content.  Reason
+might be that the specified C<Content-Encoding> or C<charset> is not
+supported.  If this option is FALSE, then decoded_content() will return
+C<undef> on errors, but will still set $@.
+
+=item C<ref>
+
+If TRUE then a reference to decoded content is returned.  This might
+be more efficient in cases where the decoded content is identical to
+the raw content as no data copying is required in this case.
+
+=back
+
+=item $mess->decodable
+
+=item HTTP::Message::decodable()
+
+This returns the encoding identifiers that decoded_content() can
+process.  In scalar context returns a comma separated string of
+identifiers.
+
+This value is suitable for initializing the C<Accept-Encoding> request
+header field.
+
+=item $mess->decode
+
+This method tries to replace the content of the message with the
+decoded version and removes the C<Content-Encoding> header.  Returns
+TRUE if successful and FALSE if not.
+
+If the message does not have a C<Content-Encoding> header this method
+does nothing and returns TRUE.
+
+Note that the content of the message is still bytes after this method
+has been called and you still need to call decoded_content() if you
+want to process its content as a string.
+
+=item $mess->encode( $encoding, ... )
+
+Apply the given encodings to the content of the message.  Returns TRUE
+if successful. The "identity" (non-)encoding is always supported; other
+currently supported encodings, subject to availability of required
+additional modules, are "gzip", "deflate", "x-bzip2" and "base64".
+
+A successful call to this function will set the C<Content-Encoding>
+header.
+
+Note that C<multipart/*> or C<message/*> messages can't be encoded and
+this method will croak if you try.
+
+=item $mess->parts
+
+=item $mess->parts( @parts )
+
+=item $mess->parts( \@parts )
+
+Messages can be composite, i.e. contain other messages.  The composite
+messages have a content type of C<multipart/*> or C<message/*>.  This
+method give access to the contained messages.
+
+The argumentless form will return a list of C<HTTP::Message> objects.
+If the content type of $msg is not C<multipart/*> or C<message/*> then
+this will return the empty list.  In scalar context only the first
+object is returned.  The returned message parts should be regarded as
+read-only (future versions of this library might make it possible
+to modify the parent by modifying the parts).
+
+If the content type of $msg is C<message/*> then there will only be
+one part returned.
+
+If the content type is C<message/http>, then the return value will be
+either an C<HTTP::Request> or an C<HTTP::Response> object.
+
+If a @parts argument is given, then the content of the message will be
+modified. The array reference form is provided so that an empty list
+can be provided.  The @parts array should contain C<HTTP::Message>
+objects.  The @parts objects are owned by $mess after this call and
+should not be modified or made part of other messages.
+
+When updating the message with this method and the old content type of
+$mess is not C<multipart/*> or C<message/*>, then the content type is
+set to C<multipart/mixed> and all other content headers are cleared.
+
+This method will croak if the content type is C<message/*> and more
+than one part is provided.
+
+=item $mess->add_part( $part )
+
+This will add a part to a message.  The $part argument should be
+another C<HTTP::Message> object.  If the previous content type of
+$mess is not C<multipart/*> then the old content (together with all
+content headers) will be made part #1 and the content type made
+C<multipart/mixed> before the new part is added.  The $part object is
+owned by $mess after this call and should not be modified or made part
+of other messages.
+
+There is no return value.
+
+=item $mess->clear
+
+Will clear the headers and set the content to the empty string.  There
+is no return value
+
+=item $mess->protocol
+
+=item $mess->protocol( $proto )
+
+Sets the HTTP protocol used for the message.  The protocol() is a string
+like C<HTTP/1.0> or C<HTTP/1.1>.
+
+=item $mess->clone
+
+Returns a copy of the message object.
+
+=item $mess->as_string
+
+=item $mess->as_string( $eol )
+
+Returns the message formatted as a single string.
+
+The optional $eol parameter specifies the line ending sequence to use.
+The default is "\n".  If no $eol is given then as_string will ensure
+that the returned string is newline terminated (even when the message
+content is not).  No extra newline is appended if an explicit $eol is
+passed.
+
+=item $mess->dump( %opt )
+
+Returns the message formatted as a string.  In void context print the string.
+
+This differs from C<< $mess->as_string >> in that it escapes the bytes
+of the content so that it's safe to print them and it limits how much
+content to print.  The escapes syntax used is the same as for Perl's
+double quoted strings.  If there is no content the string "(no
+content)" is shown in its place.
+
+Options to influence the output can be passed as key/value pairs. The
+following options are recognized:
+
+=over
+
+=item maxlength => $num
+
+How much of the content to show.  The default is 512.  Set this to 0
+for unlimited.
+
+If the content is longer then the string is chopped at the limit and
+the string "...\n(### more bytes not shown)" appended.
+
+=item no_content => $str
+
+Replaces the "(no content)" marker.
+
+=item prefix => $str
+
+A string that will be prefixed to each line of the dump.
+
+=back
+
+=back
+
+All methods unknown to C<HTTP::Message> itself are delegated to the
+C<HTTP::Headers> object that is part of every message.  This allows
+convenient access to these methods.  Refer to L<HTTP::Headers> for
+details of these methods:
+
+    $mess->header( $field => $val )
+    $mess->push_header( $field => $val )
+    $mess->init_header( $field => $val )
+    $mess->remove_header( $field )
+    $mess->remove_content_headers
+    $mess->header_field_names
+    $mess->scan( \&doit )
+
+    $mess->date
+    $mess->expires
+    $mess->if_modified_since
+    $mess->if_unmodified_since
+    $mess->last_modified
+    $mess->content_type
+    $mess->content_encoding
+    $mess->content_length
+    $mess->content_language
+    $mess->title
+    $mess->user_agent
+    $mess->server
+    $mess->from
+    $mess->referer
+    $mess->www_authenticate
+    $mess->authorization
+    $mess->proxy_authorization
+    $mess->authorization_basic
+    $mess->proxy_authorization_basic
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 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/Request.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Request.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Request.pm	(revision 27174)
@@ -0,0 +1,242 @@
+package HTTP::Request;
+
+require HTTP::Message;
+@ISA = qw(HTTP::Message);
+$VERSION = "6.00";
+
+use strict;
+
+
+
+sub new
+{
+    my($class, $method, $uri, $header, $content) = @_;
+    my $self = $class->SUPER::new($header, $content);
+    $self->method($method);
+    $self->uri($uri);
+    $self;
+}
+
+
+sub parse
+{
+    my($class, $str) = @_;
+    my $request_line;
+    if ($str =~ s/^(.*)\n//) {
+	$request_line = $1;
+    }
+    else {
+	$request_line = $str;
+	$str = "";
+    }
+
+    my $self = $class->SUPER::parse($str);
+    my($method, $uri, $protocol) = split(' ', $request_line);
+    $self->method($method) if defined($method);
+    $self->uri($uri) if defined($uri);
+    $self->protocol($protocol) if $protocol;
+    $self;
+}
+
+
+sub clone
+{
+    my $self = shift;
+    my $clone = bless $self->SUPER::clone, ref($self);
+    $clone->method($self->method);
+    $clone->uri($self->uri);
+    $clone;
+}
+
+
+sub method
+{
+    shift->_elem('_method', @_);
+}
+
+
+sub uri
+{
+    my $self = shift;
+    my $old = $self->{'_uri'};
+    if (@_) {
+	my $uri = shift;
+	if (!defined $uri) {
+	    # that's ok
+	}
+	elsif (ref $uri) {
+	    Carp::croak("A URI can't be a " . ref($uri) . " reference")
+		if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
+	    Carp::croak("Can't use a " . ref($uri) . " object as a URI")
+		unless $uri->can('scheme');
+	    $uri = $uri->clone;
+	    unless ($HTTP::URI_CLASS eq "URI") {
+		# Argh!! Hate this... old LWP legacy!
+		eval { local $SIG{__DIE__}; $uri = $uri->abs; };
+		die $@ if $@ && $@ !~ /Missing base argument/;
+	    }
+	}
+	else {
+	    $uri = $HTTP::URI_CLASS->new($uri);
+	}
+	$self->{'_uri'} = $uri;
+        delete $self->{'_uri_canonical'};
+    }
+    $old;
+}
+
+*url = \&uri;  # legacy
+
+sub uri_canonical
+{
+    my $self = shift;
+    return $self->{'_uri_canonical'} ||= $self->{'_uri'}->canonical;
+}
+
+
+sub accept_decodable
+{
+    my $self = shift;
+    $self->header("Accept-Encoding", scalar($self->decodable));
+}
+
+sub as_string
+{
+    my $self = shift;
+    my($eol) = @_;
+    $eol = "\n" unless defined $eol;
+
+    my $req_line = $self->method || "-";
+    my $uri = $self->uri;
+    $uri = (defined $uri) ? $uri->as_string : "-";
+    $req_line .= " $uri";
+    my $proto = $self->protocol;
+    $req_line .= " $proto" if $proto;
+
+    return join($eol, $req_line, $self->SUPER::as_string(@_));
+}
+
+sub dump
+{
+    my $self = shift;
+    my @pre = ($self->method || "-", $self->uri || "-");
+    if (my $prot = $self->protocol) {
+	push(@pre, $prot);
+    }
+
+    return $self->SUPER::dump(
+        preheader => join(" ", @pre),
+	@_,
+    );
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Request - HTTP style request message
+
+=head1 SYNOPSIS
+
+ require HTTP::Request;
+ $request = HTTP::Request->new(GET => 'http://www.example.com/');
+
+and usually used like this:
+
+ $ua = LWP::UserAgent->new;
+ $response = $ua->request($request);
+
+=head1 DESCRIPTION
+
+C<HTTP::Request> is a class encapsulating HTTP style requests,
+consisting of a request line, some headers, and a content body. Note
+that the LWP library uses HTTP style requests even for non-HTTP
+protocols.  Instances of this class are usually passed to the
+request() method of an C<LWP::UserAgent> object.
+
+C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore
+inherits its methods.  The following additional methods are available:
+
+=over 4
+
+=item $r = HTTP::Request->new( $method, $uri )
+
+=item $r = HTTP::Request->new( $method, $uri, $header )
+
+=item $r = HTTP::Request->new( $method, $uri, $header, $content )
+
+Constructs a new C<HTTP::Request> object describing a request on the
+object $uri using method $method.  The $method argument must be a
+string.  The $uri argument can be either a string, or a reference to a
+C<URI> object.  The optional $header argument should be a reference to
+an C<HTTP::Headers> object or a plain array reference of key/value
+pairs.  The optional $content argument should be a string of bytes.
+
+=item $r = HTTP::Request->parse( $str )
+
+This constructs a new request object by parsing the given string.
+
+=item $r->method
+
+=item $r->method( $val )
+
+This is used to get/set the method attribute.  The method should be a
+short string like "GET", "HEAD", "PUT" or "POST".
+
+=item $r->uri
+
+=item $r->uri( $val )
+
+This is used to get/set the uri attribute.  The $val can be a
+reference to a URI object or a plain string.  If a string is given,
+then it should be parseable as an absolute URI.
+
+=item $r->header( $field )
+
+=item $r->header( $field => $value )
+
+This is used to get/set header values and it is inherited from
+C<HTTP::Headers> via C<HTTP::Message>.  See L<HTTP::Headers> for
+details and other similar methods that can be used to access the
+headers.
+
+=item $r->accept_decodable
+
+This will set the C<Accept-Encoding> header to the list of encodings
+that decoded_content() can decode.
+
+=item $r->content
+
+=item $r->content( $bytes )
+
+This is used to get/set the content and it is inherited from the
+C<HTTP::Message> base class.  See L<HTTP::Message> for details and
+other methods that can be used to access the content.
+
+Note that the content should be a string of bytes.  Strings in perl
+can contain characters outside the range of a byte.  The C<Encode>
+module can be used to turn such strings into a string of bytes.
+
+=item $r->as_string
+
+=item $r->as_string( $eol )
+
+Method returning a textual representation of the request.
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>,
+L<HTTP::Response>
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 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/Request/Common.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Request/Common.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Request/Common.pm	(revision 27174)
@@ -0,0 +1,514 @@
+package HTTP::Request::Common;
+
+use strict;
+use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD);
+
+$DYNAMIC_FILE_UPLOAD ||= 0;  # make it defined (don't know why)
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT =qw(GET HEAD PUT POST);
+@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);
+
+require HTTP::Request;
+use Carp();
+
+$VERSION = "6.04";
+
+my $CRLF = "\015\012";   # "\r\n" is not portable
+
+sub GET  { _simple_req('GET',  @_); }
+sub HEAD { _simple_req('HEAD', @_); }
+sub PUT  { _simple_req('PUT' , @_); }
+sub DELETE { _simple_req('DELETE', @_); }
+
+sub POST
+{
+    my $url = shift;
+    my $req = HTTP::Request->new(POST => $url);
+    my $content;
+    $content = shift if @_ and ref $_[0];
+    my($k, $v);
+    while (($k,$v) = splice(@_, 0, 2)) {
+	if (lc($k) eq 'content') {
+	    $content = $v;
+	}
+	else {
+	    $req->push_header($k, $v);
+	}
+    }
+    my $ct = $req->header('Content-Type');
+    unless ($ct) {
+	$ct = 'application/x-www-form-urlencoded';
+    }
+    elsif ($ct eq 'form-data') {
+	$ct = 'multipart/form-data';
+    }
+
+    if (ref $content) {
+	if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
+	    require HTTP::Headers::Util;
+	    my @v = HTTP::Headers::Util::split_header_words($ct);
+	    Carp::carp("Multiple Content-Type headers") if @v > 1;
+	    @v = @{$v[0]};
+
+	    my $boundary;
+	    my $boundary_index;
+	    for (my @tmp = @v; @tmp;) {
+		my($k, $v) = splice(@tmp, 0, 2);
+		if ($k eq "boundary") {
+		    $boundary = $v;
+		    $boundary_index = @v - @tmp - 1;
+		    last;
+		}
+	    }
+
+	    ($content, $boundary) = form_data($content, $boundary, $req);
+
+	    if ($boundary_index) {
+		$v[$boundary_index] = $boundary;
+	    }
+	    else {
+		push(@v, boundary => $boundary);
+	    }
+
+	    $ct = HTTP::Headers::Util::join_header_words(@v);
+	}
+	else {
+	    # We use a temporary URI object to format
+	    # the application/x-www-form-urlencoded content.
+	    require URI;
+	    my $url = URI->new('http:');
+	    $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
+	    $content = $url->query;
+
+	    # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A')
+	    $content =~ s/(?<!%0D)%0A/%0D%0A/g if defined($content);
+	}
+    }
+
+    $req->header('Content-Type' => $ct);  # might be redundant
+    if (defined($content)) {
+	$req->header('Content-Length' =>
+		     length($content)) unless ref($content);
+	$req->content($content);
+    }
+    else {
+        $req->header('Content-Length' => 0);
+    }
+    $req;
+}
+
+
+sub _simple_req
+{
+    my($method, $url) = splice(@_, 0, 2);
+    my $req = HTTP::Request->new($method => $url);
+    my($k, $v);
+    my $content;
+    while (($k,$v) = splice(@_, 0, 2)) {
+	if (lc($k) eq 'content') {
+	    $req->add_content($v);
+            $content++;
+	}
+	else {
+	    $req->push_header($k, $v);
+	}
+    }
+    if ($content && !defined($req->header("Content-Length"))) {
+        $req->header("Content-Length", length(${$req->content_ref}));
+    }
+    $req;
+}
+
+
+sub form_data   # RFC1867
+{
+    my($data, $boundary, $req) = @_;
+    my @data = ref($data) eq "HASH" ? %$data : @$data;  # copy
+    my $fhparts;
+    my @parts;
+    my($k,$v);
+    while (($k,$v) = splice(@data, 0, 2)) {
+	if (!ref($v)) {
+	    $k =~ s/([\\\"])/\\$1/g;  # escape quotes and backslashes
+	    push(@parts,
+		 qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
+	}
+	else {
+	    my($file, $usename, @headers) = @$v;
+	    unless (defined $usename) {
+		$usename = $file;
+		$usename =~ s,.*/,, if defined($usename);
+	    }
+            $k =~ s/([\\\"])/\\$1/g;
+	    my $disp = qq(form-data; name="$k");
+            if (defined($usename) and length($usename)) {
+                $usename =~ s/([\\\"])/\\$1/g;
+                $disp .= qq(; filename="$usename");
+            }
+	    my $content = "";
+	    my $h = HTTP::Headers->new(@headers);
+	    if ($file) {
+		open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
+		binmode($fh);
+		if ($DYNAMIC_FILE_UPLOAD) {
+		    # will read file later, close it now in order to
+                    # not accumulate to many open file handles
+                    close($fh);
+		    $content = \$file;
+		}
+		else {
+		    local($/) = undef; # slurp files
+		    $content = <$fh>;
+		    close($fh);
+		}
+		unless ($h->header("Content-Type")) {
+		    require LWP::MediaTypes;
+		    LWP::MediaTypes::guess_media_type($file, $h);
+		}
+	    }
+	    if ($h->header("Content-Disposition")) {
+		# just to get it sorted first
+		$disp = $h->header("Content-Disposition");
+		$h->remove_header("Content-Disposition");
+	    }
+	    if ($h->header("Content")) {
+		$content = $h->header("Content");
+		$h->remove_header("Content");
+	    }
+	    my $head = join($CRLF, "Content-Disposition: $disp",
+			           $h->as_string($CRLF),
+			           "");
+	    if (ref $content) {
+		push(@parts, [$head, $$content]);
+		$fhparts++;
+	    }
+	    else {
+		push(@parts, $head . $content);
+	    }
+	}
+    }
+    return ("", "none") unless @parts;
+
+    my $content;
+    if ($fhparts) {
+	$boundary = boundary(10) # hopefully enough randomness
+	    unless $boundary;
+
+	# add the boundaries to the @parts array
+	for (1..@parts-1) {
+	    splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
+	}
+	unshift(@parts, "--$boundary$CRLF");
+	push(@parts, "$CRLF--$boundary--$CRLF");
+
+	# See if we can generate Content-Length header
+	my $length = 0;
+	for (@parts) {
+	    if (ref $_) {
+	 	my ($head, $f) = @$_;
+		my $file_size;
+		unless ( -f $f && ($file_size = -s _) ) {
+		    # The file is either a dynamic file like /dev/audio
+		    # or perhaps a file in the /proc file system where
+		    # stat may return a 0 size even though reading it
+		    # will produce data.  So we cannot make
+		    # a Content-Length header.  
+		    undef $length;
+		    last;
+		}
+	    	$length += $file_size + length $head;
+	    }
+	    else {
+		$length += length;
+	    }
+        }
+        $length && $req->header('Content-Length' => $length);
+
+	# set up a closure that will return content piecemeal
+	$content = sub {
+	    for (;;) {
+		unless (@parts) {
+		    defined $length && $length != 0 &&
+		    	Carp::croak "length of data sent did not match calculated Content-Length header.  Probably because uploaded file changed in size during transfer.";
+		    return;
+		}
+		my $p = shift @parts;
+		unless (ref $p) {
+		    $p .= shift @parts while @parts && !ref($parts[0]);
+		    defined $length && ($length -= length $p);
+		    return $p;
+		}
+		my($buf, $fh) = @$p;
+                unless (ref($fh)) {
+                    my $file = $fh;
+                    undef($fh);
+                    open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
+                    binmode($fh);
+                }
+		my $buflength = length $buf;
+		my $n = read($fh, $buf, 2048, $buflength);
+		if ($n) {
+		    $buflength += $n;
+		    unshift(@parts, ["", $fh]);
+		}
+		else {
+		    close($fh);
+		}
+		if ($buflength) {
+		    defined $length && ($length -= $buflength);
+		    return $buf 
+	    	}
+	    }
+	};
+
+    }
+    else {
+	$boundary = boundary() unless $boundary;
+
+	my $bno = 0;
+      CHECK_BOUNDARY:
+	{
+	    for (@parts) {
+		if (index($_, $boundary) >= 0) {
+		    # must have a better boundary
+		    $boundary = boundary(++$bno);
+		    redo CHECK_BOUNDARY;
+		}
+	    }
+	    last;
+	}
+	$content = "--$boundary$CRLF" .
+	           join("$CRLF--$boundary$CRLF", @parts) .
+		   "$CRLF--$boundary--$CRLF";
+    }
+
+    wantarray ? ($content, $boundary) : $content;
+}
+
+
+sub boundary
+{
+    my $size = shift || return "xYzZY";
+    require MIME::Base64;
+    my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
+    $b =~ s/[\W]/X/g;  # ensure alnum only
+    $b;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Request::Common - Construct common HTTP::Request objects
+
+=head1 SYNOPSIS
+
+  use HTTP::Request::Common;
+  $ua = LWP::UserAgent->new;
+  $ua->request(GET 'http://www.sn.no/');
+  $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
+
+=head1 DESCRIPTION
+
+This module provide functions that return newly created C<HTTP::Request>
+objects.  These functions are usually more convenient to use than the
+standard C<HTTP::Request> constructor for the most common requests.  The
+following functions are provided:
+
+=over 4
+
+=item GET $url
+
+=item GET $url, Header => Value,...
+
+The GET() function returns an C<HTTP::Request> object initialized with
+the "GET" method and the specified URL.  It is roughly equivalent to the
+following call
+
+  HTTP::Request->new(
+     GET => $url,
+     HTTP::Headers->new(Header => Value,...),
+  )
+
+but is less cluttered.  What is different is that a header named
+C<Content> will initialize the content part of the request instead of
+setting a header field.  Note that GET requests should normally not
+have a content, so this hack makes more sense for the PUT() and POST()
+functions described below.
+
+The get(...) method of C<LWP::UserAgent> exists as a shortcut for
+$ua->request(GET ...).
+
+=item HEAD $url
+
+=item HEAD $url, Header => Value,...
+
+Like GET() but the method in the request is "HEAD".
+
+The head(...)  method of "LWP::UserAgent" exists as a shortcut for
+$ua->request(HEAD ...).
+
+=item PUT $url
+
+=item PUT $url, Header => Value,...
+
+=item PUT $url, Header => Value,..., Content => $content
+
+Like GET() but the method in the request is "PUT".
+
+The content of the request can be specified using the "Content"
+pseudo-header.  This steals a bit of the header field namespace as
+there is no way to directly specify a header that is actually called
+"Content".  If you really need this you must update the request
+returned in a separate statement.
+
+=item DELETE $url
+
+=item DELETE $url, Header => Value,...
+
+Like GET() but the method in the request is "DELETE".  This function
+is not exported by default.
+
+=item POST $url
+
+=item POST $url, Header => Value,...
+
+=item POST $url, $form_ref, Header => Value,...
+
+=item POST $url, Header => Value,..., Content => $form_ref
+
+=item POST $url, Header => Value,..., Content => $content
+
+This works mostly like PUT() with "POST" as the method, but this
+function also takes a second optional array or hash reference
+parameter $form_ref.  As for PUT() the content can also be specified
+directly using the "Content" pseudo-header, and you may also provide
+the $form_ref this way.
+
+The $form_ref argument can be used to pass key/value pairs for the
+form content.  By default we will initialize a request using the
+C<application/x-www-form-urlencoded> content type.  This means that
+you can emulate an HTML E<lt>form> POSTing like this:
+
+  POST 'http://www.perl.org/survey.cgi',
+       [ name   => 'Gisle Aas',
+         email  => 'gisle@aas.no',
+         gender => 'M',
+         born   => '1964',
+         perc   => '3%',
+       ];
+
+This will create an HTTP::Request object that looks like this:
+
+  POST http://www.perl.org/survey.cgi
+  Content-Length: 66
+  Content-Type: application/x-www-form-urlencoded
+
+  name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
+
+Multivalued form fields can be specified by either repeating the field
+name or by passing the value as an array reference.
+
+The POST method also supports the C<multipart/form-data> content used
+for I<Form-based File Upload> as specified in RFC 1867.  You trigger
+this content format by specifying a content type of C<'form-data'> as
+one of the request headers.  If one of the values in the $form_ref is
+an array reference, then it is treated as a file part specification
+with the following interpretation:
+
+  [ $file, $filename, Header => Value... ]
+  [ undef, $filename, Header => Value,..., Content => $content ]
+
+The first value in the array ($file) is the name of a file to open.
+This file will be read and its content placed in the request.  The
+routine will croak if the file can't be opened.  Use an C<undef> as
+$file value if you want to specify the content directly with a
+C<Content> header.  The $filename is the filename to report in the
+request.  If this value is undefined, then the basename of the $file
+will be used.  You can specify an empty string as $filename if you
+want to suppress sending the filename when you provide a $file value.
+
+If a $file is provided by no C<Content-Type> header, then C<Content-Type>
+and C<Content-Encoding> will be filled in automatically with the values
+returned by LWP::MediaTypes::guess_media_type()
+
+Sending my F<~/.profile> to the survey used as example above can be
+achieved by this:
+
+  POST 'http://www.perl.org/survey.cgi',
+       Content_Type => 'form-data',
+       Content      => [ name  => 'Gisle Aas',
+                         email => 'gisle@aas.no',
+                         gender => 'M',
+                         born   => '1964',
+                         init   => ["$ENV{HOME}/.profile"],
+                       ]
+
+This will create an HTTP::Request object that almost looks this (the
+boundary and the content of your F<~/.profile> is likely to be
+different):
+
+  POST http://www.perl.org/survey.cgi
+  Content-Length: 388
+  Content-Type: multipart/form-data; boundary="6G+f"
+
+  --6G+f
+  Content-Disposition: form-data; name="name"
+
+  Gisle Aas
+  --6G+f
+  Content-Disposition: form-data; name="email"
+
+  gisle@aas.no
+  --6G+f
+  Content-Disposition: form-data; name="gender"
+
+  M
+  --6G+f
+  Content-Disposition: form-data; name="born"
+
+  1964
+  --6G+f
+  Content-Disposition: form-data; name="init"; filename=".profile"
+  Content-Type: text/plain
+
+  PATH=/local/perl/bin:$PATH
+  export PATH
+
+  --6G+f--
+
+If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE
+value, then you get back a request object with a subroutine closure as
+the content attribute.  This subroutine will read the content of any
+files on demand and return it in suitable chunks.  This allow you to
+upload arbitrary big files without using lots of memory.  You can even
+upload infinite files like F</dev/audio> if you wish; however, if
+the file is not a plain file, there will be no Content-Length header
+defined for the request.  Not all servers (or server
+applications) like this.  Also, if the file(s) change in size between
+the time the Content-Length is calculated and the time that the last
+chunk is delivered, the subroutine will C<Croak>.
+
+The post(...)  method of "LWP::UserAgent" exists as a shortcut for
+$ua->request(POST ...).
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Request>, L<LWP::UserAgent>
+
+
+=head1 COPYRIGHT
+
+Copyright 1997-2004, 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/Response.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Response.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Response.pm	(revision 27174)
@@ -0,0 +1,637 @@
+package HTTP::Response;
+
+require HTTP::Message;
+@ISA = qw(HTTP::Message);
+$VERSION = "6.04";
+
+use strict;
+use HTTP::Status ();
+
+
+
+sub new
+{
+    my($class, $rc, $msg, $header, $content) = @_;
+    my $self = $class->SUPER::new($header, $content);
+    $self->code($rc);
+    $self->message($msg);
+    $self;
+}
+
+
+sub parse
+{
+    my($class, $str) = @_;
+    my $status_line;
+    if ($str =~ s/^(.*)\n//) {
+	$status_line = $1;
+    }
+    else {
+	$status_line = $str;
+	$str = "";
+    }
+
+    my $self = $class->SUPER::parse($str);
+    my($protocol, $code, $message);
+    if ($status_line =~ /^\d{3} /) {
+       # Looks like a response created by HTTP::Response->new
+       ($code, $message) = split(' ', $status_line, 2);
+    } else {
+       ($protocol, $code, $message) = split(' ', $status_line, 3);
+    }
+    $self->protocol($protocol) if $protocol;
+    $self->code($code) if defined($code);
+    $self->message($message) if defined($message);
+    $self;
+}
+
+
+sub clone
+{
+    my $self = shift;
+    my $clone = bless $self->SUPER::clone, ref($self);
+    $clone->code($self->code);
+    $clone->message($self->message);
+    $clone->request($self->request->clone) if $self->request;
+    # we don't clone previous
+    $clone;
+}
+
+
+sub code      { shift->_elem('_rc',      @_); }
+sub message   { shift->_elem('_msg',     @_); }
+sub previous  { shift->_elem('_previous',@_); }
+sub request   { shift->_elem('_request', @_); }
+
+
+sub status_line
+{
+    my $self = shift;
+    my $code = $self->{'_rc'}  || "000";
+    my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
+    return "$code $mess";
+}
+
+
+sub base
+{
+    my $self = shift;
+    my $base = (
+	$self->header('Content-Base'),        # used to be HTTP/1.1
+	$self->header('Content-Location'),    # HTTP/1.1
+	$self->header('Base'),                # HTTP/1.0
+    )[0];
+    if ($base && $base =~ /^$URI::scheme_re:/o) {
+	# already absolute
+	return $HTTP::URI_CLASS->new($base);
+    }
+
+    my $req = $self->request;
+    if ($req) {
+        # if $base is undef here, the return value is effectively
+        # just a copy of $self->request->uri.
+        return $HTTP::URI_CLASS->new_abs($base, $req->uri);
+    }
+
+    # can't find an absolute base
+    return undef;
+}
+
+
+sub redirects {
+    my $self = shift;
+    my @r;
+    my $r = $self;
+    while (my $p = $r->previous) {
+        push(@r, $p);
+        $r = $p;
+    }
+    return @r unless wantarray;
+    return reverse @r;
+}
+
+
+sub filename
+{
+    my $self = shift;
+    my $file;
+
+    my $cd = $self->header('Content-Disposition');
+    if ($cd) {
+	require HTTP::Headers::Util;
+	if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
+	    my ($disposition, undef, %cd_param) = @{$cd[-1]};
+	    $file = $cd_param{filename};
+
+	    # RFC 2047 encoded?
+	    if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
+		my $charset = $1;
+		my $encoding = uc($2);
+		my $encfile = $3;
+
+		if ($encoding eq 'Q' || $encoding eq 'B') {
+		    local($SIG{__DIE__});
+		    eval {
+			if ($encoding eq 'Q') {
+			    $encfile =~ s/_/ /g;
+			    require MIME::QuotedPrint;
+			    $encfile = MIME::QuotedPrint::decode($encfile);
+			}
+			else { # $encoding eq 'B'
+			    require MIME::Base64;
+			    $encfile = MIME::Base64::decode($encfile);
+			}
+
+			require Encode;
+			require Encode::Locale;
+			Encode::from_to($encfile, $charset, "locale_fs");
+		    };
+
+		    $file = $encfile unless $@;
+		}
+	    }
+	}
+    }
+
+    unless (defined($file) && length($file)) {
+	my $uri;
+	if (my $cl = $self->header('Content-Location')) {
+	    $uri = URI->new($cl);
+	}
+	elsif (my $request = $self->request) {
+	    $uri = $request->uri;
+	}
+
+	if ($uri) {
+	    $file = ($uri->path_segments)[-1];
+	}
+    }
+
+    if ($file) {
+	$file =~ s,.*[\\/],,;  # basename
+    }
+
+    if ($file && !length($file)) {
+	$file = undef;
+    }
+
+    $file;
+}
+
+
+sub as_string
+{
+    my $self = shift;
+    my($eol) = @_;
+    $eol = "\n" unless defined $eol;
+
+    my $status_line = $self->status_line;
+    my $proto = $self->protocol;
+    $status_line = "$proto $status_line" if $proto;
+
+    return join($eol, $status_line, $self->SUPER::as_string(@_));
+}
+
+
+sub dump
+{
+    my $self = shift;
+
+    my $status_line = $self->status_line;
+    my $proto = $self->protocol;
+    $status_line = "$proto $status_line" if $proto;
+
+    return $self->SUPER::dump(
+	preheader => $status_line,
+        @_,
+    );
+}
+
+
+sub is_info     { HTTP::Status::is_info     (shift->{'_rc'}); }
+sub is_success  { HTTP::Status::is_success  (shift->{'_rc'}); }
+sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
+sub is_error    { HTTP::Status::is_error    (shift->{'_rc'}); }
+
+
+sub error_as_HTML
+{
+    my $self = shift;
+    my $title = 'An Error Occurred';
+    my $body  = $self->status_line;
+    $body =~ s/&/&amp;/g;
+    $body =~ s/</&lt;/g;
+    return <<EOM;
+<html>
+<head><title>$title</title></head>
+<body>
+<h1>$title</h1>
+<p>$body</p>
+</body>
+</html>
+EOM
+}
+
+
+sub current_age
+{
+    my $self = shift;
+    my $time = shift;
+
+    # Implementation of RFC 2616 section 13.2.3
+    # (age calculations)
+    my $response_time = $self->client_date;
+    my $date = $self->date;
+
+    my $age = 0;
+    if ($response_time && $date) {
+	$age = $response_time - $date;  # apparent_age
+	$age = 0 if $age < 0;
+    }
+
+    my $age_v = $self->header('Age');
+    if ($age_v && $age_v > $age) {
+	$age = $age_v;   # corrected_received_age
+    }
+
+    if ($response_time) {
+	my $request = $self->request;
+	if ($request) {
+	    my $request_time = $request->date;
+	    if ($request_time && $request_time < $response_time) {
+		# Add response_delay to age to get 'corrected_initial_age'
+		$age += $response_time - $request_time;
+	    }
+	}
+	$age += ($time || time) - $response_time;
+    }
+    return $age;
+}
+
+
+sub freshness_lifetime
+{
+    my($self, %opt) = @_;
+
+    # First look for the Cache-Control: max-age=n header
+    for my $cc ($self->header('Cache-Control')) {
+	for my $cc_dir (split(/\s*,\s*/, $cc)) {
+	    return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
+	}
+    }
+
+    # Next possibility is to look at the "Expires" header
+    my $date = $self->date || $self->client_date || $opt{time} || time;
+    if (my $expires = $self->expires) {
+	return $expires - $date;
+    }
+
+    # Must apply heuristic expiration
+    return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
+
+    # Default heuristic expiration parameters
+    $opt{h_min} ||= 60;
+    $opt{h_max} ||= 24 * 3600;
+    $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
+    $opt{h_default} ||= 3600;
+
+    # Should give a warning if more than 24 hours according to
+    # RFC 2616 section 13.2.4.  Here we just make this the default
+    # maximum value.
+
+    if (my $last_modified = $self->last_modified) {
+	my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
+	return $opt{h_min} if $h_exp < $opt{h_min};
+	return $opt{h_max} if $h_exp > $opt{h_max};
+	return $h_exp;
+    }
+
+    # default when all else fails
+    return $opt{h_min} if $opt{h_min} > $opt{h_default};
+    return $opt{h_default};
+}
+
+
+sub is_fresh
+{
+    my($self, %opt) = @_;
+    $opt{time} ||= time;
+    my $f = $self->freshness_lifetime(%opt);
+    return undef unless defined($f);
+    return $f > $self->current_age($opt{time});
+}
+
+
+sub fresh_until
+{
+    my($self, %opt) = @_;
+    $opt{time} ||= time;
+    my $f = $self->freshness_lifetime(%opt);
+    return undef unless defined($f);
+    return $f - $self->current_age($opt{time}) + $opt{time};
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Response - HTTP style response message
+
+=head1 SYNOPSIS
+
+Response objects are returned by the request() method of the C<LWP::UserAgent>:
+
+    # ...
+    $response = $ua->request($request)
+    if ($response->is_success) {
+        print $response->decoded_content;
+    }
+    else {
+        print STDERR $response->status_line, "\n";
+    }
+
+=head1 DESCRIPTION
+
+The C<HTTP::Response> class encapsulates HTTP style responses.  A
+response consists of a response line, some headers, and a content
+body. Note that the LWP library uses HTTP style responses even for
+non-HTTP protocol schemes.  Instances of this class are usually
+created and returned by the request() method of an C<LWP::UserAgent>
+object.
+
+C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
+inherits its methods.  The following additional methods are available:
+
+=over 4
+
+=item $r = HTTP::Response->new( $code )
+
+=item $r = HTTP::Response->new( $code, $msg )
+
+=item $r = HTTP::Response->new( $code, $msg, $header )
+
+=item $r = HTTP::Response->new( $code, $msg, $header, $content )
+
+Constructs a new C<HTTP::Response> object describing a response with
+response code $code and optional message $msg.  The optional $header
+argument should be a reference to an C<HTTP::Headers> object or a
+plain array reference of key/value pairs.  The optional $content
+argument should be a string of bytes.  The meanings of these arguments are
+described below.
+
+=item $r = HTTP::Response->parse( $str )
+
+This constructs a new response object by parsing the given string.
+
+=item $r->code
+
+=item $r->code( $code )
+
+This is used to get/set the code attribute.  The code is a 3 digit
+number that encode the overall outcome of an HTTP response.  The
+C<HTTP::Status> module provide constants that provide mnemonic names
+for the code attribute.
+
+=item $r->message
+
+=item $r->message( $message )
+
+This is used to get/set the message attribute.  The message is a short
+human readable single line string that explains the response code.
+
+=item $r->header( $field )
+
+=item $r->header( $field => $value )
+
+This is used to get/set header values and it is inherited from
+C<HTTP::Headers> via C<HTTP::Message>.  See L<HTTP::Headers> for
+details and other similar methods that can be used to access the
+headers.
+
+=item $r->content
+
+=item $r->content( $bytes )
+
+This is used to get/set the raw content and it is inherited from the
+C<HTTP::Message> base class.  See L<HTTP::Message> for details and
+other methods that can be used to access the content.
+
+=item $r->decoded_content( %options )
+
+This will return the content after any C<Content-Encoding> and
+charsets have been decoded.  See L<HTTP::Message> for details.
+
+=item $r->request
+
+=item $r->request( $request )
+
+This is used to get/set the request attribute.  The request attribute
+is a reference to the the request that caused this response.  It does
+not have to be the same request passed to the $ua->request() method,
+because there might have been redirects and authorization retries in
+between.
+
+=item $r->previous
+
+=item $r->previous( $response )
+
+This is used to get/set the previous attribute.  The previous
+attribute is used to link together chains of responses.  You get
+chains of responses if the first response is redirect or unauthorized.
+The value is C<undef> if this is the first response in a chain.
+
+Note that the method $r->redirects is provided as a more convenient
+way to access the response chain.
+
+=item $r->status_line
+
+Returns the string "E<lt>code> E<lt>message>".  If the message attribute
+is not set then the official name of E<lt>code> (see L<HTTP::Status>)
+is substituted.
+
+=item $r->base
+
+Returns the base URI for this response.  The return value will be a
+reference to a URI object.
+
+The base URI is obtained from one the following sources (in priority
+order):
+
+=over 4
+
+=item 1.
+
+Embedded in the document content, for instance <BASE HREF="...">
+in HTML documents.
+
+=item 2.
+
+A "Content-Base:" or a "Content-Location:" header in the response.
+
+For backwards compatibility with older HTTP implementations we will
+also look for the "Base:" header.
+
+=item 3.
+
+The URI used to request this response. This might not be the original
+URI that was passed to $ua->request() method, because we might have
+received some redirect responses first.
+
+=back
+
+If none of these sources provide an absolute URI, undef is returned.
+
+When the LWP protocol modules produce the HTTP::Response object, then
+any base URI embedded in the document (step 1) will already have
+initialized the "Content-Base:" header. This means that this method
+only performs the last 2 steps (the content is not always available
+either).
+
+=item $r->filename
+
+Returns a filename for this response.  Note that doing sanity checks
+on the returned filename (eg. removing characters that cannot be used
+on the target filesystem where the filename would be used, and
+laundering it for security purposes) are the caller's responsibility;
+the only related thing done by this method is that it makes a simple
+attempt to return a plain filename with no preceding path segments.
+
+The filename is obtained from one the following sources (in priority
+order):
+
+=over 4
+
+=item 1.
+
+A "Content-Disposition:" header in the response.  Proper decoding of
+RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
+encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
+
+=item 2.
+
+A "Content-Location:" header in the response.
+
+=item 3.
+
+The URI used to request this response. This might not be the original
+URI that was passed to $ua->request() method, because we might have
+received some redirect responses first.
+
+=back
+
+If a filename cannot be derived from any of these sources, undef is
+returned.
+
+=item $r->as_string
+
+=item $r->as_string( $eol )
+
+Returns a textual representation of the response.
+
+=item $r->is_info
+
+=item $r->is_success
+
+=item $r->is_redirect
+
+=item $r->is_error
+
+These methods indicate if the response was informational, successful, a
+redirection, or an error.  See L<HTTP::Status> for the meaning of these.
+
+=item $r->error_as_HTML
+
+Returns a string containing a complete HTML document indicating what
+error occurred.  This method should only be called when $r->is_error
+is TRUE.
+
+=item $r->redirects
+
+Returns the list of redirect responses that lead up to this response
+by following the $r->previous chain.  The list order is oldest first.
+
+In scalar context return the number of redirect responses leading up
+to this one.
+
+=item $r->current_age
+
+Calculates the "current age" of the response as specified by RFC 2616
+section 13.2.3.  The age of a response is the time since it was sent
+by the origin server.  The returned value is a number representing the
+age in seconds.
+
+=item $r->freshness_lifetime( %opt )
+
+Calculates the "freshness lifetime" of the response as specified by
+RFC 2616 section 13.2.4.  The "freshness lifetime" is the length of
+time between the generation of a response and its expiration time.
+The returned value is the number of seconds until expiry.
+
+If the response does not contain an "Expires" or a "Cache-Control"
+header, then this function will apply some simple heuristic based on
+the "Last-Modified" header to determine a suitable lifetime.  The
+following options might be passed to control the heuristics:
+
+=over
+
+=item heuristic_expiry => $bool
+
+If passed as a FALSE value, don't apply heuristics and just return
+C<undef> when "Expires" or "Cache-Control" is lacking.
+
+=item h_lastmod_fraction => $num
+
+This number represent the fraction of the difference since the
+"Last-Modified" timestamp to make the expiry time.  The default is
+C<0.10>, the suggested typical setting of 10% in RFC 2616.
+
+=item h_min => $sec
+
+This is the lower limit of the heuristic expiry age to use.  The
+default is C<60> (1 minute).
+
+=item h_max => $sec
+
+This is the upper limit of the heuristic expiry age to use.  The
+default is C<86400> (24 hours).
+
+=item h_default => $sec
+
+This is the expiry age to use when nothing else applies.  The default
+is C<3600> (1 hour) or "h_min" if greater.
+
+=back
+
+=item $r->is_fresh( %opt )
+
+Returns TRUE if the response is fresh, based on the values of
+freshness_lifetime() and current_age().  If the response is no longer
+fresh, then it has to be re-fetched or re-validated by the origin
+server.
+
+Options might be passed to control expiry heuristics, see the
+description of freshness_lifetime().
+
+=item $r->fresh_until( %opt )
+
+Returns the time (seconds since epoch) when this entity is no longer fresh.
+
+Options might be passed to control expiry heuristics, see the
+description of freshness_lifetime().
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 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/Status.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/HTTP/Status.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/HTTP/Status.pm	(revision 27174)
@@ -0,0 +1,267 @@
+package HTTP::Status;
+
+use strict;
+require 5.002;   # because we use prototypes
+
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(is_info is_success is_redirect is_error status_message);
+@EXPORT_OK = qw(is_client_error is_server_error);
+$VERSION = "6.03";
+
+# Note also addition of mnemonics to @EXPORT below
+
+# Unmarked codes are from RFC 2616
+# See also: http://en.wikipedia.org/wiki/List_of_HTTP_status_codes
+
+my %StatusCode = (
+    100 => 'Continue',
+    101 => 'Switching Protocols',
+    102 => 'Processing',                      # RFC 2518 (WebDAV)
+    200 => 'OK',
+    201 => 'Created',
+    202 => 'Accepted',
+    203 => 'Non-Authoritative Information',
+    204 => 'No Content',
+    205 => 'Reset Content',
+    206 => 'Partial Content',
+    207 => 'Multi-Status',                    # RFC 2518 (WebDAV)
+    208 => 'Already Reported',		      # RFC 5842
+    300 => 'Multiple Choices',
+    301 => 'Moved Permanently',
+    302 => 'Found',
+    303 => 'See Other',
+    304 => 'Not Modified',
+    305 => 'Use Proxy',
+    307 => 'Temporary Redirect',
+    400 => 'Bad Request',
+    401 => 'Unauthorized',
+    402 => 'Payment Required',
+    403 => 'Forbidden',
+    404 => 'Not Found',
+    405 => 'Method Not Allowed',
+    406 => 'Not Acceptable',
+    407 => 'Proxy Authentication Required',
+    408 => 'Request Timeout',
+    409 => 'Conflict',
+    410 => 'Gone',
+    411 => 'Length Required',
+    412 => 'Precondition Failed',
+    413 => 'Request Entity Too Large',
+    414 => 'Request-URI Too Large',
+    415 => 'Unsupported Media Type',
+    416 => 'Request Range Not Satisfiable',
+    417 => 'Expectation Failed',
+    418 => 'I\'m a teapot',		      # RFC 2324
+    422 => 'Unprocessable Entity',            # RFC 2518 (WebDAV)
+    423 => 'Locked',                          # RFC 2518 (WebDAV)
+    424 => 'Failed Dependency',               # RFC 2518 (WebDAV)
+    425 => 'No code',                         # WebDAV Advanced Collections
+    426 => 'Upgrade Required',                # RFC 2817
+    428 => 'Precondition Required',
+    429 => 'Too Many Requests',
+    431 => 'Request Header Fields Too Large',
+    449 => 'Retry with',                      # unofficial Microsoft
+    500 => 'Internal Server Error',
+    501 => 'Not Implemented',
+    502 => 'Bad Gateway',
+    503 => 'Service Unavailable',
+    504 => 'Gateway Timeout',
+    505 => 'HTTP Version Not Supported',
+    506 => 'Variant Also Negotiates',         # RFC 2295
+    507 => 'Insufficient Storage',            # RFC 2518 (WebDAV)
+    509 => 'Bandwidth Limit Exceeded',        # unofficial
+    510 => 'Not Extended',                    # RFC 2774
+    511 => 'Network Authentication Required',
+);
+
+my $mnemonicCode = '';
+my ($code, $message);
+while (($code, $message) = each %StatusCode) {
+    # create mnemonic subroutines
+    $message =~ s/I'm/I am/;
+    $message =~ tr/a-z \-/A-Z__/;
+    $mnemonicCode .= "sub HTTP_$message () { $code }\n";
+    $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n";  # legacy
+    $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n";
+    $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n";
+}
+eval $mnemonicCode; # only one eval for speed
+die if $@;
+
+# backwards compatibility
+*RC_MOVED_TEMPORARILY = \&RC_FOUND;  # 302 was renamed in the standard
+push(@EXPORT, "RC_MOVED_TEMPORARILY");
+
+%EXPORT_TAGS = (
+   constants => [grep /^HTTP_/, @EXPORT_OK],
+   is => [grep /^is_/, @EXPORT, @EXPORT_OK],
+);
+
+
+sub status_message  ($) { $StatusCode{$_[0]}; }
+
+sub is_info         ($) { $_[0] >= 100 && $_[0] < 200; }
+sub is_success      ($) { $_[0] >= 200 && $_[0] < 300; }
+sub is_redirect     ($) { $_[0] >= 300 && $_[0] < 400; }
+sub is_error        ($) { $_[0] >= 400 && $_[0] < 600; }
+sub is_client_error ($) { $_[0] >= 400 && $_[0] < 500; }
+sub is_server_error ($) { $_[0] >= 500 && $_[0] < 600; }
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Status - HTTP Status code processing
+
+=head1 SYNOPSIS
+
+ use HTTP::Status qw(:constants :is status_message);
+
+ if ($rc != HTTP_OK) {
+     print status_message($rc), "\n";
+ }
+
+ if (is_success($rc)) { ... }
+ if (is_error($rc)) { ... }
+ if (is_redirect($rc)) { ... }
+
+=head1 DESCRIPTION
+
+I<HTTP::Status> is a library of routines for defining and
+classifying HTTP status codes for libwww-perl.  Status codes are
+used to encode the overall outcome of an HTTP response message.  Codes
+correspond to those defined in RFC 2616 and RFC 2518.
+
+=head1 CONSTANTS
+
+The following constant functions can be used as mnemonic status code
+names.  None of these are exported by default.  Use the C<:constants>
+tag to import them all.
+
+   HTTP_CONTINUE                        (100)
+   HTTP_SWITCHING_PROTOCOLS             (101)
+   HTTP_PROCESSING                      (102)
+
+   HTTP_OK                              (200)
+   HTTP_CREATED                         (201)
+   HTTP_ACCEPTED                        (202)
+   HTTP_NON_AUTHORITATIVE_INFORMATION   (203)
+   HTTP_NO_CONTENT                      (204)
+   HTTP_RESET_CONTENT                   (205)
+   HTTP_PARTIAL_CONTENT                 (206)
+   HTTP_MULTI_STATUS                    (207)
+   HTTP_ALREADY_REPORTED		(208)
+
+   HTTP_MULTIPLE_CHOICES                (300)
+   HTTP_MOVED_PERMANENTLY               (301)
+   HTTP_FOUND                           (302)
+   HTTP_SEE_OTHER                       (303)
+   HTTP_NOT_MODIFIED                    (304)
+   HTTP_USE_PROXY                       (305)
+   HTTP_TEMPORARY_REDIRECT              (307)
+
+   HTTP_BAD_REQUEST                     (400)
+   HTTP_UNAUTHORIZED                    (401)
+   HTTP_PAYMENT_REQUIRED                (402)
+   HTTP_FORBIDDEN                       (403)
+   HTTP_NOT_FOUND                       (404)
+   HTTP_METHOD_NOT_ALLOWED              (405)
+   HTTP_NOT_ACCEPTABLE                  (406)
+   HTTP_PROXY_AUTHENTICATION_REQUIRED   (407)
+   HTTP_REQUEST_TIMEOUT                 (408)
+   HTTP_CONFLICT                        (409)
+   HTTP_GONE                            (410)
+   HTTP_LENGTH_REQUIRED                 (411)
+   HTTP_PRECONDITION_FAILED             (412)
+   HTTP_REQUEST_ENTITY_TOO_LARGE        (413)
+   HTTP_REQUEST_URI_TOO_LARGE           (414)
+   HTTP_UNSUPPORTED_MEDIA_TYPE          (415)
+   HTTP_REQUEST_RANGE_NOT_SATISFIABLE   (416)
+   HTTP_EXPECTATION_FAILED              (417)
+   HTTP_I_AM_A_TEAPOT			(418)
+   HTTP_UNPROCESSABLE_ENTITY            (422)
+   HTTP_LOCKED                          (423)
+   HTTP_FAILED_DEPENDENCY               (424)
+   HTTP_NO_CODE                         (425)
+   HTTP_UPGRADE_REQUIRED                (426)
+   HTTP_PRECONDITION_REQUIRED		(428)
+   HTTP_TOO_MANY_REQUESTS		(429)
+   HTTP_REQUEST_HEADER_FIELDS_TOO_LARGE (431)
+   HTTP_RETRY_WITH                      (449)
+
+   HTTP_INTERNAL_SERVER_ERROR           (500)
+   HTTP_NOT_IMPLEMENTED                 (501)
+   HTTP_BAD_GATEWAY                     (502)
+   HTTP_SERVICE_UNAVAILABLE             (503)
+   HTTP_GATEWAY_TIMEOUT                 (504)
+   HTTP_HTTP_VERSION_NOT_SUPPORTED      (505)
+   HTTP_VARIANT_ALSO_NEGOTIATES         (506)
+   HTTP_INSUFFICIENT_STORAGE            (507)
+   HTTP_BANDWIDTH_LIMIT_EXCEEDED        (509)
+   HTTP_NOT_EXTENDED                    (510)
+   HTTP_NETWORK_AUTHENTICATION_REQUIRED (511)
+
+=head1 FUNCTIONS
+
+The following additional functions are provided.  Most of them are
+exported by default.  The C<:is> import tag can be used to import all
+the classification functions.
+
+=over 4
+
+=item status_message( $code )
+
+The status_message() function will translate status codes to human
+readable strings. The string is the same as found in the constant
+names above.  If the $code is unknown, then C<undef> is returned.
+
+=item is_info( $code )
+
+Return TRUE if C<$code> is an I<Informational> status code (1xx).  This
+class of status code indicates a provisional response which can't have
+any content.
+
+=item is_success( $code )
+
+Return TRUE if C<$code> is a I<Successful> status code (2xx).
+
+=item is_redirect( $code )
+
+Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
+status code indicates that further action needs to be taken by the
+user agent in order to fulfill the request.
+
+=item is_error( $code )
+
+Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx).  The function
+returns TRUE for both client and server error status codes.
+
+=item is_client_error( $code )
+
+Return TRUE if C<$code> is a I<Client Error> status code (4xx). This class
+of status code is intended for cases in which the client seems to have
+erred.
+
+This function is B<not> exported by default.
+
+=item is_server_error( $code )
+
+Return TRUE if C<$code> is a I<Server Error> status code (5xx). This class
+of status codes is intended for cases in which the server is aware
+that it has erred or is incapable of performing the request.
+
+This function is B<not> exported by default.
+
+=back
+
+=head1 BUGS
+
+For legacy reasons all the C<HTTP_> constants are exported by default
+with the prefix C<RC_>.  It's recommended to use explicit imports and
+the C<:constants> tag instead of relying on this.
Index: /main/trunk/greenstone2/perllib/cpan/LWP.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP.pm	(revision 27174)
@@ -0,0 +1,669 @@
+package LWP;
+
+$VERSION = "6.05";
+sub Version { $VERSION; }
+
+require 5.008;
+require LWP::UserAgent;  # this should load everything you need
+
+1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+LWP - The World-Wide Web library for Perl
+
+=head1 SYNOPSIS
+
+  use LWP;
+  print "This is libwww-perl-$LWP::VERSION\n";
+
+
+=head1 DESCRIPTION
+
+The libwww-perl collection is a set of Perl modules which provides a
+simple and consistent application programming interface (API) to the
+World-Wide Web.  The main focus of the library is to provide classes
+and functions that allow you to write WWW clients. The library also
+contain modules that are of more general use and even classes that
+help you implement simple HTTP servers.
+
+Most modules in this library provide an object oriented API.  The user
+agent, requests sent and responses received from the WWW server are
+all represented by objects.  This makes a simple and powerful
+interface to these services.  The interface is easy to extend
+and customize for your own needs.
+
+The main features of the library are:
+
+=over 3
+
+=item *
+
+Contains various reusable components (modules) that can be
+used separately or together.
+
+=item *
+
+Provides an object oriented model of HTTP-style communication.  Within
+this framework we currently support access to http, https, gopher, ftp, news,
+file, and mailto resources.
+
+=item *
+
+Provides a full object oriented interface or
+a very simple procedural interface.
+
+=item *
+
+Supports the basic and digest authorization schemes.
+
+=item *
+
+Supports transparent redirect handling.
+
+=item *
+
+Supports access through proxy servers.
+
+=item *
+
+Provides parser for F<robots.txt> files and a framework for constructing robots.
+
+=item *
+
+Supports parsing of HTML forms.
+
+=item *
+
+Implements HTTP content negotiation algorithm that can
+be used both in protocol modules and in server scripts (like CGI
+scripts).
+
+=item *
+
+Supports HTTP cookies.
+
+=item *
+
+Some simple command line clients, for instance C<lwp-request> and C<lwp-download>.
+
+=back
+
+
+=head1 HTTP STYLE COMMUNICATION
+
+
+The libwww-perl library is based on HTTP style communication. This
+section tries to describe what that means.
+
+Let us start with this quote from the HTTP specification document
+<URL:http://www.w3.org/Protocols/>:
+
+=over 3
+
+=item
+
+The HTTP protocol is based on a request/response paradigm. A client
+establishes a connection with a server and sends a request to the
+server in the form of a request method, URI, and protocol version,
+followed by a MIME-like message containing request modifiers, client
+information, and possible body content. The server responds with a
+status line, including the message's protocol version and a success or
+error code, followed by a MIME-like message containing server
+information, entity meta-information, and possible body content.
+
+=back
+
+What this means to libwww-perl is that communication always take place
+through these steps: First a I<request> object is created and
+configured. This object is then passed to a server and we get a
+I<response> object in return that we can examine. A request is always
+independent of any previous requests, i.e. the service is stateless.
+The same simple model is used for any kind of service we want to
+access.
+
+For example, if we want to fetch a document from a remote file server,
+then we send it a request that contains a name for that document and
+the response will contain the document itself.  If we access a search
+engine, then the content of the request will contain the query
+parameters and the response will contain the query result.  If we want
+to send a mail message to somebody then we send a request object which
+contains our message to the mail server and the response object will
+contain an acknowledgment that tells us that the message has been
+accepted and will be forwarded to the recipient(s).
+
+It is as simple as that!
+
+
+=head2 The Request Object
+
+The libwww-perl request object has the class name C<HTTP::Request>.
+The fact that the class name uses C<HTTP::> as a
+prefix only implies that we use the HTTP model of communication.  It
+does not limit the kind of services we can try to pass this I<request>
+to.  For instance, we will send C<HTTP::Request>s both to ftp and
+gopher servers, as well as to the local file system.
+
+The main attributes of the request objects are:
+
+=over 3
+
+=item *
+
+B<method> is a short string that tells what kind of
+request this is.  The most common methods are B<GET>, B<PUT>,
+B<POST> and B<HEAD>.
+
+=item *
+
+B<uri> is a string denoting the protocol, server and
+the name of the "document" we want to access.  The B<uri> might
+also encode various other parameters.
+
+=item *
+
+B<headers> contains additional information about the
+request and can also used to describe the content.  The headers
+are a set of keyword/value pairs.
+
+=item *
+
+B<content> is an arbitrary amount of data.
+
+=back
+
+=head2 The Response Object
+
+The libwww-perl response object has the class name C<HTTP::Response>.
+The main attributes of objects of this class are:
+
+=over 3
+
+=item *
+
+B<code> is a numerical value that indicates the overall
+outcome of the request.
+
+=item *
+
+B<message> is a short, human readable string that
+corresponds to the I<code>.
+
+=item *
+
+B<headers> contains additional information about the
+response and describe the content.
+
+=item *
+
+B<content> is an arbitrary amount of data.
+
+=back
+
+Since we don't want to handle all possible I<code> values directly in
+our programs, a libwww-perl response object has methods that can be
+used to query what kind of response this is.  The most commonly used
+response classification methods are:
+
+=over 3
+
+=item is_success()
+
+The request was successfully received, understood or accepted.
+
+=item is_error()
+
+The request failed.  The server or the resource might not be
+available, access to the resource might be denied or other things might
+have failed for some reason.
+
+=back
+
+=head2 The User Agent
+
+Let us assume that we have created a I<request> object. What do we
+actually do with it in order to receive a I<response>?
+
+The answer is that you pass it to a I<user agent> object and this
+object takes care of all the things that need to be done
+(like low-level communication and error handling) and returns
+a I<response> object. The user agent represents your
+application on the network and provides you with an interface that
+can accept I<requests> and return I<responses>.
+
+The user agent is an interface layer between
+your application code and the network.  Through this interface you are
+able to access the various servers on the network.
+
+The class name for the user agent is C<LWP::UserAgent>.  Every
+libwww-perl application that wants to communicate should create at
+least one object of this class. The main method provided by this
+object is request(). This method takes an C<HTTP::Request> object as
+argument and (eventually) returns a C<HTTP::Response> object.
+
+The user agent has many other attributes that let you
+configure how it will interact with the network and with your
+application.
+
+=over 3
+
+=item *
+
+B<timeout> specifies how much time we give remote servers to
+respond before the library disconnects and creates an
+internal I<timeout> response.
+
+=item *
+
+B<agent> specifies the name that your application uses when it
+presents itself on the network.
+
+=item *
+
+B<from> can be set to the e-mail address of the person
+responsible for running the application.  If this is set, then the
+address will be sent to the servers with every request.
+
+=item *
+
+B<parse_head> specifies whether we should initialize response
+headers from the E<lt>head> section of HTML documents.
+
+=item *
+
+B<proxy> and B<no_proxy> specify if and when to go through
+a proxy server. <URL:http://www.w3.org/History/1994/WWW/Proxies/>
+
+=item *
+
+B<credentials> provides a way to set up user names and
+passwords needed to access certain services.
+
+=back
+
+Many applications want even more control over how they interact
+with the network and they get this by sub-classing
+C<LWP::UserAgent>.  The library includes a
+sub-class, C<LWP::RobotUA>, for robot applications.
+
+=head2 An Example
+
+This example shows how the user agent, a request and a response are
+represented in actual perl code:
+
+  # Create a user agent object
+  use LWP::UserAgent;
+  my $ua = LWP::UserAgent->new;
+  $ua->agent("MyApp/0.1 ");
+
+  # Create a request
+  my $req = HTTP::Request->new(POST => 'http://search.cpan.org/search');
+  $req->content_type('application/x-www-form-urlencoded');
+  $req->content('query=libwww-perl&mode=dist');
+
+  # Pass request to the user agent and get a response back
+  my $res = $ua->request($req);
+
+  # Check the outcome of the response
+  if ($res->is_success) {
+      print $res->content;
+  }
+  else {
+      print $res->status_line, "\n";
+  }
+
+The $ua is created once when the application starts up.  New request
+objects should normally created for each request sent.
+
+
+=head1 NETWORK SUPPORT
+
+This section discusses the various protocol schemes and
+the HTTP style methods that headers may be used for each.
+
+For all requests, a "User-Agent" header is added and initialized from
+the $ua->agent attribute before the request is handed to the network
+layer.  In the same way, a "From" header is initialized from the
+$ua->from attribute.
+
+For all responses, the library adds a header called "Client-Date".
+This header holds the time when the response was received by
+your application.  The format and semantics of the header are the
+same as the server created "Date" header.  You may also encounter other
+"Client-XXX" headers.  They are all generated by the library
+internally and are not received from the servers.
+
+=head2 HTTP Requests
+
+HTTP requests are just handed off to an HTTP server and it
+decides what happens.  Few servers implement methods beside the usual
+"GET", "HEAD", "POST" and "PUT", but CGI-scripts may implement
+any method they like.
+
+If the server is not available then the library will generate an
+internal error response.
+
+The library automatically adds a "Host" and a "Content-Length" header
+to the HTTP request before it is sent over the network.
+
+For a GET request you might want to add a "If-Modified-Since" or
+"If-None-Match" header to make the request conditional.
+
+For a POST request you should add the "Content-Type" header.  When you
+try to emulate HTML E<lt>FORM> handling you should usually let the value
+of the "Content-Type" header be "application/x-www-form-urlencoded".
+See L<lwpcook> for examples of this.
+
+The libwww-perl HTTP implementation currently support the HTTP/1.1
+and HTTP/1.0 protocol.
+
+The library allows you to access proxy server through HTTP.  This
+means that you can set up the library to forward all types of request
+through the HTTP protocol module.  See L<LWP::UserAgent> for
+documentation of this.
+
+
+=head2 HTTPS Requests
+
+HTTPS requests are HTTP requests over an encrypted network connection
+using the SSL protocol developed by Netscape.  Everything about HTTP
+requests above also apply to HTTPS requests.  In addition the library
+will add the headers "Client-SSL-Cipher", "Client-SSL-Cert-Subject" and
+"Client-SSL-Cert-Issuer" to the response.  These headers denote the
+encryption method used and the name of the server owner.
+
+The request can contain the header "If-SSL-Cert-Subject" in order to
+make the request conditional on the content of the server certificate.
+If the certificate subject does not match, no request is sent to the
+server and an internally generated error response is returned.  The
+value of the "If-SSL-Cert-Subject" header is interpreted as a Perl
+regular expression.
+
+
+=head2 FTP Requests
+
+The library currently supports GET, HEAD and PUT requests.  GET
+retrieves a file or a directory listing from an FTP server.  PUT
+stores a file on a ftp server.
+
+You can specify a ftp account for servers that want this in addition
+to user name and password.  This is specified by including an "Account"
+header in the request.
+
+User name/password can be specified using basic authorization or be
+encoded in the URL.  Failed logins return an UNAUTHORIZED response with
+"WWW-Authenticate: Basic" and can be treated like basic authorization
+for HTTP.
+
+The library supports ftp ASCII transfer mode by specifying the "type=a"
+parameter in the URL. It also supports transfer of ranges for FTP transfers
+using the "Range" header.
+
+Directory listings are by default returned unprocessed (as returned
+from the ftp server) with the content media type reported to be
+"text/ftp-dir-listing". The C<File::Listing> module provides methods
+for parsing of these directory listing.
+
+The ftp module is also able to convert directory listings to HTML and
+this can be requested via the standard HTTP content negotiation
+mechanisms (add an "Accept: text/html" header in the request if you
+want this).
+
+For normal file retrievals, the "Content-Type" is guessed based on the
+file name suffix. See L<LWP::MediaTypes>.
+
+The "If-Modified-Since" request header works for servers that implement
+the MDTM command.  It will probably not work for directory listings though.
+
+Example:
+
+  $req = HTTP::Request->new(GET => 'ftp://me:passwd@ftp.some.where.com/');
+  $req->header(Accept => "text/html, */*;q=0.1");
+
+=head2 News Requests
+
+Access to the USENET News system is implemented through the NNTP
+protocol.  The name of the news server is obtained from the
+NNTP_SERVER environment variable and defaults to "news".  It is not
+possible to specify the hostname of the NNTP server in news: URLs.
+
+The library supports GET and HEAD to retrieve news articles through the
+NNTP protocol.  You can also post articles to newsgroups by using
+(surprise!) the POST method.
+
+GET on newsgroups is not implemented yet.
+
+Examples:
+
+  $req = HTTP::Request->new(GET => 'news:abc1234@a.sn.no');
+
+  $req = HTTP::Request->new(POST => 'news:comp.lang.perl.test');
+  $req->header(Subject => 'This is a test',
+               From    => 'me@some.where.org');
+  $req->content(<<EOT);
+  This is the content of the message that we are sending to
+  the world.
+  EOT
+
+
+=head2 Gopher Request
+
+The library supports the GET and HEAD methods for gopher requests.  All
+request header values are ignored.  HEAD cheats and returns a
+response without even talking to server.
+
+Gopher menus are always converted to HTML.
+
+The response "Content-Type" is generated from the document type
+encoded (as the first letter) in the request URL path itself.
+
+Example:
+
+  $req = HTTP::Request->new(GET => 'gopher://gopher.sn.no/');
+
+
+
+=head2 File Request
+
+The library supports GET and HEAD methods for file requests.  The
+"If-Modified-Since" header is supported.  All other headers are
+ignored.  The I<host> component of the file URL must be empty or set
+to "localhost".  Any other I<host> value will be treated as an error.
+
+Directories are always converted to an HTML document.  For normal
+files, the "Content-Type" and "Content-Encoding" in the response are
+guessed based on the file suffix.
+
+Example:
+
+  $req = HTTP::Request->new(GET => 'file:/etc/passwd');
+
+
+=head2 Mailto Request
+
+You can send (aka "POST") mail messages using the library.  All
+headers specified for the request are passed on to the mail system.
+The "To" header is initialized from the mail address in the URL.
+
+Example:
+
+  $req = HTTP::Request->new(POST => 'mailto:libwww@perl.org');
+  $req->header(Subject => "subscribe");
+  $req->content("Please subscribe me to the libwww-perl mailing list!\n");
+
+=head2 CPAN Requests
+
+URLs with scheme C<cpan:> are redirected to the a suitable CPAN
+mirror.  If you have your own local mirror of CPAN you might tell LWP
+to use it for C<cpan:> URLs by an assignment like this:
+
+  $LWP::Protocol::cpan::CPAN = "file:/local/CPAN/";
+
+Suitable CPAN mirrors are also picked up from the configuration for
+the CPAN.pm, so if you have used that module a suitable mirror should
+be picked automatically.  If neither of these apply, then a redirect
+to the generic CPAN http location is issued.
+
+Example request to download the newest perl:
+
+  $req = HTTP::Request->new(GET => "cpan:src/latest.tar.gz");
+
+
+=head1 OVERVIEW OF CLASSES AND PACKAGES
+
+This table should give you a quick overview of the classes provided by the
+library. Indentation shows class inheritance.
+
+ LWP::MemberMixin   -- Access to member variables of Perl5 classes
+   LWP::UserAgent   -- WWW user agent class
+     LWP::RobotUA   -- When developing a robot applications
+   LWP::Protocol          -- Interface to various protocol schemes
+     LWP::Protocol::http  -- http:// access
+     LWP::Protocol::file  -- file:// access
+     LWP::Protocol::ftp   -- ftp:// access
+     ...
+
+ LWP::Authen::Basic -- Handle 401 and 407 responses
+ LWP::Authen::Digest
+
+ HTTP::Headers      -- MIME/RFC822 style header (used by HTTP::Message)
+ HTTP::Message      -- HTTP style message
+   HTTP::Request    -- HTTP request
+   HTTP::Response   -- HTTP response
+ HTTP::Daemon       -- A HTTP server class
+
+ WWW::RobotRules    -- Parse robots.txt files
+   WWW::RobotRules::AnyDBM_File -- Persistent RobotRules
+
+ Net::HTTP          -- Low level HTTP client
+
+The following modules provide various functions and definitions.
+
+ LWP                -- This file.  Library version number and documentation.
+ LWP::MediaTypes    -- MIME types configuration (text/html etc.)
+ LWP::Simple        -- Simplified procedural interface for common functions
+ HTTP::Status       -- HTTP status code (200 OK etc)
+ HTTP::Date         -- Date parsing module for HTTP date formats
+ HTTP::Negotiate    -- HTTP content negotiation calculation
+ File::Listing      -- Parse directory listings
+ HTML::Form         -- Processing for <form>s in HTML documents
+
+
+=head1 MORE DOCUMENTATION
+
+All modules contain detailed information on the interfaces they
+provide.  The L<lwpcook> manpage is the libwww-perl cookbook that contain
+examples of typical usage of the library.  You might want to take a
+look at how the scripts L<lwp-request>, L<lwp-download>, L<lwp-dump>
+and L<lwp-mirror> are implemented.
+
+=head1 ENVIRONMENT
+
+The following environment variables are used by LWP:
+
+=over
+
+=item HOME
+
+The C<LWP::MediaTypes> functions will look for the F<.media.types> and
+F<.mime.types> files relative to you home directory.
+
+=item http_proxy
+
+=item ftp_proxy
+
+=item xxx_proxy
+
+=item no_proxy
+
+These environment variables can be set to enable communication through
+a proxy server.  See the description of the C<env_proxy> method in
+L<LWP::UserAgent>.
+
+=item PERL_LWP_ENV_PROXY
+
+If set to a TRUE value, then the C<LWP::UserAgent> will by default call
+C<env_proxy> during initialization.  This makes LWP honor the proxy variables
+described above.
+
+=item PERL_LWP_SSL_VERIFY_HOSTNAME
+
+The default C<verify_hostname> setting for C<LWP::UserAgent>.  If
+not set the default will be 1.  Set it as 0 to disable hostname
+verification (the default prior to libwww-perl 5.840.
+
+=item PERL_LWP_SSL_CA_FILE
+
+=item PERL_LWP_SSL_CA_PATH
+
+The file and/or directory
+where the trusted Certificate Authority certificates
+is located.  See L<LWP::UserAgent> for details.
+
+=item PERL_HTTP_URI_CLASS
+
+Used to decide what URI objects to instantiate.  The default is C<URI>.
+You might want to set it to C<URI::URL> for compatibility with old times.
+
+=back
+
+=head1 AUTHORS
+
+LWP was made possible by contributions from Adam Newby, Albert
+Dvornik, Alexandre Duret-Lutz, Andreas Gustafsson, Andreas KÃ¶nig,
+Andrew Pimlott, Andy Lester, Ben Coleman, Benjamin Low, Ben Low, Ben
+Tilly, Blair Zajac, Bob Dalgleish, BooK, Brad Hughes, Brian
+J. Murrell, Brian McCauley, Charles C. Fu, Charles Lane, Chris Nandor,
+Christian Gilmore, Chris W. Unger, Craig Macdonald, Dale Couch, Dan
+Kubb, Dave Dunkin, Dave W. Smith, David Coppit, David Dick, David
+D. Kilzer, Doug MacEachern, Edward Avis, erik, Gary Shea, Gisle Aas,
+Graham Barr, Gurusamy Sarathy, Hans de Graaff, Harald Joerg, Harry
+Bochner, Hugo, Ilya Zakharevich, INOUE Yoshinari, Ivan Panchenko, Jack
+Shirazi, James Tillman, Jan Dubois, Jared Rhine, Jim Stern, Joao
+Lopes, John Klar, Johnny Lee, Josh Kronengold, Josh Rai, Joshua
+Chamas, Joshua Hoblitt, Kartik Subbarao, Keiichiro Nagano, Ken
+Williams, KONISHI Katsuhiro, Lee T Lindley, Liam Quinn, Marc Hedlund,
+Marc Langheinrich, Mark D. Anderson, Marko Asplund, Mark Stosberg,
+Markus B KrÃŒger, Markus Laker, Martijn Koster, Martin Thurn, Matthew
+Eldridge, Matthew.van.Eerde, Matt Sergeant, Michael A. Chase, Michael
+Quaranta, Michael Thompson, Mike Schilli, Moshe Kaminsky, Nathan
+Torkington, Nicolai Langfeldt, Norton Allen, Olly Betts, Paul
+J. Schinder, peterm, Philip GuentherDaniel Buenzli, Pon Hwa Lin,
+Radoslaw Zielinski, Radu Greab, Randal L. Schwartz, Richard Chen,
+Robin Barker, Roy Fielding, Sander van Zoest, Sean M. Burke,
+shildreth, Slaven Rezic, Steve A Fink, Steve Hay, Steven Butler,
+Steve_Kilbane, Takanori Ugai, Thomas Lotterer, Tim Bunce, Tom Hughes,
+Tony Finch, Ville SkyttÃ€, Ward Vandewege, William York, Yale Huang,
+and Yitzchak Scott-Thoennes.
+
+LWP owes a lot in motivation, design, and code, to the libwww-perl
+library for Perl4 by Roy Fielding, which included work from Alberto
+Accomazzi, James Casey, Brooks Cutter, Martijn Koster, Oscar
+Nierstrasz, Mel Melchner, Gertjan van Oosten, Jared Rhine, Jack
+Shirazi, Gene Spafford, Marc VanHeyningen, Steven E. Brenner, Marion
+Hakanson, Waldemar Kebsch, Tony Sanders, and Larry Wall; see the
+libwww-perl-0.40 library for details.
+
+=head1 COPYRIGHT
+
+  Copyright 1995-2009, Gisle Aas
+  Copyright 1995, Martijn Koster
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 AVAILABILITY
+
+The latest version of this library is likely to be available from CPAN
+as well as:
+
+  http://github.com/libwww-perl/libwww-perl
+
+The best place to discuss this code is on the <libwww@perl.org>
+mailing list.
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Authen/Basic.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Authen/Basic.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Authen/Basic.pm	(revision 27174)
@@ -0,0 +1,65 @@
+package LWP::Authen::Basic;
+use strict;
+
+require MIME::Base64;
+
+sub auth_header {
+    my($class, $user, $pass) = @_;
+    return "Basic " . MIME::Base64::encode("$user:$pass", "");
+}
+
+sub authenticate
+{
+    my($class, $ua, $proxy, $auth_param, $response,
+       $request, $arg, $size) = @_;
+
+    my $realm = $auth_param->{realm} || "";
+    my $url = $proxy ? $request->{proxy} : $request->uri_canonical;
+    return $response unless $url;
+    my $host_port = $url->host_port;
+    my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
+
+    my @m = $proxy ? (m_proxy => $url) : (m_host_port => $host_port);
+    push(@m, realm => $realm);
+
+    my $h = $ua->get_my_handler("request_prepare", @m, sub {
+        $_[0]{callback} = sub {
+            my($req, $ua, $h) = @_;
+            my($user, $pass) = $ua->credentials($host_port, $h->{realm});
+	    if (defined $user) {
+		my $auth_value = $class->auth_header($user, $pass, $req, $ua, $h);
+		$req->header($auth_header => $auth_value);
+	    }
+        };
+    });
+    $h->{auth_param} = $auth_param;
+
+    if (!$proxy && !$request->header($auth_header) && $ua->credentials($host_port, $realm)) {
+	# we can make sure this handler applies and retry
+        add_path($h, $url->path);
+        return $ua->request($request->clone, $arg, $size, $response);
+    }
+
+    my($user, $pass) = $ua->get_basic_credentials($realm, $url, $proxy);
+    unless (defined $user and defined $pass) {
+	$ua->set_my_handler("request_prepare", undef, @m);  # delete handler
+	return $response;
+    }
+
+    # check that the password has changed
+    my ($olduser, $oldpass) = $ua->credentials($host_port, $realm);
+    return $response if (defined $olduser and defined $oldpass and
+                         $user eq $olduser and $pass eq $oldpass);
+
+    $ua->credentials($host_port, $realm, $user, $pass);
+    add_path($h, $url->path) unless $proxy;
+    return $ua->request($request->clone, $arg, $size, $response);
+}
+
+sub add_path {
+    my($h, $path) = @_;
+    $path =~ s,[^/]+\z,,;
+    push(@{$h->{m_path_prefix}}, $path);
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Authen/Digest.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Authen/Digest.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Authen/Digest.pm	(revision 27174)
@@ -0,0 +1,68 @@
+package LWP::Authen::Digest;
+
+use strict;
+use base 'LWP::Authen::Basic';
+
+require Digest::MD5;
+
+sub auth_header {
+    my($class, $user, $pass, $request, $ua, $h) = @_;
+
+    my $auth_param = $h->{auth_param};
+
+    my $nc = sprintf "%08X", ++$ua->{authen_md5_nonce_count}{$auth_param->{nonce}};
+    my $cnonce = sprintf "%8x", time;
+
+    my $uri = $request->uri->path_query;
+    $uri = "/" unless length $uri;
+
+    my $md5 = Digest::MD5->new;
+
+    my(@digest);
+    $md5->add(join(":", $user, $auth_param->{realm}, $pass));
+    push(@digest, $md5->hexdigest);
+    $md5->reset;
+
+    push(@digest, $auth_param->{nonce});
+
+    if ($auth_param->{qop}) {
+	push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
+    }
+
+    $md5->add(join(":", $request->method, $uri));
+    push(@digest, $md5->hexdigest);
+    $md5->reset;
+
+    $md5->add(join(":", @digest));
+    my($digest) = $md5->hexdigest;
+    $md5->reset;
+
+    my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
+    @resp{qw(username uri response algorithm)} = ($user, $uri, $digest, "MD5");
+
+    if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
+	@resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
+    }
+
+    my(@order) = qw(username realm qop algorithm uri nonce nc cnonce response);
+    if($request->method =~ /^(?:POST|PUT)$/) {
+	$md5->add($request->content);
+	my $content = $md5->hexdigest;
+	$md5->reset;
+	$md5->add(join(":", @digest[0..1], $content));
+	$md5->reset;
+	$resp{"message-digest"} = $md5->hexdigest;
+	push(@order, "message-digest");
+    }
+    push(@order, "opaque");
+    my @pairs;
+    for (@order) {
+	next unless defined $resp{$_};
+	push(@pairs, "$_=" . qq("$resp{$_}"));
+    }
+
+    my $auth_value  = "Digest " . join(", ", @pairs);
+    return $auth_value;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Authen/Ntlm.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Authen/Ntlm.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Authen/Ntlm.pm	(revision 27174)
@@ -0,0 +1,180 @@
+package LWP::Authen::Ntlm;
+
+use strict;
+use vars qw/$VERSION/;
+
+$VERSION = "6.00";
+
+use Authen::NTLM "1.02";
+use MIME::Base64 "2.12";
+
+sub authenticate {
+    my($class, $ua, $proxy, $auth_param, $response,
+       $request, $arg, $size) = @_;
+
+    my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm},
+                                                  $request->uri, $proxy);
+
+    unless(defined $user and defined $pass) {
+		return $response;
+	}
+
+	if (!$ua->conn_cache()) {
+		warn "The keep_alive option must be enabled for NTLM authentication to work.  NTLM authentication aborted.\n";
+		return $response;
+	}
+
+	my($domain, $username) = split(/\\/, $user);
+
+	ntlm_domain($domain);
+	ntlm_user($username);
+	ntlm_password($pass);
+
+    my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
+
+	# my ($challenge) = $response->header('WWW-Authenticate'); 
+	my $challenge;
+	foreach ($response->header('WWW-Authenticate')) { 
+		last if /^NTLM/ && ($challenge=$_);
+	}
+
+	if ($challenge eq 'NTLM') {
+		# First phase, send handshake
+	    my $auth_value = "NTLM " . ntlm();
+		ntlm_reset();
+
+	    # Need to check this isn't a repeated fail!
+	    my $r = $response;
+		my $retry_count = 0;
+	    while ($r) {
+			my $auth = $r->request->header($auth_header);
+			++$retry_count if ($auth && $auth eq $auth_value);
+			if ($retry_count > 2) {
+				    # here we know this failed before
+				    $response->header("Client-Warning" =>
+						      "Credentials for '$user' failed before");
+				    return $response;
+			}
+			$r = $r->previous;
+	    }
+
+	    my $referral = $request->clone;
+	    $referral->header($auth_header => $auth_value);
+	    return $ua->request($referral, $arg, $size, $response);
+	}
+	
+	else {
+		# Second phase, use the response challenge (unless non-401 code
+		#  was returned, in which case, we just send back the response
+		#  object, as is
+		my $auth_value;
+		if ($response->code ne '401') {
+			return $response;
+		}
+		else {
+			my $challenge;
+			foreach ($response->header('WWW-Authenticate')) { 
+				last if /^NTLM/ && ($challenge=$_);
+			}
+			$challenge =~ s/^NTLM //;
+			ntlm();
+			$auth_value = "NTLM " . ntlm($challenge);
+			ntlm_reset();
+		}
+
+	    my $referral = $request->clone;
+	    $referral->header($auth_header => $auth_value);
+	    my $response2 = $ua->request($referral, $arg, $size, $response);
+		return $response2;
+	}
+}
+
+1;
+
+
+=head1 NAME
+
+LWP::Authen::Ntlm - Library for enabling NTLM authentication (Microsoft) in LWP
+
+=head1 SYNOPSIS
+
+ use LWP::UserAgent;
+ use HTTP::Request::Common;
+ my $url = 'http://www.company.com/protected_page.html';
+
+ # Set up the ntlm client and then the base64 encoded ntlm handshake message
+ my $ua = LWP::UserAgent->new(keep_alive=>1);
+ $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
+
+ $request = GET $url;
+ print "--Performing request now...-----------\n";
+ $response = $ua->request($request);
+ print "--Done with request-------------------\n";
+
+ if ($response->is_success) {print "It worked!->" . $response->code . "\n"}
+ else {print "It didn't work!->" . $response->code . "\n"}
+
+=head1 DESCRIPTION
+
+C<LWP::Authen::Ntlm> allows LWP to authenticate against servers that are using the 
+NTLM authentication scheme popularized by Microsoft.  This type of authentication is 
+common on intranets of Microsoft-centric organizations.
+
+The module takes advantage of the Authen::NTLM module by Mark Bush.  Since there 
+is also another Authen::NTLM module available from CPAN by Yee Man Chan with an 
+entirely different interface, it is necessary to ensure that you have the correct 
+NTLM module.
+
+In addition, there have been problems with incompatibilities between different 
+versions of Mime::Base64, which Bush's Authen::NTLM makes use of.  Therefore, it is 
+necessary to ensure that your Mime::Base64 module supports exporting of the 
+encode_base64 and decode_base64 functions.
+
+=head1 USAGE
+
+The module is used indirectly through LWP, rather than including it directly in your 
+code.  The LWP system will invoke the NTLM authentication when it encounters the 
+authentication scheme while attempting to retrieve a URL from a server.  In order 
+for the NTLM authentication to work, you must have a few things set up in your 
+code prior to attempting to retrieve the URL:
+
+=over 4
+
+=item *
+
+Enable persistent HTTP connections
+
+To do this, pass the "keep_alive=>1" option to the LWP::UserAgent when creating it, like this:
+
+    my $ua = LWP::UserAgent->new(keep_alive=>1);
+
+=item *
+
+Set the credentials on the UserAgent object
+
+The credentials must be set like this:
+
+   $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
+
+Note that you cannot use the HTTP::Request object's authorization_basic() method to set 
+the credentials.  Note, too, that the 'www.company.com:80' portion only sets credentials 
+on the specified port AND it is case-sensitive (this is due to the way LWP is coded, and 
+has nothing to do with LWP::Authen::Ntlm)
+
+=back
+
+=head1 AVAILABILITY
+
+General queries regarding LWP should be made to the LWP Mailing List.
+
+Questions specific to LWP::Authen::Ntlm can be forwarded to jtillman@bigfoot.com
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002 James Tillman. All rights reserved. This
+program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<LWP>, L<LWP::UserAgent>, L<lwpcook>.
Index: /main/trunk/greenstone2/perllib/cpan/LWP/ConnCache.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/ConnCache.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/ConnCache.pm	(revision 27174)
@@ -0,0 +1,313 @@
+package LWP::ConnCache;
+
+use strict;
+use vars qw($VERSION $DEBUG);
+
+$VERSION = "6.02";
+
+
+sub new {
+    my($class, %cnf) = @_;
+
+    my $total_capacity = 1;
+    if (exists $cnf{total_capacity}) {
+        $total_capacity = delete $cnf{total_capacity};
+    }
+    if (%cnf && $^W) {
+	require Carp;
+	Carp::carp("Unrecognised options: @{[sort keys %cnf]}")
+    }
+    my $self = bless { cc_conns => [] }, $class;
+    $self->total_capacity($total_capacity);
+    $self;
+}
+
+
+sub deposit {
+    my($self, $type, $key, $conn) = @_;
+    push(@{$self->{cc_conns}}, [$conn, $type, $key, time]);
+    $self->enforce_limits($type);
+    return;
+}
+
+
+sub withdraw {
+    my($self, $type, $key) = @_;
+    my $conns = $self->{cc_conns};
+    for my $i (0 .. @$conns - 1) {
+	my $c = $conns->[$i];
+	next unless $c->[1] eq $type && $c->[2] eq $key;
+	splice(@$conns, $i, 1);  # remove it
+	return $c->[0];
+    }
+    return undef;
+}
+
+
+sub total_capacity {
+    my $self = shift;
+    my $old = $self->{cc_limit_total};
+    if (@_) {
+	$self->{cc_limit_total} = shift;
+	$self->enforce_limits;
+    }
+    $old;
+}
+
+
+sub capacity {
+    my $self = shift;
+    my $type = shift;
+    my $old = $self->{cc_limit}{$type};
+    if (@_) {
+	$self->{cc_limit}{$type} = shift;
+	$self->enforce_limits($type);
+    }
+    $old;
+}
+
+
+sub enforce_limits {
+    my($self, $type) = @_;
+    my $conns = $self->{cc_conns};
+
+    my @types = $type ? ($type) : ($self->get_types);
+    for $type (@types) {
+	next unless $self->{cc_limit};
+	my $limit = $self->{cc_limit}{$type};
+	next unless defined $limit;
+	for my $i (reverse 0 .. @$conns - 1) {
+	    next unless $conns->[$i][1] eq $type;
+	    if (--$limit < 0) {
+		$self->dropping(splice(@$conns, $i, 1), "$type capacity exceeded");
+	    }
+	}
+    }
+
+    if (defined(my $total = $self->{cc_limit_total})) {
+	while (@$conns > $total) {
+	    $self->dropping(shift(@$conns), "Total capacity exceeded");
+	}
+    }
+}
+
+
+sub dropping {
+    my($self, $c, $reason) = @_;
+    print "DROPPING @$c [$reason]\n" if $DEBUG;
+}
+
+
+sub drop {
+    my($self, $checker, $reason) = @_;
+    if (ref($checker) ne "CODE") {
+	# make it so
+	if (!defined $checker) {
+	    $checker = sub { 1 };  # drop all of them
+	}
+	elsif (_looks_like_number($checker)) {
+	    my $age_limit = $checker;
+	    my $time_limit = time - $age_limit;
+	    $reason ||= "older than $age_limit";
+	    $checker = sub { $_[3] < $time_limit };
+	}
+	else {
+	    my $type = $checker;
+	    $reason ||= "drop $type";
+	    $checker = sub { $_[1] eq $type };  # match on type
+	}
+    }
+    $reason ||= "drop";
+
+    local $SIG{__DIE__};  # don't interfere with eval below
+    local $@;
+    my @c;
+    for (@{$self->{cc_conns}}) {
+	my $drop;
+	eval {
+	    if (&$checker(@$_)) {
+		$self->dropping($_, $reason);
+		$drop++;
+	    }
+	};
+	push(@c, $_) unless $drop;
+    }
+    @{$self->{cc_conns}} = @c;
+}
+
+
+sub prune {
+    my $self = shift;
+    $self->drop(sub { !shift->ping }, "ping");
+}
+
+
+sub get_types {
+    my $self = shift;
+    my %t;
+    $t{$_->[1]}++ for @{$self->{cc_conns}};
+    return keys %t;
+}
+
+
+sub get_connections {
+    my($self, $type) = @_;
+    my @c;
+    for (@{$self->{cc_conns}}) {
+	push(@c, $_->[0]) if !$type || ($type && $type eq $_->[1]);
+    }
+    @c;
+}
+
+
+sub _looks_like_number {
+    $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+LWP::ConnCache - Connection cache manager
+
+=head1 NOTE
+
+This module is experimental.  Details of its interface is likely to
+change in the future.
+
+=head1 SYNOPSIS
+
+ use LWP::ConnCache;
+ my $cache = LWP::ConnCache->new;
+ $cache->deposit($type, $key, $sock);
+ $sock = $cache->withdraw($type, $key);
+
+=head1 DESCRIPTION
+
+The C<LWP::ConnCache> class is the standard connection cache manager
+for LWP::UserAgent.
+
+The following basic methods are provided:
+
+=over
+
+=item $cache = LWP::ConnCache->new( %options )
+
+This method constructs a new C<LWP::ConnCache> object.  The only
+option currently accepted is 'total_capacity'.  If specified it
+initialize the total_capacity option.  It defaults to the value 1.
+
+=item $cache->total_capacity( [$num_connections] )
+
+Get/sets the number of connection that will be cached.  Connections
+will start to be dropped when this limit is reached.  If set to C<0>,
+then all connections are immediately dropped.  If set to C<undef>,
+then there is no limit.
+
+=item $cache->capacity($type, [$num_connections] )
+
+Get/set a limit for the number of connections of the specified type
+that can be cached.  The $type will typically be a short string like
+"http" or "ftp".
+
+=item $cache->drop( [$checker, [$reason]] )
+
+Drop connections by some criteria.  The $checker argument is a
+subroutine that is called for each connection.  If the routine returns
+a TRUE value then the connection is dropped.  The routine is called
+with ($conn, $type, $key, $deposit_time) as arguments.
+
+Shortcuts: If the $checker argument is absent (or C<undef>) all cached
+connections are dropped.  If the $checker is a number then all
+connections untouched that the given number of seconds or more are
+dropped.  If $checker is a string then all connections of the given
+type are dropped.
+
+The $reason argument is passed on to the dropped() method.
+
+=item $cache->prune
+
+Calling this method will drop all connections that are dead.  This is
+tested by calling the ping() method on the connections.  If the ping()
+method exists and returns a FALSE value, then the connection is
+dropped.
+
+=item $cache->get_types
+
+This returns all the 'type' fields used for the currently cached
+connections.
+
+=item $cache->get_connections( [$type] )
+
+This returns all connection objects of the specified type.  If no type
+is specified then all connections are returned.  In scalar context the
+number of cached connections of the specified type is returned.
+
+=back
+
+
+The following methods are called by low-level protocol modules to
+try to save away connections and to get them back.
+
+=over
+
+=item $cache->deposit($type, $key, $conn)
+
+This method adds a new connection to the cache.  As a result other
+already cached connections might be dropped.  Multiple connections with
+the same $type/$key might added.
+
+=item $conn = $cache->withdraw($type, $key)
+
+This method tries to fetch back a connection that was previously
+deposited.  If no cached connection with the specified $type/$key is
+found, then C<undef> is returned.  There is not guarantee that a
+deposited connection can be withdrawn, as the cache manger is free to
+drop connections at any time.
+
+=back
+
+The following methods are called internally.  Subclasses might want to
+override them.
+
+=over
+
+=item $conn->enforce_limits([$type])
+
+This method is called with after a new connection is added (deposited)
+in the cache or capacity limits are adjusted.  The default
+implementation drops connections until the specified capacity limits
+are not exceeded.
+
+=item $conn->dropping($conn_record, $reason)
+
+This method is called when a connection is dropped.  The record
+belonging to the dropped connection is passed as the first argument
+and a string describing the reason for the drop is passed as the
+second argument.  The default implementation makes some noise if the
+$LWP::ConnCache::DEBUG variable is set and nothing more.
+
+=back
+
+=head1 SUBCLASSING
+
+For specialized cache policy it makes sense to subclass
+C<LWP::ConnCache> and perhaps override the deposit(), enforce_limits()
+and dropping() methods.
+
+The object itself is a hash.  Keys prefixed with C<cc_> are reserved
+for the base class.
+
+=head1 SEE ALSO
+
+L<LWP::UserAgent>
+
+=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.
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Debug.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Debug.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Debug.pm	(revision 27174)
@@ -0,0 +1,110 @@
+package LWP::Debug;  # legacy
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(level trace debug conns);
+
+use Carp ();
+
+my @levels = qw(trace debug conns);
+%current_level = ();
+
+
+sub import
+{
+    my $pack = shift;
+    my $callpkg = caller(0);
+    my @symbols = ();
+    my @levels = ();
+    for (@_) {
+	if (/^[-+]/) {
+	    push(@levels, $_);
+	}
+	else {
+	    push(@symbols, $_);
+	}
+    }
+    Exporter::export($pack, $callpkg, @symbols);
+    level(@levels);
+}
+
+
+sub level
+{
+    for (@_) {
+	if ($_ eq '+') {              # all on
+	    # switch on all levels
+	    %current_level = map { $_ => 1 } @levels;
+	}
+	elsif ($_ eq '-') {           # all off
+	    %current_level = ();
+	}
+	elsif (/^([-+])(\w+)$/) {
+	    $current_level{$2} = $1 eq '+';
+	}
+	else {
+	    Carp::croak("Illegal level format $_");
+	}
+    }
+}
+
+
+sub trace  { _log(@_) if $current_level{'trace'}; }
+sub debug  { _log(@_) if $current_level{'debug'}; }
+sub conns  { _log(@_) if $current_level{'conns'}; }
+
+
+sub _log
+{
+    my $msg = shift;
+    $msg .= "\n" unless $msg =~ /\n$/;  # ensure trailing "\n"
+
+    my($package,$filename,$line,$sub) = caller(2);
+    print STDERR "$sub: $msg";
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWP::Debug - deprecated
+
+=head1 DESCRIPTION
+
+LWP::Debug used to provide tracing facilities, but these are not used
+by LWP any more.  The code in this module is kept around
+(undocumented) so that 3rd party code that happen to use the old
+interfaces continue to run.
+
+One useful feature that LWP::Debug provided (in an imprecise and
+troublesome way) was network traffic monitoring.  The following
+section provide some hints about recommened replacements.
+
+=head2 Network traffic monitoring
+
+The best way to monitor the network traffic that LWP generates is to
+use an external TCP monitoring program.  The Wireshark program
+(L<http://www.wireshark.org/>) is higly recommended for this.
+
+Another approach it to use a debugging HTTP proxy server and make
+LWP direct all its traffic via this one.  Call C<< $ua->proxy >> to
+set it up and then just use LWP as before.
+
+For less precise monitoring needs just setting up a few simple
+handlers might do.  The following example sets up handlers to dump the
+request and response objects that pass through LWP:
+
+  use LWP::UserAgent;
+  $ua = LWP::UserAgent->new;
+  $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
+
+  $ua->add_handler("request_send",  sub { shift->dump; return });
+  $ua->add_handler("response_done", sub { shift->dump; return });
+
+  $ua->get("http://www.example.com");
+
+=head1 SEE ALSO
+
+L<LWP::UserAgent>
Index: /main/trunk/greenstone2/perllib/cpan/LWP/DebugFile.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/DebugFile.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/DebugFile.pm	(revision 27174)
@@ -0,0 +1,5 @@
+package LWP::DebugFile;
+
+# legacy stub
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/MemberMixin.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/MemberMixin.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/MemberMixin.pm	(revision 27174)
@@ -0,0 +1,44 @@
+package LWP::MemberMixin;
+
+sub _elem
+{
+    my $self = shift;
+    my $elem = shift;
+    my $old = $self->{$elem};
+    $self->{$elem} = shift if @_;
+    return $old;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWP::MemberMixin - Member access mixin class
+
+=head1 SYNOPSIS
+
+ package Foo;
+ require LWP::MemberMixin;
+ @ISA=qw(LWP::MemberMixin);
+
+=head1 DESCRIPTION
+
+A mixin class to get methods that provide easy access to member
+variables in the %$self.
+Ideally there should be better Perl language support for this.
+
+There is only one method provided:
+
+=over 4
+
+=item _elem($elem [, $val])
+
+Internal method to get/set the value of member variable
+C<$elem>. If C<$val> is present it is used as the new value
+for the member variable.  If it is not present the current
+value is not touched. In both cases the previous value of
+the member variable is returned.
+
+=back
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol.pm	(revision 27174)
@@ -0,0 +1,291 @@
+package LWP::Protocol;
+
+require LWP::MemberMixin;
+@ISA = qw(LWP::MemberMixin);
+$VERSION = "6.00";
+
+use strict;
+use Carp ();
+use HTTP::Status ();
+use HTTP::Response;
+
+my %ImplementedBy = (); # scheme => classname
+
+
+
+sub new
+{
+    my($class, $scheme, $ua) = @_;
+
+    my $self = bless {
+	scheme => $scheme,
+	ua => $ua,
+
+	# historical/redundant
+        max_size => $ua->{max_size},
+    }, $class;
+
+    $self;
+}
+
+
+sub create
+{
+    my($scheme, $ua) = @_;
+    my $impclass = LWP::Protocol::implementor($scheme) or
+	Carp::croak("Protocol scheme '$scheme' is not supported");
+
+    # hand-off to scheme specific implementation sub-class
+    my $protocol = $impclass->new($scheme, $ua);
+
+    return $protocol;
+}
+
+
+sub implementor
+{
+    my($scheme, $impclass) = @_;
+
+    if ($impclass) {
+	$ImplementedBy{$scheme} = $impclass;
+    }
+    my $ic = $ImplementedBy{$scheme};
+    return $ic if $ic;
+
+    return '' unless $scheme =~ /^([.+\-\w]+)$/;  # check valid URL schemes
+    $scheme = $1; # untaint
+    $scheme =~ s/[.+\-]/_/g;  # make it a legal module name
+
+    # scheme not yet known, look for a 'use'd implementation
+    $ic = "LWP::Protocol::$scheme";  # default location
+    $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
+    no strict 'refs';
+    # check we actually have one for the scheme:
+    unless (@{"${ic}::ISA"}) {
+	# try to autoload it
+	eval "require $ic";
+	if ($@) {
+	    if ($@ =~ /Can't locate/) { #' #emacs get confused by '
+		$ic = '';
+	    }
+	    else {
+		die "$@\n";
+	    }
+	}
+    }
+    $ImplementedBy{$scheme} = $ic if $ic;
+    $ic;
+}
+
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+    Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
+}
+
+
+# legacy
+sub timeout    { shift->_elem('timeout',    @_); }
+sub max_size   { shift->_elem('max_size',   @_); }
+
+
+sub collect
+{
+    my ($self, $arg, $response, $collector) = @_;
+    my $content;
+    my($ua, $max_size) = @{$self}{qw(ua max_size)};
+
+    eval {
+	local $\; # protect the print below from surprises
+        if (!defined($arg) || !$response->is_success) {
+            $response->{default_add_content} = 1;
+        }
+        elsif (!ref($arg) && length($arg)) {
+            open(my $fh, ">", $arg) or die "Can't write to '$arg': $!";
+	    binmode($fh);
+            push(@{$response->{handlers}{response_data}}, {
+                callback => sub {
+                    print $fh $_[3] or die "Can't write to '$arg': $!";
+                    1;
+                },
+            });
+            push(@{$response->{handlers}{response_done}}, {
+                callback => sub {
+		    close($fh) or die "Can't write to '$arg': $!";
+		    undef($fh);
+		},
+	    });
+        }
+        elsif (ref($arg) eq 'CODE') {
+            push(@{$response->{handlers}{response_data}}, {
+                callback => sub {
+		    &$arg($_[3], $_[0], $self);
+		    1;
+                },
+            });
+        }
+        else {
+            die "Unexpected collect argument '$arg'";
+        }
+
+        $ua->run_handlers("response_header", $response);
+
+        if (delete $response->{default_add_content}) {
+            push(@{$response->{handlers}{response_data}}, {
+		callback => sub {
+		    $_[0]->add_content($_[3]);
+		    1;
+		},
+	    });
+        }
+
+
+        my $content_size = 0;
+        my $length = $response->content_length;
+        my %skip_h;
+
+        while ($content = &$collector, length $$content) {
+            for my $h ($ua->handlers("response_data", $response)) {
+                next if $skip_h{$h};
+                unless ($h->{callback}->($response, $ua, $h, $$content)) {
+                    # XXX remove from $response->{handlers}{response_data} if present
+                    $skip_h{$h}++;
+                }
+            }
+            $content_size += length($$content);
+            $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
+            if (defined($max_size) && $content_size > $max_size) {
+                $response->push_header("Client-Aborted", "max_size");
+                last;
+            }
+        }
+    };
+    my $err = $@;
+    delete $response->{handlers}{response_data};
+    delete $response->{handlers} unless %{$response->{handlers}};
+    if ($err) {
+        chomp($err);
+        $response->push_header('X-Died' => $err);
+        $response->push_header("Client-Aborted", "die");
+        return $response;
+    }
+
+    return $response;
+}
+
+
+sub collect_once
+{
+    my($self, $arg, $response) = @_;
+    my $content = \ $_[3];
+    my $first = 1;
+    $self->collect($arg, $response, sub {
+	return $content if $first--;
+	return \ "";
+    });
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+LWP::Protocol - Base class for LWP protocols
+
+=head1 SYNOPSIS
+
+ package LWP::Protocol::foo;
+ require LWP::Protocol;
+ @ISA=qw(LWP::Protocol);
+
+=head1 DESCRIPTION
+
+This class is used a the base class for all protocol implementations
+supported by the LWP library.
+
+When creating an instance of this class using
+C<LWP::Protocol::create($url)>, and you get an initialised subclass
+appropriate for that access method. In other words, the
+LWP::Protocol::create() function calls the constructor for one of its
+subclasses.
+
+All derived LWP::Protocol classes need to override the request()
+method which is used to service a request. The overridden method can
+make use of the collect() function to collect together chunks of data
+as it is received.
+
+The following methods and functions are provided:
+
+=over 4
+
+=item $prot = LWP::Protocol->new()
+
+The LWP::Protocol constructor is inherited by subclasses. As this is a
+virtual base class this method should B<not> be called directly.
+
+=item $prot = LWP::Protocol::create($scheme)
+
+Create an object of the class implementing the protocol to handle the
+given scheme. This is a function, not a method. It is more an object
+factory than a constructor. This is the function user agents should
+use to access protocols.
+
+=item $class = LWP::Protocol::implementor($scheme, [$class])
+
+Get and/or set implementor class for a scheme.  Returns '' if the
+specified scheme is not supported.
+
+=item $prot->request(...)
+
+ $response = $protocol->request($request, $proxy, undef);
+ $response = $protocol->request($request, $proxy, '/tmp/sss');
+ $response = $protocol->request($request, $proxy, \&callback, 1024);
+
+Dispatches a request over the protocol, and returns a response
+object. This method needs to be overridden in subclasses.  Refer to
+L<LWP::UserAgent> for description of the arguments.
+
+=item $prot->collect($arg, $response, $collector)
+
+Called to collect the content of a request, and process it
+appropriately into a scalar, file, or by calling a callback.  If $arg
+is undefined, then the content is stored within the $response.  If
+$arg is a simple scalar, then $arg is interpreted as a file name and
+the content is written to this file.  If $arg is a reference to a
+routine, then content is passed to this routine.
+
+The $collector is a routine that will be called and which is
+responsible for returning pieces (as ref to scalar) of the content to
+process.  The $collector signals EOF by returning a reference to an
+empty sting.
+
+The return value from collect() is the $response object reference.
+
+B<Note:> We will only use the callback or file argument if
+$response->is_success().  This avoids sending content data for
+redirects and authentication responses to the callback which would be
+confusing.
+
+=item $prot->collect_once($arg, $response, $content)
+
+Can be called when the whole response content is available as
+$content.  This will invoke collect() with a collector callback that
+returns a reference to $content the first time and an empty string the
+next.
+
+=back
+
+=head1 SEE ALSO
+
+Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
+for examples of usage.
+
+=head1 COPYRIGHT
+
+Copyright 1995-2001 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/LWP/Protocol/GHTTP.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/GHTTP.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/GHTTP.pm	(revision 27174)
@@ -0,0 +1,73 @@
+package LWP::Protocol::GHTTP;
+
+# You can tell LWP to use this module for 'http' requests by running
+# code like this before you make requests:
+#
+#    require LWP::Protocol::GHTTP;
+#    LWP::Protocol::implementor('http', 'LWP::Protocol::GHTTP');
+#
+
+use strict;
+use vars qw(@ISA);
+
+require LWP::Protocol;
+@ISA=qw(LWP::Protocol);
+
+require HTTP::Response;
+require HTTP::Status;
+
+use HTTP::GHTTP qw(METHOD_GET METHOD_HEAD METHOD_POST);
+
+my %METHOD =
+(
+ GET  => METHOD_GET,
+ HEAD => METHOD_HEAD,
+ POST => METHOD_POST,
+);
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+    my $method = $request->method;
+    unless (exists $METHOD{$method}) {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   "Bad method '$method'");
+    }
+
+    my $r = HTTP::GHTTP->new($request->uri);
+
+    # XXX what headers for repeated headers here?
+    $request->headers->scan(sub { $r->set_header(@_)});
+
+    $r->set_type($METHOD{$method});
+
+    # XXX should also deal with subroutine content.
+    my $cref = $request->content_ref;
+    $r->set_body($$cref) if length($$cref);
+
+    # XXX is this right
+    $r->set_proxy($proxy->as_string) if $proxy;
+
+    $r->process_request;
+
+    my $response = HTTP::Response->new($r->get_status);
+
+    # XXX How can get the headers out of $r??  This way is too stupid.
+    my @headers;
+    eval {
+	# Wrapped in eval because this method is not always available
+	@headers = $r->get_headers;
+    };
+    @headers = qw(Date Connection Server Content-type
+                  Accept-Ranges Server
+                  Content-Length Last-Modified ETag) if $@;
+    for (@headers) {
+	my $v = $r->get_header($_);
+	$response->header($_ => $v) if defined $v;
+    }
+
+    return $self->collect_once($arg, $response, $r->get_body);
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/cpan.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/cpan.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/cpan.pm	(revision 27174)
@@ -0,0 +1,72 @@
+package LWP::Protocol::cpan;
+
+use strict;
+use vars qw(@ISA);
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+require URI;
+require HTTP::Status;
+require HTTP::Response;
+
+our $CPAN;
+
+unless ($CPAN) {
+    # Try to find local CPAN mirror via $CPAN::Config
+    eval {
+	require CPAN::Config;
+	if($CPAN::Config) {
+	    my $urls = $CPAN::Config->{urllist};
+	    if (ref($urls) eq "ARRAY") {
+		my $file;
+		for (@$urls) {
+		    if (/^file:/) {
+			$file = $_;
+			last;
+		    }
+		}
+
+		if ($file) {
+		    $CPAN = $file;
+		}
+		else {
+		    $CPAN = $urls->[0];
+		}
+	    }
+	}
+    };
+
+    $CPAN ||= "http://cpan.org/";  # last resort
+}
+
+# ensure that we don't chop of last part
+$CPAN .= "/" unless $CPAN =~ m,/$,;
+
+
+sub request {
+    my($self, $request, $proxy, $arg, $size) = @_;
+    # check proxy
+    if (defined $proxy)
+    {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'You can not proxy with cpan');
+    }
+
+    # check method
+    my $method = $request->method;
+    unless ($method eq 'GET' || $method eq 'HEAD') {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'Library does not allow method ' .
+				   "$method for 'cpan:' URLs");
+    }
+
+    my $path = $request->uri->path;
+    $path =~ s,^/,,;
+
+    my $response = HTTP::Response->new(&HTTP::Status::RC_FOUND);
+    $response->header("Location" => URI->new_abs($path, $CPAN));
+    $response;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/data.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/data.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/data.pm	(revision 27174)
@@ -0,0 +1,52 @@
+package LWP::Protocol::data;
+
+# Implements access to data:-URLs as specified in RFC 2397
+
+use strict;
+use vars qw(@ISA);
+
+require HTTP::Response;
+require HTTP::Status;
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+use HTTP::Date qw(time2str);
+require LWP;  # needs version number
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size) = @_;
+
+    # check proxy
+    if (defined $proxy)
+    {
+	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+				  'You can not proxy with data');
+    }
+
+    # check method
+    my $method = $request->method;
+    unless ($method eq 'GET' || $method eq 'HEAD') {
+	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+				  'Library does not allow method ' .
+				  "$method for 'data:' URLs");
+    }
+
+    my $url = $request->uri;
+    my $response = HTTP::Response->new( &HTTP::Status::RC_OK, "Document follows");
+
+    my $media_type = $url->media_type;
+
+    my $data = $url->data;
+    $response->header('Content-Type'   => $media_type,
+		      'Content-Length' => length($data),
+		      'Date'           => time2str(time),
+		      'Server'         => "libwww-perl-internal/$LWP::VERSION"
+		     );
+
+    $data = "" if $method eq "HEAD";
+    return $self->collect_once($arg, $response, $data);
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/file.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/file.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/file.pm	(revision 27174)
@@ -0,0 +1,146 @@
+package LWP::Protocol::file;
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+use strict;
+
+require LWP::MediaTypes;
+require HTTP::Request;
+require HTTP::Response;
+require HTTP::Status;
+require HTTP::Date;
+
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size) = @_;
+
+    $size = 4096 unless defined $size and $size > 0;
+
+    # check proxy
+    if (defined $proxy)
+    {
+	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+				  'You can not proxy through the filesystem');
+    }
+
+    # check method
+    my $method = $request->method;
+    unless ($method eq 'GET' || $method eq 'HEAD') {
+	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+				  'Library does not allow method ' .
+				  "$method for 'file:' URLs");
+    }
+
+    # check url
+    my $url = $request->uri;
+
+    my $scheme = $url->scheme;
+    if ($scheme ne 'file') {
+	return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+			   "LWP::Protocol::file::request called for '$scheme'");
+    }
+
+    # URL OK, look at file
+    my $path  = $url->file;
+
+    # test file exists and is readable
+    unless (-e $path) {
+	return HTTP::Response->new( &HTTP::Status::RC_NOT_FOUND,
+				  "File `$path' does not exist");
+    }
+    unless (-r _) {
+	return HTTP::Response->new( &HTTP::Status::RC_FORBIDDEN,
+				  'User does not have read permission');
+    }
+
+    # looks like file exists
+    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
+       $atime,$mtime,$ctime,$blksize,$blocks)
+	    = stat(_);
+
+    # XXX should check Accept headers?
+
+    # check if-modified-since
+    my $ims = $request->header('If-Modified-Since');
+    if (defined $ims) {
+	my $time = HTTP::Date::str2time($ims);
+	if (defined $time and $time >= $mtime) {
+	    return HTTP::Response->new( &HTTP::Status::RC_NOT_MODIFIED,
+				      "$method $path");
+	}
+    }
+
+    # Ok, should be an OK response by now...
+    my $response = HTTP::Response->new( &HTTP::Status::RC_OK );
+
+    # fill in response headers
+    $response->header('Last-Modified', HTTP::Date::time2str($mtime));
+
+    if (-d _) {         # If the path is a directory, process it
+	# generate the HTML for directory
+	opendir(D, $path) or
+	   return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+				     "Cannot read directory '$path': $!");
+	my(@files) = sort readdir(D);
+	closedir(D);
+
+	# Make directory listing
+	require URI::Escape;
+	require HTML::Entities;
+        my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
+	for (@files) {
+	    my $furl = URI::Escape::uri_escape($_);
+            if ( -d "$pathe$_" ) {
+                $furl .= '/';
+                $_ .= '/';
+            }
+	    my $desc = HTML::Entities::encode($_);
+	    $_ = qq{<LI><A HREF="$furl">$desc</A>};
+	}
+	# Ensure that the base URL is "/" terminated
+	my $base = $url->clone;
+	unless ($base->path =~ m|/$|) {
+	    $base->path($base->path . "/");
+	}
+	my $html = join("\n",
+			"<HTML>\n<HEAD>",
+			"<TITLE>Directory $path</TITLE>",
+			"<BASE HREF=\"$base\">",
+			"</HEAD>\n<BODY>",
+			"<H1>Directory listing of $path</H1>",
+			"<UL>", @files, "</UL>",
+			"</BODY>\n</HTML>\n");
+
+	$response->header('Content-Type',   'text/html');
+	$response->header('Content-Length', length $html);
+	$html = "" if $method eq "HEAD";
+
+	return $self->collect_once($arg, $response, $html);
+
+    }
+
+    # path is a regular file
+    $response->header('Content-Length', $filesize);
+    LWP::MediaTypes::guess_media_type($path, $response);
+
+    # read the file
+    if ($method ne "HEAD") {
+	open(F, $path) or return new
+	    HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+			   "Cannot read file '$path': $!");
+	binmode(F);
+	$response =  $self->collect($arg, $response, sub {
+	    my $content = "";
+	    my $bytes = sysread(F, $content, $size);
+	    return \$content if $bytes > 0;
+	    return \ "";
+	});
+	close(F);
+    }
+
+    $response;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/ftp.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/ftp.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/ftp.pm	(revision 27174)
@@ -0,0 +1,543 @@
+package LWP::Protocol::ftp;
+
+# Implementation of the ftp protocol (RFC 959). We let the Net::FTP
+# package do all the dirty work.
+
+use Carp ();
+
+use HTTP::Status ();
+use HTTP::Negotiate ();
+use HTTP::Response ();
+use LWP::MediaTypes ();
+use File::Listing ();
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+use strict;
+eval {
+    package LWP::Protocol::MyFTP;
+
+    require Net::FTP;
+    Net::FTP->require_version(2.00);
+
+    use vars qw(@ISA);
+    @ISA=qw(Net::FTP);
+
+    sub new {
+	my $class = shift;
+
+	my $self = $class->SUPER::new(@_) || return undef;
+
+	my $mess = $self->message;  # welcome message
+	$mess =~ s|\n.*||s; # only first line left
+	$mess =~ s|\s*ready\.?$||;
+	# Make the version number more HTTP like
+	$mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||;
+	${*$self}{myftp_server} = $mess;
+	#$response->header("Server", $mess);
+
+	$self;
+    }
+
+    sub http_server {
+	my $self = shift;
+	${*$self}{myftp_server};
+    }
+
+    sub home {
+	my $self = shift;
+	my $old = ${*$self}{myftp_home};
+	if (@_) {
+	    ${*$self}{myftp_home} = shift;
+	}
+	$old;
+    }
+
+    sub go_home {
+	my $self = shift;
+	$self->cwd(${*$self}{myftp_home});
+    }
+
+    sub request_count {
+	my $self = shift;
+	++${*$self}{myftp_reqcount};
+    }
+
+    sub ping {
+	my $self = shift;
+	return $self->go_home;
+    }
+
+};
+my $init_failed = $@;
+
+
+sub _connect {
+    my($self, $host, $port, $user, $account, $password, $timeout) = @_;
+
+    my $key;
+    my $conn_cache = $self->{ua}{conn_cache};
+    if ($conn_cache) {
+	$key = "$host:$port:$user";
+	$key .= ":$account" if defined($account);
+	if (my $ftp = $conn_cache->withdraw("ftp", $key)) {
+	    if ($ftp->ping) {
+		# save it again
+		$conn_cache->deposit("ftp", $key, $ftp);
+		return $ftp;
+	    }
+	}
+    }
+
+    # try to make a connection
+    my $ftp = LWP::Protocol::MyFTP->new($host,
+					Port => $port,
+					Timeout => $timeout,
+					LocalAddr => $self->{ua}{local_address},
+				       );
+    # XXX Should be some what to pass on 'Passive' (header??)
+    unless ($ftp) {
+	$@ =~ s/^Net::FTP: //;
+	return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@);
+    }
+
+    unless ($ftp->login($user, $password, $account)) {
+	# Unauthorized.  Let's fake a RC_UNAUTHORIZED response
+	my $mess = scalar($ftp->message);
+	$mess =~ s/\n$//;
+	my $res =  HTTP::Response->new(&HTTP::Status::RC_UNAUTHORIZED, $mess);
+	$res->header("Server", $ftp->http_server);
+	$res->header("WWW-Authenticate", qq(Basic Realm="FTP login"));
+	return $res;
+    }
+
+    my $home = $ftp->pwd;
+    $ftp->home($home);
+
+    $conn_cache->deposit("ftp", $key, $ftp) if $conn_cache;
+
+    return $ftp;
+}
+
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+    $size = 4096 unless $size;
+
+    # check proxy
+    if (defined $proxy)
+    {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'You can not proxy through the ftp');
+    }
+
+    my $url = $request->uri;
+    if ($url->scheme ne 'ftp') {
+	my $scheme = $url->scheme;
+	return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+		       "LWP::Protocol::ftp::request called for '$scheme'");
+    }
+
+    # check method
+    my $method = $request->method;
+
+    unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'Library does not allow method ' .
+				   "$method for 'ftp:' URLs");
+    }
+
+    if ($init_failed) {
+	return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+				   $init_failed);
+    }
+
+    my $host     = $url->host;
+    my $port     = $url->port;
+    my $user     = $url->user;
+    my $password = $url->password;
+
+    # If a basic autorization header is present than we prefer these over
+    # the username/password specified in the URL.
+    {
+	my($u,$p) = $request->authorization_basic;
+	if (defined $u) {
+	    $user = $u;
+	    $password = $p;
+	}
+    }
+
+    # We allow the account to be specified in the "Account" header
+    my $account = $request->header('Account');
+
+    my $ftp = $self->_connect($host, $port, $user, $account, $password, $timeout);
+    return $ftp if ref($ftp) eq "HTTP::Response"; # ugh!
+
+    # Create an initial response object
+    my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+    $response->header(Server => $ftp->http_server);
+    $response->header('Client-Request-Num' => $ftp->request_count);
+    $response->request($request);
+
+    # Get & fix the path
+    my @path =  grep { length } $url->path_segments;
+    my $remote_file = pop(@path);
+    $remote_file = '' unless defined $remote_file;
+
+    my $type;
+    if (ref $remote_file) {
+	my @params;
+	($remote_file, @params) = @$remote_file;
+	for (@params) {
+	    $type = $_ if s/^type=//;
+	}
+    }
+
+    if ($type && $type eq 'a') {
+	$ftp->ascii;
+    }
+    else {
+	$ftp->binary;
+    }
+
+    for (@path) {
+	unless ($ftp->cwd($_)) {
+	    return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
+				       "Can't chdir to $_");
+	}
+    }
+
+    if ($method eq 'GET' || $method eq 'HEAD') {
+	if (my $mod_time = $ftp->mdtm($remote_file)) {
+	    $response->last_modified($mod_time);
+	    if (my $ims = $request->if_modified_since) {
+		if ($mod_time <= $ims) {
+		    $response->code(&HTTP::Status::RC_NOT_MODIFIED);
+		    $response->message("Not modified");
+		    return $response;
+		}
+	    }
+	}
+
+	# We'll use this later to abort the transfer if necessary. 
+	# if $max_size is defined, we need to abort early. Otherwise, it's
+      # a normal transfer
+	my $max_size = undef;
+
+	# Set resume location, if the client requested it
+	if ($request->header('Range') && $ftp->supported('REST'))
+	{
+		my $range_info = $request->header('Range');
+
+		# Change bytes=2772992-6781209 to just 2772992
+		my ($start_byte,$end_byte) = $range_info =~ /.*=\s*(\d+)-(\d+)?/;
+		if ( defined $start_byte && !defined $end_byte ) {
+
+		  # open range -- only the start is specified
+
+		  $ftp->restart( $start_byte );
+		  # don't define $max_size, we don't want to abort early
+		}
+		elsif ( defined $start_byte && defined $end_byte &&
+			$start_byte >= 0 && $end_byte >= $start_byte ) {
+
+		  $ftp->restart( $start_byte );
+		  $max_size = $end_byte - $start_byte;
+		}
+		else {
+
+		  return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+		     'Incorrect syntax for Range request');
+		}
+	}
+	elsif ($request->header('Range') && !$ftp->supported('REST'))
+	{
+		return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
+	         "Server does not support resume.");
+	}
+
+	my $data;  # the data handle
+	if (length($remote_file) and $data = $ftp->retr($remote_file)) {
+	    my($type, @enc) = LWP::MediaTypes::guess_media_type($remote_file);
+	    $response->header('Content-Type',   $type) if $type;
+	    for (@enc) {
+		$response->push_header('Content-Encoding', $_);
+	    }
+	    my $mess = $ftp->message;
+	    if ($mess =~ /\((\d+)\s+bytes\)/) {
+		$response->header('Content-Length', "$1");
+	    }
+
+	    if ($method ne 'HEAD') {
+		# Read data from server
+		$response = $self->collect($arg, $response, sub {
+		    my $content = '';
+		    my $result = $data->read($content, $size);
+
+                    # Stop early if we need to.
+                    if (defined $max_size)
+                    {
+                      # We need an interface to Net::FTP::dataconn for getting
+                      # the number of bytes already read
+                      my $bytes_received = $data->bytes_read();
+
+                      # We were already over the limit. (Should only happen
+                      # once at the end.)
+                      if ($bytes_received - length($content) > $max_size)
+                      {
+                        $content = '';
+                      }
+                      # We just went over the limit
+                      elsif ($bytes_received  > $max_size)
+                      {
+                        # Trim content
+                        $content = substr($content, 0,
+                          $max_size - ($bytes_received - length($content)) );
+                      }
+                      # We're under the limit
+                      else
+                      {
+                      }
+                    }
+
+		    return \$content;
+		} );
+	    }
+	    # abort is needed for HEAD, it's == close if the transfer has
+	    # already completed.
+	    unless ($data->abort) {
+		# Something did not work too well.  Note that we treat
+		# responses to abort() with code 0 in case of HEAD as ok
+		# (at least wu-ftpd 2.6.1(1) does that).
+		if ($method ne 'HEAD' || $ftp->code != 0) {
+		    $response->code(&HTTP::Status::RC_INTERNAL_SERVER_ERROR);
+		    $response->message("FTP close response: " . $ftp->code .
+				       " " . $ftp->message);
+		}
+	    }
+	}
+	elsif (!length($remote_file) || ( $ftp->code >= 400 && $ftp->code < 600 )) {
+	    # not a plain file, try to list instead
+	    if (length($remote_file) && !$ftp->cwd($remote_file)) {
+		return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
+					   "File '$remote_file' not found");
+	    }
+
+	    # It should now be safe to try to list the directory
+	    my @lsl = $ftp->dir;
+
+	    # Try to figure out if the user want us to convert the
+	    # directory listing to HTML.
+	    my @variants =
+	      (
+	       ['html',  0.60, 'text/html'            ],
+	       ['dir',   1.00, 'text/ftp-dir-listing' ]
+	      );
+	    #$HTTP::Negotiate::DEBUG=1;
+	    my $prefer = HTTP::Negotiate::choose(\@variants, $request);
+
+	    my $content = '';
+
+	    if (!defined($prefer)) {
+		return HTTP::Response->new(&HTTP::Status::RC_NOT_ACCEPTABLE,
+			       "Neither HTML nor directory listing wanted");
+	    }
+	    elsif ($prefer eq 'html') {
+		$response->header('Content-Type' => 'text/html');
+		$content = "<HEAD><TITLE>File Listing</TITLE>\n";
+		my $base = $request->uri->clone;
+		my $path = $base->path;
+		$base->path("$path/") unless $path =~ m|/$|;
+		$content .= qq(<BASE HREF="$base">\n</HEAD>\n);
+		$content .= "<BODY>\n<UL>\n";
+		for (File::Listing::parse_dir(\@lsl, 'GMT')) {
+		    my($name, $type, $size, $mtime, $mode) = @$_;
+		    $content .= qq(  <LI> <a href="$name">$name</a>);
+		    $content .= " $size bytes" if $type eq 'f';
+		    $content .= "\n";
+		}
+		$content .= "</UL></body>\n";
+	    }
+	    else {
+		$response->header('Content-Type', 'text/ftp-dir-listing');
+		$content = join("\n", @lsl, '');
+	    }
+
+	    $response->header('Content-Length', length($content));
+
+	    if ($method ne 'HEAD') {
+		$response = $self->collect_once($arg, $response, $content);
+	    }
+	}
+	else {
+	    my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+			  "FTP return code " . $ftp->code);
+	    $res->content_type("text/plain");
+	    $res->content($ftp->message);
+	    return $res;
+	}
+    }
+    elsif ($method eq 'PUT') {
+	# method must be PUT
+	unless (length($remote_file)) {
+	    return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				       "Must have a file name to PUT to");
+	}
+	my $data;
+	if ($data = $ftp->stor($remote_file)) {
+	    my $content = $request->content;
+	    my $bytes = 0;
+	    if (defined $content) {
+		if (ref($content) eq 'SCALAR') {
+		    $bytes = $data->write($$content, length($$content));
+		}
+		elsif (ref($content) eq 'CODE') {
+		    my($buf, $n);
+		    while (length($buf = &$content)) {
+			$n = $data->write($buf, length($buf));
+			last unless $n;
+			$bytes += $n;
+		    }
+		}
+		elsif (!ref($content)) {
+		    if (defined $content && length($content)) {
+			$bytes = $data->write($content, length($content));
+		    }
+		}
+		else {
+		    die "Bad content";
+		}
+	    }
+	    $data->close;
+
+	    $response->code(&HTTP::Status::RC_CREATED);
+	    $response->header('Content-Type', 'text/plain');
+	    $response->content("$bytes bytes stored as $remote_file on $host\n")
+
+	}
+	else {
+	    my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+					  "FTP return code " . $ftp->code);
+	    $res->content_type("text/plain");
+	    $res->content($ftp->message);
+	    return $res;
+	}
+    }
+    else {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   "Illegal method $method");
+    }
+
+    $response;
+}
+
+1;
+
+__END__
+
+# This is what RFC 1738 has to say about FTP access:
+# --------------------------------------------------
+#
+# 3.2. FTP
+#
+#    The FTP URL scheme is used to designate files and directories on
+#    Internet hosts accessible using the FTP protocol (RFC959).
+#
+#    A FTP URL follow the syntax described in Section 3.1.  If :<port> is
+#    omitted, the port defaults to 21.
+#
+# 3.2.1. FTP Name and Password
+#
+#    A user name and password may be supplied; they are used in the ftp
+#    "USER" and "PASS" commands after first making the connection to the
+#    FTP server.  If no user name or password is supplied and one is
+#    requested by the FTP server, the conventions for "anonymous" FTP are
+#    to be used, as follows:
+#
+#         The user name "anonymous" is supplied.
+#
+#         The password is supplied as the Internet e-mail address
+#         of the end user accessing the resource.
+#
+#    If the URL supplies a user name but no password, and the remote
+#    server requests a password, the program interpreting the FTP URL
+#    should request one from the user.
+#
+# 3.2.2. FTP url-path
+#
+#    The url-path of a FTP URL has the following syntax:
+#
+#         <cwd1>/<cwd2>/.../<cwdN>/<name>;type=<typecode>
+#
+#    Where <cwd1> through <cwdN> and <name> are (possibly encoded) strings
+#    and <typecode> is one of the characters "a", "i", or "d".  The part
+#    ";type=<typecode>" may be omitted. The <cwdx> and <name> parts may be
+#    empty. The whole url-path may be omitted, including the "/"
+#    delimiting it from the prefix containing user, password, host, and
+#    port.
+#
+#    The url-path is interpreted as a series of FTP commands as follows:
+#
+#       Each of the <cwd> elements is to be supplied, sequentially, as the
+#       argument to a CWD (change working directory) command.
+#
+#       If the typecode is "d", perform a NLST (name list) command with
+#       <name> as the argument, and interpret the results as a file
+#       directory listing.
+#
+#       Otherwise, perform a TYPE command with <typecode> as the argument,
+#       and then access the file whose name is <name> (for example, using
+#       the RETR command.)
+#
+#    Within a name or CWD component, the characters "/" and ";" are
+#    reserved and must be encoded. The components are decoded prior to
+#    their use in the FTP protocol.  In particular, if the appropriate FTP
+#    sequence to access a particular file requires supplying a string
+#    containing a "/" as an argument to a CWD or RETR command, it is
+#    necessary to encode each "/".
+#
+#    For example, the URL <URL:ftp://myname@host.dom/%2Fetc/motd> is
+#    interpreted by FTP-ing to "host.dom", logging in as "myname"
+#    (prompting for a password if it is asked for), and then executing
+#    "CWD /etc" and then "RETR motd". This has a different meaning from
+#    <URL:ftp://myname@host.dom/etc/motd> which would "CWD etc" and then
+#    "RETR motd"; the initial "CWD" might be executed relative to the
+#    default directory for "myname". On the other hand,
+#    <URL:ftp://myname@host.dom//etc/motd>, would "CWD " with a null
+#    argument, then "CWD etc", and then "RETR motd".
+#
+#    FTP URLs may also be used for other operations; for example, it is
+#    possible to update a file on a remote file server, or infer
+#    information about it from the directory listings. The mechanism for
+#    doing so is not spelled out here.
+#
+# 3.2.3. FTP Typecode is Optional
+#
+#    The entire ;type=<typecode> part of a FTP URL is optional. If it is
+#    omitted, the client program interpreting the URL must guess the
+#    appropriate mode to use. In general, the data content type of a file
+#    can only be guessed from the name, e.g., from the suffix of the name;
+#    the appropriate type code to be used for transfer of the file can
+#    then be deduced from the data content of the file.
+#
+# 3.2.4 Hierarchy
+#
+#    For some file systems, the "/" used to denote the hierarchical
+#    structure of the URL corresponds to the delimiter used to construct a
+#    file name hierarchy, and thus, the filename will look similar to the
+#    URL path. This does NOT mean that the URL is a Unix filename.
+#
+# 3.2.5. Optimization
+#
+#    Clients accessing resources via FTP may employ additional heuristics
+#    to optimize the interaction. For some FTP servers, for example, it
+#    may be reasonable to keep the control connection open while accessing
+#    multiple URLs from the same server. However, there is no common
+#    hierarchical model to the FTP protocol, so if a directory change
+#    command has been given, it is impossible in general to deduce what
+#    sequence should be given to navigate to another directory for a
+#    second retrieval, if the paths are different.  The only reliable
+#    algorithm is to disconnect and reestablish the control connection.
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/gopher.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/gopher.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/gopher.pm	(revision 27174)
@@ -0,0 +1,213 @@
+package LWP::Protocol::gopher;
+
+# Implementation of the gopher protocol (RFC 1436)
+#
+# This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden'
+# which in turn is a vastly modified version of Oscar's http'get()
+# dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
+# including contributions from Marc van Heyningen and Martijn Koster.
+
+use strict;
+use vars qw(@ISA);
+
+require HTTP::Response;
+require HTTP::Status;
+require IO::Socket;
+require IO::Select;
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+
+my %gopher2mimetype = (
+    '0' => 'text/plain',                # 0 file
+    '1' => 'text/html',                 # 1 menu
+					# 2 CSO phone-book server
+					# 3 Error
+    '4' => 'application/mac-binhex40',  # 4 BinHexed Macintosh file
+    '5' => 'application/zip',           # 5 DOS binary archive of some sort
+    '6' => 'application/octet-stream',  # 6 UNIX uuencoded file.
+    '7' => 'text/html',                 # 7 Index-Search server
+					# 8 telnet session
+    '9' => 'application/octet-stream',  # 9 binary file
+    'h' => 'text/html',                 # html
+    'g' => 'image/gif',                 # gif
+    'I' => 'image/*',                   # some kind of image
+);
+
+my %gopher2encoding = (
+    '6' => 'x_uuencode',                # 6 UNIX uuencoded file.
+);
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+    $size = 4096 unless $size;
+
+    # check proxy
+    if (defined $proxy) {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'You can not proxy through the gopher');
+    }
+
+    my $url = $request->uri;
+    die "bad scheme" if $url->scheme ne 'gopher';
+
+
+    my $method = $request->method;
+    unless ($method eq 'GET' || $method eq 'HEAD') {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'Library does not allow method ' .
+				   "$method for 'gopher:' URLs");
+    }
+
+    my $gophertype = $url->gopher_type;
+    unless (exists $gopher2mimetype{$gophertype}) {
+	return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
+				   'Library does not support gophertype ' .
+				   $gophertype);
+    }
+
+    my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+    $response->header('Content-type' => $gopher2mimetype{$gophertype}
+					|| 'text/plain');
+    $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
+	if exists $gopher2encoding{$gophertype};
+
+    if ($method eq 'HEAD') {
+	# XXX: don't even try it so we set this header
+	$response->header('Client-Warning' => 'Client answer only');
+	return $response;
+    }
+    
+    if ($gophertype eq '7' && ! $url->search) {
+      # the url is the prompt for a gopher search; supply boiler-plate
+      return $self->collect_once($arg, $response, <<"EOT");
+<HEAD>
+<TITLE>Gopher Index</TITLE>
+<ISINDEX>
+</HEAD>
+<BODY>
+<H1>$url<BR>Gopher Search</H1>
+This is a searchable Gopher index.
+Use the search function of your browser to enter search terms.
+</BODY>
+EOT
+    }
+
+    my $host = $url->host;
+    my $port = $url->port;
+
+    my $requestLine = "";
+
+    my $selector = $url->selector;
+    if (defined $selector) {
+	$requestLine .= $selector;
+	my $search = $url->search;
+	if (defined $search) {
+	    $requestLine .= "\t$search";
+	    my $string = $url->string;
+	    if (defined $string) {
+		$requestLine .= "\t$string";
+	    }
+	}
+    }
+    $requestLine .= "\015\012";
+
+    # potential request headers are just ignored
+
+    # Ok, lets make the request
+    my $socket = IO::Socket::INET->new(PeerAddr => $host,
+				       PeerPort => $port,
+				       LocalAddr => $self->{ua}{local_address},
+				       Proto    => 'tcp',
+				       Timeout  => $timeout);
+    die "Can't connect to $host:$port" unless $socket;
+    my $sel = IO::Select->new($socket);
+
+    {
+	die "write timeout" if $timeout && !$sel->can_write($timeout);
+	my $n = syswrite($socket, $requestLine, length($requestLine));
+	die $! unless defined($n);
+	die "short write" if $n != length($requestLine);
+    }
+
+    my $user_arg = $arg;
+
+    # must handle menus in a special way since they are to be
+    # converted to HTML.  Undefing $arg ensures that the user does
+    # not see the data before we get a change to convert it.
+    $arg = undef if $gophertype eq '1' || $gophertype eq '7';
+
+    # collect response
+    my $buf = '';
+    $response = $self->collect($arg, $response, sub {
+	die "read timeout" if $timeout && !$sel->can_read($timeout);
+        my $n = sysread($socket, $buf, $size);
+	die $! unless defined($n);
+	return \$buf;
+      } );
+
+    # Convert menu to HTML and return data to user.
+    if ($gophertype eq '1' || $gophertype eq '7') {
+	my $content = menu2html($response->content);
+	if (defined $user_arg) {
+	    $response = $self->collect_once($user_arg, $response, $content);
+	}
+	else {
+	    $response->content($content);
+	}
+    }
+
+    $response;
+}
+
+
+sub gopher2url
+{
+    my($gophertype, $path, $host, $port) = @_;
+
+    my $url;
+
+    if ($gophertype eq '8' || $gophertype eq 'T') {
+	# telnet session
+	$url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
+	$url->user($path) if defined $path;
+    }
+    else {
+	$path = URI::Escape::uri_escape($path);
+	$url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
+    }
+    $url->host($host);
+    $url->port($port);
+    $url;
+}
+
+sub menu2html {
+    my($menu) = @_;
+
+    $menu =~ s/\015//g;  # remove carriage return
+    my $tmp = <<"EOT";
+<HTML>
+<HEAD>
+   <TITLE>Gopher menu</TITLE>
+</HEAD>
+<BODY>
+<H1>Gopher menu</H1>
+EOT
+    for (split("\n", $menu)) {
+	last if /^\./;
+	my($pretty, $path, $host, $port) = split("\t");
+
+	$pretty =~ s/^(.)//;
+	my $type = $1;
+
+	my $url = gopher2url($type, $path, $host, $port)->as_string;
+	$tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
+    }
+    $tmp .= "</BODY>\n</HTML>\n";
+    $tmp;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/http.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/http.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/http.pm	(revision 27174)
@@ -0,0 +1,464 @@
+package LWP::Protocol::http;
+
+use strict;
+
+require HTTP::Response;
+require HTTP::Status;
+require Net::HTTP;
+
+use vars qw(@ISA @EXTRA_SOCK_OPTS);
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+my $CRLF = "\015\012";
+
+sub _new_socket
+{
+    my($self, $host, $port, $timeout) = @_;
+    my $conn_cache = $self->{ua}{conn_cache};
+    if ($conn_cache) {
+	if (my $sock = $conn_cache->withdraw($self->socket_type, "$host:$port")) {
+	    return $sock if $sock && !$sock->can_read(0);
+	    # if the socket is readable, then either the peer has closed the
+	    # connection or there are some garbage bytes on it.  In either
+	    # case we abandon it.
+	    $sock->close;
+	}
+    }
+
+    local($^W) = 0;  # IO::Socket::INET can be noisy
+    my $sock = $self->socket_class->new(PeerAddr => $host,
+					PeerPort => $port,
+					LocalAddr => $self->{ua}{local_address},
+					Proto    => 'tcp',
+					Timeout  => $timeout,
+					KeepAlive => !!$conn_cache,
+					SendTE    => 1,
+					$self->_extra_sock_opts($host, $port),
+				       );
+
+    unless ($sock) {
+	# IO::Socket::INET leaves additional error messages in $@
+	my $status = "Can't connect to $host:$port";
+	if ($@ =~ /\bconnect: (.*)/ ||
+	    $@ =~ /\b(Bad hostname)\b/ ||
+	    $@ =~ /\b(certificate verify failed)\b/ ||
+	    $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
+	) {
+	    $status .= " ($1)";
+	}
+	die "$status\n\n$@";
+    }
+
+    # perl 5.005's IO::Socket does not have the blocking method.
+    eval { $sock->blocking(0); };
+
+    $sock;
+}
+
+sub socket_type
+{
+    return "http";
+}
+
+sub socket_class
+{
+    my $self = shift;
+    (ref($self) || $self) . "::Socket";
+}
+
+sub _extra_sock_opts  # to be overridden by subclass
+{
+    return @EXTRA_SOCK_OPTS;
+}
+
+sub _check_sock
+{
+    #my($self, $req, $sock) = @_;
+}
+
+sub _get_sock_info
+{
+    my($self, $res, $sock) = @_;
+    if (defined(my $peerhost = $sock->peerhost)) {
+        $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
+    }
+}
+
+sub _fixup_header
+{
+    my($self, $h, $url, $proxy) = @_;
+
+    # Extract 'Host' header
+    my $hhost = $url->authority;
+    if ($hhost =~ s/^([^\@]*)\@//) {  # get rid of potential "user:pass@"
+	# add authorization header if we need them.  HTTP URLs do
+	# not really support specification of user and password, but
+	# we allow it.
+	if (defined($1) && not $h->header('Authorization')) {
+	    require URI::Escape;
+	    $h->authorization_basic(map URI::Escape::uri_unescape($_),
+				    split(":", $1, 2));
+	}
+    }
+    $h->init_header('Host' => $hhost);
+
+    if ($proxy) {
+	# Check the proxy URI's userinfo() for proxy credentials
+	# export http_proxy="http://proxyuser:proxypass@proxyhost:port"
+	my $p_auth = $proxy->userinfo();
+	if(defined $p_auth) {
+	    require URI::Escape;
+	    $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
+					  split(":", $p_auth, 2))
+	}
+    }
+}
+
+sub hlist_remove {
+    my($hlist, $k) = @_;
+    $k = lc $k;
+    for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
+	next unless lc($hlist->[$i]) eq $k;
+	splice(@$hlist, $i, 2);
+    }
+}
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+    $size ||= 4096;
+
+    # check method
+    my $method = $request->method;
+    unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
+	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+				  'Library does not allow method ' .
+				  "$method for 'http:' URLs");
+    }
+
+    my $url = $request->uri;
+    my($host, $port, $fullpath);
+
+    # Check if we're proxy'ing
+    if (defined $proxy) {
+	# $proxy is an URL to an HTTP server which will proxy this request
+	$host = $proxy->host;
+	$port = $proxy->port;
+	$fullpath = $method eq "CONNECT" ?
+                       ($url->host . ":" . $url->port) :
+                       $url->as_string;
+    }
+    else {
+	$host = $url->host;
+	$port = $url->port;
+	$fullpath = $url->path_query;
+	$fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
+    }
+
+    # connect to remote site
+    my $socket = $self->_new_socket($host, $port, $timeout);
+
+    my $http_version = "";
+    if (my $proto = $request->protocol) {
+	if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) {
+	    $http_version = $1;
+	    $socket->http_version($http_version);
+	    $socket->send_te(0) if $http_version eq "1.0";
+	}
+    }
+
+    $self->_check_sock($request, $socket);
+
+    my @h;
+    my $request_headers = $request->headers->clone;
+    $self->_fixup_header($request_headers, $url, $proxy);
+
+    $request_headers->scan(sub {
+			       my($k, $v) = @_;
+			       $k =~ s/^://;
+			       $v =~ s/\n/ /g;
+			       push(@h, $k, $v);
+			   });
+
+    my $content_ref = $request->content_ref;
+    $content_ref = $$content_ref if ref($$content_ref);
+    my $chunked;
+    my $has_content;
+
+    if (ref($content_ref) eq 'CODE') {
+	my $clen = $request_headers->header('Content-Length');
+	$has_content++ if $clen;
+	unless (defined $clen) {
+	    push(@h, "Transfer-Encoding" => "chunked");
+	    $has_content++;
+	    $chunked++;
+	}
+    }
+    else {
+	# Set (or override) Content-Length header
+	my $clen = $request_headers->header('Content-Length');
+	if (defined($$content_ref) && length($$content_ref)) {
+	    $has_content = length($$content_ref);
+	    if (!defined($clen) || $clen ne $has_content) {
+		if (defined $clen) {
+		    warn "Content-Length header value was wrong, fixed";
+		    hlist_remove(\@h, 'Content-Length');
+		}
+		push(@h, 'Content-Length' => $has_content);
+	    }
+	}
+	elsif ($clen) {
+	    warn "Content-Length set when there is no content, fixed";
+	    hlist_remove(\@h, 'Content-Length');
+	}
+    }
+
+    my $write_wait = 0;
+    $write_wait = 2
+	if ($request_headers->header("Expect") || "") =~ /100-continue/;
+
+    my $req_buf = $socket->format_request($method, $fullpath, @h);
+    #print "------\n$req_buf\n------\n";
+
+    if (!$has_content || $write_wait || $has_content > 8*1024) {
+      WRITE:
+        {
+            # Since this just writes out the header block it should almost
+            # always succeed to send the whole buffer in a single write call.
+            my $n = $socket->syswrite($req_buf, length($req_buf));
+            unless (defined $n) {
+                redo WRITE if $!{EINTR};
+                if ($!{EAGAIN}) {
+                    select(undef, undef, undef, 0.1);
+                    redo WRITE;
+                }
+                die "write failed: $!";
+            }
+            if ($n) {
+                substr($req_buf, 0, $n, "");
+            }
+            else {
+                select(undef, undef, undef, 0.5);
+            }
+            redo WRITE if length $req_buf;
+        }
+    }
+
+    my($code, $mess, @junk);
+    my $drop_connection;
+
+    if ($has_content) {
+	my $eof;
+	my $wbuf;
+	my $woffset = 0;
+      INITIAL_READ:
+	if ($write_wait) {
+	    # skip filling $wbuf when waiting for 100-continue
+	    # because if the response is a redirect or auth required
+	    # the request will be cloned and there is no way
+	    # to reset the input stream
+	    # return here via the label after the 100-continue is read
+	}
+	elsif (ref($content_ref) eq 'CODE') {
+	    my $buf = &$content_ref();
+	    $buf = "" unless defined($buf);
+	    $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
+		if $chunked;
+	    substr($buf, 0, 0) = $req_buf if $req_buf;
+	    $wbuf = \$buf;
+	}
+	else {
+	    if ($req_buf) {
+		my $buf = $req_buf . $$content_ref;
+		$wbuf = \$buf;
+	    }
+	    else {
+		$wbuf = $content_ref;
+	    }
+	    $eof = 1;
+	}
+
+	my $fbits = '';
+	vec($fbits, fileno($socket), 1) = 1;
+
+      WRITE:
+	while ($write_wait || $woffset < length($$wbuf)) {
+
+	    my $sel_timeout = $timeout;
+	    if ($write_wait) {
+		$sel_timeout = $write_wait if $write_wait < $sel_timeout;
+	    }
+	    my $time_before;
+            $time_before = time if $sel_timeout;
+
+	    my $rbits = $fbits;
+	    my $wbits = $write_wait ? undef : $fbits;
+            my $sel_timeout_before = $sel_timeout;
+          SELECT:
+            {
+                my $nfound = select($rbits, $wbits, undef, $sel_timeout);
+                if ($nfound < 0) {
+                    if ($!{EINTR} || $!{EAGAIN}) {
+                        if ($time_before) {
+                            $sel_timeout = $sel_timeout_before - (time - $time_before);
+                            $sel_timeout = 0 if $sel_timeout < 0;
+                        }
+                        redo SELECT;
+                    }
+                    die "select failed: $!";
+                }
+	    }
+
+	    if ($write_wait) {
+		$write_wait -= time - $time_before;
+		$write_wait = 0 if $write_wait < 0;
+	    }
+
+	    if (defined($rbits) && $rbits =~ /[^\0]/) {
+		# readable
+		my $buf = $socket->_rbuf;
+		my $n = $socket->sysread($buf, 1024, length($buf));
+                unless (defined $n) {
+                    die "read failed: $!" unless  $!{EINTR} || $!{EAGAIN};
+                    # if we get here the rest of the block will do nothing
+                    # and we will retry the read on the next round
+                }
+		elsif ($n == 0) {
+                    # the server closed the connection before we finished
+                    # writing all the request content.  No need to write any more.
+                    $drop_connection++;
+                    last WRITE;
+		}
+		$socket->_rbuf($buf);
+		if (!$code && $buf =~ /\015?\012\015?\012/) {
+		    # a whole response header is present, so we can read it without blocking
+		    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
+									junk_out => \@junk,
+								       );
+		    if ($code eq "100") {
+			$write_wait = 0;
+			undef($code);
+			goto INITIAL_READ;
+		    }
+		    else {
+			$drop_connection++;
+			last WRITE;
+			# XXX should perhaps try to abort write in a nice way too
+		    }
+		}
+	    }
+	    if (defined($wbits) && $wbits =~ /[^\0]/) {
+		my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
+                unless (defined $n) {
+                    die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
+                    $n = 0;  # will retry write on the next round
+                }
+                elsif ($n == 0) {
+		    die "write failed: no bytes written";
+		}
+		$woffset += $n;
+
+		if (!$eof && $woffset >= length($$wbuf)) {
+		    # need to refill buffer from $content_ref code
+		    my $buf = &$content_ref();
+		    $buf = "" unless defined($buf);
+		    $eof++ unless length($buf);
+		    $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
+			if $chunked;
+		    $wbuf = \$buf;
+		    $woffset = 0;
+		}
+	    }
+	} # WRITE
+    }
+
+    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
+	unless $code;
+    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
+	if $code eq "100";
+
+    my $response = HTTP::Response->new($code, $mess);
+    my $peer_http_version = $socket->peer_http_version;
+    $response->protocol("HTTP/$peer_http_version");
+    {
+	local $HTTP::Headers::TRANSLATE_UNDERSCORE;
+	$response->push_header(@h);
+    }
+    $response->push_header("Client-Junk" => \@junk) if @junk;
+
+    $response->request($request);
+    $self->_get_sock_info($response, $socket);
+
+    if ($method eq "CONNECT") {
+	$response->{client_socket} = $socket;  # so it can be picked up
+	return $response;
+    }
+
+    if (my @te = $response->remove_header('Transfer-Encoding')) {
+	$response->push_header('Client-Transfer-Encoding', \@te);
+    }
+    $response->push_header('Client-Response-Num', scalar $socket->increment_response_count);
+
+    my $complete;
+    $response = $self->collect($arg, $response, sub {
+	my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
+	my $n;
+      READ:
+	{
+	    $n = $socket->read_entity_body($buf, $size);
+            unless (defined $n) {
+                redo READ if $!{EINTR} || $!{EAGAIN};
+                die "read failed: $!";
+            }
+	    redo READ if $n == -1;
+	}
+	$complete++ if !$n;
+        return \$buf;
+    } );
+    $drop_connection++ unless $complete;
+
+    @h = $socket->get_trailers;
+    if (@h) {
+	local $HTTP::Headers::TRANSLATE_UNDERSCORE;
+	$response->push_header(@h);
+    }
+
+    # keep-alive support
+    unless ($drop_connection) {
+	if (my $conn_cache = $self->{ua}{conn_cache}) {
+	    my %connection = map { (lc($_) => 1) }
+		             split(/\s*,\s*/, ($response->header("Connection") || ""));
+	    if (($peer_http_version eq "1.1" && !$connection{close}) ||
+		$connection{"keep-alive"})
+	    {
+		$conn_cache->deposit($self->socket_type, "$host:$port", $socket);
+	    }
+	}
+    }
+
+    $response;
+}
+
+
+#-----------------------------------------------------------
+package LWP::Protocol::http::SocketMethods;
+
+sub ping {
+    my $self = shift;
+    !$self->can_read(0);
+}
+
+sub increment_response_count {
+    my $self = shift;
+    return ++${*$self}{'myhttp_response_count'};
+}
+
+#-----------------------------------------------------------
+package LWP::Protocol::http::Socket;
+use vars qw(@ISA);
+@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/loopback.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/loopback.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/loopback.pm	(revision 27174)
@@ -0,0 +1,26 @@
+package LWP::Protocol::loopback;
+
+use strict;
+use vars qw(@ISA);
+require HTTP::Response;
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+sub request {
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+    my $response = HTTP::Response->new(200, "OK");
+    $response->content_type("message/http; msgtype=request");
+
+    $response->header("Via", "loopback/1.0 $proxy")
+	if $proxy;
+
+    $response->header("X-Arg", $arg);
+    $response->header("X-Read-Size", $size);
+    $response->header("X-Timeout", $timeout);
+
+    return $self->collect_once($arg, $response, $request->as_string);
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/mailto.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/mailto.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/mailto.pm	(revision 27174)
@@ -0,0 +1,183 @@
+package LWP::Protocol::mailto;
+
+# This module implements the mailto protocol.  It is just a simple
+# frontend to the Unix sendmail program except on MacOS, where it uses
+# Mail::Internet.
+
+require LWP::Protocol;
+require HTTP::Request;
+require HTTP::Response;
+require HTTP::Status;
+
+use Carp;
+use strict;
+use vars qw(@ISA $SENDMAIL);
+
+@ISA = qw(LWP::Protocol);
+
+unless ($SENDMAIL = $ENV{SENDMAIL}) {
+    for my $sm (qw(/usr/sbin/sendmail
+		   /usr/lib/sendmail
+		   /usr/ucblib/sendmail
+		  ))
+    {
+	if (-x $sm) {
+	    $SENDMAIL = $sm;
+	    last;
+	}
+    }
+    die "Can't find the 'sendmail' program" unless $SENDMAIL;
+}
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size) = @_;
+
+    my ($mail, $addr) if $^O eq "MacOS";
+    my @text = () if $^O eq "MacOS";
+
+    # check proxy
+    if (defined $proxy)
+    {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				  'You can not proxy with mail');
+    }
+
+    # check method
+    my $method = $request->method;
+
+    if ($method ne 'POST') {
+	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+				  'Library does not allow method ' .
+				  "$method for 'mailto:' URLs");
+    }
+
+    # check url
+    my $url = $request->uri;
+
+    my $scheme = $url->scheme;
+    if ($scheme ne 'mailto') {
+	return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+			 "LWP::Protocol::mailto::request called for '$scheme'");
+    }
+    if ($^O eq "MacOS") {
+	eval {
+	    require Mail::Internet;
+	};
+	if($@) {
+	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	               "You don't have MailTools installed");
+	}
+	unless ($ENV{SMTPHOSTS}) {
+	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	               "You don't have SMTPHOSTS defined");
+	}
+    }
+    else {
+	unless (-x $SENDMAIL) {
+	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	               "You don't have $SENDMAIL");
+    }
+    }
+    if ($^O eq "MacOS") {
+	    $mail = Mail::Internet->new or
+	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	    "Can't get a Mail::Internet object");
+    }
+    else {
+	open(SENDMAIL, "| $SENDMAIL -oi -t") or
+	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	               "Can't run $SENDMAIL: $!");
+    }
+    if ($^O eq "MacOS") {
+	$addr = $url->encoded822addr;
+    }
+    else {
+	$request = $request->clone;  # we modify a copy
+	my @h = $url->headers;  # URL headers override those in the request
+	while (@h) {
+	    my $k = shift @h;
+	    my $v = shift @h;
+	    next unless defined $v;
+	    if (lc($k) eq "body") {
+		$request->content($v);
+	    }
+	    else {
+		$request->push_header($k => $v);
+	    }
+	}
+    }
+    if ($^O eq "MacOS") {
+	$mail->add(To => $addr);
+	$mail->add(split(/[:\n]/,$request->headers_as_string));
+    }
+    else {
+	print SENDMAIL $request->headers_as_string;
+	print SENDMAIL "\n";
+    }
+    my $content = $request->content;
+    if (defined $content) {
+	my $contRef = ref($content) ? $content : \$content;
+	if (ref($contRef) eq 'SCALAR') {
+	    if ($^O eq "MacOS") {
+		@text = split("\n",$$contRef);
+		foreach (@text) {
+		    $_ .= "\n";
+		}
+	    }
+	    else {
+	    print SENDMAIL $$contRef;
+	    }
+
+	}
+	elsif (ref($contRef) eq 'CODE') {
+	    # Callback provides data
+	    my $d;
+	    if ($^O eq "MacOS") {
+		my $stuff = "";
+		while (length($d = &$contRef)) {
+		    $stuff .= $d;
+		}
+		@text = split("\n",$stuff);
+		foreach (@text) {
+		    $_ .= "\n";
+		}
+	    }
+	    else {
+		print SENDMAIL $d;
+	    }
+	}
+    }
+    if ($^O eq "MacOS") {
+	$mail->body(\@text);
+	unless ($mail->smtpsend) {
+	    return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+				       "Mail::Internet->smtpsend unable to send message to <$addr>");
+	}
+    }
+    else {
+	unless (close(SENDMAIL)) {
+	    my $err = $! ? "$!" : "Exit status $?";
+	    return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+				       "$SENDMAIL: $err");
+	}
+    }
+
+
+    my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED,
+				       "Mail accepted");
+    $response->header('Content-Type', 'text/plain');
+    if ($^O eq "MacOS") {
+	$response->header('Server' => "Mail::Internet $Mail::Internet::VERSION");
+	$response->content("Message sent to <$addr>\n");
+    }
+    else {
+	$response->header('Server' => $SENDMAIL);
+	my $to = $request->header("To");
+	$response->content("Message sent to <$to>\n");
+    }
+
+    return $response;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/nntp.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/nntp.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/nntp.pm	(revision 27174)
@@ -0,0 +1,145 @@
+package LWP::Protocol::nntp;
+
+# Implementation of the Network News Transfer Protocol (RFC 977)
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+require HTTP::Response;
+require HTTP::Status;
+require Net::NNTP;
+
+use strict;
+
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+    $size = 4096 unless $size;
+
+    # Check for proxy
+    if (defined $proxy) {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'You can not proxy through NNTP');
+    }
+
+    # Check that the scheme is as expected
+    my $url = $request->uri;
+    my $scheme = $url->scheme;
+    unless ($scheme eq 'news' || $scheme eq 'nntp') {
+	return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+				   "LWP::Protocol::nntp::request called for '$scheme'");
+    }
+
+    # check for a valid method
+    my $method = $request->method;
+    unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'Library does not allow method ' .
+				   "$method for '$scheme:' URLs");
+    }
+
+    # extract the identifier and check against posting to an article
+    my $groupart = $url->_group;
+    my $is_art = $groupart =~ /@/;
+
+    if ($is_art && $method eq 'POST') {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   "Can't post to an article <$groupart>");
+    }
+
+    my $nntp = Net::NNTP->new($url->host,
+			      #Port    => 18574,
+			      Timeout => $timeout,
+			      #Debug   => 1,
+			     );
+    die "Can't connect to nntp server" unless $nntp;
+
+    # Check the initial welcome message from the NNTP server
+    if ($nntp->status != 2) {
+	return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
+				   $nntp->message);
+    }
+    my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+
+    my $mess = $nntp->message;
+
+    # Try to extract server name from greeting message.
+    # Don't know if this works well for a large class of servers, but
+    # this works for our server.
+    $mess =~ s/\s+ready\b.*//;
+    $mess =~ s/^\S+\s+//;
+    $response->header(Server => $mess);
+
+    # First we handle posting of articles
+    if ($method eq 'POST') {
+	$nntp->quit; $nntp = undef;
+	$response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
+	$response->message("POST not implemented yet");
+	return $response;
+    }
+
+    # The method must be "GET" or "HEAD" by now
+    if (!$is_art) {
+	if (!$nntp->group($groupart)) {
+	    $response->code(&HTTP::Status::RC_NOT_FOUND);
+	    $response->message($nntp->message);
+	}
+	$nntp->quit; $nntp = undef;
+	# HEAD: just check if the group exists
+	if ($method eq 'GET' && $response->is_success) {
+	    $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
+	    $response->message("GET newsgroup not implemented yet");
+	}
+	return $response;
+    }
+
+    # Send command to server to retrieve an article (or just the headers)
+    my $get = $method eq 'HEAD' ? "head" : "article";
+    my $art = $nntp->$get("<$groupart>");
+    unless ($art) {
+	$nntp->quit; $nntp = undef;
+	$response->code(&HTTP::Status::RC_NOT_FOUND);
+	$response->message($nntp->message);
+	return $response;
+    }
+
+    # Parse headers
+    my($key, $val);
+    local $_;
+    while ($_ = shift @$art) {
+	if (/^\s+$/) {
+	    last;  # end of headers
+	}
+	elsif (/^(\S+):\s*(.*)/) {
+	    $response->push_header($key, $val) if $key;
+	    ($key, $val) = ($1, $2);
+	}
+	elsif (/^\s+(.*)/) {
+	    next unless $key;
+	    $val .= $1;
+	}
+	else {
+	    unshift(@$art, $_);
+	    last;
+	}
+    }
+    $response->push_header($key, $val) if $key;
+
+    # Ensure that there is a Content-Type header
+    $response->header("Content-Type", "text/plain")
+	unless $response->header("Content-Type");
+
+    # Collect the body
+    $response = $self->collect_once($arg, $response, join("", @$art))
+      if @$art;
+
+    # Say goodbye to the server
+    $nntp->quit;
+    $nntp = undef;
+
+    $response;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/nogo.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/nogo.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Protocol/nogo.pm	(revision 27174)
@@ -0,0 +1,24 @@
+package LWP::Protocol::nogo;
+# If you want to disable access to a particular scheme, use this
+# class and then call
+#   LWP::Protocol::implementor(that_scheme, 'LWP::Protocol::nogo');
+# For then on, attempts to access URLs with that scheme will generate
+# a 500 error.
+
+use strict;
+use vars qw(@ISA);
+require HTTP::Response;
+require HTTP::Status;
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+sub request {
+    my($self, $request) = @_;
+    my $scheme = $request->uri->scheme;
+    
+    return HTTP::Response->new(
+      &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+      "Access to \'$scheme\' URIs has been disabled"
+    );
+}
+1;
Index: /main/trunk/greenstone2/perllib/cpan/LWP/RobotUA.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/RobotUA.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/RobotUA.pm	(revision 27174)
@@ -0,0 +1,303 @@
+package LWP::RobotUA;
+
+require LWP::UserAgent;
+@ISA = qw(LWP::UserAgent);
+$VERSION = "6.03";
+
+require WWW::RobotRules;
+require HTTP::Request;
+require HTTP::Response;
+
+use Carp ();
+use HTTP::Status ();
+use HTTP::Date qw(time2str);
+use strict;
+
+
+#
+# Additional attributes in addition to those found in LWP::UserAgent:
+#
+# $self->{'delay'}    Required delay between request to the same
+#                     server in minutes.
+#
+# $self->{'rules'}     A WWW::RobotRules object
+#
+
+sub new
+{
+    my $class = shift;
+    my %cnf;
+    if (@_ < 4) {
+	# legacy args
+	@cnf{qw(agent from rules)} = @_;
+    }
+    else {
+	%cnf = @_;
+    }
+
+    Carp::croak('LWP::RobotUA agent required') unless $cnf{agent};
+    Carp::croak('LWP::RobotUA from address required')
+	unless $cnf{from} && $cnf{from} =~ m/\@/;
+
+    my $delay = delete $cnf{delay} || 1;
+    my $use_sleep = delete $cnf{use_sleep};
+    $use_sleep = 1 unless defined($use_sleep);
+    my $rules = delete $cnf{rules};
+
+    my $self = LWP::UserAgent->new(%cnf);
+    $self = bless $self, $class;
+
+    $self->{'delay'} = $delay;   # minutes
+    $self->{'use_sleep'} = $use_sleep;
+
+    if ($rules) {
+	$rules->agent($cnf{agent});
+	$self->{'rules'} = $rules;
+    }
+    else {
+	$self->{'rules'} = WWW::RobotRules->new($cnf{agent});
+    }
+
+    $self;
+}
+
+
+sub delay     { shift->_elem('delay',     @_); }
+sub use_sleep { shift->_elem('use_sleep', @_); }
+
+
+sub agent
+{
+    my $self = shift;
+    my $old = $self->SUPER::agent(@_);
+    if (@_) {
+	# Changing our name means to start fresh
+	$self->{'rules'}->agent($self->{'agent'}); 
+    }
+    $old;
+}
+
+
+sub rules {
+    my $self = shift;
+    my $old = $self->_elem('rules', @_);
+    $self->{'rules'}->agent($self->{'agent'}) if @_;
+    $old;
+}
+
+
+sub no_visits
+{
+    my($self, $netloc) = @_;
+    $self->{'rules'}->no_visits($netloc) || 0;
+}
+
+*host_count = \&no_visits;  # backwards compatibility with LWP-5.02
+
+
+sub host_wait
+{
+    my($self, $netloc) = @_;
+    return undef unless defined $netloc;
+    my $last = $self->{'rules'}->last_visit($netloc);
+    if ($last) {
+	my $wait = int($self->{'delay'} * 60 - (time - $last));
+	$wait = 0 if $wait < 0;
+	return $wait;
+    }
+    return 0;
+}
+
+
+sub simple_request
+{
+    my($self, $request, $arg, $size) = @_;
+
+    # Do we try to access a new server?
+    my $allowed = $self->{'rules'}->allowed($request->uri);
+
+    if ($allowed < 0) {
+	# Host is not visited before, or robots.txt expired; fetch "robots.txt"
+	my $robot_url = $request->uri->clone;
+	$robot_url->path("robots.txt");
+	$robot_url->query(undef);
+
+	# make access to robot.txt legal since this will be a recursive call
+	$self->{'rules'}->parse($robot_url, ""); 
+
+	my $robot_req = HTTP::Request->new('GET', $robot_url);
+	my $parse_head = $self->parse_head(0);
+	my $robot_res = $self->request($robot_req);
+	$self->parse_head($parse_head);
+	my $fresh_until = $robot_res->fresh_until;
+	my $content = "";
+	if ($robot_res->is_success && $robot_res->content_is_text) {
+	    $content = $robot_res->decoded_content;
+	    $content = "" unless $content && $content =~ /^\s*Disallow\s*:/mi;
+	}
+	$self->{'rules'}->parse($robot_url, $content, $fresh_until);
+
+	# recalculate allowed...
+	$allowed = $self->{'rules'}->allowed($request->uri);
+    }
+
+    # Check rules
+    unless ($allowed) {
+	my $res = HTTP::Response->new(
+	  &HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt');
+	$res->request( $request ); # bind it to that request
+	return $res;
+    }
+
+    my $netloc = eval { local $SIG{__DIE__}; $request->uri->host_port; };
+    my $wait = $self->host_wait($netloc);
+
+    if ($wait) {
+	if ($self->{'use_sleep'}) {
+	    sleep($wait)
+	}
+	else {
+	    my $res = HTTP::Response->new(
+	      &HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down');
+	    $res->header('Retry-After', time2str(time + $wait));
+	    $res->request( $request ); # bind it to that request
+	    return $res;
+	}
+    }
+
+    # Perform the request
+    my $res = $self->SUPER::simple_request($request, $arg, $size);
+
+    $self->{'rules'}->visit($netloc);
+
+    $res;
+}
+
+
+sub as_string
+{
+    my $self = shift;
+    my @s;
+    push(@s, "Robot: $self->{'agent'} operated by $self->{'from'}  [$self]");
+    push(@s, "    Minimum delay: " . int($self->{'delay'}*60) . "s");
+    push(@s, "    Will sleep if too early") if $self->{'use_sleep'};
+    push(@s, "    Rules = $self->{'rules'}");
+    join("\n", @s, '');
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+LWP::RobotUA - a class for well-behaved Web robots
+
+=head1 SYNOPSIS
+
+  use LWP::RobotUA;
+  my $ua = LWP::RobotUA->new('my-robot/0.1', 'me@foo.com');
+  $ua->delay(10);  # be very nice -- max one hit every ten minutes!
+  ...
+
+  # Then just use it just like a normal LWP::UserAgent:
+  my $response = $ua->get('http://whatever.int/...');
+  ...
+
+=head1 DESCRIPTION
+
+This class implements a user agent that is suitable for robot
+applications.  Robots should be nice to the servers they visit.  They
+should consult the F</robots.txt> file to ensure that they are welcomed
+and they should not make requests too frequently.
+
+But before you consider writing a robot, take a look at
+<URL:http://www.robotstxt.org/>.
+
+When you use a I<LWP::RobotUA> object as your user agent, then you do not
+really have to think about these things yourself; C<robots.txt> files
+are automatically consulted and obeyed, the server isn't queried
+too rapidly, and so on.  Just send requests
+as you do when you are using a normal I<LWP::UserAgent>
+object (using C<< $ua->get(...) >>, C<< $ua->head(...) >>,
+C<< $ua->request(...) >>, etc.), and this
+special agent will make sure you are nice.
+
+=head1 METHODS
+
+The LWP::RobotUA is a sub-class of LWP::UserAgent and implements the
+same methods. In addition the following methods are provided:
+
+=over 4
+
+=item $ua = LWP::RobotUA->new( %options )
+
+=item $ua = LWP::RobotUA->new( $agent, $from )
+
+=item $ua = LWP::RobotUA->new( $agent, $from, $rules )
+
+The LWP::UserAgent options C<agent> and C<from> are mandatory.  The
+options C<delay>, C<use_sleep> and C<rules> initialize attributes
+private to the RobotUA.  If C<rules> are not provided, then
+C<WWW::RobotRules> is instantiated providing an internal database of
+F<robots.txt>.
+
+It is also possible to just pass the value of C<agent>, C<from> and
+optionally C<rules> as plain positional arguments.
+
+=item $ua->delay
+
+=item $ua->delay( $minutes )
+
+Get/set the minimum delay between requests to the same server, in
+I<minutes>.  The default is 1 minute.  Note that this number doesn't
+have to be an integer; for example, this sets the delay to 10 seconds:
+
+    $ua->delay(10/60);
+
+=item $ua->use_sleep
+
+=item $ua->use_sleep( $boolean )
+
+Get/set a value indicating whether the UA should sleep() if requests
+arrive too fast, defined as $ua->delay minutes not passed since
+last request to the given server.  The default is TRUE.  If this value is
+FALSE then an internal SERVICE_UNAVAILABLE response will be generated.
+It will have an Retry-After header that indicates when it is OK to
+send another request to this server.
+
+=item $ua->rules
+
+=item $ua->rules( $rules )
+
+Set/get which I<WWW::RobotRules> object to use.
+
+=item $ua->no_visits( $netloc )
+
+Returns the number of documents fetched from this server host. Yeah I
+know, this method should probably have been named num_visits() or
+something like that. :-(
+
+=item $ua->host_wait( $netloc )
+
+Returns the number of I<seconds> (from now) you must wait before you can
+make a new request to this host.
+
+=item $ua->as_string
+
+Returns a string that describes the state of the UA.
+Mainly useful for debugging.
+
+=back
+
+=head1 SEE ALSO
+
+L<LWP::UserAgent>, L<WWW::RobotRules>
+
+=head1 COPYRIGHT
+
+Copyright 1996-2004 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/LWP/Simple.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/Simple.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/Simple.pm	(revision 27174)
@@ -0,0 +1,253 @@
+package LWP::Simple;
+
+use strict;
+use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK $VERSION);
+
+require Exporter;
+
+@EXPORT = qw(get head getprint getstore mirror);
+@EXPORT_OK = qw($ua);
+
+# I really hate this.  I was a bad idea to do it in the first place.
+# Wonder how to get rid of it???  (It even makes LWP::Simple 7% slower
+# for trivial tests)
+use HTTP::Status;
+push(@EXPORT, @HTTP::Status::EXPORT);
+
+$VERSION = "6.00";
+
+sub import
+{
+    my $pkg = shift;
+    my $callpkg = caller;
+    Exporter::export($pkg, $callpkg, @_);
+}
+
+use LWP::UserAgent ();
+use HTTP::Status ();
+use HTTP::Date ();
+$ua = LWP::UserAgent->new;  # we create a global UserAgent object
+$ua->agent("LWP::Simple/$VERSION ");
+$ua->env_proxy;
+
+
+sub get ($)
+{
+    my $response = $ua->get(shift);
+    return $response->decoded_content if $response->is_success;
+    return undef;
+}
+
+
+sub head ($)
+{
+    my($url) = @_;
+    my $request = HTTP::Request->new(HEAD => $url);
+    my $response = $ua->request($request);
+
+    if ($response->is_success) {
+	return $response unless wantarray;
+	return (scalar $response->header('Content-Type'),
+		scalar $response->header('Content-Length'),
+		HTTP::Date::str2time($response->header('Last-Modified')),
+		HTTP::Date::str2time($response->header('Expires')),
+		scalar $response->header('Server'),
+	       );
+    }
+    return;
+}
+
+
+sub getprint ($)
+{
+    my($url) = @_;
+    my $request = HTTP::Request->new(GET => $url);
+    local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
+    my $callback = sub { print $_[0] };
+    if ($^O eq "MacOS") {
+	$callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] }
+    }
+    my $response = $ua->request($request, $callback);
+    unless ($response->is_success) {
+	print STDERR $response->status_line, " <URL:$url>\n";
+    }
+    $response->code;
+}
+
+
+sub getstore ($$)
+{
+    my($url, $file) = @_;
+    my $request = HTTP::Request->new(GET => $url);
+    my $response = $ua->request($request, $file);
+
+    $response->code;
+}
+
+
+sub mirror ($$)
+{
+    my($url, $file) = @_;
+    my $response = $ua->mirror($url, $file);
+    $response->code;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWP::Simple - simple procedural interface to LWP
+
+=head1 SYNOPSIS
+
+ perl -MLWP::Simple -e 'getprint "http://www.sn.no"'
+
+ use LWP::Simple;
+ $content = get("http://www.sn.no/");
+ die "Couldn't get it!" unless defined $content;
+
+ if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) {
+     ...
+ }
+
+ if (is_success(getprint("http://www.sn.no/"))) {
+     ...
+ }
+
+=head1 DESCRIPTION
+
+This module is meant for people who want a simplified view of the
+libwww-perl library.  It should also be suitable for one-liners.  If
+you need more control or access to the header fields in the requests
+sent and responses received, then you should use the full object-oriented
+interface provided by the C<LWP::UserAgent> module.
+
+The following functions are provided (and exported) by this module:
+
+=over 3
+
+=item get($url)
+
+The get() function will fetch the document identified by the given URL
+and return it.  It returns C<undef> if it fails.  The $url argument can
+be either a string or a reference to a URI object.
+
+You will not be able to examine the response code or response headers
+(like 'Content-Type') when you are accessing the web using this
+function.  If you need that information you should use the full OO
+interface (see L<LWP::UserAgent>).
+
+=item head($url)
+
+Get document headers. Returns the following 5 values if successful:
+($content_type, $document_length, $modified_time, $expires, $server)
+
+Returns an empty list if it fails.  In scalar context returns TRUE if
+successful.
+
+=item getprint($url)
+
+Get and print a document identified by a URL. The document is printed
+to the selected default filehandle for output (normally STDOUT) as
+data is received from the network.  If the request fails, then the
+status code and message are printed on STDERR.  The return value is
+the HTTP response code.
+
+=item getstore($url, $file)
+
+Gets a document identified by a URL and stores it in the file. The
+return value is the HTTP response code.
+
+=item mirror($url, $file)
+
+Get and store a document identified by a URL, using
+I<If-modified-since>, and checking the I<Content-Length>.  Returns
+the HTTP response code.
+
+=back
+
+This module also exports the HTTP::Status constants and procedures.
+You can use them when you check the response code from getprint(),
+getstore() or mirror().  The constants are:
+
+   RC_CONTINUE
+   RC_SWITCHING_PROTOCOLS
+   RC_OK
+   RC_CREATED
+   RC_ACCEPTED
+   RC_NON_AUTHORITATIVE_INFORMATION
+   RC_NO_CONTENT
+   RC_RESET_CONTENT
+   RC_PARTIAL_CONTENT
+   RC_MULTIPLE_CHOICES
+   RC_MOVED_PERMANENTLY
+   RC_MOVED_TEMPORARILY
+   RC_SEE_OTHER
+   RC_NOT_MODIFIED
+   RC_USE_PROXY
+   RC_BAD_REQUEST
+   RC_UNAUTHORIZED
+   RC_PAYMENT_REQUIRED
+   RC_FORBIDDEN
+   RC_NOT_FOUND
+   RC_METHOD_NOT_ALLOWED
+   RC_NOT_ACCEPTABLE
+   RC_PROXY_AUTHENTICATION_REQUIRED
+   RC_REQUEST_TIMEOUT
+   RC_CONFLICT
+   RC_GONE
+   RC_LENGTH_REQUIRED
+   RC_PRECONDITION_FAILED
+   RC_REQUEST_ENTITY_TOO_LARGE
+   RC_REQUEST_URI_TOO_LARGE
+   RC_UNSUPPORTED_MEDIA_TYPE
+   RC_INTERNAL_SERVER_ERROR
+   RC_NOT_IMPLEMENTED
+   RC_BAD_GATEWAY
+   RC_SERVICE_UNAVAILABLE
+   RC_GATEWAY_TIMEOUT
+   RC_HTTP_VERSION_NOT_SUPPORTED
+
+The HTTP::Status classification functions are:
+
+=over 3
+
+=item is_success($rc)
+
+True if response code indicated a successful request.
+
+=item is_error($rc)
+
+True if response code indicated that an error occurred.
+
+=back
+
+The module will also export the LWP::UserAgent object as C<$ua> if you
+ask for it explicitly.
+
+The user agent created by this module will identify itself as
+"LWP::Simple/#.##"
+and will initialize its proxy defaults from the environment (by
+calling $ua->env_proxy).
+
+=head1 CAVEAT
+
+Note that if you are using both LWP::Simple and the very popular CGI.pm
+module, you may be importing a C<head> function from each module,
+producing a warning like "Prototype mismatch: sub main::head ($) vs
+none". Get around this problem by just not importing LWP::Simple's
+C<head> function, like so:
+
+        use LWP::Simple qw(!head);
+        use CGI qw(:standard);  # then only CGI.pm defines a head()
+
+Then if you do need LWP::Simple's C<head> function, you can just call
+it as C<LWP::Simple::head($url)>.
+
+=head1 SEE ALSO
+
+L<LWP>, L<lwpcook>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>,
+L<lwp-mirror>
Index: /main/trunk/greenstone2/perllib/cpan/LWP/UserAgent.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/LWP/UserAgent.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/LWP/UserAgent.pm	(revision 27174)
@@ -0,0 +1,1860 @@
+package LWP::UserAgent;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+require LWP::MemberMixin;
+@ISA = qw(LWP::MemberMixin);
+$VERSION = "6.05";
+
+use HTTP::Request ();
+use HTTP::Response ();
+use HTTP::Date ();
+
+use LWP ();
+use LWP::Protocol ();
+
+use Carp ();
+
+
+sub new
+{
+    # Check for common user mistake
+    Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference") 
+        if ref($_[1]) eq 'HASH'; 
+
+    my($class, %cnf) = @_;
+
+    my $agent = delete $cnf{agent};
+    my $from  = delete $cnf{from};
+    my $def_headers = delete $cnf{default_headers};
+    my $timeout = delete $cnf{timeout};
+    $timeout = 3*60 unless defined $timeout;
+    my $local_address = delete $cnf{local_address};
+    my $ssl_opts = delete $cnf{ssl_opts} || {};
+    unless (exists $ssl_opts->{verify_hostname}) {
+	# The processing of HTTPS_CA_* below is for compatibility with Crypt::SSLeay
+	if (exists $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME}) {
+	    $ssl_opts->{verify_hostname} = $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME};
+	}
+	elsif ($ENV{HTTPS_CA_FILE} || $ENV{HTTPS_CA_DIR}) {
+	    # Crypt-SSLeay compatibility (verify peer certificate; but not the hostname)
+	    $ssl_opts->{verify_hostname} = 0;
+	    $ssl_opts->{SSL_verify_mode} = 1;
+	}
+	else {
+	    $ssl_opts->{verify_hostname} = 1;
+	}
+    }
+    unless (exists $ssl_opts->{SSL_ca_file}) {
+	if (my $ca_file = $ENV{PERL_LWP_SSL_CA_FILE} || $ENV{HTTPS_CA_FILE}) {
+	    $ssl_opts->{SSL_ca_file} = $ca_file;
+	}
+    }
+    unless (exists $ssl_opts->{SSL_ca_path}) {
+	if (my $ca_path = $ENV{PERL_LWP_SSL_CA_PATH} || $ENV{HTTPS_CA_DIR}) {
+	    $ssl_opts->{SSL_ca_path} = $ca_path;
+	}
+    }
+    my $use_eval = delete $cnf{use_eval};
+    $use_eval = 1 unless defined $use_eval;
+    my $parse_head = delete $cnf{parse_head};
+    $parse_head = 1 unless defined $parse_head;
+    my $show_progress = delete $cnf{show_progress};
+    my $max_size = delete $cnf{max_size};
+    my $max_redirect = delete $cnf{max_redirect};
+    $max_redirect = 7 unless defined $max_redirect;
+    my $env_proxy = exists $cnf{env_proxy} ? delete $cnf{env_proxy} : $ENV{PERL_LWP_ENV_PROXY};
+
+    my $cookie_jar = delete $cnf{cookie_jar};
+    my $conn_cache = delete $cnf{conn_cache};
+    my $keep_alive = delete $cnf{keep_alive};
+    
+    Carp::croak("Can't mix conn_cache and keep_alive")
+	  if $conn_cache && $keep_alive;
+
+    my $protocols_allowed   = delete $cnf{protocols_allowed};
+    my $protocols_forbidden = delete $cnf{protocols_forbidden};
+    
+    my $requests_redirectable = delete $cnf{requests_redirectable};
+    $requests_redirectable = ['GET', 'HEAD']
+      unless defined $requests_redirectable;
+
+    # Actually ""s are just as good as 0's, but for concision we'll just say:
+    Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
+      if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
+    Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
+      if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
+    Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!")
+      if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY';
+
+
+    if (%cnf && $^W) {
+	Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
+    }
+
+    my $self = bless {
+		      def_headers  => $def_headers,
+		      timeout      => $timeout,
+		      local_address => $local_address,
+		      ssl_opts     => $ssl_opts,
+		      use_eval     => $use_eval,
+                      show_progress=> $show_progress,
+		      max_size     => $max_size,
+		      max_redirect => $max_redirect,
+                      proxy        => {},
+		      no_proxy     => [],
+                      protocols_allowed     => $protocols_allowed,
+                      protocols_forbidden   => $protocols_forbidden,
+                      requests_redirectable => $requests_redirectable,
+		     }, $class;
+
+    $self->agent(defined($agent) ? $agent : $class->_agent)
+	if defined($agent) || !$def_headers || !$def_headers->header("User-Agent");
+    $self->from($from) if $from;
+    $self->cookie_jar($cookie_jar) if $cookie_jar;
+    $self->parse_head($parse_head);
+    $self->env_proxy if $env_proxy;
+
+    $self->protocols_allowed(  $protocols_allowed  ) if $protocols_allowed;
+    $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;
+
+    if ($keep_alive) {
+	$conn_cache ||= { total_capacity => $keep_alive };
+    }
+    $self->conn_cache($conn_cache) if $conn_cache;
+
+    return $self;
+}
+
+
+sub send_request
+{
+    my($self, $request, $arg, $size) = @_;
+    my($method, $url) = ($request->method, $request->uri);
+    my $scheme = $url->scheme;
+
+    local($SIG{__DIE__});  # protect against user defined die handlers
+
+    $self->progress("begin", $request);
+
+    my $response = $self->run_handlers("request_send", $request);
+
+    unless ($response) {
+        my $protocol;
+
+        {
+            # Honor object-specific restrictions by forcing protocol objects
+            #  into class LWP::Protocol::nogo.
+            my $x;
+            if($x = $self->protocols_allowed) {
+                if (grep lc($_) eq $scheme, @$x) {
+                }
+                else {
+                    require LWP::Protocol::nogo;
+                    $protocol = LWP::Protocol::nogo->new;
+                }
+            }
+            elsif ($x = $self->protocols_forbidden) {
+                if(grep lc($_) eq $scheme, @$x) {
+                    require LWP::Protocol::nogo;
+                    $protocol = LWP::Protocol::nogo->new;
+                }
+            }
+            # else fall thru and create the protocol object normally
+        }
+
+        # Locate protocol to use
+        my $proxy = $request->{proxy};
+        if ($proxy) {
+            $scheme = $proxy->scheme;
+        }
+
+        unless ($protocol) {
+            $protocol = eval { LWP::Protocol::create($scheme, $self) };
+            if ($@) {
+                $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
+                $response =  _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
+                if ($scheme eq "https") {
+                    $response->message($response->message . " (LWP::Protocol::https not installed)");
+                    $response->content_type("text/plain");
+                    $response->content(<<EOT);
+LWP will support https URLs if the LWP::Protocol::https module
+is installed.
+EOT
+                }
+            }
+        }
+
+        if (!$response && $self->{use_eval}) {
+            # we eval, and turn dies into responses below
+            eval {
+                $response = $protocol->request($request, $proxy, $arg, $size, $self->{timeout}) ||
+		    die "No response returned by $protocol";
+            };
+            if ($@) {
+                if (UNIVERSAL::isa($@, "HTTP::Response")) {
+                    $response = $@;
+                    $response->request($request);
+                }
+                else {
+                    my $full = $@;
+                    (my $status = $@) =~ s/\n.*//s;
+                    $status =~ s/ at .* line \d+.*//s;  # remove file/line number
+                    my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : &HTTP::Status::RC_INTERNAL_SERVER_ERROR;
+                    $response = _new_response($request, $code, $status, $full);
+                }
+            }
+        }
+        elsif (!$response) {
+            $response = $protocol->request($request, $proxy,
+                                           $arg, $size, $self->{timeout});
+            # XXX: Should we die unless $response->is_success ???
+        }
+    }
+
+    $response->request($request);  # record request for reference
+    $response->header("Client-Date" => HTTP::Date::time2str(time));
+
+    $self->run_handlers("response_done", $response);
+
+    $self->progress("end", $response);
+    return $response;
+}
+
+
+sub prepare_request
+{
+    my($self, $request) = @_;
+    die "Method missing" unless $request->method;
+    my $url = $request->uri;
+    die "URL missing" unless $url;
+    die "URL must be absolute" unless $url->scheme;
+
+    $self->run_handlers("request_preprepare", $request);
+
+    if (my $def_headers = $self->{def_headers}) {
+	for my $h ($def_headers->header_field_names) {
+	    $request->init_header($h => [$def_headers->header($h)]);
+	}
+    }
+
+    $self->run_handlers("request_prepare", $request);
+
+    return $request;
+}
+
+
+sub simple_request
+{
+    my($self, $request, $arg, $size) = @_;
+
+    # sanity check the request passed in
+    if (defined $request) {
+	if (ref $request) {
+	    Carp::croak("You need a request object, not a " . ref($request) . " object")
+	      if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or
+		 !$request->can('method') or !$request->can('uri');
+	}
+	else {
+	    Carp::croak("You need a request object, not '$request'");
+	}
+    }
+    else {
+        Carp::croak("No request object passed in");
+    }
+
+    eval {
+	$request = $self->prepare_request($request);
+    };
+    if ($@) {
+	$@ =~ s/ at .* line \d+.*//s;  # remove file/line number
+	return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $@);
+    }
+    return $self->send_request($request, $arg, $size);
+}
+
+
+sub request
+{
+    my($self, $request, $arg, $size, $previous) = @_;
+
+    my $response = $self->simple_request($request, $arg, $size);
+    $response->previous($previous) if $previous;
+
+    if ($response->redirects >= $self->{max_redirect}) {
+        $response->header("Client-Warning" =>
+                          "Redirect loop detected (max_redirect = $self->{max_redirect})");
+        return $response;
+    }
+
+    if (my $req = $self->run_handlers("response_redirect", $response)) {
+        return $self->request($req, $arg, $size, $response);
+    }
+
+    my $code = $response->code;
+
+    if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
+	$code == &HTTP::Status::RC_FOUND or
+	$code == &HTTP::Status::RC_SEE_OTHER or
+	$code == &HTTP::Status::RC_TEMPORARY_REDIRECT)
+    {
+	my $referral = $request->clone;
+
+	# These headers should never be forwarded
+	$referral->remove_header('Host', 'Cookie');
+	
+	if ($referral->header('Referer') &&
+	    $request->uri->scheme eq 'https' &&
+	    $referral->uri->scheme eq 'http')
+	{
+	    # RFC 2616, section 15.1.3.
+	    # https -> http redirect, suppressing Referer
+	    $referral->remove_header('Referer');
+	}
+
+	if ($code == &HTTP::Status::RC_SEE_OTHER ||
+	    $code == &HTTP::Status::RC_FOUND) 
+        {
+	    my $method = uc($referral->method);
+	    unless ($method eq "GET" || $method eq "HEAD") {
+		$referral->method("GET");
+		$referral->content("");
+		$referral->remove_content_headers;
+	    }
+	}
+
+	# And then we update the URL based on the Location:-header.
+	my $referral_uri = $response->header('Location');
+	{
+	    # Some servers erroneously return a relative URL for redirects,
+	    # so make it absolute if it not already is.
+	    local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
+	    my $base = $response->base;
+	    $referral_uri = "" unless defined $referral_uri;
+	    $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
+		            ->abs($base);
+	}
+	$referral->uri($referral_uri);
+
+	return $response unless $self->redirect_ok($referral, $response);
+	return $self->request($referral, $arg, $size, $response);
+
+    }
+    elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
+	     $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
+	    )
+    {
+	my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
+	my $ch_header = $proxy ?  "Proxy-Authenticate" : "WWW-Authenticate";
+	my @challenge = $response->header($ch_header);
+	unless (@challenge) {
+	    $response->header("Client-Warning" => 
+			      "Missing Authenticate header");
+	    return $response;
+	}
+
+	require HTTP::Headers::Util;
+	CHALLENGE: for my $challenge (@challenge) {
+	    $challenge =~ tr/,/;/;  # "," is used to separate auth-params!!
+	    ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
+	    my $scheme = shift(@$challenge);
+	    shift(@$challenge); # no value
+	    $challenge = { @$challenge };  # make rest into a hash
+
+	    unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
+		$response->header("Client-Warning" => 
+				  "Bad authentication scheme '$scheme'");
+		return $response;
+	    }
+	    $scheme = $1;  # untainted now
+	    my $class = "LWP::Authen::\u$scheme";
+	    $class =~ s/-/_/g;
+
+	    no strict 'refs';
+	    unless (%{"$class\::"}) {
+		# try to load it
+		eval "require $class";
+		if ($@) {
+		    if ($@ =~ /^Can\'t locate/) {
+			$response->header("Client-Warning" =>
+					  "Unsupported authentication scheme '$scheme'");
+		    }
+		    else {
+			$response->header("Client-Warning" => $@);
+		    }
+		    next CHALLENGE;
+		}
+	    }
+	    unless ($class->can("authenticate")) {
+		$response->header("Client-Warning" =>
+				  "Unsupported authentication scheme '$scheme'");
+		next CHALLENGE;
+	    }
+	    return $class->authenticate($self, $proxy, $challenge, $response,
+					$request, $arg, $size);
+	}
+	return $response;
+    }
+    return $response;
+}
+
+
+#
+# Now the shortcuts...
+#
+sub get {
+    require HTTP::Request::Common;
+    my($self, @parameters) = @_;
+    my @suff = $self->_process_colonic_headers(\@parameters,1);
+    return $self->request( HTTP::Request::Common::GET( @parameters ), @suff );
+}
+
+
+sub post {
+    require HTTP::Request::Common;
+    my($self, @parameters) = @_;
+    my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
+    return $self->request( HTTP::Request::Common::POST( @parameters ), @suff );
+}
+
+
+sub head {
+    require HTTP::Request::Common;
+    my($self, @parameters) = @_;
+    my @suff = $self->_process_colonic_headers(\@parameters,1);
+    return $self->request( HTTP::Request::Common::HEAD( @parameters ), @suff );
+}
+
+
+sub put {
+    require HTTP::Request::Common;
+    my($self, @parameters) = @_;
+    my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
+    return $self->request( HTTP::Request::Common::PUT( @parameters ), @suff );
+}
+
+
+sub delete {
+    require HTTP::Request::Common;
+    my($self, @parameters) = @_;
+    my @suff = $self->_process_colonic_headers(\@parameters,1);
+    return $self->request( HTTP::Request::Common::DELETE( @parameters ), @suff );
+}
+
+
+sub _process_colonic_headers {
+    # Process :content_cb / :content_file / :read_size_hint headers.
+    my($self, $args, $start_index) = @_;
+
+    my($arg, $size);
+    for(my $i = $start_index; $i < @$args; $i += 2) {
+	next unless defined $args->[$i];
+
+	#printf "Considering %s => %s\n", $args->[$i], $args->[$i + 1];
+
+	if($args->[$i] eq ':content_cb') {
+	    # Some sanity-checking...
+	    $arg = $args->[$i + 1];
+	    Carp::croak("A :content_cb value can't be undef") unless defined $arg;
+	    Carp::croak("A :content_cb value must be a coderef")
+		unless ref $arg and UNIVERSAL::isa($arg, 'CODE');
+	    
+	}
+	elsif ($args->[$i] eq ':content_file') {
+	    $arg = $args->[$i + 1];
+
+	    # Some sanity-checking...
+	    Carp::croak("A :content_file value can't be undef")
+		unless defined $arg;
+	    Carp::croak("A :content_file value can't be a reference")
+		if ref $arg;
+	    Carp::croak("A :content_file value can't be \"\"")
+		unless length $arg;
+
+	}
+	elsif ($args->[$i] eq ':read_size_hint') {
+	    $size = $args->[$i + 1];
+	    # Bother checking it?
+
+	}
+	else {
+	    next;
+	}
+	splice @$args, $i, 2;
+	$i -= 2;
+    }
+
+    # And return a suitable suffix-list for request(REQ,...)
+
+    return             unless defined $arg;
+    return $arg, $size if     defined $size;
+    return $arg;
+}
+
+
+sub is_online {
+    my $self = shift;
+    return 1 if $self->get("http://www.msftncsi.com/ncsi.txt")->content eq "Microsoft NCSI";
+    return 1 if $self->get("http://www.apple.com")->content =~ m,<title>Apple</title>,;
+    return 0;
+}
+
+
+my @ANI = qw(- \ | /);
+
+sub progress {
+    my($self, $status, $m) = @_;
+    return unless $self->{show_progress};
+
+    local($,, $\);
+    if ($status eq "begin") {
+        print STDERR "** ", $m->method, " ", $m->uri, " ==> ";
+        $self->{progress_start} = time;
+        $self->{progress_lastp} = "";
+        $self->{progress_ani} = 0;
+    }
+    elsif ($status eq "end") {
+        delete $self->{progress_lastp};
+        delete $self->{progress_ani};
+        print STDERR $m->status_line;
+        my $t = time - delete $self->{progress_start};
+        print STDERR " (${t}s)" if $t;
+        print STDERR "\n";
+    }
+    elsif ($status eq "tick") {
+        print STDERR "$ANI[$self->{progress_ani}++]\b";
+        $self->{progress_ani} %= @ANI;
+    }
+    else {
+        my $p = sprintf "%3.0f%%", $status * 100;
+        return if $p eq $self->{progress_lastp};
+        print STDERR "$p\b\b\b\b";
+        $self->{progress_lastp} = $p;
+    }
+    STDERR->flush;
+}
+
+
+#
+# This whole allow/forbid thing is based on man 1 at's way of doing things.
+#
+sub is_protocol_supported
+{
+    my($self, $scheme) = @_;
+    if (ref $scheme) {
+	# assume we got a reference to an URI object
+	$scheme = $scheme->scheme;
+    }
+    else {
+	Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported")
+	    if $scheme =~ /\W/;
+	$scheme = lc $scheme;
+    }
+
+    my $x;
+    if(ref($self) and $x       = $self->protocols_allowed) {
+      return 0 unless grep lc($_) eq $scheme, @$x;
+    }
+    elsif (ref($self) and $x = $self->protocols_forbidden) {
+      return 0 if grep lc($_) eq $scheme, @$x;
+    }
+
+    local($SIG{__DIE__});  # protect against user defined die handlers
+    $x = LWP::Protocol::implementor($scheme);
+    return 1 if $x and $x ne 'LWP::Protocol::nogo';
+    return 0;
+}
+
+
+sub protocols_allowed      { shift->_elem('protocols_allowed'    , @_) }
+sub protocols_forbidden    { shift->_elem('protocols_forbidden'  , @_) }
+sub requests_redirectable  { shift->_elem('requests_redirectable', @_) }
+
+
+sub redirect_ok
+{
+    # RFC 2616, section 10.3.2 and 10.3.3 say:
+    #  If the 30[12] status code is received in response to a request other
+    #  than GET or HEAD, the user agent MUST NOT automatically redirect the
+    #  request unless it can be confirmed by the user, since this might
+    #  change the conditions under which the request was issued.
+
+    # Note that this routine used to be just:
+    #  return 0 if $_[1]->method eq "POST";  return 1;
+
+    my($self, $new_request, $response) = @_;
+    my $method = $response->request->method;
+    return 0 unless grep $_ eq $method,
+      @{ $self->requests_redirectable || [] };
+    
+    if ($new_request->uri->scheme eq 'file') {
+      $response->header("Client-Warning" =>
+			"Can't redirect to a file:// URL!");
+      return 0;
+    }
+    
+    # Otherwise it's apparently okay...
+    return 1;
+}
+
+
+sub credentials
+{
+    my $self = shift;
+    my $netloc = lc(shift);
+    my $realm = shift || "";
+    my $old = $self->{basic_authentication}{$netloc}{$realm};
+    if (@_) {
+        $self->{basic_authentication}{$netloc}{$realm} = [@_];
+    }
+    return unless $old;
+    return @$old if wantarray;
+    return join(":", @$old);
+}
+
+
+sub get_basic_credentials
+{
+    my($self, $realm, $uri, $proxy) = @_;
+    return if $proxy;
+    return $self->credentials($uri->host_port, $realm);
+}
+
+
+sub timeout      { shift->_elem('timeout',      @_); }
+sub local_address{ shift->_elem('local_address',@_); }
+sub max_size     { shift->_elem('max_size',     @_); }
+sub max_redirect { shift->_elem('max_redirect', @_); }
+sub show_progress{ shift->_elem('show_progress', @_); }
+
+sub ssl_opts {
+    my $self = shift;
+    if (@_ == 1) {
+	my $k = shift;
+	return $self->{ssl_opts}{$k};
+    }
+    if (@_) {
+	my $old;
+	while (@_) {
+	    my($k, $v) = splice(@_, 0, 2);
+	    $old = $self->{ssl_opts}{$k} unless @_;
+	    if (defined $v) {
+		$self->{ssl_opts}{$k} = $v;
+	    }
+	    else {
+		delete $self->{ssl_opts}{$k};
+	    }
+	}
+	%{$self->{ssl_opts}} = (%{$self->{ssl_opts}}, @_);
+	return $old;
+    }
+
+    return keys %{$self->{ssl_opts}};
+}
+
+sub parse_head {
+    my $self = shift;
+    if (@_) {
+        my $flag = shift;
+        my $parser;
+        my $old = $self->set_my_handler("response_header", $flag ? sub {
+               my($response, $ua) = @_;
+               require HTML::HeadParser;
+               $parser = HTML::HeadParser->new;
+               $parser->xml_mode(1) if $response->content_is_xhtml;
+               $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
+
+               push(@{$response->{handlers}{response_data}}, {
+		   callback => sub {
+		       return unless $parser;
+		       unless ($parser->parse($_[3])) {
+			   my $h = $parser->header;
+			   my $r = $_[0];
+			   for my $f ($h->header_field_names) {
+			       $r->init_header($f, [$h->header($f)]);
+			   }
+			   undef($parser);
+		       }
+		   },
+	       });
+
+            } : undef,
+            m_media_type => "html",
+        );
+        return !!$old;
+    }
+    else {
+        return !!$self->get_my_handler("response_header");
+    }
+}
+
+sub cookie_jar {
+    my $self = shift;
+    my $old = $self->{cookie_jar};
+    if (@_) {
+	my $jar = shift;
+	if (ref($jar) eq "HASH") {
+	    require HTTP::Cookies;
+	    $jar = HTTP::Cookies->new(%$jar);
+	}
+	$self->{cookie_jar} = $jar;
+        $self->set_my_handler("request_prepare",
+            $jar ? sub { $jar->add_cookie_header($_[0]); } : undef,
+        );
+        $self->set_my_handler("response_done",
+            $jar ? sub { $jar->extract_cookies($_[0]); } : undef,
+        );
+    }
+    $old;
+}
+
+sub default_headers {
+    my $self = shift;
+    my $old = $self->{def_headers} ||= HTTP::Headers->new;
+    if (@_) {
+	Carp::croak("default_headers not set to HTTP::Headers compatible object")
+	    unless @_ == 1 && $_[0]->can("header_field_names");
+	$self->{def_headers} = shift;
+    }
+    return $old;
+}
+
+sub default_header {
+    my $self = shift;
+    return $self->default_headers->header(@_);
+}
+
+sub _agent       { "libwww-perl/$LWP::VERSION" }
+
+sub agent {
+    my $self = shift;
+    if (@_) {
+	my $agent = shift;
+        if ($agent) {
+            $agent .= $self->_agent if $agent =~ /\s+$/;
+        }
+        else {
+            undef($agent)
+        }
+        return $self->default_header("User-Agent", $agent);
+    }
+    return $self->default_header("User-Agent");
+}
+
+sub from {  # legacy
+    my $self = shift;
+    return $self->default_header("From", @_);
+}
+
+
+sub conn_cache {
+    my $self = shift;
+    my $old = $self->{conn_cache};
+    if (@_) {
+	my $cache = shift;
+	if (ref($cache) eq "HASH") {
+	    require LWP::ConnCache;
+	    $cache = LWP::ConnCache->new(%$cache);
+	}
+	$self->{conn_cache} = $cache;
+    }
+    $old;
+}
+
+
+sub add_handler {
+    my($self, $phase, $cb, %spec) = @_;
+    $spec{line} ||= join(":", (caller)[1,2]);
+    my $conf = $self->{handlers}{$phase} ||= do {
+        require HTTP::Config;
+        HTTP::Config->new;
+    };
+    $conf->add(%spec, callback => $cb);
+}
+
+sub set_my_handler {
+    my($self, $phase, $cb, %spec) = @_;
+    $spec{owner} = (caller(1))[3] unless exists $spec{owner};
+    $self->remove_handler($phase, %spec);
+    $spec{line} ||= join(":", (caller)[1,2]);
+    $self->add_handler($phase, $cb, %spec) if $cb;
+}
+
+sub get_my_handler {
+    my $self = shift;
+    my $phase = shift;
+    my $init = pop if @_ % 2;
+    my %spec = @_;
+    my $conf = $self->{handlers}{$phase};
+    unless ($conf) {
+        return unless $init;
+        require HTTP::Config;
+        $conf = $self->{handlers}{$phase} = HTTP::Config->new;
+    }
+    $spec{owner} = (caller(1))[3] unless exists $spec{owner};
+    my @h = $conf->find(%spec);
+    if (!@h && $init) {
+        if (ref($init) eq "CODE") {
+            $init->(\%spec);
+        }
+        elsif (ref($init) eq "HASH") {
+            while (my($k, $v) = each %$init) {
+                $spec{$k} = $v;
+            }
+        }
+        $spec{callback} ||= sub {};
+        $spec{line} ||= join(":", (caller)[1,2]);
+        $conf->add(\%spec);
+        return \%spec;
+    }
+    return wantarray ? @h : $h[0];
+}
+
+sub remove_handler {
+    my($self, $phase, %spec) = @_;
+    if ($phase) {
+        my $conf = $self->{handlers}{$phase} || return;
+        my @h = $conf->remove(%spec);
+        delete $self->{handlers}{$phase} if $conf->empty;
+        return @h;
+    }
+
+    return unless $self->{handlers};
+    return map $self->remove_handler($_), sort keys %{$self->{handlers}};
+}
+
+sub handlers {
+    my($self, $phase, $o) = @_;
+    my @h;
+    if ($o->{handlers} && $o->{handlers}{$phase}) {
+        push(@h, @{$o->{handlers}{$phase}});
+    }
+    if (my $conf = $self->{handlers}{$phase}) {
+        push(@h, $conf->matching($o));
+    }
+    return @h;
+}
+
+sub run_handlers {
+    my($self, $phase, $o) = @_;
+    if (defined(wantarray)) {
+        for my $h ($self->handlers($phase, $o)) {
+            my $ret = $h->{callback}->($o, $self, $h);
+            return $ret if $ret;
+        }
+        return undef;
+    }
+
+    for my $h ($self->handlers($phase, $o)) {
+        $h->{callback}->($o, $self, $h);
+    }
+}
+
+
+# deprecated
+sub use_eval   { shift->_elem('use_eval',  @_); }
+sub use_alarm
+{
+    Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
+	if @_ > 1 && $^W;
+    "";
+}
+
+
+sub clone
+{
+    my $self = shift;
+    my $copy = bless { %$self }, ref $self;  # copy most fields
+
+    delete $copy->{handlers};
+    delete $copy->{conn_cache};
+
+    # copy any plain arrays and hashes; known not to need recursive copy
+    for my $k (qw(proxy no_proxy requests_redirectable ssl_opts)) {
+        next unless $copy->{$k};
+        if (ref($copy->{$k}) eq "ARRAY") {
+            $copy->{$k} = [ @{$copy->{$k}} ];
+        }
+        elsif (ref($copy->{$k}) eq "HASH") {
+            $copy->{$k} = { %{$copy->{$k}} };
+        }
+    }
+
+    if ($self->{def_headers}) {
+        $copy->{def_headers} = $self->{def_headers}->clone;
+    }
+
+    # re-enable standard handlers
+    $copy->parse_head($self->parse_head);
+
+    # no easy way to clone the cookie jar; so let's just remove it for now
+    $copy->cookie_jar(undef);
+
+    $copy;
+}
+
+
+sub mirror
+{
+    my($self, $url, $file) = @_;
+
+    my $request = HTTP::Request->new('GET', $url);
+
+    # If the file exists, add a cache-related header
+    if ( -e $file ) {
+        my ($mtime) = ( stat($file) )[9];
+        if ($mtime) {
+            $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) );
+        }
+    }
+    my $tmpfile = "$file-$$";
+
+    my $response = $self->request($request, $tmpfile);
+    if ( $response->header('X-Died') ) {
+	die $response->header('X-Died');
+    }
+
+    # Only fetching a fresh copy of the would be considered success.
+    # If the file was not modified, "304" would returned, which 
+    # is considered by HTTP::Status to be a "redirect", /not/ "success"
+    if ( $response->is_success ) {
+        my @stat        = stat($tmpfile) or die "Could not stat tmpfile '$tmpfile': $!";
+        my $file_length = $stat[7];
+        my ($content_length) = $response->header('Content-length');
+
+        if ( defined $content_length and $file_length < $content_length ) {
+            unlink($tmpfile);
+            die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n";
+        }
+        elsif ( defined $content_length and $file_length > $content_length ) {
+            unlink($tmpfile);
+            die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n";
+        }
+        # The file was the expected length. 
+        else {
+            # Replace the stale file with a fresh copy
+            if ( -e $file ) {
+                # Some dosish systems fail to rename if the target exists
+                chmod 0777, $file;
+                unlink $file;
+            }
+            rename( $tmpfile, $file )
+                or die "Cannot rename '$tmpfile' to '$file': $!\n";
+
+            # make sure the file has the same last modification time
+            if ( my $lm = $response->last_modified ) {
+                utime $lm, $lm, $file;
+            }
+        }
+    }
+    # The local copy is fresh enough, so just delete the temp file  
+    else {
+	unlink($tmpfile);
+    }
+    return $response;
+}
+
+
+sub _need_proxy {
+    my($req, $ua) = @_;
+    return if exists $req->{proxy};
+    my $proxy = $ua->{proxy}{$req->uri->scheme} || return;
+    if ($ua->{no_proxy}) {
+        if (my $host = eval { $req->uri->host }) {
+            for my $domain (@{$ua->{no_proxy}}) {
+                if ($host =~ /\Q$domain\E$/) {
+                    return;
+                }
+            }
+        }
+    }
+    $req->{proxy} = $HTTP::URI_CLASS->new($proxy);
+}
+
+
+sub proxy
+{
+    my $self = shift;
+    my $key  = shift;
+    return map $self->proxy($_, @_), @$key if ref $key;
+
+    Carp::croak("'$key' is not a valid URI scheme") unless $key =~ /^$URI::scheme_re\z/;
+    my $old = $self->{'proxy'}{$key};
+    if (@_) {
+        my $url = shift;
+        if (defined($url) && length($url)) {
+            Carp::croak("Proxy must be specified as absolute URI; '$url' is not") unless $url =~ /^$URI::scheme_re:/;
+            Carp::croak("Bad http proxy specification '$url'") if $url =~ /^https?:/ && $url !~ m,^https?://\w,;
+        }
+        $self->{proxy}{$key} = $url;
+        $self->set_my_handler("request_preprepare", \&_need_proxy)
+    }
+    return $old;
+}
+
+
+sub env_proxy {
+    my ($self) = @_;
+    require Encode;
+    require Encode::Locale;
+    my($k,$v);
+    while(($k, $v) = each %ENV) {
+	if ($ENV{REQUEST_METHOD}) {
+	    # Need to be careful when called in the CGI environment, as
+	    # the HTTP_PROXY variable is under control of that other guy.
+	    next if $k =~ /^HTTP_/;
+	    $k = "HTTP_PROXY" if $k eq "CGI_HTTP_PROXY";
+	}
+	$k = lc($k);
+	next unless $k =~ /^(.*)_proxy$/;
+	$k = $1;
+	if ($k eq 'no') {
+	    $self->no_proxy(split(/\s*,\s*/, $v));
+	}
+	else {
+            # Ignore random _proxy variables, allow only valid schemes
+            next unless $k =~ /^$URI::scheme_re\z/;
+            # Ignore xxx_proxy variables if xxx isn't a supported protocol
+            next unless LWP::Protocol::implementor($k);
+	    $self->proxy($k, Encode::decode(locale => $v));
+	}
+    }
+}
+
+
+sub no_proxy {
+    my($self, @no) = @_;
+    if (@no) {
+	push(@{ $self->{'no_proxy'} }, @no);
+    }
+    else {
+	$self->{'no_proxy'} = [];
+    }
+}
+
+
+sub _new_response {
+    my($request, $code, $message, $content) = @_;
+    $message ||= HTTP::Status::status_message($code);
+    my $response = HTTP::Response->new($code, $message);
+    $response->request($request);
+    $response->header("Client-Date" => HTTP::Date::time2str(time));
+    $response->header("Client-Warning" => "Internal response");
+    $response->header("Content-Type" => "text/plain");
+    $response->content($content || "$code $message\n");
+    return $response;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWP::UserAgent - Web user agent class
+
+=head1 SYNOPSIS
+
+ require LWP::UserAgent;
+ 
+ my $ua = LWP::UserAgent->new;
+ $ua->timeout(10);
+ $ua->env_proxy;
+ 
+ my $response = $ua->get('http://search.cpan.org/');
+ 
+ if ($response->is_success) {
+     print $response->decoded_content;  # or whatever
+ }
+ else {
+     die $response->status_line;
+ }
+
+=head1 DESCRIPTION
+
+The C<LWP::UserAgent> is a class implementing a web user agent.
+C<LWP::UserAgent> objects can be used to dispatch web requests.
+
+In normal use the application creates an C<LWP::UserAgent> object, and
+then configures it with values for timeouts, proxies, name, etc. It
+then creates an instance of C<HTTP::Request> for the request that
+needs to be performed. This request is then passed to one of the
+request method the UserAgent, which dispatches it using the relevant
+protocol, and returns a C<HTTP::Response> object.  There are
+convenience methods for sending the most common request types: get(),
+head(), post(), put() and delete().  When using these methods then the
+creation of the request object is hidden as shown in the synopsis above.
+
+The basic approach of the library is to use HTTP style communication
+for all protocol schemes.  This means that you will construct
+C<HTTP::Request> objects and receive C<HTTP::Response> objects even
+for non-HTTP resources like I<gopher> and I<ftp>.  In order to achieve
+even more similarity to HTTP style communications, gopher menus and
+file directories are converted to HTML documents.
+
+=head1 CONSTRUCTOR METHODS
+
+The following constructor methods are available:
+
+=over 4
+
+=item $ua = LWP::UserAgent->new( %options )
+
+This method constructs a new C<LWP::UserAgent> object and returns it.
+Key/value pair arguments may be provided to set up the initial state.
+The following options correspond to attribute methods described below:
+
+   KEY                     DEFAULT
+   -----------             --------------------
+   agent                   "libwww-perl/#.###"
+   from                    undef
+   conn_cache              undef
+   cookie_jar              undef
+   default_headers         HTTP::Headers->new
+   local_address           undef
+   ssl_opts		   { verify_hostname => 1 }
+   max_size                undef
+   max_redirect            7
+   parse_head              1
+   protocols_allowed       undef
+   protocols_forbidden     undef
+   requests_redirectable   ['GET', 'HEAD']
+   timeout                 180
+
+The following additional options are also accepted: If the C<env_proxy> option
+is passed in with a TRUE value, then proxy settings are read from environment
+variables (see env_proxy() method below).  If C<env_proxy> isn't provided the
+C<PERL_LWP_ENV_PROXY> environment variable controls if env_proxy() is called
+during initialization.  If the C<keep_alive> option is passed in, then a
+C<LWP::ConnCache> is set up (see conn_cache() method below).  The C<keep_alive>
+value is passed on as the C<total_capacity> for the connection cache.
+
+=item $ua->clone
+
+Returns a copy of the LWP::UserAgent object.
+
+=back
+
+=head1 ATTRIBUTES
+
+The settings of the configuration attributes modify the behaviour of the
+C<LWP::UserAgent> when it dispatches requests.  Most of these can also
+be initialized by options passed to the constructor method.
+
+The following attribute methods are provided.  The attribute value is
+left unchanged if no argument is given.  The return value from each
+method is the old attribute value.
+
+=over
+
+=item $ua->agent
+
+=item $ua->agent( $product_id )
+
+Get/set the product token that is used to identify the user agent on
+the network.  The agent value is sent as the "User-Agent" header in
+the requests.  The default is the string returned by the _agent()
+method (see below).
+
+If the $product_id ends with space then the _agent() string is
+appended to it.
+
+The user agent string should be one or more simple product identifiers
+with an optional version number separated by the "/" character.
+Examples are:
+
+  $ua->agent('Checkbot/0.4 ' . $ua->_agent);
+  $ua->agent('Checkbot/0.4 ');    # same as above
+  $ua->agent('Mozilla/5.0');
+  $ua->agent("");                 # don't identify
+
+=item $ua->_agent
+
+Returns the default agent identifier.  This is a string of the form
+"libwww-perl/#.###", where "#.###" is substituted with the version number
+of this library.
+
+=item $ua->from
+
+=item $ua->from( $email_address )
+
+Get/set the e-mail address for the human user who controls
+the requesting user agent.  The address should be machine-usable, as
+defined in RFC 822.  The C<from> value is send as the "From" header in
+the requests.  Example:
+
+  $ua->from('gaas@cpan.org');
+
+The default is to not send a "From" header.  See the default_headers()
+method for the more general interface that allow any header to be defaulted.
+
+=item $ua->cookie_jar
+
+=item $ua->cookie_jar( $cookie_jar_obj )
+
+Get/set the cookie jar object to use.  The only requirement is that
+the cookie jar object must implement the extract_cookies($request) and
+add_cookie_header($response) methods.  These methods will then be
+invoked by the user agent as requests are sent and responses are
+received.  Normally this will be a C<HTTP::Cookies> object or some
+subclass.
+
+The default is to have no cookie_jar, i.e. never automatically add
+"Cookie" headers to the requests.
+
+Shortcut: If a reference to a plain hash is passed in as the
+$cookie_jar_object, then it is replaced with an instance of
+C<HTTP::Cookies> that is initialized based on the hash.  This form also
+automatically loads the C<HTTP::Cookies> module.  It means that:
+
+  $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" });
+
+is really just a shortcut for:
+
+  require HTTP::Cookies;
+  $ua->cookie_jar(HTTP::Cookies->new(file => "$ENV{HOME}/.cookies.txt"));
+
+=item $ua->default_headers
+
+=item $ua->default_headers( $headers_obj )
+
+Get/set the headers object that will provide default header values for
+any requests sent.  By default this will be an empty C<HTTP::Headers>
+object.
+
+=item $ua->default_header( $field )
+
+=item $ua->default_header( $field => $value )
+
+This is just a short-cut for $ua->default_headers->header( $field =>
+$value ). Example:
+
+  $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
+  $ua->default_header('Accept-Language' => "no, en");
+
+=item $ua->conn_cache
+
+=item $ua->conn_cache( $cache_obj )
+
+Get/set the C<LWP::ConnCache> object to use.  See L<LWP::ConnCache>
+for details.
+
+=item $ua->credentials( $netloc, $realm )
+
+=item $ua->credentials( $netloc, $realm, $uname, $pass )
+
+Get/set the user name and password to be used for a realm.
+
+The $netloc is a string of the form "<host>:<port>".  The username and
+password will only be passed to this server.  Example:
+
+  $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret");
+
+=item $ua->local_address
+
+=item $ua->local_address( $address )
+
+Get/set the local interface to bind to for network connections.  The interface
+can be specified as a hostname or an IP address.  This value is passed as the
+C<LocalAddr> argument to L<IO::Socket::INET>.
+
+=item $ua->max_size
+
+=item $ua->max_size( $bytes )
+
+Get/set the size limit for response content.  The default is C<undef>,
+which means that there is no limit.  If the returned response content
+is only partial, because the size limit was exceeded, then a
+"Client-Aborted" header will be added to the response.  The content
+might end up longer than C<max_size> as we abort once appending a
+chunk of data makes the length exceed the limit.  The "Content-Length"
+header, if present, will indicate the length of the full content and
+will normally not be the same as C<< length($res->content) >>.
+
+=item $ua->max_redirect
+
+=item $ua->max_redirect( $n )
+
+This reads or sets the object's limit of how many times it will obey
+redirection responses in a given request cycle.
+
+By default, the value is 7. This means that if you call request()
+method and the response is a redirect elsewhere which is in turn a
+redirect, and so on seven times, then LWP gives up after that seventh
+request.
+
+=item $ua->parse_head
+
+=item $ua->parse_head( $boolean )
+
+Get/set a value indicating whether we should initialize response
+headers from the E<lt>head> section of HTML documents. The default is
+TRUE.  Do not turn this off, unless you know what you are doing.
+
+=item $ua->protocols_allowed
+
+=item $ua->protocols_allowed( \@protocols )
+
+This reads (or sets) this user agent's list of protocols that the
+request methods will exclusively allow.  The protocol names are case
+insensitive.
+
+For example: C<$ua-E<gt>protocols_allowed( [ 'http', 'https'] );>
+means that this user agent will I<allow only> those protocols,
+and attempts to use this user agent to access URLs with any other
+schemes (like "ftp://...") will result in a 500 error.
+
+To delete the list, call: C<$ua-E<gt>protocols_allowed(undef)>
+
+By default, an object has neither a C<protocols_allowed> list, nor a
+C<protocols_forbidden> list.
+
+Note that having a C<protocols_allowed> list causes any
+C<protocols_forbidden> list to be ignored.
+
+=item $ua->protocols_forbidden
+
+=item $ua->protocols_forbidden( \@protocols )
+
+This reads (or sets) this user agent's list of protocols that the
+request method will I<not> allow. The protocol names are case
+insensitive.
+
+For example: C<$ua-E<gt>protocols_forbidden( [ 'file', 'mailto'] );>
+means that this user agent will I<not> allow those protocols, and
+attempts to use this user agent to access URLs with those schemes
+will result in a 500 error.
+
+To delete the list, call: C<$ua-E<gt>protocols_forbidden(undef)>
+
+=item $ua->requests_redirectable
+
+=item $ua->requests_redirectable( \@requests )
+
+This reads or sets the object's list of request names that
+C<$ua-E<gt>redirect_ok(...)> will allow redirection for.  By
+default, this is C<['GET', 'HEAD']>, as per RFC 2616.  To
+change to include 'POST', consider:
+
+   push @{ $ua->requests_redirectable }, 'POST';
+
+=item $ua->show_progress
+
+=item $ua->show_progress( $boolean )
+
+Get/set a value indicating whether a progress bar should be displayed
+on on the terminal as requests are processed. The default is FALSE.
+
+=item $ua->timeout
+
+=item $ua->timeout( $secs )
+
+Get/set the timeout value in seconds. The default timeout() value is
+180 seconds, i.e. 3 minutes.
+
+The requests is aborted if no activity on the connection to the server
+is observed for C<timeout> seconds.  This means that the time it takes
+for the complete transaction and the request() method to actually
+return might be longer.
+
+=item $ua->ssl_opts
+
+=item $ua->ssl_opts( $key )
+
+=item $ua->ssl_opts( $key => $value )
+
+Get/set the options for SSL connections.  Without argument return the list
+of options keys currently set.  With a single argument return the current
+value for the given option.  With 2 arguments set the option value and return
+the old.  Setting an option to the value C<undef> removes this option.
+
+The options that LWP relates to are:
+
+=over
+
+=item C<verify_hostname> => $bool
+
+When TRUE LWP will for secure protocol schemes ensure it connects to servers
+that have a valid certificate matching the expected hostname.  If FALSE no
+checks are made and you can't be sure that you communicate with the expected peer.
+The no checks behaviour was the default for libwww-perl-5.837 and earlier releases.
+
+This option is initialized from the L<PERL_LWP_SSL_VERIFY_HOSTNAME> environment
+variable.  If this environment variable isn't set; then C<verify_hostname>
+defaults to 1.
+
+=item C<SSL_ca_file> => $path
+
+The path to a file containing Certificate Authority certificates.
+A default setting for this option is provided by checking the environment
+variables C<PERL_LWP_SSL_CA_FILE> and C<HTTPS_CA_FILE> in order.
+
+=item C<SSL_ca_path> => $path
+
+The path to a directory containing files containing Certificate Authority
+certificates.
+A default setting for this option is provided by checking the environment
+variables C<PERL_LWP_SSL_CA_PATH> and C<HTTPS_CA_DIR> in order.
+
+=back
+
+Other options can be set and are processed directly by the SSL Socket implementation
+in use.  See L<IO::Socket::SSL> or L<Net::SSL> for details.
+
+The libwww-perl core no longer bundles protocol plugins for SSL.  You will need
+to install L<LWP::Protocol::https> separately to enable support for processing
+https-URLs.
+
+=back
+
+=head2 Proxy attributes
+
+The following methods set up when requests should be passed via a
+proxy server.
+
+=over
+
+=item $ua->proxy(\@schemes, $proxy_url)
+
+=item $ua->proxy($scheme, $proxy_url)
+
+Set/retrieve proxy URL for a scheme:
+
+ $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/');
+ $ua->proxy('gopher', 'http://proxy.sn.no:8001/');
+
+The first form specifies that the URL is to be used for proxying of
+access methods listed in the list in the first method argument,
+i.e. 'http' and 'ftp'.
+
+The second form shows a shorthand form for specifying
+proxy URL for a single access scheme.
+
+=item $ua->no_proxy( $domain, ... )
+
+Do not proxy requests to the given domains.  Calling no_proxy without
+any domains clears the list of domains. Eg:
+
+ $ua->no_proxy('localhost', 'example.com');
+
+=item $ua->env_proxy
+
+Load proxy settings from *_proxy environment variables.  You might
+specify proxies like this (sh-syntax):
+
+  gopher_proxy=http://proxy.my.place/
+  wais_proxy=http://proxy.my.place/
+  no_proxy="localhost,example.com"
+  export gopher_proxy wais_proxy no_proxy
+
+csh or tcsh users should use the C<setenv> command to define these
+environment variables.
+
+On systems with case insensitive environment variables there exists a
+name clash between the CGI environment variables and the C<HTTP_PROXY>
+environment variable normally picked up by env_proxy().  Because of
+this C<HTTP_PROXY> is not honored for CGI scripts.  The
+C<CGI_HTTP_PROXY> environment variable can be used instead.
+
+=back
+
+=head2 Handlers
+
+Handlers are code that injected at various phases during the
+processing of requests.  The following methods are provided to manage
+the active handlers:
+
+=over
+
+=item $ua->add_handler( $phase => \&cb, %matchspec )
+
+Add handler to be invoked in the given processing phase.  For how to
+specify %matchspec see L<HTTP::Config/"Matching">.
+
+The possible values $phase and the corresponding callback signatures are:
+
+=over
+
+=item request_preprepare => sub { my($request, $ua, $h) = @_; ... }
+
+The handler is called before the C<request_prepare> and other standard
+initialization of of the request.  This can be used to set up headers
+and attributes that the C<request_prepare> handler depends on.  Proxy
+initialization should take place here; but in general don't register
+handlers for this phase.
+
+=item request_prepare => sub { my($request, $ua, $h) = @_; ... }
+
+The handler is called before the request is sent and can modify the
+request any way it see fit.  This can for instance be used to add
+certain headers to specific requests.
+
+The method can assign a new request object to $_[0] to replace the
+request that is sent fully.
+
+The return value from the callback is ignored.  If an exception is
+raised it will abort the request and make the request method return a
+"400 Bad request" response.
+
+=item request_send => sub { my($request, $ua, $h) = @_; ... }
+
+This handler gets a chance of handling requests before they're sent to the
+protocol handlers.  It should return an HTTP::Response object if it
+wishes to terminate the processing; otherwise it should return nothing.
+
+The C<response_header> and C<response_data> handlers will not be
+invoked for this response, but the C<response_done> will be.
+
+=item response_header => sub { my($response, $ua, $h) = @_; ... }
+
+This handler is called right after the response headers have been
+received, but before any content data.  The handler might set up
+handlers for data and might croak to abort the request.
+
+The handler might set the $response->{default_add_content} value to
+control if any received data should be added to the response object
+directly.  This will initially be false if the $ua->request() method
+was called with a $content_file or $content_cb argument; otherwise true.
+
+=item response_data => sub { my($response, $ua, $h, $data) = @_; ... }
+
+This handler is called for each chunk of data received for the
+response.  The handler might croak to abort the request.
+
+This handler needs to return a TRUE value to be called again for
+subsequent chunks for the same request.
+
+=item response_done => sub { my($response, $ua, $h) = @_; ... }
+
+The handler is called after the response has been fully received, but
+before any redirect handling is attempted.  The handler can be used to
+extract information or modify the response.
+
+=item response_redirect => sub { my($response, $ua, $h) = @_; ... }
+
+The handler is called in $ua->request after C<response_done>.  If the
+handler returns an HTTP::Request object we'll start over with processing
+this request instead.
+
+=back
+
+=item $ua->remove_handler( undef, %matchspec )
+
+=item $ua->remove_handler( $phase, %matchspec )
+
+Remove handlers that match the given %matchspec.  If $phase is not
+provided remove handlers from all phases.
+
+Be careful as calling this function with %matchspec that is not not
+specific enough can remove handlers not owned by you.  It's probably
+better to use the set_my_handler() method instead.
+
+The removed handlers are returned.
+
+=item $ua->set_my_handler( $phase, $cb, %matchspec )
+
+Set handlers private to the executing subroutine.  Works by defaulting
+an C<owner> field to the %matchspec that holds the name of the called
+subroutine.  You might pass an explicit C<owner> to override this.
+
+If $cb is passed as C<undef>, remove the handler.
+
+=item $ua->get_my_handler( $phase, %matchspec )
+
+=item $ua->get_my_handler( $phase, %matchspec, $init )
+
+Will retrieve the matching handler as hash ref.
+
+If C<$init> is passed passed as a TRUE value, create and add the
+handler if it's not found.  If $init is a subroutine reference, then
+it's called with the created handler hash as argument.  This sub might
+populate the hash with extra fields; especially the callback.  If
+$init is a hash reference, merge the hashes.
+
+=item $ua->handlers( $phase, $request )
+
+=item $ua->handlers( $phase, $response )
+
+Returns the handlers that apply to the given request or response at
+the given processing phase.
+
+=back
+
+=head1 REQUEST METHODS
+
+The methods described in this section are used to dispatch requests
+via the user agent.  The following request methods are provided:
+
+=over
+
+=item $ua->get( $url )
+
+=item $ua->get( $url , $field_name => $value, ... )
+
+This method will dispatch a C<GET> request on the given $url.  Further
+arguments can be given to initialize the headers of the request. These
+are given as separate name/value pairs.  The return value is a
+response object.  See L<HTTP::Response> for a description of the
+interface it provides.
+
+There will still be a response object returned when LWP can't connect to the
+server specified in the URL or when other failures in protocol handlers occur.
+These internal responses use the standard HTTP status codes, so the responses
+can't be differentiated by testing the response status code alone.  Error
+responses that LWP generates internally will have the "Client-Warning" header
+set to the value "Internal response".  If you need to differentiate these
+internal responses from responses that a remote server actually generates, you
+need to test this header value.
+
+Fields names that start with ":" are special.  These will not
+initialize headers of the request but will determine how the response
+content is treated.  The following special field names are recognized:
+
+    :content_file   => $filename
+    :content_cb     => \&callback
+    :read_size_hint => $bytes
+
+If a $filename is provided with the C<:content_file> option, then the
+response content will be saved here instead of in the response
+object.  If a callback is provided with the C<:content_cb> option then
+this function will be called for each chunk of the response content as
+it is received from the server.  If neither of these options are
+given, then the response content will accumulate in the response
+object itself.  This might not be suitable for very large response
+bodies.  Only one of C<:content_file> or C<:content_cb> can be
+specified.  The content of unsuccessful responses will always
+accumulate in the response object itself, regardless of the
+C<:content_file> or C<:content_cb> options passed in.
+
+The C<:read_size_hint> option is passed to the protocol module which
+will try to read data from the server in chunks of this size.  A
+smaller value for the C<:read_size_hint> will result in a higher
+number of callback invocations.
+
+The callback function is called with 3 arguments: a chunk of data, a
+reference to the response object, and a reference to the protocol
+object.  The callback can abort the request by invoking die().  The
+exception message will show up as the "X-Died" header field in the
+response returned by the get() function.
+
+=item $ua->head( $url )
+
+=item $ua->head( $url , $field_name => $value, ... )
+
+This method will dispatch a C<HEAD> request on the given $url.
+Otherwise it works like the get() method described above.
+
+=item $ua->post( $url, \%form )
+
+=item $ua->post( $url, \@form )
+
+=item $ua->post( $url, \%form, $field_name => $value, ... )
+
+=item $ua->post( $url, $field_name => $value,... Content => \%form )
+
+=item $ua->post( $url, $field_name => $value,... Content => \@form )
+
+=item $ua->post( $url, $field_name => $value,... Content => $content )
+
+This method will dispatch a C<POST> request on the given $url, with
+%form or @form providing the key/value pairs for the fill-in form
+content. Additional headers and content options are the same as for
+the get() method.
+
+This method will use the POST() function from C<HTTP::Request::Common>
+to build the request.  See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
+=item $ua->put( $url, \%form )
+
+=item $ua->put( $url, \@form )
+
+=item $ua->put( $url, \%form, $field_name => $value, ... )
+
+=item $ua->put( $url, $field_name => $value,... Content => \%form )
+
+=item $ua->put( $url, $field_name => $value,... Content => \@form )
+
+=item $ua->put( $url, $field_name => $value,... Content => $content )
+
+This method will dispatch a C<PUT> request on the given $url, with
+%form or @form providing the key/value pairs for the fill-in form
+content. Additional headers and content options are the same as for
+the get() method.
+
+This method will use the PUT() function from C<HTTP::Request::Common>
+to build the request.  See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
+=item $ua->delete( $url )
+
+=item $ua->delete( $url, $field_name => $value, ... )
+
+This method will dispatch a C<DELETE> request on the given $url.  Additional
+headers and content options are the same as for the get() method.
+
+This method will use the DELETE() function from C<HTTP::Request::Common>
+to build the request.  See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
+=item $ua->mirror( $url, $filename )
+
+This method will get the document identified by $url and store it in
+file called $filename.  If the file already exists, then the request
+will contain an "If-Modified-Since" header matching the modification
+time of the file.  If the document on the server has not changed since
+this time, then nothing happens.  If the document has been updated, it
+will be downloaded again.  The modification time of the file will be
+forced to match that of the server.
+
+The return value is the the response object.
+
+=item $ua->request( $request )
+
+=item $ua->request( $request, $content_file )
+
+=item $ua->request( $request, $content_cb )
+
+=item $ua->request( $request, $content_cb, $read_size_hint )
+
+This method will dispatch the given $request object.  Normally this
+will be an instance of the C<HTTP::Request> class, but any object with
+a similar interface will do.  The return value is a response object.
+See L<HTTP::Request> and L<HTTP::Response> for a description of the
+interface provided by these classes.
+
+The request() method will process redirects and authentication
+responses transparently.  This means that it may actually send several
+simple requests via the simple_request() method described below.
+
+The request methods described above; get(), head(), post() and
+mirror(), will all dispatch the request they build via this method.
+They are convenience methods that simply hides the creation of the
+request object for you.
+
+The $content_file, $content_cb and $read_size_hint all correspond to
+options described with the get() method above.
+
+You are allowed to use a CODE reference as C<content> in the request
+object passed in.  The C<content> function should return the content
+when called.  The content can be returned in chunks.  The content
+function will be invoked repeatedly until it return an empty string to
+signal that there is no more content.
+
+=item $ua->simple_request( $request )
+
+=item $ua->simple_request( $request, $content_file )
+
+=item $ua->simple_request( $request, $content_cb )
+
+=item $ua->simple_request( $request, $content_cb, $read_size_hint )
+
+This method dispatches a single request and returns the response
+received.  Arguments are the same as for request() described above.
+
+The difference from request() is that simple_request() will not try to
+handle redirects or authentication responses.  The request() method
+will in fact invoke this method for each simple request it sends.
+
+=item $ua->is_online
+
+Tries to determine if you have access to the Internet.  Returns
+TRUE if the built-in heuristics determine that the user agent is
+able to access the Internet (over HTTP).  See also L<LWP::Online>.
+
+=item $ua->is_protocol_supported( $scheme )
+
+You can use this method to test whether this user agent object supports the
+specified C<scheme>.  (The C<scheme> might be a string (like 'http' or
+'ftp') or it might be an URI object reference.)
+
+Whether a scheme is supported, is determined by the user agent's
+C<protocols_allowed> or C<protocols_forbidden> lists (if any), and by
+the capabilities of LWP.  I.e., this will return TRUE only if LWP
+supports this protocol I<and> it's permitted for this particular
+object.
+
+=back
+
+=head2 Callback methods
+
+The following methods will be invoked as requests are processed. These
+methods are documented here because subclasses of C<LWP::UserAgent>
+might want to override their behaviour.
+
+=over
+
+=item $ua->prepare_request( $request )
+
+This method is invoked by simple_request().  Its task is to modify the
+given $request object by setting up various headers based on the
+attributes of the user agent. The return value should normally be the
+$request object passed in.  If a different request object is returned
+it will be the one actually processed.
+
+The headers affected by the base implementation are; "User-Agent",
+"From", "Range" and "Cookie".
+
+=item $ua->redirect_ok( $prospective_request, $response )
+
+This method is called by request() before it tries to follow a
+redirection to the request in $response.  This should return a TRUE
+value if this redirection is permissible.  The $prospective_request
+will be the request to be sent if this method returns TRUE.
+
+The base implementation will return FALSE unless the method
+is in the object's C<requests_redirectable> list,
+FALSE if the proposed redirection is to a "file://..."
+URL, and TRUE otherwise.
+
+=item $ua->get_basic_credentials( $realm, $uri, $isproxy )
+
+This is called by request() to retrieve credentials for documents
+protected by Basic or Digest Authentication.  The arguments passed in
+is the $realm provided by the server, the $uri requested and a boolean
+flag to indicate if this is authentication against a proxy server.
+
+The method should return a username and password.  It should return an
+empty list to abort the authentication resolution attempt.  Subclasses
+can override this method to prompt the user for the information. An
+example of this can be found in C<lwp-request> program distributed
+with this library.
+
+The base implementation simply checks a set of pre-stored member
+variables, set up with the credentials() method.
+
+=item $ua->progress( $status, $request_or_response )
+
+This is called frequently as the response is received regardless of
+how the content is processed.  The method is called with $status
+"begin" at the start of processing the request and with $state "end"
+before the request method returns.  In between these $status will be
+the fraction of the response currently received or the string "tick"
+if the fraction can't be calculated.
+
+When $status is "begin" the second argument is the request object,
+otherwise it is the response object.
+
+=back
+
+=head1 SEE ALSO
+
+See L<LWP> for a complete overview of libwww-perl5.  See L<lwpcook>
+and the scripts F<lwp-request> and F<lwp-download> for examples of
+usage.
+
+See L<HTTP::Request> and L<HTTP::Response> for a description of the
+message objects dispatched and received.  See L<HTTP::Request::Common>
+and L<HTML::Form> for other ways to build request objects.
+
+See L<WWW::Mechanize> and L<WWW::Search> for examples of more
+specialized user agents based on C<LWP::UserAgent>.
+
+=head1 COPYRIGHT
+
+Copyright 1995-2009 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/URI/Escape.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/Escape.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/Escape.pm	(revision 27174)
@@ -0,0 +1,208 @@
+package URI::Escape;
+use strict;
+
+=head1 NAME
+
+URI::Escape - Percent-encode and percent-decode unsafe characters
+
+=head1 SYNOPSIS
+
+ use URI::Escape;
+ $safe = uri_escape("10% is enough\n");
+ $verysafe = uri_escape("foo", "\0-\377");
+ $str  = uri_unescape($safe);
+
+=head1 DESCRIPTION
+
+This module provides functions to percent-encode and percent-decode URI strings as
+defined by RFC 3986. Percent-encoding URI's is informally called "URI escaping".
+This is the terminology used by this module, which predates the formalization of the
+terms by the RFC by several years.
+
+A URI consists of a restricted set of characters.  The restricted set
+of characters consists of digits, letters, and a few graphic symbols
+chosen from those common to most of the character encodings and input
+facilities available to Internet users.  They are made up of the
+"unreserved" and "reserved" character sets as defined in RFC 3986.
+
+   unreserved    = ALPHA / DIGIT / "-" / "." / "_" / "~"
+   reserved      = ":" / "/" / "?" / "#" / "[" / "]" / "@"
+                   "!" / "$" / "&" / "'" / "(" / ")"
+                 / "*" / "+" / "," / ";" / "="
+
+In addition, any byte (octet) can be represented in a URI by an escape
+sequence: a triplet consisting of the character "%" followed by two
+hexadecimal digits.  A byte can also be represented directly by a
+character, using the US-ASCII character for that octet.
+
+Some of the characters are I<reserved> for use as delimiters or as
+part of certain URI components.  These must be escaped if they are to
+be treated as ordinary data.  Read RFC 3986 for further details.
+
+The functions provided (and exported by default) from this module are:
+
+=over 4
+
+=item uri_escape( $string )
+
+=item uri_escape( $string, $unsafe )
+
+Replaces each unsafe character in the $string with the corresponding
+escape sequence and returns the result.  The $string argument should
+be a string of bytes.  The uri_escape() function will croak if given a
+characters with code above 255.  Use uri_escape_utf8() if you know you
+have such chars or/and want chars in the 128 .. 255 range treated as
+UTF-8.
+
+The uri_escape() function takes an optional second argument that
+overrides the set of characters that are to be escaped.  The set is
+specified as a string that can be used in a regular expression
+character class (between [ ]).  E.g.:
+
+  "\x00-\x1f\x7f-\xff"          # all control and hi-bit characters
+  "a-z"                         # all lower case characters
+  "^A-Za-z"                     # everything not a letter
+
+The default set of characters to be escaped is all those which are
+I<not> part of the C<unreserved> character class shown above as well
+as the reserved characters.  I.e. the default is:
+
+    "^A-Za-z0-9\-\._~"
+
+=item uri_escape_utf8( $string )
+
+=item uri_escape_utf8( $string, $unsafe )
+
+Works like uri_escape(), but will encode chars as UTF-8 before
+escaping them.  This makes this function able to deal with characters
+with code above 255 in $string.  Note that chars in the 128 .. 255
+range will be escaped differently by this function compared to what
+uri_escape() would.  For chars in the 0 .. 127 range there is no
+difference.
+
+Equivalent to:
+
+    utf8::encode($string);
+    my $uri = uri_escape($string);
+
+Note: JavaScript has a function called escape() that produces the
+sequence "%uXXXX" for chars in the 256 .. 65535 range.  This function
+has really nothing to do with URI escaping but some folks got confused
+since it "does the right thing" in the 0 .. 255 range.  Because of
+this you sometimes see "URIs" with these kind of escapes.  The
+JavaScript encodeURIComponent() function is similar to uri_escape_utf8().
+
+=item uri_unescape($string,...)
+
+Returns a string with each %XX sequence replaced with the actual byte
+(octet).
+
+This does the same as:
+
+   $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+
+but does not modify the string in-place as this RE would.  Using the
+uri_unescape() function instead of the RE might make the code look
+cleaner and is a few characters less to type.
+
+In a simple benchmark test I did,
+calling the function (instead of the inline RE above) if a few chars
+were unescaped was something like 40% slower, and something like 700% slower if none were.  If
+you are going to unescape a lot of times it might be a good idea to
+inline the RE.
+
+If the uri_unescape() function is passed multiple strings, then each
+one is returned unescaped.
+
+=back
+
+The module can also export the C<%escapes> hash, which contains the
+mapping from all 256 bytes to the corresponding escape codes.  Lookup
+in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))>
+each time.
+
+=head1 SEE ALSO
+
+L<URI>
+
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 Gisle Aas.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+require Exporter;
+our @ISA = qw(Exporter);
+our %escapes;
+our @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8);
+our @EXPORT_OK = qw(%escapes);
+our $VERSION = "3.31";
+
+use Carp ();
+
+# Build a char->hex map
+for (0..255) {
+    $escapes{chr($_)} = sprintf("%%%02X", $_);
+}
+
+my %subst;  # compiled patterns
+
+my %Unsafe = (
+    RFC2732 => qr/[^A-Za-z0-9\-_.!~*'()]/,
+    RFC3986 => qr/[^A-Za-z0-9\-\._~]/,
+);
+
+sub uri_escape {
+    my($text, $patn) = @_;
+    return undef unless defined $text;
+    if (defined $patn){
+        unless (exists  $subst{$patn}) {
+            # Because we can't compile the regex we fake it with a cached sub
+            (my $tmp = $patn) =~ s,/,\\/,g;
+            eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1} || _fail_hi(\$1)/ge; }";
+            Carp::croak("uri_escape: $@") if $@;
+        }
+        &{$subst{$patn}}($text);
+    } else {
+        $text =~ s/($Unsafe{RFC3986})/$escapes{$1} || _fail_hi($1)/ge;
+    }
+    $text;
+}
+
+sub _fail_hi {
+    my $chr = shift;
+    Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr));
+}
+
+sub uri_escape_utf8 {
+    my $text = shift;
+    utf8::encode($text);
+    return uri_escape($text, @_);
+}
+
+sub uri_unescape {
+    # Note from RFC1630:  "Sequences which start with a percent sign
+    # but are not followed by two hexadecimal characters are reserved
+    # for future extension"
+    my $str = shift;
+    if (@_ && wantarray) {
+        # not executed for the common case of a single argument
+        my @str = ($str, @_);  # need to copy
+        for (@str) {
+            s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+        }
+        return @str;
+    }
+    $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str;
+    $str;
+}
+
+sub escape_char {
+    return join '', @URI::Escape::escapes{$_[0] =~ /(\C)/g};
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/Heuristic.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/Heuristic.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/Heuristic.pm	(revision 27174)
@@ -0,0 +1,253 @@
+package URI::Heuristic;
+
+=head1 NAME
+
+URI::Heuristic - Expand URI using heuristics
+
+=head1 SYNOPSIS
+
+ use URI::Heuristic qw(uf_uristr);
+ $u = uf_uristr("perl");             # http://www.perl.com
+ $u = uf_uristr("www.sol.no/sol");   # http://www.sol.no/sol
+ $u = uf_uristr("aas");              # http://www.aas.no
+ $u = uf_uristr("ftp.funet.fi");     # ftp://ftp.funet.fi
+ $u = uf_uristr("/etc/passwd");      # file:/etc/passwd
+
+=head1 DESCRIPTION
+
+This module provides functions that expand strings into real absolute
+URIs using some built-in heuristics.  Strings that already represent
+absolute URIs (i.e. that start with a C<scheme:> part) are never modified
+and are returned unchanged.  The main use of these functions is to
+allow abbreviated URIs similar to what many web browsers allow for URIs
+typed in by the user.
+
+The following functions are provided:
+
+=over 4
+
+=item uf_uristr($str)
+
+Tries to make the argument string
+into a proper absolute URI string.  The "uf_" prefix stands for "User 
+Friendly".  Under MacOS, it assumes that any string with a common URL 
+scheme (http, ftp, etc.) is a URL rather than a local path.  So don't name 
+your volumes after common URL schemes and expect uf_uristr() to construct 
+valid file: URL's on those volumes for you, because it won't.
+
+=item uf_uri($str)
+
+Works the same way as uf_uristr() but
+returns a C<URI> object.
+
+=back
+
+=head1 ENVIRONMENT
+
+If the hostname portion of a URI does not contain any dots, then
+certain qualified guesses are made.  These guesses are governed by
+the following environment variables:
+
+=over 10
+
+=item COUNTRY
+
+The two-letter country code (ISO 3166) for your location.  If
+the domain name of your host ends with two letters, then it is taken
+to be the default country. See also L<Locale::Country>.
+
+=item HTTP_ACCEPT_LANGUAGE, LC_ALL, LANG
+
+If COUNTRY is not set, these standard environment variables are
+examined and country (not language) information possibly found in them
+is used as the default country.
+
+=item URL_GUESS_PATTERN
+
+Contains a space-separated list of URL patterns to try.  The string
+"ACME" is for some reason used as a placeholder for the host name in
+the URL provided.  Example:
+
+ URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com"
+ export URL_GUESS_PATTERN
+
+Specifying URL_GUESS_PATTERN disables any guessing rules based on
+country.  An empty URL_GUESS_PATTERN disables any guessing that
+involves host name lookups.
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 1997-1998, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+use strict;
+
+use vars qw(@EXPORT_OK $VERSION $MY_COUNTRY %LOCAL_GUESSING $DEBUG);
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr);
+$VERSION = "4.20";
+
+sub MY_COUNTRY() {
+    for ($MY_COUNTRY) {
+	return $_ if defined;
+
+	# First try the environment.
+	$_ = $ENV{COUNTRY};
+	return $_ if defined;
+
+	# Try the country part of LC_ALL and LANG from environment
+	my @srcs = ($ENV{LC_ALL}, $ENV{LANG});
+	# ...and HTTP_ACCEPT_LANGUAGE before those if present
+	if (my $httplang = $ENV{HTTP_ACCEPT_LANGUAGE}) {
+	    # TODO: q-value processing/ordering
+	    for $httplang (split(/\s*,\s*/, $httplang)) {
+		if ($httplang =~ /^\s*([a-zA-Z]+)[_-]([a-zA-Z]{2})\s*$/) {
+		    unshift(@srcs, "${1}_${2}");
+		    last;
+		}
+	    }
+	}
+	for (@srcs) {
+	    next unless defined;
+	    return lc($1) if /^[a-zA-Z]+_([a-zA-Z]{2})(?:[.@]|$)/;
+	}
+
+	# Last bit of domain name.  This may access the network.
+	require Net::Domain;
+	my $fqdn = Net::Domain::hostfqdn();
+	$_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/;
+	return $_ if defined;
+
+	# Give up.  Defined but false.
+	return ($_ = 0);
+    }
+}
+
+%LOCAL_GUESSING =
+(
+ 'us' => [qw(www.ACME.gov www.ACME.mil)],
+ 'gb' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)],
+ 'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)],
+ 'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)],
+ # send corrections and new entries to <gisle@aas.no>
+);
+# Backwards compatibility; uk != United Kingdom in ISO 3166
+$LOCAL_GUESSING{uk} = $LOCAL_GUESSING{gb};
+
+
+sub uf_uristr ($)
+{
+    local($_) = @_;
+    print STDERR "uf_uristr: resolving $_\n" if $DEBUG;
+    return unless defined;
+
+    s/^\s+//;
+    s/\s+$//;
+
+    if (/^(www|web|home)[a-z0-9-]*(?:\.|$)/i) {
+	$_ = "http://$_";
+
+    } elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) {
+	$_ = lc($1) . "://$_";
+
+    } elsif ($^O ne "MacOS" && 
+	    (m,^/,      ||          # absolute file name
+	     m,^\.\.?/, ||          # relative file name
+	     m,^[a-zA-Z]:[/\\],)    # dosish file name
+	    )
+    {
+	$_ = "file:$_";
+
+    } elsif ($^O eq "MacOS" && m/:/) {
+        # potential MacOS file name
+	unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) {
+	    require URI::file;
+	    my $a = URI::file->new($_)->as_string;
+	    $_ = ($a =~ m/^file:/) ? $a : "file:$a";
+	}
+    } elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) {
+	$_ = "mailto:$_";
+
+    } elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) {      # no scheme specified
+	if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) {
+	    my $host = $1;
+
+	    my $scheme = "http";
+	    if (/^:(\d+)\b/) {
+		# Some more or less well known ports
+		if ($1 =~ /^[56789]?443$/) {
+		    $scheme = "https";
+		} elsif ($1 eq "21") {
+		    $scheme = "ftp";
+		}
+	    }
+
+	    if ($host !~ /\./ && $host ne "localhost") {
+		my @guess;
+		if (exists $ENV{URL_GUESS_PATTERN}) {
+		    @guess = map { s/\bACME\b/$host/; $_ }
+		             split(' ', $ENV{URL_GUESS_PATTERN});
+		} else {
+		    if (MY_COUNTRY()) {
+			my $special = $LOCAL_GUESSING{MY_COUNTRY()};
+			if ($special) {
+			    my @special = @$special;
+			    push(@guess, map { s/\bACME\b/$host/; $_ }
+                                               @special);
+			} else {
+			    push(@guess, "www.$host." . MY_COUNTRY());
+			}
+		    }
+		    push(@guess, map "www.$host.$_",
+			             "com", "org", "net", "edu", "int");
+		}
+
+
+		my $guess;
+		for $guess (@guess) {
+		    print STDERR "uf_uristr: gethostbyname('$guess.')..."
+		      if $DEBUG;
+		    if (gethostbyname("$guess.")) {
+			print STDERR "yes\n" if $DEBUG;
+			$host = $guess;
+			last;
+		    }
+		    print STDERR "no\n" if $DEBUG;
+		}
+	    }
+	    $_ = "$scheme://$host$_";
+
+	} else {
+	    # pure junk, just return it unchanged...
+
+	}
+    }
+    print STDERR "uf_uristr: ==> $_\n" if $DEBUG;
+
+    $_;
+}
+
+sub uf_uri ($)
+{
+    require URI;
+    URI->new(uf_uristr($_[0]));
+}
+
+# legacy
+*uf_urlstr = \*uf_uristr;
+
+sub uf_url ($)
+{
+    require URI::URL;
+    URI::URL->new(uf_uristr($_[0]));
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/IRI.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/IRI.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/IRI.pm	(revision 27174)
@@ -0,0 +1,44 @@
+package URI::IRI;
+
+# Experimental
+
+use strict;
+use URI ();
+
+use overload '""' => sub { shift->as_string };
+
+sub new {
+    my($class, $uri, $scheme) = @_;
+    utf8::upgrade($uri);
+    return bless {
+	uri => URI->new($uri, $scheme),
+    }, $class;
+}
+
+sub clone {
+    my $self = shift;
+    return bless {
+	uri => $self->{uri}->clone,
+    }, ref($self);
+}
+
+sub as_string {
+    my $self = shift;
+    return $self->{uri}->as_iri;
+}
+
+sub AUTOLOAD
+{
+    use vars qw($AUTOLOAD);
+    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+
+    # We create the function here so that it will not need to be
+    # autoloaded the next time.
+    no strict 'refs';
+    *$method = sub { shift->{uri}->$method(@_) };
+    goto &$method;
+}
+
+sub DESTROY {}   # avoid AUTOLOADing it
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/QueryParam.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/QueryParam.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/QueryParam.pm	(revision 27174)
@@ -0,0 +1,193 @@
+package URI::QueryParam;
+
+use strict;
+
+sub URI::_query::query_param {
+    my $self = shift;
+    my @old = $self->query_form;
+
+    if (@_ == 0) {
+	# get keys
+	my (%seen, $i);
+	return grep !($i++ % 2 || $seen{$_}++), @old;
+    }
+
+    my $key = shift;
+    my @i = grep $_ % 2 == 0 && $old[$_] eq $key, 0 .. $#old;
+
+    if (@_) {
+	my @new = @old;
+	my @new_i = @i;
+	my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
+
+	while (@new_i > @vals) {
+	    splice @new, pop @new_i, 2;
+	}
+	if (@vals > @new_i) {
+	    my $i = @new_i ? $new_i[-1] + 2 : @new;
+	    my @splice = splice @vals, @new_i, @vals - @new_i;
+
+	    splice @new, $i, 0, map { $key => $_ } @splice;
+	}
+	if (@vals) {
+	    #print "SET $new_i[0]\n";
+	    @new[ map $_ + 1, @new_i ] = @vals;
+	}
+
+	$self->query_form(\@new);
+    }
+
+    return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef;
+}
+
+sub URI::_query::query_param_append {
+    my $self = shift;
+    my $key = shift;
+    my @vals = map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_;
+    $self->query_form($self->query_form, $key => \@vals);  # XXX
+    return;
+}
+
+sub URI::_query::query_param_delete {
+    my $self = shift;
+    my $key = shift;
+    my @old = $self->query_form;
+    my @vals;
+
+    for (my $i = @old - 2; $i >= 0; $i -= 2) {
+	next if $old[$i] ne $key;
+	push(@vals, (splice(@old, $i, 2))[1]);
+    }
+    $self->query_form(\@old) if @vals;
+    return wantarray ? reverse @vals : $vals[-1];
+}
+
+sub URI::_query::query_form_hash {
+    my $self = shift;
+    my @old = $self->query_form;
+    if (@_) {
+	$self->query_form(@_ == 1 ? %{shift(@_)} : @_);
+    }
+    my %hash;
+    while (my($k, $v) = splice(@old, 0, 2)) {
+	if (exists $hash{$k}) {
+	    for ($hash{$k}) {
+		$_ = [$_] unless ref($_) eq "ARRAY";
+		push(@$_, $v);
+	    }
+	}
+	else {
+	    $hash{$k} = $v;
+	}
+    }
+    return \%hash;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::QueryParam - Additional query methods for URIs
+
+=head1 SYNOPSIS
+
+  use URI;
+  use URI::QueryParam;
+
+  $u = URI->new("", "http");
+  $u->query_param(foo => 1, 2, 3);
+  print $u->query;    # prints foo=1&foo=2&foo=3
+
+  for my $key ($u->query_param) {
+      print "$key: ", join(", ", $u->query_param($key)), "\n";
+  }
+
+=head1 DESCRIPTION
+
+Loading the C<URI::QueryParam> module adds some extra methods to
+URIs that support query methods.  These methods provide an alternative
+interface to the $u->query_form data.
+
+The query_param_* methods have deliberately been made identical to the
+interface of the corresponding C<CGI.pm> methods.
+
+The following additional methods are made available:
+
+=over
+
+=item @keys = $u->query_param
+
+=item @values = $u->query_param( $key )
+
+=item $first_value = $u->query_param( $key )
+
+=item $u->query_param( $key, $value,... )
+
+If $u->query_param is called with no arguments, it returns all the
+distinct parameter keys of the URI.  In a scalar context it returns the
+number of distinct keys.
+
+When a $key argument is given, the method returns the parameter values with the
+given key.  In a scalar context, only the first parameter value is
+returned.
+
+If additional arguments are given, they are used to update successive
+parameters with the given key.  If any of the values provided are
+array references, then the array is dereferenced to get the actual
+values.
+
+=item $u->query_param_append($key, $value,...)
+
+Adds new parameters with the given
+key without touching any old parameters with the same key.  It
+can be explained as a more efficient version of:
+
+   $u->query_param($key,
+                   $u->query_param($key),
+                   $value,...);
+
+One difference is that this expression would return the old values
+of $key, whereas the query_param_append() method does not.
+
+=item @values = $u->query_param_delete($key)
+
+=item $first_value = $u->query_param_delete($key)
+
+Deletes all key/value pairs with the given key.
+The old values are returned.  In a scalar context, only the first value
+is returned.
+
+Using the query_param_delete() method is slightly more efficient than
+the equivalent:
+
+   $u->query_param($key, []);
+
+=item $hashref = $u->query_form_hash
+
+=item $u->query_form_hash( \%new_form )
+
+Returns a reference to a hash that represents the
+query form's key/value pairs.  If a key occurs multiple times, then the hash
+value becomes an array reference.
+
+Note that sequence information is lost.  This means that:
+
+   $u->query_form_hash($u->query_form_hash);
+
+is not necessarily a no-op, as it may reorder the key/value pairs.
+The values returned by the query_param() method should stay the same
+though.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>, L<CGI>
+
+=head1 COPYRIGHT
+
+Copyright 2002 Gisle Aas.
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/URI/Split.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/Split.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/Split.pm	(revision 27174)
@@ -0,0 +1,96 @@
+package URI::Split;
+
+use strict;
+
+use vars qw(@ISA @EXPORT_OK);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(uri_split uri_join);
+
+use URI::Escape ();
+
+sub uri_split {
+     return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
+}
+
+sub uri_join {
+    my($scheme, $auth, $path, $query, $frag) = @_;
+    my $uri = defined($scheme) ? "$scheme:" : "";
+    $path = "" unless defined $path;
+    if (defined $auth) {
+	$auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
+	$uri .= "//$auth";
+	$path = "/$path" if length($path) && $path !~ m,^/,;
+    }
+    elsif ($path =~ m,^//,) {
+	$uri .= "//";  # XXX force empty auth
+    }
+    unless (length $uri) {
+	$path =~ s,(:), URI::Escape::escape_char($1),e while $path =~ m,^[^:/?\#]+:,;
+    }
+    $path =~ s,([?\#]), URI::Escape::escape_char($1),eg;
+    $uri .= $path;
+    if (defined $query) {
+	$query =~ s,(\#), URI::Escape::escape_char($1),eg;
+	$uri .= "?$query";
+    }
+    $uri .= "#$frag" if defined $frag;
+    $uri;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::Split - Parse and compose URI strings
+
+=head1 SYNOPSIS
+
+ use URI::Split qw(uri_split uri_join);
+ ($scheme, $auth, $path, $query, $frag) = uri_split($uri);
+ $uri = uri_join($scheme, $auth, $path, $query, $frag);
+
+=head1 DESCRIPTION
+
+Provides functions to parse and compose URI
+strings.  The following functions are provided:
+
+=over
+
+=item ($scheme, $auth, $path, $query, $frag) = uri_split($uri)
+
+Breaks up a URI string into its component
+parts.  An C<undef> value is returned for those parts that are not
+present.  The $path part is always present (but can be the empty
+string) and is thus never returned as C<undef>.
+
+No sensible value is returned if this function is called in a scalar
+context.
+
+=item $uri = uri_join($scheme, $auth, $path, $query, $frag)
+
+Puts together a URI string from its parts.
+Missing parts are signaled by passing C<undef> for the corresponding
+argument.
+
+Minimal escaping is applied to parts that contain reserved chars
+that would confuse a parser.  For instance, any occurrence of '?' or '#'
+in $path is always escaped, as it would otherwise be parsed back
+as a query or fragment.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>, L<URI::Escape>
+
+=head1 COPYRIGHT
+
+Copyright 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/URI/URL.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/URL.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/URL.pm	(revision 27174)
@@ -0,0 +1,305 @@
+package URI::URL;
+
+require URI::WithBase;
+@ISA=qw(URI::WithBase);
+
+use strict;
+use vars qw(@EXPORT $VERSION);
+
+$VERSION = "5.04";
+
+# Provide as much as possible of the old URI::URL interface for backwards
+# compatibility...
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT = qw(url);
+
+# Easy to use constructor
+sub url ($;$) { URI::URL->new(@_); }
+
+use URI::Escape qw(uri_unescape);
+
+sub new
+{
+    my $class = shift;
+    my $self = $class->SUPER::new(@_);
+    $self->[0] = $self->[0]->canonical;
+    $self;
+}
+
+sub newlocal
+{
+    my $class = shift;
+    require URI::file;
+    bless [URI::file->new_abs(shift)], $class;
+}
+
+{package URI::_foreign;
+    sub _init  # hope it is not defined
+    {
+	my $class = shift;
+	die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT;
+	$class->SUPER::_init(@_);
+    }
+}
+
+sub strict
+{
+    my $old = $URI::URL::STRICT;
+    $URI::URL::STRICT = shift if @_;
+    $old;
+}
+
+sub print_on
+{
+    my $self = shift;
+    require Data::Dumper;
+    print STDERR Data::Dumper::Dumper($self);
+}
+
+sub _try
+{
+    my $self = shift;
+    my $method = shift;
+    scalar(eval { $self->$method(@_) });
+}
+
+sub crack
+{
+    # should be overridden by subclasses
+    my $self = shift;
+    (scalar($self->scheme),
+     $self->_try("user"),
+     $self->_try("password"),
+     $self->_try("host"),
+     $self->_try("port"),
+     $self->_try("path"),
+     $self->_try("params"),
+     $self->_try("query"),
+     scalar($self->fragment),
+    )
+}
+
+sub full_path
+{
+    my $self = shift;
+    my $path = $self->path_query;
+    $path = "/" unless length $path;
+    $path;
+}
+
+sub netloc
+{
+    shift->authority(@_);
+}
+
+sub epath
+{
+    my $path = shift->SUPER::path(@_);
+    $path =~ s/;.*//;
+    $path;
+}
+
+sub eparams
+{
+    my $self = shift;
+    my @p = $self->path_segments;
+    return unless ref($p[-1]);
+    @p = @{$p[-1]};
+    shift @p;
+    join(";", @p);
+}
+
+sub params { shift->eparams(@_); }
+
+sub path {
+    my $self = shift;
+    my $old = $self->epath(@_);
+    return unless defined wantarray;
+    return '/' if !defined($old) || !length($old);
+    Carp::croak("Path components contain '/' (you must call epath)")
+	if $old =~ /%2[fF]/ and !@_;
+    $old = "/$old" if $old !~ m|^/| && defined $self->netloc;
+    return uri_unescape($old);
+}
+
+sub path_components {
+    shift->path_segments(@_);
+}
+
+sub query {
+    my $self = shift;
+    my $old = $self->equery(@_);
+    if (defined(wantarray) && defined($old)) {
+	if ($old =~ /%(?:26|2[bB]|3[dD])/) {  # contains escaped '=' '&' or '+'
+	    my $mess;
+	    for ($old) {
+		$mess = "Query contains both '+' and '%2B'"
+		  if /\+/ && /%2[bB]/;
+		$mess = "Form query contains escaped '=' or '&'"
+		  if /=/  && /%(?:3[dD]|26)/;
+	    }
+	    if ($mess) {
+		Carp::croak("$mess (you must call equery)");
+	    }
+	}
+	# Now it should be safe to unescape the string without loosing
+	# information
+	return uri_unescape($old);
+    }
+    undef;
+
+}
+
+sub abs
+{
+    my $self = shift;
+    my $base = shift;
+    my $allow_scheme = shift;
+    $allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME
+	unless defined $allow_scheme;
+    local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme;
+    local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS;
+    $self->SUPER::abs($base);
+}
+
+sub frag { shift->fragment(@_); }
+sub keywords { shift->query_keywords(@_); }
+
+# file:
+sub local_path { shift->file; }
+sub unix_path  { shift->file("unix"); }
+sub dos_path   { shift->file("dos");  }
+sub mac_path   { shift->file("mac");  }
+sub vms_path   { shift->file("vms");  }
+
+# mailto:
+sub address { shift->to(@_); }
+sub encoded822addr { shift->to(@_); }
+sub URI::mailto::authority { shift->to(@_); }  # make 'netloc' method work
+
+# news:
+sub groupart { shift->_group(@_); }
+sub article  { shift->message(@_); }
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::URL - Uniform Resource Locators
+
+=head1 SYNOPSIS
+
+ $u1 = URI::URL->new($str, $base);
+ $u2 = $u1->abs;
+
+=head1 DESCRIPTION
+
+This module is provided for backwards compatibility with modules that
+depend on the interface provided by the C<URI::URL> class that used to
+be distributed with the libwww-perl library.
+
+The following differences exist compared to the C<URI> class interface:
+
+=over 3
+
+=item *
+
+The URI::URL module exports the url() function as an alternate
+constructor interface.
+
+=item *
+
+The constructor takes an optional $base argument.  The C<URI::URL>
+class is a subclass of C<URI::WithBase>.
+
+=item *
+
+The URI::URL->newlocal class method is the same as URI::file->new_abs.
+
+=item *
+
+URI::URL::strict(1)
+
+=item *
+
+$url->print_on method
+
+=item *
+
+$url->crack method
+
+=item *
+
+$url->full_path: same as ($uri->abs_path || "/")
+
+=item *
+
+$url->netloc: same as $uri->authority
+
+=item *
+
+$url->epath, $url->equery: same as $uri->path, $uri->query
+
+=item *
+
+$url->path and $url->query pass unescaped strings.
+
+=item *
+
+$url->path_components: same as $uri->path_segments (if you don't
+consider path segment parameters)
+
+=item *
+
+$url->params and $url->eparams methods
+
+=item *
+
+$url->base method.  See L<URI::WithBase>.
+
+=item *
+
+$url->abs and $url->rel have an optional $base argument.  See
+L<URI::WithBase>.
+
+=item *
+
+$url->frag: same as $uri->fragment
+
+=item *
+
+$url->keywords: same as $uri->query_keywords
+
+=item *
+
+$url->localpath and friends map to $uri->file.
+
+=item *
+
+$url->address and $url->encoded822addr: same as $uri->to for mailto URI
+
+=item *
+
+$url->groupart method for news URI
+
+=item *
+
+$url->article: same as $uri->message
+
+=back
+
+
+
+=head1 SEE ALSO
+
+L<URI>, L<URI::WithBase>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2000 Gisle Aas.
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/URI/WithBase.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/WithBase.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/WithBase.pm	(revision 27174)
@@ -0,0 +1,171 @@
+package URI::WithBase;
+
+use strict;
+use vars qw($AUTOLOAD $VERSION);
+use URI;
+
+$VERSION = "2.20";
+
+use overload '""' => "as_string", fallback => 1;
+
+sub as_string;  # help overload find it
+
+sub new
+{
+    my($class, $uri, $base) = @_;
+    my $ibase = $base;
+    if ($base && ref($base) && UNIVERSAL::isa($base, __PACKAGE__)) {
+	$base = $base->abs;
+	$ibase = $base->[0];
+    }
+    bless [URI->new($uri, $ibase), $base], $class;
+}
+
+sub new_abs
+{
+    my $class = shift;
+    my $self = $class->new(@_);
+    $self->abs;
+}
+
+sub _init
+{
+    my $class = shift;
+    my($str, $scheme) = @_;
+    bless [URI->new($str, $scheme), undef], $class;
+}
+
+sub eq
+{
+    my($self, $other) = @_;
+    $other = $other->[0] if UNIVERSAL::isa($other, __PACKAGE__);
+    $self->[0]->eq($other);
+}
+
+sub AUTOLOAD
+{
+    my $self = shift;
+    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+    return if $method eq "DESTROY";
+    $self->[0]->$method(@_);
+}
+
+sub can {                                  # override UNIVERSAL::can
+    my $self = shift;
+    $self->SUPER::can(@_) || (
+      ref($self)
+      ? $self->[0]->can(@_)
+      : undef
+    )
+}
+
+sub base {
+    my $self = shift;
+    my $base  = $self->[1];
+
+    if (@_) { # set
+	my $new_base = shift;
+	# ensure absoluteness
+	$new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__);
+	$self->[1] = $new_base;
+    }
+    return unless defined wantarray;
+
+    # The base attribute supports 'lazy' conversion from URL strings
+    # to URL objects. Strings may be stored but when a string is
+    # fetched it will automatically be converted to a URL object.
+    # The main benefit is to make it much cheaper to say:
+    #   URI::WithBase->new($random_url_string, 'http:')
+    if (defined($base) && !ref($base)) {
+	$base = ref($self)->new($base);
+	$self->[1] = $base unless @_;
+    }
+    $base;
+}
+
+sub clone
+{
+    my $self = shift;
+    my $base = $self->[1];
+    $base = $base->clone if ref($base);
+    bless [$self->[0]->clone, $base], ref($self);
+}
+
+sub abs
+{
+    my $self = shift;
+    my $base = shift || $self->base || return $self->clone;
+    $base = $base->as_string if ref($base);
+    bless [$self->[0]->abs($base, @_), $base], ref($self);
+}
+
+sub rel
+{
+    my $self = shift;
+    my $base = shift || $self->base || return $self->clone;
+    $base = $base->as_string if ref($base);
+    bless [$self->[0]->rel($base, @_), $base], ref($self);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::WithBase - URIs which remember their base
+
+=head1 SYNOPSIS
+
+ $u1 = URI::WithBase->new($str, $base);
+ $u2 = $u1->abs;
+
+ $base = $u1->base;
+ $u1->base( $new_base )
+
+=head1 DESCRIPTION
+
+This module provides the C<URI::WithBase> class.  Objects of this class
+are like C<URI> objects, but can keep their base too.  The base
+represents the context where this URI was found and can be used to
+absolutize or relativize the URI.  All the methods described in L<URI>
+are supported for C<URI::WithBase> objects.
+
+The methods provided in addition to or modified from those of C<URI> are:
+
+=over 4
+
+=item $uri = URI::WithBase->new($str, [$base])
+
+The constructor takes an optional base URI as the second argument.
+If provided, this argument initializes the base attribute.
+
+=item $uri->base( [$new_base] )
+
+Can be used to get or set the value of the base attribute.
+The return value, which is the old value, is a URI object or C<undef>.
+
+=item $uri->abs( [$base_uri] )
+
+The $base_uri argument is now made optional as the object carries its
+base with it.  A new object is returned even if $uri is already
+absolute (while plain URI objects simply return themselves in
+that case).
+
+=item $uri->rel( [$base_uri] )
+
+The $base_uri argument is now made optional as the object carries its
+base with it.  A new object is always returned.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<URI>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2002 Gisle Aas.
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/URI/_foreign.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_foreign.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_foreign.pm	(revision 27174)
@@ -0,0 +1,6 @@
+package URI::_foreign;
+
+require URI::_generic;
+@ISA=qw(URI::_generic);
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/_generic.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_generic.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_generic.pm	(revision 27174)
@@ -0,0 +1,252 @@
+package URI::_generic;
+require URI;
+require URI::_query;
+@ISA=qw(URI URI::_query);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+use Carp ();
+
+my $ACHAR = $URI::uric;  $ACHAR =~ s,\\[/?],,g;
+my $PCHAR = $URI::uric;  $PCHAR =~ s,\\[?],,g;
+
+sub _no_scheme_ok { 1 }
+
+sub authority
+{
+    my $self = shift;
+    $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;
+
+    if (@_) {
+	my $auth = shift;
+	$$self = $1;
+	my $rest = $3;
+	if (defined $auth) {
+	    $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego;
+	    utf8::downgrade($auth);
+	    $$self .= "//$auth";
+	}
+	_check_path($rest, $$self);
+	$$self .= $rest;
+    }
+    $2;
+}
+
+sub path
+{
+    my $self = shift;
+    $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;
+
+    if (@_) {
+	$$self = $1;
+	my $rest = $3;
+	my $new_path = shift;
+	$new_path = "" unless defined $new_path;
+	$new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego;
+	utf8::downgrade($new_path);
+	_check_path($new_path, $$self);
+	$$self .= $new_path . $rest;
+    }
+    $2;
+}
+
+sub path_query
+{
+    my $self = shift;
+    $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;
+
+    if (@_) {
+	$$self = $1;
+	my $rest = $3;
+	my $new_path = shift;
+	$new_path = "" unless defined $new_path;
+	$new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
+	utf8::downgrade($new_path);
+	_check_path($new_path, $$self);
+	$$self .= $new_path . $rest;
+    }
+    $2;
+}
+
+sub _check_path
+{
+    my($path, $pre) = @_;
+    my $prefix;
+    if ($pre =~ m,/,) {  # authority present
+	$prefix = "/" if length($path) && $path !~ m,^[/?\#],;
+    }
+    else {
+	if ($path =~ m,^//,) {
+	    Carp::carp("Path starting with double slash is confusing")
+		if $^W;
+	}
+	elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
+	    Carp::carp("Path might look like scheme, './' prepended")
+		if $^W;
+	    $prefix = "./";
+	}
+    }
+    substr($_[0], 0, 0) = $prefix if defined $prefix;
+}
+
+sub path_segments
+{
+    my $self = shift;
+    my $path = $self->path;
+    if (@_) {
+	my @arg = @_;  # make a copy
+	for (@arg) {
+	    if (ref($_)) {
+		my @seg = @$_;
+		$seg[0] =~ s/%/%25/g;
+		for (@seg) { s/;/%3B/g; }
+		$_ = join(";", @seg);
+	    }
+	    else {
+		 s/%/%25/g; s/;/%3B/g;
+	    }
+	    s,/,%2F,g;
+	}
+	$self->path(join("/", @arg));
+    }
+    return $path unless wantarray;
+    map {/;/ ? $self->_split_segment($_)
+             : uri_unescape($_) }
+        split('/', $path, -1);
+}
+
+
+sub _split_segment
+{
+    my $self = shift;
+    require URI::_segment;
+    URI::_segment->new(@_);
+}
+
+
+sub abs
+{
+    my $self = shift;
+    my $base = shift || Carp::croak("Missing base argument");
+
+    if (my $scheme = $self->scheme) {
+	return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
+	$base = URI->new($base) unless ref $base;
+	return $self unless $scheme eq $base->scheme;
+    }
+
+    $base = URI->new($base) unless ref $base;
+    my $abs = $self->clone;
+    $abs->scheme($base->scheme);
+    return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
+    $abs->authority($base->authority);
+
+    my $path = $self->path;
+    return $abs if $path =~ m,^/,;
+
+    if (!length($path)) {
+	my $abs = $base->clone;
+	my $query = $self->query;
+	$abs->query($query) if defined $query;
+	$abs->fragment($self->fragment);
+	return $abs;
+    }
+
+    my $p = $base->path;
+    $p =~ s,[^/]+$,,;
+    $p .= $path;
+    my @p = split('/', $p, -1);
+    shift(@p) if @p && !length($p[0]);
+    my $i = 1;
+    while ($i < @p) {
+	#print "$i ", join("/", @p), " ($p[$i])\n";
+	if ($p[$i-1] eq ".") {
+	    splice(@p, $i-1, 1);
+	    $i-- if $i > 1;
+	}
+	elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
+	    splice(@p, $i-1, 2);
+	    if ($i > 1) {
+		$i--;
+		push(@p, "") if $i == @p;
+	    }
+	}
+	else {
+	    $i++;
+	}
+    }
+    $p[-1] = "" if @p && $p[-1] eq ".";  # trailing "/."
+    if ($URI::ABS_REMOTE_LEADING_DOTS) {
+        shift @p while @p && $p[0] =~ /^\.\.?$/;
+    }
+    $abs->path("/" . join("/", @p));
+    $abs;
+}
+
+# The opposite of $url->abs.  Return a URI which is as relative as possible
+sub rel {
+    my $self = shift;
+    my $base = shift || Carp::croak("Missing base argument");
+    my $rel = $self->clone;
+    $base = URI->new($base) unless ref $base;
+
+    #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
+    my $scheme = $rel->scheme;
+    my $auth   = $rel->canonical->authority;
+    my $path   = $rel->path;
+
+    if (!defined($scheme) && !defined($auth)) {
+	# it is already relative
+	return $rel;
+    }
+
+    #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
+    my $bscheme = $base->scheme;
+    my $bauth   = $base->canonical->authority;
+    my $bpath   = $base->path;
+
+    for ($bscheme, $bauth, $auth) {
+	$_ = '' unless defined
+    }
+
+    unless ($scheme eq $bscheme && $auth eq $bauth) {
+	# different location, can't make it relative
+	return $rel;
+    }
+
+    for ($path, $bpath) {  $_ = "/$_" unless m,^/,; }
+
+    # Make it relative by eliminating scheme and authority
+    $rel->scheme(undef);
+    $rel->authority(undef);
+
+    # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
+    # First we calculate common initial path components length ($li).
+    my $li = 1;
+    while (1) {
+	my $i = index($path, '/', $li);
+	last if $i < 0 ||
+                $i != index($bpath, '/', $li) ||
+	        substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
+	$li=$i+1;
+    }
+    # then we nuke it from both paths
+    substr($path, 0,$li) = '';
+    substr($bpath,0,$li) = '';
+
+    if ($path eq $bpath &&
+        defined($rel->fragment) &&
+        !defined($rel->query)) {
+        $rel->path("");
+    }
+    else {
+        # Add one "../" for each path component left in the base path
+        $path = ('../' x $bpath =~ tr|/|/|) . $path;
+	$path = "./" if $path eq "";
+        $rel->path($path);
+    }
+
+    $rel;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/_idna.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_idna.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_idna.pm	(revision 27174)
@@ -0,0 +1,87 @@
+package URI::_idna;
+
+# This module implements the RFCs 3490 (IDNA) and 3491 (Nameprep)
+# based on Python-2.6.4/Lib/encodings/idna.py
+
+use strict;
+use URI::_punycode qw(encode_punycode decode_punycode);
+use Carp qw(croak);
+
+BEGIN {
+  *URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS = $] < 5.008_003
+    ? sub () { 1 }
+    : sub () { 0 }
+  ;
+}
+
+my $ASCII = qr/^[\x00-\x7F]*\z/;
+
+sub encode {
+    my $idomain = shift;
+    my @labels = split(/\./, $idomain, -1);
+    my @last_empty;
+    push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq "";
+    for (@labels) {
+	$_ = ToASCII($_);
+    }
+
+    return eval 'join(".", @labels, @last_empty)' if URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS;
+    return join(".", @labels, @last_empty);
+}
+
+sub decode {
+    my $domain = shift;
+    return join(".", map ToUnicode($_), split(/\./, $domain, -1))
+}
+
+sub nameprep { # XXX real implementation missing
+    my $label = shift;
+    $label = lc($label);
+    return $label;
+}
+
+sub check_size {
+    my $label = shift;
+    croak "Label empty" if $label eq "";
+    croak "Label too long" if length($label) > 63;
+    return $label;
+}
+
+sub ToASCII {
+    my $label = shift;
+    return check_size($label) if $label =~ $ASCII;
+
+    # Step 2: nameprep
+    $label = nameprep($label);
+    # Step 3: UseSTD3ASCIIRules is false
+    # Step 4: try ASCII again
+    return check_size($label) if $label =~ $ASCII;
+
+    # Step 5: Check ACE prefix
+    if ($label =~ /^xn--/) {
+        croak "Label starts with ACE prefix";
+    }
+
+    # Step 6: Encode with PUNYCODE
+    $label = encode_punycode($label);
+
+    # Step 7: Prepend ACE prefix
+    $label = "xn--$label";
+
+    # Step 8: Check size
+    return check_size($label);
+}
+
+sub ToUnicode {
+    my $label = shift;
+    $label = nameprep($label) unless $label =~ $ASCII;
+    return $label unless $label =~ /^xn--/;
+    my $result = decode_punycode(substr($label, 4));
+    my $label2 = ToASCII($result);
+    if (lc($label) ne $label2) {
+	croak "IDNA does not round-trip: '\L$label\E' vs '$label2'";
+    }
+    return $result;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/_ldap.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_ldap.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_ldap.pm	(revision 27174)
@@ -0,0 +1,140 @@
+# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package URI::_ldap;
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = "1.12";
+
+use URI::Escape qw(uri_unescape);
+
+sub _ldap_elem {
+  my $self  = shift;
+  my $elem  = shift;
+  my $query = $self->query;
+  my @bits  = (split(/\?/,defined($query) ? $query : ""),("")x4);
+  my $old   = $bits[$elem];
+
+  if (@_) {
+    my $new = shift;
+    $new =~ s/\?/%3F/g;
+    $bits[$elem] = $new;
+    $query = join("?",@bits);
+    $query =~ s/\?+$//;
+    $query = undef unless length($query);
+    $self->query($query);
+  }
+
+  $old;
+}
+
+sub dn {
+  my $old = shift->path(@_);
+  $old =~ s:^/::;
+  uri_unescape($old);
+}
+
+sub attributes {
+  my $self = shift;
+  my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ());
+  return $old unless wantarray;
+  map { uri_unescape($_) } split(/,/,$old);
+}
+
+sub _scope {
+  my $self = shift;
+  my $old = _ldap_elem($self,1, @_);
+  return unless defined wantarray && defined $old;
+  uri_unescape($old);
+}
+
+sub scope {
+  my $old = &_scope;
+  $old = "base" unless length $old;
+  $old;
+}
+
+sub _filter {
+  my $self = shift;
+  my $old = _ldap_elem($self,2, @_);
+  return unless defined wantarray && defined $old;
+  uri_unescape($old); # || "(objectClass=*)";
+}
+
+sub filter {
+  my $old = &_filter;
+  $old = "(objectClass=*)" unless length $old;
+  $old;
+}
+
+sub extensions {
+  my $self = shift;
+  my @ext;
+  while (@_) {
+    my $key = shift;
+    my $value = shift;
+    push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value));
+  }
+  @ext = join(",", @ext) if @ext;
+  my $old = _ldap_elem($self,3, @ext);
+  return $old unless wantarray;
+  map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old);
+}
+
+sub canonical
+{
+    my $self = shift;
+    my $other = $self->_nonldap_canonical;
+
+    # The stuff below is not as efficient as one might hope...
+
+    $other = $other->clone if $other == $self;
+
+    $other->dn(_normalize_dn($other->dn));
+
+    # Should really know about mixed case "postalAddress", etc...
+    $other->attributes(map lc, $other->attributes);
+
+    # Lowercase scope, remove default
+    my $old_scope = $other->scope;
+    my $new_scope = lc($old_scope);
+    $new_scope = "" if $new_scope eq "base";
+    $other->scope($new_scope) if $new_scope ne $old_scope;
+
+    # Remove filter if default
+    my $old_filter = $other->filter;
+    $other->filter("") if lc($old_filter) eq "(objectclass=*)" ||
+	                  lc($old_filter) eq "objectclass=*";
+
+    # Lowercase extensions types and deal with known extension values
+    my @ext = $other->extensions;
+    for (my $i = 0; $i < @ext; $i += 2) {
+	my $etype = $ext[$i] = lc($ext[$i]);
+	if ($etype =~ /^!?bindname$/) {
+	    $ext[$i+1] = _normalize_dn($ext[$i+1]);
+	}
+    }
+    $other->extensions(@ext) if @ext;
+    
+    $other;
+}
+
+sub _normalize_dn  # RFC 2253
+{
+    my $dn = shift;
+
+    return $dn;
+    # The code below will fail if the "+" or "," is embedding in a quoted
+    # string or simply escaped...
+
+    my @dn = split(/([+,])/, $dn);
+    for (@dn) {
+	s/^([a-zA-Z]+=)/lc($1)/e;
+    }
+    join("", @dn);
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/_login.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_login.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_login.pm	(revision 27174)
@@ -0,0 +1,10 @@
+package URI::_login;
+
+require URI::_server;
+require URI::_userpass;
+@ISA = qw(URI::_server URI::_userpass);
+
+# Generic terminal logins.  This is used as a base class for 'telnet',
+# 'tn3270', and 'rlogin' URL schemes.
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/_punycode.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_punycode.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_punycode.pm	(revision 27174)
@@ -0,0 +1,202 @@
+package URI::_punycode;
+
+use strict;
+our $VERSION = "0.04";
+
+require Exporter;
+our @ISA    = qw(Exporter);
+our @EXPORT = qw(encode_punycode decode_punycode);
+
+use integer;
+
+our $DEBUG = 0;
+
+use constant BASE => 36;
+use constant TMIN => 1;
+use constant TMAX => 26;
+use constant SKEW => 38;
+use constant DAMP => 700;
+use constant INITIAL_BIAS => 72;
+use constant INITIAL_N => 128;
+
+my $Delimiter = chr 0x2D;
+my $BasicRE   = qr/[\x00-\x7f]/;
+
+sub _croak { require Carp; Carp::croak(@_); }
+
+sub digit_value {
+    my $code = shift;
+    return ord($code) - ord("A") if $code =~ /[A-Z]/;
+    return ord($code) - ord("a") if $code =~ /[a-z]/;
+    return ord($code) - ord("0") + 26 if $code =~ /[0-9]/;
+    return;
+}
+
+sub code_point {
+    my $digit = shift;
+    return $digit + ord('a') if 0 <= $digit && $digit <= 25;
+    return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36;
+    die 'NOT COME HERE';
+}
+
+sub adapt {
+    my($delta, $numpoints, $firsttime) = @_;
+    $delta = $firsttime ? $delta / DAMP : $delta / 2;
+    $delta += $delta / $numpoints;
+    my $k = 0;
+    while ($delta > ((BASE - TMIN) * TMAX) / 2) {
+	$delta /= BASE - TMIN;
+	$k += BASE;
+    }
+    return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW));
+}
+
+sub decode_punycode {
+    my $code = shift;
+
+    my $n      = INITIAL_N;
+    my $i      = 0;
+    my $bias   = INITIAL_BIAS;
+    my @output;
+
+    if ($code =~ s/(.*)$Delimiter//o) {
+	push @output, map ord, split //, $1;
+	return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o;
+    }
+
+    while ($code) {
+	my $oldi = $i;
+	my $w    = 1;
+    LOOP:
+	for (my $k = BASE; 1; $k += BASE) {
+	    my $cp = substr($code, 0, 1, '');
+	    my $digit = digit_value($cp);
+	    defined $digit or return _croak("invalid punycode input");
+	    $i += $digit * $w;
+	    my $t = ($k <= $bias) ? TMIN
+		: ($k >= $bias + TMAX) ? TMAX : $k - $bias;
+	    last LOOP if $digit < $t;
+	    $w *= (BASE - $t);
+	}
+	$bias = adapt($i - $oldi, @output + 1, $oldi == 0);
+	warn "bias becomes $bias" if $DEBUG;
+	$n += $i / (@output + 1);
+	$i = $i % (@output + 1);
+	splice(@output, $i, 0, $n);
+	warn join " ", map sprintf('%04x', $_), @output if $DEBUG;
+	$i++;
+    }
+    return join '', map chr, @output;
+}
+
+sub encode_punycode {
+    my $input = shift;
+    my @input = split //, $input;
+
+    my $n     = INITIAL_N;
+    my $delta = 0;
+    my $bias  = INITIAL_BIAS;
+
+    my @output;
+    my @basic = grep /$BasicRE/, @input;
+    my $h = my $b = @basic;
+    push @output, @basic;
+    push @output, $Delimiter if $b && $h < @input;
+    warn "basic codepoints: (@output)" if $DEBUG;
+
+    while ($h < @input) {
+	my $m = min(grep { $_ >= $n } map ord, @input);
+	warn sprintf "next code point to insert is %04x", $m if $DEBUG;
+	$delta += ($m - $n) * ($h + 1);
+	$n = $m;
+	for my $i (@input) {
+	    my $c = ord($i);
+	    $delta++ if $c < $n;
+	    if ($c == $n) {
+		my $q = $delta;
+	    LOOP:
+		for (my $k = BASE; 1; $k += BASE) {
+		    my $t = ($k <= $bias) ? TMIN :
+			($k >= $bias + TMAX) ? TMAX : $k - $bias;
+		    last LOOP if $q < $t;
+		    my $cp = code_point($t + (($q - $t) % (BASE - $t)));
+		    push @output, chr($cp);
+		    $q = ($q - $t) / (BASE - $t);
+		}
+		push @output, chr(code_point($q));
+		$bias = adapt($delta, $h + 1, $h == $b);
+		warn "bias becomes $bias" if $DEBUG;
+		$delta = 0;
+		$h++;
+	    }
+	}
+	$delta++;
+	$n++;
+    }
+    return join '', @output;
+}
+
+sub min {
+    my $min = shift;
+    for (@_) { $min = $_ if $_ <= $min }
+    return $min;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+URI::_punycode - encodes Unicode string in Punycode
+
+=head1 SYNOPSIS
+
+  use URI::_punycode;
+  $punycode = encode_punycode($unicode);
+  $unicode  = decode_punycode($punycode);
+
+=head1 DESCRIPTION
+
+URI::_punycode is a module to encode / decode Unicode strings into
+Punycode, an efficient encoding of Unicode for use with IDNA.
+
+This module requires Perl 5.6.0 or over to handle UTF8 flagged Unicode
+strings.
+
+=head1 FUNCTIONS
+
+This module exports following functions by default.
+
+=over 4
+
+=item encode_punycode
+
+  $punycode = encode_punycode($unicode);
+
+takes Unicode string (UTF8-flagged variable) and returns Punycode
+encoding for it.
+
+=item decode_punycode
+
+  $unicode = decode_punycode($punycode)
+
+takes Punycode encoding and returns original Unicode string.
+
+=back
+
+These functions throw exceptions on failure. You can catch 'em via
+C<eval>.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt> is the author of
+IDNA::Punycode v0.02 which was the basis for this module.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<IDNA::Punycode>, RFC 3492
+
+=cut
Index: /main/trunk/greenstone2/perllib/cpan/URI/_query.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_query.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_query.pm	(revision 27174)
@@ -0,0 +1,93 @@
+package URI::_query;
+
+use strict;
+use URI ();
+use URI::Escape qw(uri_unescape);
+
+sub query
+{
+    my $self = shift;
+    $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die;
+
+    if (@_) {
+	my $q = shift;
+	$$self = $1;
+	if (defined $q) {
+	    $q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
+	    utf8::downgrade($q);
+	    $$self .= "?$q";
+	}
+	$$self .= $3;
+    }
+    $2;
+}
+
+# Handle ...?foo=bar&bar=foo type of query
+sub query_form {
+    my $self = shift;
+    my $old = $self->query;
+    if (@_) {
+        # Try to set query string
+        my $delim;
+        my $r = $_[0];
+        if (ref($r) eq "ARRAY") {
+            $delim = $_[1];
+            @_ = @$r;
+        }
+        elsif (ref($r) eq "HASH") {
+            $delim = $_[1];
+            @_ = %$r;
+        }
+        $delim = pop if @_ % 2;
+
+        my @query;
+        while (my($key,$vals) = splice(@_, 0, 2)) {
+            $key = '' unless defined $key;
+	    $key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
+	    $key =~ s/ /+/g;
+	    $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals];
+            for my $val (@$vals) {
+                $val = '' unless defined $val;
+		$val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
+                $val =~ s/ /+/g;
+                push(@query, "$key=$val");
+            }
+        }
+        if (@query) {
+            unless ($delim) {
+                $delim = $1 if $old && $old =~ /([&;])/;
+                $delim ||= $URI::DEFAULT_QUERY_FORM_DELIMITER || "&";
+            }
+            $self->query(join($delim, @query));
+        }
+        else {
+            $self->query(undef);
+        }
+    }
+    return if !defined($old) || !length($old) || !defined(wantarray);
+    return unless $old =~ /=/; # not a form
+    map { s/\+/ /g; uri_unescape($_) }
+         map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old);
+}
+
+# Handle ...?dog+bones type of query
+sub query_keywords
+{
+    my $self = shift;
+    my $old = $self->query;
+    if (@_) {
+        # Try to set query string
+	my @copy = @_;
+	@copy = @{$copy[0]} if @copy == 1 && ref($copy[0]) eq "ARRAY";
+	for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; }
+	$self->query(@copy ? join('+', @copy) : undef);
+    }
+    return if !defined($old) || !defined(wantarray);
+    return if $old =~ /=/;  # not keywords, but a form
+    map { uri_unescape($_) } split(/\+/, $old, -1);
+}
+
+# Some URI::URL compatibility stuff
+*equery = \&query;
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/_segment.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_segment.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_segment.pm	(revision 27174)
@@ -0,0 +1,20 @@
+package URI::_segment;
+
+# Represents a generic path_segment so that it can be treated as
+# a string too.
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+use overload '""' => sub { $_[0]->[0] },
+             fallback => 1;
+
+sub new
+{
+    my $class = shift;
+    my @segment = split(';', shift, -1);
+    $segment[0] = uri_unescape($segment[0]);
+    bless \@segment, $class;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/_server.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_server.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_server.pm	(revision 27174)
@@ -0,0 +1,162 @@
+package URI::_server;
+require URI::_generic;
+@ISA=qw(URI::_generic);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+sub _uric_escape {
+    my($class, $str) = @_;
+    if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
+	my($scheme, $host, $rest) = ($1, $2, $3);
+	my $ui = $host =~ s/(.*@)// ? $1 : "";
+	my $port = $host =~ s/(:\d+)\z// ? $1 : "";
+	if (_host_escape($host)) {
+	    $str = "$scheme//$ui$host$port$rest";
+	}
+    }
+    return $class->SUPER::_uric_escape($str);
+}
+
+sub _host_escape {
+    return unless $_[0] =~ /[^URI::uric]/;
+    eval {
+	require URI::_idna;
+	$_[0] = URI::_idna::encode($_[0]);
+    };
+    return 0 if $@;
+    return 1;
+}
+
+sub as_iri {
+    my $self = shift;
+    my $str = $self->SUPER::as_iri;
+    if ($str =~ /\bxn--/) {
+	if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
+	    my($scheme, $host, $rest) = ($1, $2, $3);
+	    my $ui = $host =~ s/(.*@)// ? $1 : "";
+	    my $port = $host =~ s/(:\d+)\z// ? $1 : "";
+	    require URI::_idna;
+	    $host = URI::_idna::decode($host);
+	    $str = "$scheme//$ui$host$port$rest";
+	}
+    }
+    return $str;
+}
+
+sub userinfo
+{
+    my $self = shift;
+    my $old = $self->authority;
+
+    if (@_) {
+	my $new = $old;
+	$new = "" unless defined $new;
+	$new =~ s/.*@//;  # remove old stuff
+	my $ui = shift;
+	if (defined $ui) {
+	    $ui =~ s/@/%40/g;   # protect @
+	    $new = "$ui\@$new";
+	}
+	$self->authority($new);
+    }
+    return undef if !defined($old) || $old !~ /(.*)@/;
+    return $1;
+}
+
+sub host
+{
+    my $self = shift;
+    my $old = $self->authority;
+    if (@_) {
+	my $tmp = $old;
+	$tmp = "" unless defined $tmp;
+	my $ui = ($tmp =~ /(.*@)/) ? $1 : "";
+	my $port = ($tmp =~ /(:\d+)$/) ? $1 : "";
+	my $new = shift;
+	$new = "" unless defined $new;
+	if (length $new) {
+	    $new =~ s/[@]/%40/g;   # protect @
+	    if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) {
+		$new =~ s/(:\d*)\z// || die "Assert";
+		$port = $1;
+	    }
+	    $new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address
+	    _host_escape($new);
+	}
+	$self->authority("$ui$new$port");
+    }
+    return undef unless defined $old;
+    $old =~ s/.*@//;
+    $old =~ s/:\d+$//;          # remove the port
+    $old =~ s{^\[(.*)\]$}{$1};  # remove brackets around IPv6 (RFC 3986 3.2.2)
+    return uri_unescape($old);
+}
+
+sub ihost
+{
+    my $self = shift;
+    my $old = $self->host(@_);
+    if ($old =~ /(^|\.)xn--/) {
+	require URI::_idna;
+	$old = URI::_idna::decode($old);
+    }
+    return $old;
+}
+
+sub _port
+{
+    my $self = shift;
+    my $old = $self->authority;
+    if (@_) {
+	my $new = $old;
+	$new =~ s/:\d*$//;
+	my $port = shift;
+	$new .= ":$port" if defined $port;
+	$self->authority($new);
+    }
+    return $1 if defined($old) && $old =~ /:(\d*)$/;
+    return;
+}
+
+sub port
+{
+    my $self = shift;
+    my $port = $self->_port(@_);
+    $port = $self->default_port if !defined($port) || $port eq "";
+    $port;
+}
+
+sub host_port
+{
+    my $self = shift;
+    my $old = $self->authority;
+    $self->host(shift) if @_;
+    return undef unless defined $old;
+    $old =~ s/.*@//;        # zap userinfo
+    $old =~ s/:$//;         # empty port should be treated the same a no port
+    $old .= ":" . $self->port unless $old =~ /:\d+$/;
+    $old;
+}
+
+
+sub default_port { undef }
+
+sub canonical
+{
+    my $self = shift;
+    my $other = $self->SUPER::canonical;
+    my $host = $other->host || "";
+    my $port = $other->_port;
+    my $uc_host = $host =~ /[A-Z]/;
+    my $def_port = defined($port) && ($port eq "" ||
+                                      $port == $self->default_port);
+    if ($uc_host || $def_port) {
+	$other = $other->clone if $other == $self;
+	$other->host(lc $host) if $uc_host;
+	$other->port(undef)    if $def_port;
+    }
+    $other;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/_userpass.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/_userpass.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/_userpass.pm	(revision 27174)
@@ -0,0 +1,51 @@
+package URI::_userpass;
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+sub user
+{
+    my $self = shift;
+    my $info = $self->userinfo;
+    if (@_) {
+	my $new = shift;
+	my $pass = defined($info) ? $info : "";
+	$pass =~ s/^[^:]*//;
+
+	if (!defined($new) && !length($pass)) {
+	    $self->userinfo(undef);
+	} else {
+	    $new = "" unless defined($new);
+	    $new =~ s/%/%25/g;
+	    $new =~ s/:/%3A/g;
+	    $self->userinfo("$new$pass");
+	}
+    }
+    return unless defined $info;
+    $info =~ s/:.*//;
+    uri_unescape($info);
+}
+
+sub password
+{
+    my $self = shift;
+    my $info = $self->userinfo;
+    if (@_) {
+	my $new = shift;
+	my $user = defined($info) ? $info : "";
+	$user =~ s/:.*//;
+
+	if (!defined($new) && !length($user)) {
+	    $self->userinfo(undef);
+	} else {
+	    $new = "" unless defined($new);
+	    $new =~ s/%/%25/g;
+	    $self->userinfo("$user:$new");
+	}
+    }
+    return unless defined $info;
+    return unless $info =~ s/^[^:]*://;
+    uri_unescape($info);
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/data.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/data.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/data.pm	(revision 27174)
@@ -0,0 +1,140 @@
+package URI::data;  # RFC 2397
+
+require URI;
+@ISA=qw(URI);
+
+use strict;
+
+use MIME::Base64 qw(encode_base64 decode_base64);
+use URI::Escape  qw(uri_unescape);
+
+sub media_type
+{
+    my $self = shift;
+    my $opaque = $self->opaque;
+    $opaque =~ /^([^,]*),?/ or die;
+    my $old = $1;
+    my $base64;
+    $base64 = $1 if $old =~ s/(;base64)$//i;
+    if (@_) {
+	my $new = shift;
+	$new = "" unless defined $new;
+	$new =~ s/%/%25/g;
+	$new =~ s/,/%2C/g;
+	$base64 = "" unless defined $base64;
+	$opaque =~ s/^[^,]*,?/$new$base64,/;
+	$self->opaque($opaque);
+    }
+    return uri_unescape($old) if $old;  # media_type can't really be "0"
+    "text/plain;charset=US-ASCII";      # default type
+}
+
+sub data
+{
+    my $self = shift;
+    my($enc, $data) = split(",", $self->opaque, 2);
+    unless (defined $data) {
+	$data = "";
+	$enc  = "" unless defined $enc;
+    }
+    my $base64 = ($enc =~ /;base64$/i);
+    if (@_) {
+	$enc =~ s/;base64$//i if $base64;
+	my $new = shift;
+	$new = "" unless defined $new;
+	my $uric_count = _uric_count($new);
+	my $urienc_len = $uric_count + (length($new) - $uric_count) * 3;
+	my $base64_len = int((length($new)+2) / 3) * 4;
+	$base64_len += 7;  # because of ";base64" marker
+	if ($base64_len < $urienc_len || $_[0]) {
+	    $enc .= ";base64";
+	    $new = encode_base64($new, "");
+	} else {
+	    $new =~ s/%/%25/g;
+	}
+	$self->opaque("$enc,$new");
+    }
+    return unless defined wantarray;
+    $data = uri_unescape($data);
+    return $base64 ? decode_base64($data) : $data;
+}
+
+# I could not find a better way to interpolate the tr/// chars from
+# a variable.
+my $ENC = $URI::uric;
+$ENC =~ s/%//;
+
+eval <<EOT; die $@ if $@;
+sub _uric_count
+{
+    \$_[0] =~ tr/$ENC//;
+}
+EOT
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::data - URI that contains immediate data
+
+=head1 SYNOPSIS
+
+ use URI;
+
+ $u = URI->new("data:");
+ $u->media_type("image/gif");
+ $u->data(scalar(`cat camel.gif`));
+ print "$u\n";
+ open(XV, "|xv -") and print XV $u->data;
+
+=head1 DESCRIPTION
+
+The C<URI::data> class supports C<URI> objects belonging to the I<data>
+URI scheme.  The I<data> URI scheme is specified in RFC 2397.  It
+allows inclusion of small data items as "immediate" data, as if it had
+been included externally.  Examples:
+
+  data:,Perl%20is%20good
+
+  data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI
+    AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG
+    Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p
+    KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI
+    JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs=
+
+
+
+C<URI> objects belonging to the data scheme support the common methods
+(described in L<URI>) and the following two scheme-specific methods:
+
+=over 4
+
+=item $uri->media_type( [$new_media_type] )
+
+Can be used to get or set the media type specified in the
+URI.  If no media type is specified, then the default
+C<"text/plain;charset=US-ASCII"> is returned.
+
+=item $uri->data( [$new_data] )
+
+Can be used to get or set the data contained in the URI.
+The data is passed unescaped (in binary form).  The decision about
+whether to base64 encode the data in the URI is taken automatically,
+based on the encoding that produces the shorter URI string.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>
+
+=head1 COPYRIGHT
+
+Copyright 1995-1998 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/URI/file.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/file.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/file.pm	(revision 27174)
@@ -0,0 +1,328 @@
+package URI::file;
+
+use strict;
+use vars qw(@ISA $VERSION $DEFAULT_AUTHORITY %OS_CLASS);
+
+require URI::_generic;
+@ISA = qw(URI::_generic);
+$VERSION = "4.21";
+
+use URI::Escape qw(uri_unescape);
+
+$DEFAULT_AUTHORITY = "";
+
+# Map from $^O values to implementation classes.  The Unix
+# class is the default.
+%OS_CLASS = (
+     os2     => "OS2",
+     mac     => "Mac",
+     MacOS   => "Mac",
+     MSWin32 => "Win32",
+     win32   => "Win32",
+     msdos   => "FAT",
+     dos     => "FAT",
+     qnx     => "QNX",
+);
+
+sub os_class
+{
+    my($OS) = shift || $^O;
+
+    my $class = "URI::file::" . ($OS_CLASS{$OS} || "Unix");
+    no strict 'refs';
+    unless (%{"$class\::"}) {
+	eval "require $class";
+	die $@ if $@;
+    }
+    $class;
+}
+
+sub host { uri_unescape(shift->authority(@_)) }
+
+sub new
+{
+    my($class, $path, $os) = @_;
+    os_class($os)->new($path);
+}
+
+sub new_abs
+{
+    my $class = shift;
+    my $file = $class->new(@_);
+    return $file->abs($class->cwd) unless $$file =~ /^file:/;
+    $file;
+}
+
+sub cwd
+{
+    my $class = shift;
+    require Cwd;
+    my $cwd = Cwd::cwd();
+    $cwd = VMS::Filespec::unixpath($cwd) if $^O eq 'VMS';
+    $cwd = $class->new($cwd);
+    $cwd .= "/" unless substr($cwd, -1, 1) eq "/";
+    $cwd;
+}
+
+sub canonical {
+    my $self = shift;
+    my $other = $self->SUPER::canonical;
+
+    my $scheme = $other->scheme;
+    my $auth = $other->authority;
+    return $other if !defined($scheme) && !defined($auth);  # relative
+
+    if (!defined($auth) ||
+	$auth eq "" ||
+	lc($auth) eq "localhost" ||
+	(defined($DEFAULT_AUTHORITY) && lc($auth) eq lc($DEFAULT_AUTHORITY))
+       )
+    {
+	# avoid cloning if $auth already match
+	if ((defined($auth) || defined($DEFAULT_AUTHORITY)) &&
+	    (!defined($auth) || !defined($DEFAULT_AUTHORITY) || $auth ne $DEFAULT_AUTHORITY)
+	   )
+	{
+	    $other = $other->clone if $self == $other;
+	    $other->authority($DEFAULT_AUTHORITY);
+        }
+    }
+
+    $other;
+}
+
+sub file
+{
+    my($self, $os) = @_;
+    os_class($os)->file($self);
+}
+
+sub dir
+{
+    my($self, $os) = @_;
+    os_class($os)->dir($self);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::file - URI that maps to local file names
+
+=head1 SYNOPSIS
+
+ use URI::file;
+ 
+ $u1 = URI->new("file:/foo/bar");
+ $u2 = URI->new("foo/bar", "file");
+ 
+ $u3 = URI::file->new($path);
+ $u4 = URI::file->new("c:\\windows\\", "win32");
+ 
+ $u1->file;
+ $u1->file("mac");
+
+=head1 DESCRIPTION
+
+The C<URI::file> class supports C<URI> objects belonging to the I<file>
+URI scheme.  This scheme allows us to map the conventional file names
+found on various computer systems to the URI name space.  An old
+specification of the I<file> URI scheme is found in RFC 1738.  Some
+older background information is also in RFC 1630. There are no newer
+specifications as far as I know.
+
+If you simply want to construct I<file> URI objects from URI strings,
+use the normal C<URI> constructor.  If you want to construct I<file>
+URI objects from the actual file names used by various systems, then
+use one of the following C<URI::file> constructors:
+
+=over 4
+
+=item $u = URI::file->new( $filename, [$os] )
+
+Maps a file name to the I<file:> URI name space, creates a URI object
+and returns it.  The $filename is interpreted as belonging to the
+indicated operating system ($os), which defaults to the value of the
+$^O variable.  The $filename can be either absolute or relative, and
+the corresponding type of URI object for $os is returned.
+
+=item $u = URI::file->new_abs( $filename, [$os] )
+
+Same as URI::file->new, but makes sure that the URI returned
+represents an absolute file name.  If the $filename argument is
+relative, then the name is resolved relative to the current directory,
+i.e. this constructor is really the same as:
+
+  URI::file->new($filename)->abs(URI::file->cwd);
+
+=item $u = URI::file->cwd
+
+Returns a I<file> URI that represents the current working directory.
+See L<Cwd>.
+
+=back
+
+The following methods are supported for I<file> URI (in addition to
+the common and generic methods described in L<URI>):
+
+=over 4
+
+=item $u->file( [$os] )
+
+Returns a file name.  It maps from the URI name space
+to the file name space of the indicated operating system.
+
+It might return C<undef> if the name can not be represented in the
+indicated file system.
+
+=item $u->dir( [$os] )
+
+Some systems use a different form for names of directories than for plain
+files.  Use this method if you know you want to use the name for
+a directory.
+
+=back
+
+The C<URI::file> module can be used to map generic file names to names
+suitable for the current system.  As such, it can work as a nice
+replacement for the C<File::Spec> module.  For instance, the following
+code translates the UNIX-style file name F<Foo/Bar.pm> to a name
+suitable for the local system:
+
+  $file = URI::file->new("Foo/Bar.pm", "unix")->file;
+  die "Can't map filename Foo/Bar.pm for $^O" unless defined $file;
+  open(FILE, $file) || die "Can't open '$file': $!";
+  # do something with FILE
+
+=head1 MAPPING NOTES
+
+Most computer systems today have hierarchically organized file systems.
+Mapping the names used in these systems to the generic URI syntax
+allows us to work with relative file URIs that behave as they should
+when resolved using the generic algorithm for URIs (specified in RFC
+2396).  Mapping a file name to the generic URI syntax involves mapping
+the path separator character to "/" and encoding any reserved
+characters that appear in the path segments of the file name.  If
+path segments consisting of the strings "." or ".." have a
+different meaning than what is specified for generic URIs, then these
+must be encoded as well.
+
+If the file system has device, volume or drive specifications as
+the root of the name space, then it makes sense to map them to the
+authority field of the generic URI syntax.  This makes sure that
+relative URIs can not be resolved "above" them, i.e. generally how
+relative file names work in those systems.
+
+Another common use of the authority field is to encode the host on which
+this file name is valid.  The host name "localhost" is special and
+generally has the same meaning as a missing or empty authority
+field.  This use is in conflict with using it as a device
+specification, but can often be resolved for device specifications
+having characters not legal in plain host names.
+
+File name to URI mapping in normally not one-to-one.  There are
+usually many URIs that map to any given file name.  For instance, an
+authority of "localhost" maps the same as a URI with a missing or empty
+authority.
+
+Example 1: The Mac classic (Mac OS 9 and earlier) used ":" as path separator,
+but not in the same way as a generic URI. ":foo" was a relative name.  "foo:bar"
+was an absolute name.  Also, path segments could contain the "/" character as well
+as the literal "." or "..".  So the mapping looks like this:
+
+  Mac classic           URI
+  ----------            -------------------
+  :foo:bar     <==>     foo/bar
+  :            <==>     ./
+  ::foo:bar    <==>     ../foo/bar
+  :::          <==>     ../../
+  foo:bar      <==>     file:/foo/bar
+  foo:bar:     <==>     file:/foo/bar/
+  ..           <==>     %2E%2E
+  <undef>      <==      /
+  foo/         <==      file:/foo%2F
+  ./foo.txt    <==      file:/.%2Ffoo.txt
+
+Note that if you want a relative URL, you *must* begin the path with a :.  Any
+path that begins with [^:] is treated as absolute.
+
+Example 2: The UNIX file system is easy to map, as it uses the same path
+separator as URIs, has a single root, and segments of "." and ".."
+have the same meaning.  URIs that have the character "\0" or "/" as
+part of any path segment can not be turned into valid UNIX file names.
+
+  UNIX                  URI
+  ----------            ------------------
+  foo/bar      <==>     foo/bar
+  /foo/bar     <==>     file:/foo/bar
+  /foo/bar     <==      file://localhost/foo/bar
+  file:         ==>     ./file:
+  <undef>      <==      file:/fo%00/bar
+  /            <==>     file:/
+
+=cut
+
+
+RFC 1630
+
+   [...]
+
+   There is clearly a danger of confusion that a link made to a local
+   file should be followed by someone on a different system, with
+   unexpected and possibly harmful results.  Therefore, the convention
+   is that even a "file" URL is provided with a host part.  This allows
+   a client on another system to know that it cannot access the file
+   system, or perhaps to use some other local mechanism to access the
+   file.
+
+   The special value "localhost" is used in the host field to indicate
+   that the filename should really be used on whatever host one is.
+   This for example allows links to be made to files which are
+   distributed on many machines, or to "your unix local password file"
+   subject of course to consistency across the users of the data.
+
+   A void host field is equivalent to "localhost".
+
+=head1 CONFIGURATION VARIABLES
+
+The following configuration variables influence how the class and its
+methods behave:
+
+=over
+
+=item %URI::file::OS_CLASS
+
+This hash maps OS identifiers to implementation classes.  You might
+want to add or modify this if you want to plug in your own file
+handler class.  Normally the keys should match the $^O values in use.
+
+If there is no mapping then the "Unix" implementation is used.
+
+=item $URI::file::DEFAULT_AUTHORITY
+
+This determine what "authority" string to include in absolute file
+URIs.  It defaults to "".  If you prefer verbose URIs you might set it
+to be "localhost".
+
+Setting this value to C<undef> force behaviour compatible to URI v1.31
+and earlier.  In this mode host names in UNC paths and drive letters
+are mapped to the authority component on Windows, while we produce
+authority-less URIs on Unix.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<URI>, L<File::Spec>, L<perlport>
+
+=head1 COPYRIGHT
+
+Copyright 1995-1998,2004 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/URI/file/Base.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/file/Base.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/file/Base.pm	(revision 27174)
@@ -0,0 +1,80 @@
+package URI::file::Base;
+
+use strict;
+use URI::Escape qw();
+
+sub new
+{
+    my $class = shift;
+    my $path  = shift;
+    $path = "" unless defined $path;
+
+    my($auth, $escaped_auth, $escaped_path);
+
+    ($auth, $escaped_auth) = $class->_file_extract_authority($path);
+    ($path, $escaped_path) = $class->_file_extract_path($path);
+
+    if (defined $auth) {
+	$auth =~ s,%,%25,g unless $escaped_auth;
+	$auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
+	$auth = "//$auth";
+	if (defined $path) {
+	    $path = "/$path" unless substr($path, 0, 1) eq "/";
+	} else {
+	    $path = "";
+	}
+    } else {
+	return undef unless defined $path;
+	$auth = "";
+    }
+
+    $path =~ s,([%;?]), URI::Escape::escape_char($1),eg unless $escaped_path;
+    $path =~ s/\#/%23/g;
+
+    my $uri = $auth . $path;
+    $uri = "file:$uri" if substr($uri, 0, 1) eq "/";
+
+    URI->new($uri, "file");
+}
+
+sub _file_extract_authority
+{
+    my($class, $path) = @_;
+    return undef unless $class->_file_is_absolute($path);
+    return $URI::file::DEFAULT_AUTHORITY;
+}
+
+sub _file_extract_path
+{
+    return undef;
+}
+
+sub _file_is_absolute
+{
+    return 0;
+}
+
+sub _file_is_localhost
+{
+    shift; # class
+    my $host = lc(shift);
+    return 1 if $host eq "localhost";
+    eval {
+	require Net::Domain;
+	lc(Net::Domain::hostfqdn()) eq $host ||
+	lc(Net::Domain::hostname()) eq $host;
+    };
+}
+
+sub file
+{
+    undef;
+}
+
+sub dir
+{
+    my $self = shift;
+    $self->file(@_);
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/file/FAT.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/file/FAT.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/file/FAT.pm	(revision 27174)
@@ -0,0 +1,23 @@
+package URI::file::FAT;
+
+require URI::file::Win32;
+@ISA=qw(URI::file::Win32);
+
+sub fix_path
+{
+    shift; # class
+    for (@_) {
+	# turn it into 8.3 names
+	my @p = map uc, split(/\./, $_, -1);
+	return if @p > 2;     # more than 1 dot is not allowed
+	@p = ("") unless @p;  # split bug? (returns nothing when splitting "")
+	$_ = substr($p[0], 0, 8);
+        if (@p > 1) {
+	    my $ext = substr($p[1], 0, 3);
+	    $_ .= ".$ext" if length $ext;
+	}
+    }
+    1;  # ok
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/file/Mac.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/file/Mac.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/file/Mac.pm	(revision 27174)
@@ -0,0 +1,120 @@
+package URI::file::Mac;
+
+require URI::file::Base;
+@ISA=qw(URI::file::Base);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+
+
+sub _file_extract_path
+{
+    my $class = shift;
+    my $path = shift;
+
+    my @pre;
+    if ($path =~ s/^(:+)//) {
+	if (length($1) == 1) {
+	    @pre = (".") unless length($path);
+	} else {
+	    @pre = ("..") x (length($1) - 1);
+	}
+    } else { #absolute
+	$pre[0] = "";
+    }
+
+    my $isdir = ($path =~ s/:$//);
+    $path =~ s,([%/;]), URI::Escape::escape_char($1),eg;
+
+    my @path = split(/:/, $path, -1);
+    for (@path) {
+	if ($_ eq "." || $_ eq "..") {
+	    $_ = "%2E" x length($_);
+	}
+	$_ = ".." unless length($_);
+    }
+    push (@path,"") if $isdir;
+    (join("/", @pre, @path), 1);
+}
+
+
+sub file
+{
+    my $class = shift;
+    my $uri = shift;
+    my @path;
+
+    my $auth = $uri->authority;
+    if (defined $auth) {
+	if (lc($auth) ne "localhost" && $auth ne "") {
+	    my $u_auth = uri_unescape($auth);
+	    if (!$class->_file_is_localhost($u_auth)) {
+		# some other host (use it as volume name)
+		@path = ("", $auth);
+		# XXX or just return to make it illegal;
+	    }
+	}
+    }
+    my @ps = split("/", $uri->path, -1);
+    shift @ps if @path;
+    push(@path, @ps);
+
+    my $pre = "";
+    if (!@path) {
+	return;  # empty path; XXX return ":" instead?
+    } elsif ($path[0] eq "") {
+	# absolute
+	shift(@path);
+	if (@path == 1) {
+	    return if $path[0] eq "";  # not root directory
+	    push(@path, "");           # volume only, effectively append ":"
+	}
+	@ps = @path;
+	@path = ();
+        my $part;
+	for (@ps) {  #fix up "." and "..", including interior, in relatives
+	    next if $_ eq ".";
+	    $part = $_ eq ".." ? "" : $_;
+	    push(@path,$part);
+	}
+	if ($ps[-1] eq "..") {  #if this happens, we need another :
+	    push(@path,"");
+	}
+	
+    } else {
+	$pre = ":";
+	@ps = @path;
+	@path = ();
+        my $part;
+	for (@ps) {  #fix up "." and "..", including interior, in relatives
+	    next if $_ eq ".";
+	    $part = $_ eq ".." ? "" : $_;
+	    push(@path,$part);
+	}
+	if ($ps[-1] eq "..") {  #if this happens, we need another :
+	    push(@path,"");
+	}
+	
+    }
+    return unless $pre || @path;
+    for (@path) {
+	s/;.*//;  # get rid of parameters
+	#return unless length; # XXX
+	$_ = uri_unescape($_);
+	return if /\0/;
+	return if /:/;  # Should we?
+    }
+    $pre . join(":", @path);
+}
+
+sub dir
+{
+    my $class = shift;
+    my $path = $class->file(@_);
+    return unless defined $path;
+    $path .= ":" unless $path =~ /:$/;
+    $path;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/file/OS2.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/file/OS2.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/file/OS2.pm	(revision 27174)
@@ -0,0 +1,28 @@
+package URI::file::OS2;
+
+require URI::file::Win32;
+@ISA=qw(URI::file::Win32);
+
+# The Win32 version translates k:/foo to file://k:/foo  (?!)
+# We add an empty host
+
+sub _file_extract_authority
+{
+    my $class = shift;
+    return $1 if $_[0] =~ s,^\\\\([^\\]+),,;  # UNC
+    return $1 if $_[0] =~ s,^//([^/]+),,;     # UNC too?
+
+    if ($_[0] =~ m#^[a-zA-Z]{1,2}:#) {	      # allow for ab: drives
+	return "";
+    }
+    return;
+}
+
+sub file {
+  my $p = &URI::file::Win32::file;
+  return unless defined $p;
+  $p =~ s,\\,/,g;
+  $p;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/file/QNX.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/file/QNX.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/file/QNX.pm	(revision 27174)
@@ -0,0 +1,18 @@
+package URI::file::QNX;
+
+require URI::file::Unix;
+@ISA=qw(URI::file::Unix);
+
+use strict;
+
+sub _file_extract_path
+{
+    my($class, $path) = @_;
+    # tidy path
+    $path =~ s,(.)//+,$1/,g; # ^// is correct
+    $path =~ s,(/\.)+/,/,g;
+    $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
+    $path;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/file/Unix.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/file/Unix.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/file/Unix.pm	(revision 27174)
@@ -0,0 +1,55 @@
+package URI::file::Unix;
+
+require URI::file::Base;
+@ISA=qw(URI::file::Base);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+sub _file_extract_path
+{
+    my($class, $path) = @_;
+
+    # tidy path
+    $path =~ s,//+,/,g;
+    $path =~ s,(/\.)+/,/,g;
+    $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
+
+    return $path;
+}
+
+sub _file_is_absolute {
+    my($class, $path) = @_;
+    return $path =~ m,^/,;
+}
+
+sub file
+{
+    my $class = shift;
+    my $uri = shift;
+    my @path;
+
+    my $auth = $uri->authority;
+    if (defined($auth)) {
+	if (lc($auth) ne "localhost" && $auth ne "") {
+	    $auth = uri_unescape($auth);
+	    unless ($class->_file_is_localhost($auth)) {
+		push(@path, "", "", $auth);
+	    }
+	}
+    }
+
+    my @ps = $uri->path_segments;
+    shift @ps if @path;
+    push(@path, @ps);
+
+    for (@path) {
+	# Unix file/directory names are not allowed to contain '\0' or '/'
+	return undef if /\0/;
+	return undef if /\//;  # should we really?
+    }
+
+    return join("/", @path);
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/file/Win32.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/file/Win32.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/file/Win32.pm	(revision 27174)
@@ -0,0 +1,84 @@
+package URI::file::Win32;
+
+require URI::file::Base;
+@ISA=qw(URI::file::Base);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+sub _file_extract_authority
+{
+    my $class = shift;
+
+    return $class->SUPER::_file_extract_authority($_[0])
+	if defined $URI::file::DEFAULT_AUTHORITY;
+
+    return $1 if $_[0] =~ s,^\\\\([^\\]+),,;  # UNC
+    return $1 if $_[0] =~ s,^//([^/]+),,;     # UNC too?
+
+    if ($_[0] =~ s,^([a-zA-Z]:),,) {
+	my $auth = $1;
+	$auth .= "relative" if $_[0] !~ m,^[\\/],;
+	return $auth;
+    }
+    return undef;
+}
+
+sub _file_extract_path
+{
+    my($class, $path) = @_;
+    $path =~ s,\\,/,g;
+    #$path =~ s,//+,/,g;
+    $path =~ s,(/\.)+/,/,g;
+
+    if (defined $URI::file::DEFAULT_AUTHORITY) {
+	$path =~ s,^([a-zA-Z]:),/$1,;
+    }
+
+    return $path;
+}
+
+sub _file_is_absolute {
+    my($class, $path) = @_;
+    return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],;
+}
+
+sub file
+{
+    my $class = shift;
+    my $uri = shift;
+    my $auth = $uri->authority;
+    my $rel; # is filename relative to drive specified in authority
+    if (defined $auth) {
+        $auth = uri_unescape($auth);
+	if ($auth =~ /^([a-zA-Z])[:|](relative)?/) {
+	    $auth = uc($1) . ":";
+	    $rel++ if $2;
+	} elsif (lc($auth) eq "localhost") {
+	    $auth = "";
+	} elsif (length $auth) {
+	    $auth = "\\\\" . $auth;  # UNC
+	}
+    } else {
+	$auth = "";
+    }
+
+    my @path = $uri->path_segments;
+    for (@path) {
+	return undef if /\0/;
+	return undef if /\//;
+	#return undef if /\\/;        # URLs with "\" is not uncommon
+    }
+    return undef unless $class->fix_path(@path);
+
+    my $path = join("\\", @path);
+    $path =~ s/^\\// if $rel;
+    $path = $auth . $path;
+    $path =~ s,^\\([a-zA-Z])[:|],\u$1:,;
+
+    return $path;
+}
+
+sub fix_path { 1; }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/ftp.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/ftp.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/ftp.pm	(revision 27174)
@@ -0,0 +1,45 @@
+package URI::ftp;
+
+require URI::_server;
+require URI::_userpass;
+@ISA=qw(URI::_server URI::_userpass);
+
+use strict;
+
+sub default_port { 21 }
+
+sub path { shift->path_query(@_) }  # XXX
+
+sub _user     { shift->SUPER::user(@_);     }
+sub _password { shift->SUPER::password(@_); }
+
+sub user
+{
+    my $self = shift;
+    my $user = $self->_user(@_);
+    $user = "anonymous" unless defined $user;
+    $user;
+}
+
+sub password
+{
+    my $self = shift;
+    my $pass = $self->_password(@_);
+    unless (defined $pass) {
+	my $user = $self->user;
+	if ($user eq 'anonymous' || $user eq 'ftp') {
+	    # anonymous ftp login password
+            # If there is no ftp anonymous password specified
+            # then we'll just use 'anonymous@'
+            # We don't try to send the read e-mail address because:
+            # - We want to remain anonymous
+            # - We want to stop SPAM
+            # - We don't want to let ftp sites to discriminate by the user,
+            #   host, country or ftp client being used.
+	    $pass = 'anonymous@';
+	}
+    }
+    $pass;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/gopher.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/gopher.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/gopher.pm	(revision 27174)
@@ -0,0 +1,94 @@
+package URI::gopher;  # <draft-murali-url-gopher>, Dec 4, 1996
+
+require URI::_server;
+@ISA=qw(URI::_server);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+#  A Gopher URL follows the common internet scheme syntax as defined in 
+#  section 4.3 of [RFC-URL-SYNTAX]:
+#
+#        gopher://<host>[:<port>]/<gopher-path>
+#
+#  where
+#
+#        <gopher-path> :=  <gopher-type><selector> | 
+#                          <gopher-type><selector>%09<search> |
+#                          <gopher-type><selector>%09<search>%09<gopher+_string>
+#
+#        <gopher-type> := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7'
+#                         '8' | '9' | '+' | 'I' | 'g' | 'T'
+#
+#        <selector>    := *pchar     Refer to RFC 1808 [4]
+#        <search>      := *pchar
+#        <gopher+_string> := *uchar  Refer to RFC 1738 [3]
+#        
+#  If the optional port is omitted, the port defaults to 70. 
+
+sub default_port { 70 }
+
+sub _gopher_type
+{
+    my $self = shift;
+    my $path = $self->path_query;
+    $path =~ s,^/,,;
+    my $gtype = $1 if $path =~ s/^(.)//s;
+    if (@_) {
+	my $new_type = shift;
+	if (defined($new_type)) {
+	    Carp::croak("Bad gopher type '$new_type'")
+               unless length($new_type) == 1;
+	    substr($path, 0, 0) = $new_type;
+	    $self->path_query($path);
+	} else {
+	    Carp::croak("Can't delete gopher type when selector is present")
+		if length($path);
+	    $self->path_query(undef);
+	}
+    }
+    return $gtype;
+}
+
+sub gopher_type
+{
+    my $self = shift;
+    my $gtype = $self->_gopher_type(@_);
+    $gtype = "1" unless defined $gtype;
+    $gtype;
+}
+
+*gtype = \&gopher_type;  # URI::URL compatibility
+
+sub selector { shift->_gfield(0, @_) }
+sub search   { shift->_gfield(1, @_) }
+sub string   { shift->_gfield(2, @_) }
+
+sub _gfield
+{
+    my $self = shift;
+    my $fno  = shift;
+    my $path = $self->path_query;
+
+    # not according to spec., but many popular browsers accept
+    # gopher URLs with a '?' before the search string.
+    $path =~ s/\?/\t/;
+    $path = uri_unescape($path);
+    $path =~ s,^/,,;
+    my $gtype = $1 if $path =~ s,^(.),,s;
+    my @path = split(/\t/, $path, 3);
+    if (@_) {
+	# modify
+	my $new = shift;
+	$path[$fno] = $new;
+	pop(@path) while @path && !defined($path[-1]);
+	for (@path) { $_="" unless defined }
+	$path = $gtype;
+	$path = "1" unless defined $path;
+	$path .= join("\t", @path);
+	$self->path_query($path);
+    }
+    $path[$fno];
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/http.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/http.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/http.pm	(revision 27174)
@@ -0,0 +1,25 @@
+package URI::http;
+
+require URI::_server;
+@ISA=qw(URI::_server);
+
+use strict;
+
+sub default_port { 80 }
+
+sub canonical
+{
+    my $self = shift;
+    my $other = $self->SUPER::canonical;
+
+    my $slash_path = defined($other->authority) &&
+        !length($other->path) && !defined($other->query);
+
+    if ($slash_path) {
+	$other = $other->clone if $other == $self;
+	$other->path("/");
+    }
+    $other;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/https.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/https.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/https.pm	(revision 27174)
@@ -0,0 +1,9 @@
+package URI::https;
+require URI::http;
+@ISA=qw(URI::http);
+
+sub default_port { 443 }
+
+sub secure { 1 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/ldap.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/ldap.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/ldap.pm	(revision 27174)
@@ -0,0 +1,122 @@
+# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package URI::ldap;
+
+use strict;
+
+use vars qw(@ISA $VERSION);
+$VERSION = "1.12";
+
+require URI::_server;
+require URI::_ldap;
+@ISA=qw(URI::_ldap URI::_server);
+
+sub default_port { 389 }
+
+sub _nonldap_canonical {
+    my $self = shift;
+    $self->URI::_server::canonical(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::ldap - LDAP Uniform Resource Locators
+
+=head1 SYNOPSIS
+
+  use URI;
+
+  $uri = URI->new("ldap:$uri_string");
+  $dn     = $uri->dn;
+  $filter = $uri->filter;
+  @attr   = $uri->attributes;
+  $scope  = $uri->scope;
+  %extn   = $uri->extensions;
+  
+  $uri = URI->new("ldap:");  # start empty
+  $uri->host("ldap.itd.umich.edu");
+  $uri->dn("o=University of Michigan,c=US");
+  $uri->attributes(qw(postalAddress));
+  $uri->scope('sub');
+  $uri->filter('(cn=Babs Jensen)');
+  print $uri->as_string,"\n";
+
+=head1 DESCRIPTION
+
+C<URI::ldap> provides an interface to parse an LDAP URI into its
+constituent parts and also to build a URI as described in
+RFC 2255.
+
+=head1 METHODS
+
+C<URI::ldap> supports all the generic and server methods defined by
+L<URI>, plus the following.
+
+Each of the following methods can be used to set or get the value in
+the URI. The values are passed in unescaped form.  None of these
+return undefined values, but elements without a default can be empty.
+If arguments are given, then a new value is set for the given part
+of the URI.
+
+=over 4
+
+=item $uri->dn( [$new_dn] )
+
+Sets or gets the I<Distinguished Name> part of the URI.  The DN
+identifies the base object of the LDAP search.
+
+=item $uri->attributes( [@new_attrs] )
+
+Sets or gets the list of attribute names which are
+returned by the search.
+
+=item $uri->scope( [$new_scope] )
+
+Sets or gets the scope to be used by the search. The value can be one of
+C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the
+return value defaults to C<"base">.
+
+=item $uri->_scope( [$new_scope] )
+
+Same as scope(), but does not default to anything.
+
+=item $uri->filter( [$new_filter] )
+
+Sets or gets the filter to be used by the search. If none is given in
+the URI then the return value defaults to C<"(objectClass=*)">.
+
+=item $uri->_filter( [$new_filter] )
+
+Same as filter(), but does not default to anything.
+
+=item $uri->extensions( [$etype => $evalue,...] )
+
+Sets or gets the extensions used for the search. The list passed should
+be in the form etype1 => evalue1, etype2 => evalue2,... This is also
+the form of list that is returned.
+
+=back
+
+=head1 SEE ALSO
+
+L<http://tools.ietf.org/html/rfc2255>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+Slightly modified by Gisle Aas to fit into the URI distribution.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1998 Graham Barr. All rights reserved. This program 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/URI/ldapi.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/ldapi.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/ldapi.pm	(revision 27174)
@@ -0,0 +1,30 @@
+package URI::ldapi;
+
+use strict;
+
+use vars qw(@ISA);
+
+require URI::_generic;
+require URI::_ldap;
+@ISA=qw(URI::_ldap URI::_generic);
+
+require URI::Escape;
+
+sub un_path {
+    my $self = shift;
+    my $old = URI::Escape::uri_unescape($self->authority);
+    if (@_) {
+	my $p = shift;
+	$p =~ s/:/%3A/g;
+	$p =~ s/\@/%40/g;
+	$self->authority($p);
+    }
+    return $old;
+}
+
+sub _nonldap_canonical {
+    my $self = shift;
+    $self->URI::_generic::canonical(@_);
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/ldaps.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/ldaps.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/ldaps.pm	(revision 27174)
@@ -0,0 +1,9 @@
+package URI::ldaps;
+require URI::ldap;
+@ISA=qw(URI::ldap);
+
+sub default_port { 636 }
+
+sub secure { 1 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/mailto.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/mailto.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/mailto.pm	(revision 27174)
@@ -0,0 +1,72 @@
+package URI::mailto;  # RFC 2368
+
+require URI;
+require URI::_query;
+@ISA=qw(URI URI::_query);
+
+use strict;
+
+sub to
+{
+    my $self = shift;
+    my @old = $self->headers;
+    if (@_) {
+	my @new = @old;
+	# get rid of any other to: fields
+	for (my $i = 0; $i < @new; $i += 2) {
+	    if (lc($new[$i] || '') eq "to") {
+		splice(@new, $i, 2);
+		redo;
+	    }
+	}
+
+	my $to = shift;
+	$to = "" unless defined $to;
+	unshift(@new, "to" => $to);
+	$self->headers(@new);
+    }
+    return unless defined wantarray;
+
+    my @to;
+    while (@old) {
+	my $h = shift @old;
+	my $v = shift @old;
+	push(@to, $v) if lc($h) eq "to";
+    }
+    join(",", @to);
+}
+
+
+sub headers
+{
+    my $self = shift;
+
+    # The trick is to just treat everything as the query string...
+    my $opaque = "to=" . $self->opaque;
+    $opaque =~ s/\?/&/;
+
+    if (@_) {
+	my @new = @_;
+
+	# strip out any "to" fields
+	my @to;
+	for (my $i=0; $i < @new; $i += 2) {
+	    if (lc($new[$i] || '') eq "to") {
+		push(@to, (splice(@new, $i, 2))[1]);  # remove header
+		redo;
+	    }
+	}
+
+	my $new = join(",",@to);
+	$new =~ s/%/%25/g;
+	$new =~ s/\?/%3F/g;
+	$self->opaque($new);
+	$self->query_form(@new) if @new;
+    }
+    return unless defined wantarray;
+
+    # I am lazy today...
+    URI->new("mailto:?$opaque")->query_form;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/mms.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/mms.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/mms.pm	(revision 27174)
@@ -0,0 +1,8 @@
+package URI::mms;
+
+require URI::http;
+@ISA=qw(URI::http);
+
+sub default_port { 1755 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/news.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/news.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/news.pm	(revision 27174)
@@ -0,0 +1,68 @@
+package URI::news;  # draft-gilman-news-url-01
+
+require URI::_server;
+@ISA=qw(URI::_server);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+use Carp ();
+
+sub default_port { 119 }
+
+#   newsURL      =  scheme ":" [ news-server ] [ refbygroup | message ]
+#   scheme       =  "news" | "snews" | "nntp"
+#   news-server  =  "//" server "/"
+#   refbygroup   = group [ "/" messageno [ "-" messageno ] ]
+#   message      = local-part "@" domain
+
+sub _group
+{
+    my $self = shift;
+    my $old = $self->path;
+    if (@_) {
+	my($group,$from,$to) = @_;
+	if ($group =~ /\@/) {
+            $group =~ s/^<(.*)>$/$1/;  # "<" and ">" should not be part of it
+	}
+	$group =~ s,%,%25,g;
+	$group =~ s,/,%2F,g;
+	my $path = $group;
+	if (defined $from) {
+	    $path .= "/$from";
+	    $path .= "-$to" if defined $to;
+	}
+	$self->path($path);
+    }
+
+    $old =~ s,^/,,;
+    if ($old !~ /\@/ && $old =~ s,/(.*),, && wantarray) {
+	my $extra = $1;
+	return (uri_unescape($old), split(/-/, $extra));
+    }
+    uri_unescape($old);
+}
+
+
+sub group
+{
+    my $self = shift;
+    if (@_) {
+	Carp::croak("Group name can't contain '\@'") if $_[0] =~ /\@/;
+    }
+    my @old = $self->_group(@_);
+    return if $old[0] =~ /\@/;
+    wantarray ? @old : $old[0];
+}
+
+sub message
+{
+    my $self = shift;
+    if (@_) {
+	Carp::croak("Message must contain '\@'") unless $_[0] =~ /\@/;
+    }
+    my $old = $self->_group(@_);
+    return unless $old =~ /\@/;
+    return $old;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/nntp.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/nntp.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/nntp.pm	(revision 27174)
@@ -0,0 +1,6 @@
+package URI::nntp;  # draft-gilman-news-url-01
+
+require URI::news;
+@ISA=qw(URI::news);
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/pop.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/pop.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/pop.pm	(revision 27174)
@@ -0,0 +1,68 @@
+package URI::pop;   # RFC 2384
+
+require URI::_server;
+@ISA=qw(URI::_server);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+sub default_port { 110 }
+
+#pop://<user>;auth=<auth>@<host>:<port>
+
+sub user
+{
+    my $self = shift;
+    my $old = $self->userinfo;
+
+    if (@_) {
+	my $new_info = $old;
+	$new_info = "" unless defined $new_info;
+	$new_info =~ s/^[^;]*//;
+
+	my $new = shift;
+	if (!defined($new) && !length($new_info)) {
+	    $self->userinfo(undef);
+	} else {
+	    $new = "" unless defined $new;
+	    $new =~ s/%/%25/g;
+	    $new =~ s/;/%3B/g;
+	    $self->userinfo("$new$new_info");
+	}
+    }
+
+    return unless defined $old;
+    $old =~ s/;.*//;
+    return uri_unescape($old);
+}
+
+sub auth
+{
+    my $self = shift;
+    my $old = $self->userinfo;
+
+    if (@_) {
+	my $new = $old;
+	$new = "" unless defined $new;
+	$new =~ s/(^[^;]*)//;
+	my $user = $1;
+	$new =~ s/;auth=[^;]*//i;
+
+	
+	my $auth = shift;
+	if (defined $auth) {
+	    $auth =~ s/%/%25/g;
+	    $auth =~ s/;/%3B/g;
+	    $new = ";AUTH=$auth$new";
+	}
+	$self->userinfo("$user$new");
+	
+    }
+
+    return unless defined $old;
+    $old =~ s/^[^;]*//;
+    return uri_unescape($1) if $old =~ /;auth=(.*)/i;
+    return;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/rlogin.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/rlogin.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/rlogin.pm	(revision 27174)
@@ -0,0 +1,7 @@
+package URI::rlogin;
+require URI::_login;
+@ISA = qw(URI::_login);
+
+sub default_port { 513 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/rsync.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/rsync.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/rsync.pm	(revision 27174)
@@ -0,0 +1,12 @@
+package URI::rsync;  # http://rsync.samba.org/
+
+# rsync://[USER@]HOST[:PORT]/SRC
+
+require URI::_server;
+require URI::_userpass;
+
+@ISA=qw(URI::_server URI::_userpass);
+
+sub default_port { 873 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/rtsp.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/rtsp.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/rtsp.pm	(revision 27174)
@@ -0,0 +1,8 @@
+package URI::rtsp;
+
+require URI::http;
+@ISA=qw(URI::http);
+
+sub default_port { 554 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/rtspu.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/rtspu.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/rtspu.pm	(revision 27174)
@@ -0,0 +1,8 @@
+package URI::rtspu;
+
+require URI::rtsp;
+@ISA=qw(URI::rtsp);
+
+sub default_port { 554 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/sip.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/sip.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/sip.pm	(revision 27174)
@@ -0,0 +1,86 @@
+#
+# Written by Ryan Kereliuk <ryker@ryker.org>.  This file may be
+# distributed under the same terms as Perl itself.
+#
+# The RFC 3261 sip URI is <scheme>:<authority>;<params>?<query>.
+#
+
+package URI::sip;
+
+require URI::_server;
+require URI::_userpass;
+@ISA=qw(URI::_server URI::_userpass);
+
+use strict;
+use vars qw(@ISA $VERSION);
+use URI::Escape qw(uri_unescape);
+
+$VERSION = "0.11";
+
+sub default_port { 5060 }
+
+sub authority
+{
+    my $self = shift;
+    $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die;
+    my $old = $2;
+
+    if (@_) {
+        my $auth = shift;
+        $$self = defined($1) ? $1 : "";
+        my $rest = $3;
+        if (defined $auth) {
+            $auth =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
+            $$self .= "$auth";
+        }
+        $$self .= $rest;
+    }
+    $old;
+}
+
+sub params_form
+{
+    my $self = shift;
+    $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
+    my $paramstr = $3;
+
+    if (@_) {
+    	my @args = @_; 
+        $$self = $1 . $2;
+        my $rest = $4;
+	my @new;
+	for (my $i=0; $i < @args; $i += 2) {
+	    push(@new, "$args[$i]=$args[$i+1]");
+	}
+	$paramstr = join(";", @new);
+	$$self .= ";" . $paramstr . $rest;
+    }
+    $paramstr =~ s/^;//o;
+    return split(/[;=]/, $paramstr);
+}
+
+sub params
+{
+    my $self = shift;
+    $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
+    my $paramstr = $3;
+
+    if (@_) {
+    	my $new = shift; 
+        $$self = $1 . $2;
+        my $rest = $4;
+	$$self .= $paramstr . $rest;
+    }
+    $paramstr =~ s/^;//o;
+    return $paramstr;
+}
+
+# Inherited methods that make no sense for a SIP URI.
+sub path {}
+sub path_query {}
+sub path_segments {}
+sub abs { shift }
+sub rel { shift }
+sub query_keywords {}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/sips.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/sips.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/sips.pm	(revision 27174)
@@ -0,0 +1,9 @@
+package URI::sips;
+require URI::sip;
+@ISA=qw(URI::sip);
+
+sub default_port { 5061 }
+
+sub secure { 1 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/snews.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/snews.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/snews.pm	(revision 27174)
@@ -0,0 +1,10 @@
+package URI::snews;  # draft-gilman-news-url-01
+
+require URI::news;
+@ISA=qw(URI::news);
+
+sub default_port { 563 }
+
+sub secure { 1 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/ssh.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/ssh.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/ssh.pm	(revision 27174)
@@ -0,0 +1,11 @@
+package URI::ssh;
+require URI::_login;
+@ISA=qw(URI::_login);
+
+# ssh://[USER@]HOST[:PORT]/SRC
+
+sub default_port { 22 }
+
+sub secure { 1 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/telnet.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/telnet.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/telnet.pm	(revision 27174)
@@ -0,0 +1,7 @@
+package URI::telnet;
+require URI::_login;
+@ISA = qw(URI::_login);
+
+sub default_port { 23 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/tn3270.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/tn3270.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/tn3270.pm	(revision 27174)
@@ -0,0 +1,7 @@
+package URI::tn3270;
+require URI::_login;
+@ISA = qw(URI::_login);
+
+sub default_port { 23 }
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/urn.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/urn.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/urn.pm	(revision 27174)
@@ -0,0 +1,97 @@
+package URI::urn;  # RFC 2141
+
+require URI;
+@ISA=qw(URI);
+
+use strict;
+use Carp qw(carp);
+
+use vars qw(%implementor);
+
+sub _init {
+    my $class = shift;
+    my $self = $class->SUPER::_init(@_);
+    my $nid = $self->nid;
+
+    my $impclass = $implementor{$nid};
+    return $impclass->_urn_init($self, $nid) if $impclass;
+
+    $impclass = "URI::urn";
+    if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) {
+	my $id = $nid;
+	# make it a legal perl identifier
+	$id =~ s/-/_/g;
+	$id = "_$id" if $id =~ /^\d/;
+
+	$impclass = "URI::urn::$id";
+	no strict 'refs';
+	unless (@{"${impclass}::ISA"}) {
+	    # Try to load it
+	    eval "require $impclass";
+	    die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
+	    $impclass = "URI::urn" unless @{"${impclass}::ISA"};
+	}
+    }
+    else {
+	carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W;
+    }
+    $implementor{$nid} = $impclass;
+
+    return $impclass->_urn_init($self, $nid);
+}
+
+sub _urn_init {
+    my($class, $self, $nid) = @_;
+    bless $self, $class;
+}
+
+sub _nid {
+    my $self = shift;
+    my $opaque = $self->opaque;
+    if (@_) {
+	my $v = $opaque;
+	my $new = shift;
+	$v =~ s/[^:]*/$new/;
+	$self->opaque($v);
+	# XXX possible rebless
+    }
+    $opaque =~ s/:.*//s;
+    return $opaque;
+}
+
+sub nid {  # namespace identifier
+    my $self = shift;
+    my $nid = $self->_nid(@_);
+    $nid = lc($nid) if defined($nid);
+    return $nid;
+}
+
+sub nss {  # namespace specific string
+    my $self = shift;
+    my $opaque = $self->opaque;
+    if (@_) {
+	my $v = $opaque;
+	my $new = shift;
+	if (defined $new) {
+	    $v =~ s/(:|\z).*/:$new/;
+	}
+	else {
+	    $v =~ s/:.*//s;
+	}
+	$self->opaque($v);
+    }
+    return undef unless $opaque =~ s/^[^:]*://;
+    return $opaque;
+}
+
+sub canonical {
+    my $self = shift;
+    my $nid = $self->_nid;
+    my $new = $self->SUPER::canonical;
+    return $new if $nid !~ /[A-Z]/ || $nid =~ /%/;
+    $new = $new->clone if $new == $self;
+    $new->nid(lc($nid));
+    return $new;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/urn/isbn.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/urn/isbn.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/urn/isbn.pm	(revision 27174)
@@ -0,0 +1,102 @@
+package URI::urn::isbn;  # RFC 3187
+
+require URI::urn;
+@ISA=qw(URI::urn);
+
+use strict;
+use Carp qw(carp);
+
+BEGIN {
+    require Business::ISBN;
+    
+    local $^W = 0; # don't warn about dev versions, perl5.004 style
+    warn "Using Business::ISBN version " . Business::ISBN->VERSION . 
+        " which is deprecated.\nUpgrade to Business::ISBN version 2\n"
+        if Business::ISBN->VERSION < 2;
+    }
+    
+sub _isbn {
+    my $nss = shift;
+    $nss = $nss->nss if ref($nss);
+    my $isbn = Business::ISBN->new($nss);
+    $isbn = undef if $isbn && !$isbn->is_valid;
+    return $isbn;
+}
+
+sub _nss_isbn {
+    my $self = shift;
+    my $nss = $self->nss(@_);
+    my $isbn = _isbn($nss);
+    $isbn = $isbn->as_string if $isbn;
+    return($nss, $isbn);
+}
+
+sub isbn {
+    my $self = shift;
+    my $isbn;
+    (undef, $isbn) = $self->_nss_isbn(@_);
+    return $isbn;
+}
+
+sub isbn_publisher_code {
+    my $isbn = shift->_isbn || return undef;
+    return $isbn->publisher_code;
+}
+
+BEGIN {
+my $group_method = do {
+    local $^W = 0; # don't warn about dev versions, perl5.004 style
+    Business::ISBN->VERSION >= 2 ? 'group_code' : 'country_code';
+    };
+
+sub isbn_group_code {
+    my $isbn = shift->_isbn || return undef;
+    return $isbn->$group_method;
+}
+}
+
+sub isbn_country_code {
+    my $name = (caller(0))[3]; $name =~ s/.*:://;
+    carp "$name is DEPRECATED. Use isbn_group_code instead";
+    
+    no strict 'refs';
+    &isbn_group_code;
+}
+
+BEGIN {
+my $isbn13_method = do {
+    local $^W = 0; # don't warn about dev versions, perl5.004 style
+    Business::ISBN->VERSION >= 2 ? 'as_isbn13' : 'as_ean';
+    };
+
+sub isbn13 {
+    my $isbn = shift->_isbn || return undef;
+    
+    # Business::ISBN 1.x didn't put hyphens in the EAN, and it was just a string
+    # Business::ISBN 2.0 doesn't do EAN, but it does ISBN-13 objects
+    #   and it uses the hyphens, so call as_string with an empty anon array
+    # or, adjust the test and features to say that it comes out with hyphens.
+    my $thingy = $isbn->$isbn13_method;
+    return eval { $thingy->can( 'as_string' ) } ? $thingy->as_string([]) : $thingy;
+}
+}
+
+sub isbn_as_ean {
+    my $name = (caller(0))[3]; $name =~ s/.*:://;
+    carp "$name is DEPRECATED. Use isbn13 instead";
+
+    no strict 'refs';
+    &isbn13;
+}
+
+sub canonical {
+    my $self = shift;
+    my($nss, $isbn) = $self->_nss_isbn;
+    my $new = $self->SUPER::canonical;
+    return $new unless $nss && $isbn && $nss ne $isbn;
+    $new = $new->clone if $new == $self;
+    $new->nss($isbn);
+    return $new;
+}
+
+1;
Index: /main/trunk/greenstone2/perllib/cpan/URI/urn/oid.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cpan/URI/urn/oid.pm	(revision 27174)
+++ /main/trunk/greenstone2/perllib/cpan/URI/urn/oid.pm	(revision 27174)
@@ -0,0 +1,18 @@
+package URI::urn::oid;  # RFC 2061
+
+require URI::urn;
+@ISA=qw(URI::urn);
+
+use strict;
+
+sub oid {
+    my $self = shift;
+    my $old = $self->nss;
+    if (@_) {
+	$self->nss(join(".", @_));
+    }
+    return split(/\./, $old) if wantarray;
+    return $old;
+}
+
+1;
