diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/URI | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/URI')
51 files changed, 0 insertions, 4072 deletions
diff --git a/Master/tlpkg/tlperl/lib/URI/Escape.pm b/Master/tlpkg/tlperl/lib/URI/Escape.pm deleted file mode 100755 index c2da23becac..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/Escape.pm +++ /dev/null @@ -1,218 +0,0 @@ -package URI::Escape; -use strict; - -=head1 NAME - -URI::Escape - Escape and unescape 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 escape and unescape URI strings as -defined by RFC 2396 (and updated by RFC 2732). -A URI consists of a restricted set of characters, -denoted as C<uric> in RFC 2396. 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: - - "A" .. "Z", "a" .. "z", "0" .. "9", - ";", "/", "?", ":", "@", "&", "=", "+", "$", ",", "[", "]", # 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 (iff the -character is part of C<uric>). - -Some of the C<uric> 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 2396 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<uric> 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 do 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. - -The call: - - $uri = uri_escape_utf8($string); - -will be the same as: - - use Encode qw(encode); - $uri = uri_escape(encode("UTF-8", $string)); - -but will even work for perl-5.6 for chars in the 128 .. 255 range. - -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 - -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); -use vars qw(%escapes); - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(uri_escape uri_unescape uri_escape_utf8); -@EXPORT_OK = qw(%escapes); -$VERSION = "3.29"; - -use Carp (); - -# Build a char->hex map -for (0..255) { - $escapes{chr($_)} = sprintf("%%%02X", $_); -} - -my %subst; # compiled patternes - -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 { - # Default unsafe characters. RFC 2732 ^(uric - reserved) - $text =~ s/([^A-Za-z0-9\-_.!~*'()])/$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; - if ($] < 5.008) { - $text =~ s/([^\0-\x7F])/do {my $o = ord($1); sprintf("%c%c", 0xc0 | ($o >> 6), 0x80 | ($o & 0x3f)) }/ge; - } - else { - 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 - foreach (@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; diff --git a/Master/tlpkg/tlperl/lib/URI/Heuristic.pm b/Master/tlpkg/tlperl/lib/URI/Heuristic.pm deleted file mode 100755 index eb000609b9d..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/Heuristic.pm +++ /dev/null @@ -1,222 +0,0 @@ -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 two 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 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.18"; - -sub MY_COUNTRY() { - for ($MY_COUNTRY) { - return $_ if defined; - - # First try the environment. - $_ = $ENV{COUNTRY}; - return $_ if defined; - - # Could use LANG, LC_ALL, etc at this point, but probably too - # much of a wild guess. (Catalan != Canada, etc.) - # - - # 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)], - 'uk' => [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> -); - - -sub uf_uristr ($) -{ - local($_) = @_; - print STDERR "uf_uristr: resolving $_\n" if $DEBUG; - return unless defined; - - s/^\s+//; - s/\s+$//; - - if (/^(www|web|home)\./) { - $_ = "http://$_"; - - } elsif (/^(ftp|gopher|news|wais|http|https)\./) { - $_ = "$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; - - 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; - } - } - $_ = "http://$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; diff --git a/Master/tlpkg/tlperl/lib/URI/IRI.pm b/Master/tlpkg/tlperl/lib/URI/IRI.pm deleted file mode 100755 index 39336fce5ac..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/IRI.pm +++ /dev/null @@ -1,44 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/QueryParam.pm b/Master/tlpkg/tlperl/lib/URI/QueryParam.pm deleted file mode 100755 index 3f634b12b77..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/QueryParam.pm +++ /dev/null @@ -1,200 +0,0 @@ -package URI::QueryParam; - -use strict; - -sub URI::_query::query_param { - my $self = shift; - my @old = $self->query_form; - - if (@_ == 0) { - # get keys - my %seen; - my @keys; - for (my $i = 0; $i < @old; $i += 2) { - push(@keys, $old[$i]) unless $seen{$old[$i]}++; - } - return @keys; - } - - my $key = shift; - my @i; - - for (my $i = 0; $i < @old; $i += 2) { - push(@i, $i) if $old[$i] eq $key; - } - - if (@_) { - my @new = @old; - my @new_i = @i; - my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; - #print "VALS:@vals [@i]\n"; - while (@new_i > @vals) { - #print "REMOVE $new_i[-1]\n"; - splice(@new, pop(@new_i), 2); - } - while (@vals > @new_i) { - my $i = @new_i ? $new_i[-1] + 2 : @new; - #print "SPLICE $i\n"; - splice(@new, $i, 0, $key => pop(@vals)); - } - for (@vals) { - #print "SET $new_i[0]\n"; - $new[shift(@new_i)+1] = $_; - } - - $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; - $self->query_form($self->query_form, $key => \@_); # 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 diff --git a/Master/tlpkg/tlperl/lib/URI/Split.pm b/Master/tlpkg/tlperl/lib/URI/Split.pm deleted file mode 100755 index ad430b93277..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/Split.pm +++ /dev/null @@ -1,96 +0,0 @@ -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 diff --git a/Master/tlpkg/tlperl/lib/URI/URL.pm b/Master/tlpkg/tlperl/lib/URI/URL.pm deleted file mode 100755 index 77354488c86..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/URL.pm +++ /dev/null @@ -1,305 +0,0 @@ -package URI::URL; - -require URI::WithBase; -@ISA=qw(URI::WithBase); - -use strict; -use vars qw(@EXPORT $VERSION); - -$VERSION = "5.03"; - -# 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 diff --git a/Master/tlpkg/tlperl/lib/URI/WithBase.pm b/Master/tlpkg/tlperl/lib/URI/WithBase.pm deleted file mode 100755 index 0337c6b6450..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/WithBase.pm +++ /dev/null @@ -1,171 +0,0 @@ -package URI::WithBase; - -use strict; -use vars qw($AUTOLOAD $VERSION); -use URI; - -$VERSION = "2.19"; - -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 diff --git a/Master/tlpkg/tlperl/lib/URI/_foreign.pm b/Master/tlpkg/tlperl/lib/URI/_foreign.pm deleted file mode 100755 index 075f0fd3417..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_foreign.pm +++ /dev/null @@ -1,6 +0,0 @@ -package URI::_foreign; - -require URI::_generic; -@ISA=qw(URI::_generic); - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/_generic.pm b/Master/tlpkg/tlperl/lib/URI/_generic.pm deleted file mode 100755 index 2a02332853c..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_generic.pm +++ /dev/null @@ -1,249 +0,0 @@ -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; - $$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; - _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; - _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 oposite 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; diff --git a/Master/tlpkg/tlperl/lib/URI/_idna.pm b/Master/tlpkg/tlperl/lib/URI/_idna.pm deleted file mode 100755 index 39366e5b831..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_idna.pm +++ /dev/null @@ -1,78 +0,0 @@ -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); - -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 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; diff --git a/Master/tlpkg/tlperl/lib/URI/_ldap.pm b/Master/tlpkg/tlperl/lib/URI/_ldap.pm deleted file mode 100755 index 608dbd339a3..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_ldap.pm +++ /dev/null @@ -1,140 +0,0 @@ -# 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.10"; - -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); - - # Lowecase 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; diff --git a/Master/tlpkg/tlperl/lib/URI/_login.pm b/Master/tlpkg/tlperl/lib/URI/_login.pm deleted file mode 100755 index 4583f20a9a6..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_login.pm +++ /dev/null @@ -1,10 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/_punycode.pm b/Master/tlpkg/tlperl/lib/URI/_punycode.pm deleted file mode 100755 index e5600327a06..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_punycode.pm +++ /dev/null @@ -1,203 +0,0 @@ -package URI::_punycode; - -use strict; -our $VERSION = 0.02; - -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; # doesn't work in 5.6.x! - my @input = map substr($input, $_, 1), 0..length($input)-1; - - 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 throws exceptionsn 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 diff --git a/Master/tlpkg/tlperl/lib/URI/_query.pm b/Master/tlpkg/tlperl/lib/URI/_query.pm deleted file mode 100755 index 0c6aa285e42..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_query.pm +++ /dev/null @@ -1,92 +0,0 @@ -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; - $$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; diff --git a/Master/tlpkg/tlperl/lib/URI/_segment.pm b/Master/tlpkg/tlperl/lib/URI/_segment.pm deleted file mode 100755 index c91b69608e3..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_segment.pm +++ /dev/null @@ -1,20 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/_server.pm b/Master/tlpkg/tlperl/lib/URI/_server.pm deleted file mode 100755 index f72ec22657b..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_server.pm +++ /dev/null @@ -1,162 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/_userpass.pm b/Master/tlpkg/tlperl/lib/URI/_userpass.pm deleted file mode 100755 index a0361ae0dd7..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/_userpass.pm +++ /dev/null @@ -1,51 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/data.pm b/Master/tlpkg/tlperl/lib/URI/data.pm deleted file mode 100755 index dccd8181289..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/data.pm +++ /dev/null @@ -1,140 +0,0 @@ -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 diff --git a/Master/tlpkg/tlperl/lib/URI/file.pm b/Master/tlpkg/tlperl/lib/URI/file.pm deleted file mode 100755 index 0ce42529566..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/file.pm +++ /dev/null @@ -1,329 +0,0 @@ -package URI::file; - -use strict; -use vars qw(@ISA $VERSION $DEFAULT_AUTHORITY %OS_CLASS); - -require URI::_generic; -@ISA = qw(URI::_generic); -$VERSION = "4.20"; - -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 path { shift->path_query(@_) } -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 uses ":" as path separator, but not in the same way -as a generic URI. ":foo" is a relative name. "foo:bar" is an absolute -name. Also, path segments can contain the "/" character as well as the -literal "." or "..". So the mapping looks like this: - - Mac 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 diff --git a/Master/tlpkg/tlperl/lib/URI/file/Base.pm b/Master/tlpkg/tlperl/lib/URI/file/Base.pm deleted file mode 100755 index 941793b0f93..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/file/Base.pm +++ /dev/null @@ -1,80 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/file/FAT.pm b/Master/tlpkg/tlperl/lib/URI/file/FAT.pm deleted file mode 100755 index 328169bd0bf..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/file/FAT.pm +++ /dev/null @@ -1,23 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/file/Mac.pm b/Master/tlpkg/tlperl/lib/URI/file/Mac.pm deleted file mode 100755 index 6cfa78192e0..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/file/Mac.pm +++ /dev/null @@ -1,120 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/file/OS2.pm b/Master/tlpkg/tlperl/lib/URI/file/OS2.pm deleted file mode 100755 index ad0a78ede52..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/file/OS2.pm +++ /dev/null @@ -1,28 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/file/QNX.pm b/Master/tlpkg/tlperl/lib/URI/file/QNX.pm deleted file mode 100755 index 93a4983d2bb..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/file/QNX.pm +++ /dev/null @@ -1,18 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/file/Unix.pm b/Master/tlpkg/tlperl/lib/URI/file/Unix.pm deleted file mode 100755 index 5f8aaae9050..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/file/Unix.pm +++ /dev/null @@ -1,55 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/file/Win32.pm b/Master/tlpkg/tlperl/lib/URI/file/Win32.pm deleted file mode 100755 index 04593863a92..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/file/Win32.pm +++ /dev/null @@ -1,84 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/ftp.pm b/Master/tlpkg/tlperl/lib/URI/ftp.pm deleted file mode 100755 index 89aeb07cdc9..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/ftp.pm +++ /dev/null @@ -1,45 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/gopher.pm b/Master/tlpkg/tlperl/lib/URI/gopher.pm deleted file mode 100755 index ae6690423bc..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/gopher.pm +++ /dev/null @@ -1,94 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/http.pm b/Master/tlpkg/tlperl/lib/URI/http.pm deleted file mode 100755 index cb698224060..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/http.pm +++ /dev/null @@ -1,25 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/https.pm b/Master/tlpkg/tlperl/lib/URI/https.pm deleted file mode 100755 index c39c67b5ec3..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/https.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::https; -require URI::http; -@ISA=qw(URI::http); - -sub default_port { 443 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/ldap.pm b/Master/tlpkg/tlperl/lib/URI/ldap.pm deleted file mode 100755 index 8af504b269d..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/ldap.pm +++ /dev/null @@ -1,122 +0,0 @@ -# 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.11"; - -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<RFC-2255|http://www.cis.ohio-state.edu/htbin/rfc/rfc2255.html> - -=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 diff --git a/Master/tlpkg/tlperl/lib/URI/ldapi.pm b/Master/tlpkg/tlperl/lib/URI/ldapi.pm deleted file mode 100755 index d92b13f3a49..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/ldapi.pm +++ /dev/null @@ -1,30 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/ldaps.pm b/Master/tlpkg/tlperl/lib/URI/ldaps.pm deleted file mode 100755 index 20180d55773..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/ldaps.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::ldaps; -require URI::ldap; -@ISA=qw(URI::ldap); - -sub default_port { 636 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/mailto.pm b/Master/tlpkg/tlperl/lib/URI/mailto.pm deleted file mode 100755 index 88761c40333..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/mailto.pm +++ /dev/null @@ -1,72 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/mms.pm b/Master/tlpkg/tlperl/lib/URI/mms.pm deleted file mode 100755 index 2f1015b61d9..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/mms.pm +++ /dev/null @@ -1,8 +0,0 @@ -package URI::mms; - -require URI::http; -@ISA=qw(URI::http); - -sub default_port { 1755 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/news.pm b/Master/tlpkg/tlperl/lib/URI/news.pm deleted file mode 100755 index 1ffb419f673..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/news.pm +++ /dev/null @@ -1,68 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/nntp.pm b/Master/tlpkg/tlperl/lib/URI/nntp.pm deleted file mode 100755 index af61e036cc7..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/nntp.pm +++ /dev/null @@ -1,6 +0,0 @@ -package URI::nntp; # draft-gilman-news-url-01 - -require URI::news; -@ISA=qw(URI::news); - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/pop.pm b/Master/tlpkg/tlperl/lib/URI/pop.pm deleted file mode 100755 index 50b8d6dd511..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/pop.pm +++ /dev/null @@ -1,68 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/rlogin.pm b/Master/tlpkg/tlperl/lib/URI/rlogin.pm deleted file mode 100755 index 18bb76272a4..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/rlogin.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::rlogin; -require URI::_login; -@ISA = qw(URI::_login); - -sub default_port { 513 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/rsync.pm b/Master/tlpkg/tlperl/lib/URI/rsync.pm deleted file mode 100755 index 160d9d0c065..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/rsync.pm +++ /dev/null @@ -1,12 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/rtsp.pm b/Master/tlpkg/tlperl/lib/URI/rtsp.pm deleted file mode 100755 index 982ca5ebf1e..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/rtsp.pm +++ /dev/null @@ -1,8 +0,0 @@ -package URI::rtsp; - -require URI::http; -@ISA=qw(URI::http); - -sub default_port { 554 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/rtspu.pm b/Master/tlpkg/tlperl/lib/URI/rtspu.pm deleted file mode 100755 index dbcf12bb2f4..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/rtspu.pm +++ /dev/null @@ -1,8 +0,0 @@ -package URI::rtspu; - -require URI::rtsp; -@ISA=qw(URI::rtsp); - -sub default_port { 554 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/sip.pm b/Master/tlpkg/tlperl/lib/URI/sip.pm deleted file mode 100755 index 1ace52c4f58..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/sip.pm +++ /dev/null @@ -1,86 +0,0 @@ -# -# 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.10"; - -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; diff --git a/Master/tlpkg/tlperl/lib/URI/sips.pm b/Master/tlpkg/tlperl/lib/URI/sips.pm deleted file mode 100755 index b32e105e24b..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/sips.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::sips; -require URI::sip; -@ISA=qw(URI::sip); - -sub default_port { 5061 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/snews.pm b/Master/tlpkg/tlperl/lib/URI/snews.pm deleted file mode 100755 index 7e5b0379e15..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/snews.pm +++ /dev/null @@ -1,8 +0,0 @@ -package URI::snews; # draft-gilman-news-url-01 - -require URI::news; -@ISA=qw(URI::news); - -sub default_port { 563 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/ssh.pm b/Master/tlpkg/tlperl/lib/URI/ssh.pm deleted file mode 100755 index 5cd30fc3bfc..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/ssh.pm +++ /dev/null @@ -1,9 +0,0 @@ -package URI::ssh; -require URI::_login; -@ISA=qw(URI::_login); - -# ssh://[USER@]HOST[:PORT]/SRC - -sub default_port { 22 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/telnet.pm b/Master/tlpkg/tlperl/lib/URI/telnet.pm deleted file mode 100755 index 5f842d35787..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/telnet.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::telnet; -require URI::_login; -@ISA = qw(URI::_login); - -sub default_port { 23 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/tn3270.pm b/Master/tlpkg/tlperl/lib/URI/tn3270.pm deleted file mode 100755 index dd1e648e713..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/tn3270.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::tn3270; -require URI::_login; -@ISA = qw(URI::_login); - -sub default_port { 23 } - -1; diff --git a/Master/tlpkg/tlperl/lib/URI/urn.pm b/Master/tlpkg/tlperl/lib/URI/urn.pm deleted file mode 100755 index 12d40b265bc..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/urn.pm +++ /dev/null @@ -1,97 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/urn/isbn.pm b/Master/tlpkg/tlperl/lib/URI/urn/isbn.pm deleted file mode 100755 index 0da931bfb69..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/urn/isbn.pm +++ /dev/null @@ -1,102 +0,0 @@ -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; diff --git a/Master/tlpkg/tlperl/lib/URI/urn/oid.pm b/Master/tlpkg/tlperl/lib/URI/urn/oid.pm deleted file mode 100755 index 301b2bcd834..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/urn/oid.pm +++ /dev/null @@ -1,18 +0,0 @@ -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; |