Browse files

機能追加

  • Loading branch information...
1 parent adfc9f2 commit 9d1bdcb6e29b6d451689130280f7dead3f2f4c3b @cho45 committed Mar 6, 2010
Showing with 8,409 additions and 7 deletions.
  1. +1 −1 bin/niro.psgi
  2. +1,102 −0 extlib/lib/perl5/URI.pm
  3. +218 −0 extlib/lib/perl5/URI/Escape.pm
  4. +222 −0 extlib/lib/perl5/URI/Heuristic.pm
  5. +44 −0 extlib/lib/perl5/URI/IRI.pm
  6. +200 −0 extlib/lib/perl5/URI/QueryParam.pm
  7. +96 −0 extlib/lib/perl5/URI/Split.pm
  8. +305 −0 extlib/lib/perl5/URI/URL.pm
  9. +171 −0 extlib/lib/perl5/URI/WithBase.pm
  10. +6 −0 extlib/lib/perl5/URI/_foreign.pm
  11. +249 −0 extlib/lib/perl5/URI/_generic.pm
  12. +78 −0 extlib/lib/perl5/URI/_idna.pm
  13. +140 −0 extlib/lib/perl5/URI/_ldap.pm
  14. +10 −0 extlib/lib/perl5/URI/_login.pm
  15. +203 −0 extlib/lib/perl5/URI/_punycode.pm
  16. +92 −0 extlib/lib/perl5/URI/_query.pm
  17. +20 −0 extlib/lib/perl5/URI/_segment.pm
  18. +162 −0 extlib/lib/perl5/URI/_server.pm
  19. +51 −0 extlib/lib/perl5/URI/_userpass.pm
  20. +140 −0 extlib/lib/perl5/URI/data.pm
  21. +329 −0 extlib/lib/perl5/URI/file.pm
  22. +80 −0 extlib/lib/perl5/URI/file/Base.pm
  23. +23 −0 extlib/lib/perl5/URI/file/FAT.pm
  24. +120 −0 extlib/lib/perl5/URI/file/Mac.pm
  25. +28 −0 extlib/lib/perl5/URI/file/OS2.pm
  26. +18 −0 extlib/lib/perl5/URI/file/QNX.pm
  27. +55 −0 extlib/lib/perl5/URI/file/Unix.pm
  28. +84 −0 extlib/lib/perl5/URI/file/Win32.pm
  29. +45 −0 extlib/lib/perl5/URI/ftp.pm
  30. +94 −0 extlib/lib/perl5/URI/gopher.pm
  31. +25 −0 extlib/lib/perl5/URI/http.pm
  32. +7 −0 extlib/lib/perl5/URI/https.pm
  33. +122 −0 extlib/lib/perl5/URI/ldap.pm
  34. +30 −0 extlib/lib/perl5/URI/ldapi.pm
  35. +7 −0 extlib/lib/perl5/URI/ldaps.pm
  36. +72 −0 extlib/lib/perl5/URI/mailto.pm
  37. +8 −0 extlib/lib/perl5/URI/mms.pm
  38. +68 −0 extlib/lib/perl5/URI/news.pm
  39. +6 −0 extlib/lib/perl5/URI/nntp.pm
  40. +68 −0 extlib/lib/perl5/URI/pop.pm
  41. +7 −0 extlib/lib/perl5/URI/rlogin.pm
  42. +12 −0 extlib/lib/perl5/URI/rsync.pm
  43. +8 −0 extlib/lib/perl5/URI/rtsp.pm
  44. +8 −0 extlib/lib/perl5/URI/rtspu.pm
  45. +86 −0 extlib/lib/perl5/URI/sip.pm
  46. +7 −0 extlib/lib/perl5/URI/sips.pm
  47. +8 −0 extlib/lib/perl5/URI/snews.pm
  48. +9 −0 extlib/lib/perl5/URI/ssh.pm
  49. +7 −0 extlib/lib/perl5/URI/telnet.pm
  50. +7 −0 extlib/lib/perl5/URI/tn3270.pm
  51. +97 −0 extlib/lib/perl5/URI/urn.pm
  52. +102 −0 extlib/lib/perl5/URI/urn/isbn.pm
  53. +18 −0 extlib/lib/perl5/URI/urn/oid.pm
  54. +122 −0 extlib/lib/perl5/i486-linux-gnu-thread-multi/auto/URI/.packlist
  55. +22 −0 extlib/lib/perl5/i486-linux-gnu-thread-multi/perllocal.pod
  56. +887 −0 extlib/man/man3/URI.3pm
  57. +275 −0 extlib/man/man3/URI::Escape.3pm
  58. +196 −0 extlib/man/man3/URI::Heuristic.3pm
  59. +247 −0 extlib/man/man3/URI::QueryParam.3pm
  60. +175 −0 extlib/man/man3/URI::Split.3pm
  61. +197 −0 extlib/man/man3/URI::URL.3pm
  62. +178 −0 extlib/man/man3/URI::WithBase.3pm
  63. +179 −0 extlib/man/man3/URI::_punycode.3pm
  64. +188 −0 extlib/man/man3/URI::data.3pm
  65. +317 −0 extlib/man/man3/URI::file.3pm
  66. +215 −0 extlib/man/man3/URI::ldap.3pm
  67. +3 −2 lib/Niro.pm
  68. +2 −1 lib/Niro/Model/Row/Entry.pm
  69. +1 −1 modules/Text-Xatena
  70. +28 −1 static/js/site-script.js
  71. +1 −1 templates/_entry.html
  72. +1 −0 tools/build_extlib.sh
View
2 bin/niro.psgi
@@ -1,4 +1,4 @@
-#!perl -Imodules/Plack/lib modules/Plack/scripts/plackup -app
+#!perl -Imodules/Plack/lib modules/Plack/scripts/plackup -r -app
use strict;
use warnings;
use utf8;
View
1,102 extlib/lib/perl5/URI.pm
@@ -0,0 +1,1102 @@
+package URI;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "1.52";
+
+use vars qw($ABS_REMOTE_LEADING_DOTS $ABS_ALLOW_RELATIVE_SCHEME $DEFAULT_QUERY_FORM_DELIMITER);
+
+my %implements; # mapping from scheme to implementor class
+
+# Some "official" character classes
+
+use vars qw($reserved $mark $unreserved $uric $scheme_re);
+$reserved = q(;/?:@&=+$,[]);
+$mark = q(-_.!~*'()); #'; emacs
+$unreserved = "A-Za-z0-9\Q$mark\E";
+$uric = quotemeta($reserved) . $unreserved . "%";
+
+$scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*';
+
+use Carp ();
+use URI::Escape ();
+
+use overload ('""' => sub { ${$_[0]} },
+ '==' => sub { _obj_eq(@_) },
+ '!=' => sub { !_obj_eq(@_) },
+ fallback => 1,
+ );
+
+# Check if two objects are the same object
+sub _obj_eq {
+ return overload::StrVal($_[0]) eq overload::StrVal($_[1]);
+}
+
+sub new
+{
+ my($class, $uri, $scheme) = @_;
+
+ $uri = defined ($uri) ? "$uri" : ""; # stringify
+ # Get rid of potential wrapping
+ $uri =~ s/^<(?:URL:)?(.*)>$/$1/; #
+ $uri =~ s/^"(.*)"$/$1/;
+ $uri =~ s/^\s+//;
+ $uri =~ s/\s+$//;
+
+ my $impclass;
+ if ($uri =~ m/^($scheme_re):/so) {
+ $scheme = $1;
+ }
+ else {
+ if (($impclass = ref($scheme))) {
+ $scheme = $scheme->scheme;
+ }
+ elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) {
+ $scheme = $1;
+ }
+ }
+ $impclass ||= implementor($scheme) ||
+ do {
+ require URI::_foreign;
+ $impclass = 'URI::_foreign';
+ };
+
+ return $impclass->_init($uri, $scheme);
+}
+
+
+sub new_abs
+{
+ my($class, $uri, $base) = @_;
+ $uri = $class->new($uri, $base);
+ $uri->abs($base);
+}
+
+
+sub _init
+{
+ my $class = shift;
+ my($str, $scheme) = @_;
+ # find all funny characters and encode the bytes.
+ $str = $class->_uric_escape($str);
+ $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o ||
+ $class->_no_scheme_ok;
+ my $self = bless \$str, $class;
+ $self;
+}
+
+
+sub _uric_escape
+{
+ my($class, $str) = @_;
+ $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego;
+ return $str;
+}
+
+
+sub implementor
+{
+ my($scheme, $impclass) = @_;
+ if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
+ require URI::_generic;
+ return "URI::_generic";
+ }
+
+ $scheme = lc($scheme);
+
+ if ($impclass) {
+ # Set the implementor class for a given scheme
+ my $old = $implements{$scheme};
+ $impclass->_init_implementor($scheme);
+ $implements{$scheme} = $impclass;
+ return $old;
+ }
+
+ my $ic = $implements{$scheme};
+ return $ic if $ic;
+
+ # scheme not yet known, look for internal or
+ # preloaded (with 'use') implementation
+ $ic = "URI::$scheme"; # default location
+
+ # turn scheme into a valid perl identifier by a simple transformation...
+ $ic =~ s/\+/_P/g;
+ $ic =~ s/\./_O/g;
+ $ic =~ s/\-/_/g;
+
+ no strict 'refs';
+ # check we actually have one for the scheme:
+ unless (@{"${ic}::ISA"}) {
+ # Try to load it
+ eval "require $ic";
+ die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
+ return unless @{"${ic}::ISA"};
+ }
+
+ $ic->_init_implementor($scheme);
+ $implements{$scheme} = $ic;
+ $ic;
+}
+
+
+sub _init_implementor
+{
+ my($class, $scheme) = @_;
+ # Remember that one implementor class may actually
+ # serve to implement several URI schemes.
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $other = $$self;
+ bless \$other, ref $self;
+}
+
+
+sub _no_scheme_ok { 0 }
+
+sub _scheme
+{
+ my $self = shift;
+
+ unless (@_) {
+ return unless $$self =~ /^($scheme_re):/o;
+ return $1;
+ }
+
+ my $old;
+ my $new = shift;
+ if (defined($new) && length($new)) {
+ Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
+ $old = $1 if $$self =~ s/^($scheme_re)://o;
+ my $newself = URI->new("$new:$$self");
+ $$self = $$newself;
+ bless $self, ref($newself);
+ }
+ else {
+ if ($self->_no_scheme_ok) {
+ $old = $1 if $$self =~ s/^($scheme_re)://o;
+ Carp::carp("Oops, opaque part now look like scheme")
+ if $^W && $$self =~ m/^$scheme_re:/o
+ }
+ else {
+ $old = $1 if $$self =~ m/^($scheme_re):/o;
+ }
+ }
+
+ return $old;
+}
+
+sub scheme
+{
+ my $scheme = shift->_scheme(@_);
+ return unless defined $scheme;
+ lc($scheme);
+}
+
+
+sub opaque
+{
+ my $self = shift;
+
+ unless (@_) {
+ $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
+ return $1;
+ }
+
+ $$self =~ /^($scheme_re:)? # optional scheme
+ ([^\#]*) # opaque
+ (\#.*)? # optional fragment
+ $/sx or die;
+
+ my $old_scheme = $1;
+ my $old_opaque = $2;
+ my $old_frag = $3;
+
+ my $new_opaque = shift;
+ $new_opaque = "" unless defined $new_opaque;
+ $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego;
+
+ $$self = defined($old_scheme) ? $old_scheme : "";
+ $$self .= $new_opaque;
+ $$self .= $old_frag if defined $old_frag;
+
+ $old_opaque;
+}
+
+*path = \&opaque; # alias
+
+
+sub fragment
+{
+ my $self = shift;
+ unless (@_) {
+ return unless $$self =~ /\#(.*)/s;
+ return $1;
+ }
+
+ my $old;
+ $old = $1 if $$self =~ s/\#(.*)//s;
+
+ my $new_frag = shift;
+ if (defined $new_frag) {
+ $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego;
+ $$self .= "#$new_frag";
+ }
+ $old;
+}
+
+
+sub as_string
+{
+ my $self = shift;
+ $$self;
+}
+
+
+sub as_iri
+{
+ my $self = shift;
+ my $str = $$self;
+ if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) {
+ # All this crap because the more obvious:
+ #
+ # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift })
+ #
+ # doesn't work before Encode 2.39. Wait for a standard release
+ # to bundle that version.
+
+ require Encode;
+ my $enc = Encode::find_encoding("UTF-8");
+ my $u = "";
+ while (length $str) {
+ $u .= $enc->decode($str, Encode::FB_QUIET());
+ if (length $str) {
+ # escape next char
+ $u .= URI::Escape::escape_char(substr($str, 0, 1, ""));
+ }
+ }
+ $str = $u;
+ }
+ return $str;
+}
+
+
+sub canonical
+{
+ # Make sure scheme is lowercased, that we don't escape unreserved chars,
+ # and that we use upcase escape sequences.
+
+ my $self = shift;
+ my $scheme = $self->_scheme || "";
+ my $uc_scheme = $scheme =~ /[A-Z]/;
+ my $esc = $$self =~ /%[a-fA-F0-9]{2}/;
+ return $self unless $uc_scheme || $esc;
+
+ my $other = $self->clone;
+ if ($uc_scheme) {
+ $other->_scheme(lc $scheme);
+ }
+ if ($esc) {
+ $$other =~ s{%([0-9a-fA-F]{2})}
+ { my $a = chr(hex($1));
+ $a =~ /^[$unreserved]\z/o ? $a : "%\U$1"
+ }ge;
+ }
+ return $other;
+}
+
+# Compare two URIs, subclasses will provide a more correct implementation
+sub eq {
+ my($self, $other) = @_;
+ $self = URI->new($self, $other) unless ref $self;
+ $other = URI->new($other, $self) unless ref $other;
+ ref($self) eq ref($other) && # same class
+ $self->canonical->as_string eq $other->canonical->as_string;
+}
+
+# generic-URI transformation methods
+sub abs { $_[0]; }
+sub rel { $_[0]; }
+
+# help out Storable
+sub STORABLE_freeze {
+ my($self, $cloning) = @_;
+ return $$self;
+}
+
+sub STORABLE_thaw {
+ my($self, $cloning, $str) = @_;
+ $$self = $str;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI - Uniform Resource Identifiers (absolute and relative)
+
+=head1 SYNOPSIS
+
+ $u1 = URI->new("http://www.perl.com");
+ $u2 = URI->new("foo", "http");
+ $u3 = $u2->abs($u1);
+ $u4 = $u3->clone;
+ $u5 = URI->new("HTTP://WWW.perl.com:80")->canonical;
+
+ $str = $u->as_string;
+ $str = "$u";
+
+ $scheme = $u->scheme;
+ $opaque = $u->opaque;
+ $path = $u->path;
+ $frag = $u->fragment;
+
+ $u->scheme("ftp");
+ $u->host("ftp.perl.com");
+ $u->path("cpan/");
+
+=head1 DESCRIPTION
+
+This module implements the C<URI> class. Objects of this class
+represent "Uniform Resource Identifier references" as specified in RFC
+2396 (and updated by RFC 2732).
+
+A Uniform Resource Identifier is a compact string of characters that
+identifies an abstract or physical resource. A Uniform Resource
+Identifier can be further classified as either a Uniform Resource Locator
+(URL) or a Uniform Resource Name (URN). The distinction between URL
+and URN does not matter to the C<URI> class interface. A
+"URI-reference" is a URI that may have additional information attached
+in the form of a fragment identifier.
+
+An absolute URI reference consists of three parts: a I<scheme>, a
+I<scheme-specific part> and a I<fragment> identifier. A subset of URI
+references share a common syntax for hierarchical namespaces. For
+these, the scheme-specific part is further broken down into
+I<authority>, I<path> and I<query> components. These URIs can also
+take the form of relative URI references, where the scheme (and
+usually also the authority) component is missing, but implied by the
+context of the URI reference. The three forms of URI reference
+syntax are summarized as follows:
+
+ <scheme>:<scheme-specific-part>#<fragment>
+ <scheme>://<authority><path>?<query>#<fragment>
+ <path>?<query>#<fragment>
+
+The components into which a URI reference can be divided depend on the
+I<scheme>. The C<URI> class provides methods to get and set the
+individual components. The methods available for a specific
+C<URI> object depend on the scheme.
+
+=head1 CONSTRUCTORS
+
+The following methods construct new C<URI> objects:
+
+=over 4
+
+=item $uri = URI->new( $str )
+
+=item $uri = URI->new( $str, $scheme )
+
+Constructs a new URI object. The string
+representation of a URI is given as argument, together with an optional
+scheme specification. Common URI wrappers like "" and <>, as well as
+leading and trailing white space, are automatically removed from
+the $str argument before it is processed further.
+
+The constructor determines the scheme, maps this to an appropriate
+URI subclass, constructs a new object of that class and returns it.
+
+The $scheme argument is only used when $str is a
+relative URI. It can be either a simple string that
+denotes the scheme, a string containing an absolute URI reference, or
+an absolute C<URI> object. If no $scheme is specified for a relative
+URI $str, then $str is simply treated as a generic URI (no scheme-specific
+methods available).
+
+The set of characters available for building URI references is
+restricted (see L<URI::Escape>). Characters outside this set are
+automatically escaped by the URI constructor.
+
+=item $uri = URI->new_abs( $str, $base_uri )
+
+Constructs a new absolute URI object. The $str argument can
+denote a relative or absolute URI. If relative, then it is
+absolutized using $base_uri as base. The $base_uri must be an absolute
+URI.
+
+=item $uri = URI::file->new( $filename )
+
+=item $uri = URI::file->new( $filename, $os )
+
+Constructs a new I<file> URI from a file name. See L<URI::file>.
+
+=item $uri = URI::file->new_abs( $filename )
+
+=item $uri = URI::file->new_abs( $filename, $os )
+
+Constructs a new absolute I<file> URI from a file name. See
+L<URI::file>.
+
+=item $uri = URI::file->cwd
+
+Returns the current working directory as a I<file> URI. See
+L<URI::file>.
+
+=item $uri->clone
+
+Returns a copy of the $uri.
+
+=back
+
+=head1 COMMON METHODS
+
+The methods described in this section are available for all C<URI>
+objects.
+
+Methods that give access to components of a URI always return the
+old value of the component. The value returned is C<undef> if the
+component was not present. There is generally a difference between a
+component that is empty (represented as C<"">) and a component that is
+missing (represented as C<undef>). If an accessor method is given an
+argument, it updates the corresponding component in addition to
+returning the old value of the component. Passing an undefined
+argument removes the component (if possible). The description of
+each accessor method indicates whether the component is passed as
+an escaped or an unescaped string. A component that can be further
+divided into sub-parts are usually passed escaped, as unescaping might
+change its semantics.
+
+The common methods available for all URI are:
+
+=over 4
+
+=item $uri->scheme
+
+=item $uri->scheme( $new_scheme )
+
+Sets and returns the scheme part of the $uri. If the $uri is
+relative, then $uri->scheme returns C<undef>. If called with an
+argument, it updates the scheme of $uri, possibly changing the
+class of $uri, and returns the old scheme value. The method croaks
+if the new scheme name is illegal; a scheme name must begin with a
+letter and must consist of only US-ASCII letters, numbers, and a few
+special marks: ".", "+", "-". This restriction effectively means
+that the scheme must be passed unescaped. Passing an undefined
+argument to the scheme method makes the URI relative (if possible).
+
+Letter case does not matter for scheme names. The string
+returned by $uri->scheme is always lowercase. If you want the scheme
+just as it was written in the URI in its original case,
+you can use the $uri->_scheme method instead.
+
+=item $uri->opaque
+
+=item $uri->opaque( $new_opaque )
+
+Sets and returns the scheme-specific part of the $uri
+(everything between the scheme and the fragment)
+as an escaped string.
+
+=item $uri->path
+
+=item $uri->path( $new_path )
+
+Sets and returns the same value as $uri->opaque unless the URI
+supports the generic syntax for hierarchical namespaces.
+In that case the generic method is overridden to set and return
+the part of the URI between the I<host name> and the I<fragment>.
+
+=item $uri->fragment
+
+=item $uri->fragment( $new_frag )
+
+Returns the fragment identifier of a URI reference
+as an escaped string.
+
+=item $uri->as_string
+
+Returns a URI object to a plain ASCII string. URI objects are
+also converted to plain strings automatically by overloading. This
+means that $uri objects can be used as plain strings in most Perl
+constructs.
+
+=item $uri->as_iri
+
+Returns a Unicode string representing the URI. Escaped UTF-8 sequences
+representing non-ASCII characters are turned into their corresponding Unicode
+code point.
+
+=item $uri->canonical
+
+Returns a normalized version of the URI. The rules
+for normalization are scheme-dependent. They usually involve
+lowercasing the scheme and Internet host name components,
+removing the explicit port specification if it matches the default port,
+uppercasing all escape sequences, and unescaping octets that can be
+better represented as plain characters.
+
+For efficiency reasons, if the $uri is already in normalized form,
+then a reference to it is returned instead of a copy.
+
+=item $uri->eq( $other_uri )
+
+=item URI::eq( $first_uri, $other_uri )
+
+Tests whether two URI references are equal. URI references
+that normalize to the same string are considered equal. The method
+can also be used as a plain function which can also test two string
+arguments.
+
+If you need to test whether two C<URI> object references denote the
+same object, use the '==' operator.
+
+=item $uri->abs( $base_uri )
+
+Returns an absolute URI reference. If $uri is already
+absolute, then a reference to it is simply returned. If the $uri
+is relative, then a new absolute URI is constructed by combining the
+$uri and the $base_uri, and returned.
+
+=item $uri->rel( $base_uri )
+
+Returns a relative URI reference if it is possible to
+make one that denotes the same resource relative to $base_uri.
+If not, then $uri is simply returned.
+
+=back
+
+=head1 GENERIC METHODS
+
+The following methods are available to schemes that use the
+common/generic syntax for hierarchical namespaces. The descriptions of
+schemes below indicate which these are. Unknown schemes are
+assumed to support the generic syntax, and therefore the following
+methods:
+
+=over 4
+
+=item $uri->authority
+
+=item $uri->authority( $new_authority )
+
+Sets and returns the escaped authority component
+of the $uri.
+
+=item $uri->path
+
+=item $uri->path( $new_path )
+
+Sets and returns the escaped path component of
+the $uri (the part between the host name and the query or fragment).
+The path can never be undefined, but it can be the empty string.
+
+=item $uri->path_query
+
+=item $uri->path_query( $new_path_query )
+
+Sets and returns the escaped path and query
+components as a single entity. The path and the query are
+separated by a "?" character, but the query can itself contain "?".
+
+=item $uri->path_segments
+
+=item $uri->path_segments( $segment, ... )
+
+Sets and returns the path. In a scalar context, it returns
+the same value as $uri->path. In a list context, it returns the
+unescaped path segments that make up the path. Path segments that
+have parameters are returned as an anonymous array. The first element
+is the unescaped path segment proper; subsequent elements are escaped
+parameter strings. Such an anonymous array uses overloading so it can
+be treated as a string too, but this string does not include the
+parameters.
+
+Note that absolute paths have the empty string as their first
+I<path_segment>, i.e. the I<path> C</foo/bar> have 3
+I<path_segments>; "", "foo" and "bar".
+
+=item $uri->query
+
+=item $uri->query( $new_query )
+
+Sets and returns the escaped query component of
+the $uri.
+
+=item $uri->query_form
+
+=item $uri->query_form( $key1 => $val1, $key2 => $val2, ... )
+
+=item $uri->query_form( $key1 => $val1, $key2 => $val2, ..., $delim )
+
+=item $uri->query_form( \@key_value_pairs )
+
+=item $uri->query_form( \@key_value_pairs, $delim )
+
+=item $uri->query_form( \%hash )
+
+=item $uri->query_form( \%hash, $delim )
+
+Sets and returns query components that use the
+I<application/x-www-form-urlencoded> format. Key/value pairs are
+separated by "&", and the key is separated from the value by a "="
+character.
+
+The form can be set either by passing separate key/value pairs, or via
+an array or hash reference. Passing an empty array or an empty hash
+removes the query component, whereas passing no arguments at all leaves
+the component unchanged. The order of keys is undefined if a hash
+reference is passed. The old value is always returned as a list of
+separate key/value pairs. Assigning this list to a hash is unwise as
+the keys returned might repeat.
+
+The values passed when setting the form can be plain strings or
+references to arrays of strings. Passing an array of values has the
+same effect as passing the key repeatedly with one value at a time.
+All the following statements have the same effect:
+
+ $uri->query_form(foo => 1, foo => 2);
+ $uri->query_form(foo => [1, 2]);
+ $uri->query_form([ foo => 1, foo => 2 ]);
+ $uri->query_form([ foo => [1, 2] ]);
+ $uri->query_form({ foo => [1, 2] });
+
+The $delim parameter can be passed as ";" to force the key/value pairs
+to be delimited by ";" instead of "&" in the query string. This
+practice is often recommended for URLs embedded in HTML or XML
+documents as this avoids the trouble of escaping the "&" character.
+You might also set the $URI::DEFAULT_QUERY_FORM_DELIMITER variable to
+";" for the same global effect.
+
+The C<URI::QueryParam> module can be loaded to add further methods to
+manipulate the form of a URI. See L<URI::QueryParam> for details.
+
+=item $uri->query_keywords
+
+=item $uri->query_keywords( $keywords, ... )
+
+=item $uri->query_keywords( \@keywords )
+
+Sets and returns query components that use the
+keywords separated by "+" format.
+
+The keywords can be set either by passing separate keywords directly
+or by passing a reference to an array of keywords. Passing an empty
+array removes the query component, whereas passing no arguments at
+all leaves the component unchanged. The old value is always returned
+as a list of separate words.
+
+=back
+
+=head1 SERVER METHODS
+
+For schemes where the I<authority> component denotes an Internet host,
+the following methods are available in addition to the generic
+methods.
+
+=over 4
+
+=item $uri->userinfo
+
+=item $uri->userinfo( $new_userinfo )
+
+Sets and returns the escaped userinfo part of the
+authority component.
+
+For some schemes this is a user name and a password separated by
+a colon. This practice is not recommended. Embedding passwords in
+clear text (such as URI) has proven to be a security risk in almost
+every case where it has been used.
+
+=item $uri->host
+
+=item $uri->host( $new_host )
+
+Sets and returns the unescaped hostname.
+
+If the $new_host string ends with a colon and a number, then this
+number also sets the port.
+
+For IPv6 addresses the brackets around the raw address is removed in the return
+value from $uri->host. When setting the host attribute to an IPv6 address you
+can use a raw address or one enclosed in brackets. The address needs to be
+enclosed in brackets if you want to pass in a new port value as well.
+
+=item $uri->ihost
+
+Returns the host in Unicode form. Any IDNA A-labels are turned into U-labels.
+
+=item $uri->port
+
+=item $uri->port( $new_port )
+
+Sets and returns the port. The port is a simple integer
+that should be greater than 0.
+
+If a port is not specified explicitly in the URI, then the URI scheme's default port
+is returned. If you don't want the default port
+substituted, then you can use the $uri->_port method instead.
+
+=item $uri->host_port
+
+=item $uri->host_port( $new_host_port )
+
+Sets and returns the host and port as a single
+unit. The returned value includes a port, even if it matches the
+default port. The host part and the port part are separated by a
+colon: ":".
+
+For IPv6 addresses the bracketing is preserved; thus
+URI->new("http://[::1]/")->host_port returns "[::1]:80". Contrast this with
+$uri->host which will remove the brackets.
+
+=item $uri->default_port
+
+Returns the default port of the URI scheme to which $uri
+belongs. For I<http> this is the number 80, for I<ftp> this
+is the number 21, etc. The default port for a scheme can not be
+changed.
+
+=back
+
+=head1 SCHEME-SPECIFIC SUPPORT
+
+Scheme-specific support is provided for the following URI schemes. For C<URI>
+objects that do not belong to one of these, you can only use the common and
+generic methods.
+
+=over 4
+
+=item B<data>:
+
+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.
+
+C<URI> objects belonging to the data scheme support the common methods
+and two new methods to access their scheme-specific components:
+$uri->media_type and $uri->data. See L<URI::data> for details.
+
+=item B<file>:
+
+An old specification of the I<file> URI scheme is found in RFC 1738.
+A new RFC 2396 based specification in not available yet, but file URI
+references are in common use.
+
+C<URI> objects belonging to the file scheme support the common and
+generic methods. In addition, they provide two methods for mapping file URIs
+back to local file names; $uri->file and $uri->dir. See L<URI::file>
+for details.
+
+=item B<ftp>:
+
+An old specification of the I<ftp> URI scheme is found in RFC 1738. A
+new RFC 2396 based specification in not available yet, but ftp URI
+references are in common use.
+
+C<URI> objects belonging to the ftp scheme support the common,
+generic and server methods. In addition, they provide two methods for
+accessing the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<gopher>:
+
+The I<gopher> URI scheme is specified in
+<draft-murali-url-gopher-1996-12-04> and will hopefully be available
+as a RFC 2396 based specification.
+
+C<URI> objects belonging to the gopher scheme support the common,
+generic and server methods. In addition, they support some methods for
+accessing gopher-specific path components: $uri->gopher_type,
+$uri->selector, $uri->search, $uri->string.
+
+=item B<http>:
+
+The I<http> URI scheme is specified in RFC 2616.
+The scheme is used to reference resources hosted by HTTP servers.
+
+C<URI> objects belonging to the http scheme support the common,
+generic and server methods.
+
+=item B<https>:
+
+The I<https> URI scheme is a Netscape invention which is commonly
+implemented. The scheme is used to reference HTTP servers through SSL
+connections. Its syntax is the same as http, but the default
+port is different.
+
+=item B<ldap>:
+
+The I<ldap> URI scheme is specified in RFC 2255. LDAP is the
+Lightweight Directory Access Protocol. An ldap URI describes an LDAP
+search operation to perform to retrieve information from an LDAP
+directory.
+
+C<URI> objects belonging to the ldap scheme support the common,
+generic and server methods as well as ldap-specific methods: $uri->dn,
+$uri->attributes, $uri->scope, $uri->filter, $uri->extensions. See
+L<URI::ldap> for details.
+
+=item B<ldapi>:
+
+Like the I<ldap> URI scheme, but uses a UNIX domain socket. The
+server methods are not supported, and the local socket path is
+available as $uri->un_path. The I<ldapi> scheme is used by the
+OpenLDAP package. There is no real specification for it, but it is
+mentioned in various OpenLDAP manual pages.
+
+=item B<ldaps>:
+
+Like the I<ldap> URI scheme, but uses an SSL connection. This
+scheme is deprecated, as the preferred way is to use the I<start_tls>
+mechanism.
+
+=item B<mailto>:
+
+The I<mailto> URI scheme is specified in RFC 2368. The scheme was
+originally used to designate the Internet mailing address of an
+individual or service. It has (in RFC 2368) been extended to allow
+setting of other mail header fields and the message body.
+
+C<URI> objects belonging to the mailto scheme support the common
+methods and the generic query methods. In addition, they support the
+following mailto-specific methods: $uri->to, $uri->headers.
+
+Note that the "foo@example.com" part of a mailto is I<not> the
+C<userinfo> and C<host> but instead the C<path>. This allowed a
+mailto to contain multiple comma-seperated email addresses.
+
+=item B<mms>:
+
+The I<mms> URL specification can be found at L<http://sdp.ppona.com/>
+C<URI> objects belonging to the mms scheme support the common,
+generic, and server methods, with the exception of userinfo and
+query-related sub-components.
+
+=item B<news>:
+
+The I<news>, I<nntp> and I<snews> URI schemes are specified in
+<draft-gilman-news-url-01> and will hopefully be available as an RFC
+2396 based specification soon.
+
+C<URI> objects belonging to the news scheme support the common,
+generic and server methods. In addition, they provide some methods to
+access the path: $uri->group and $uri->message.
+
+=item B<nntp>:
+
+See I<news> scheme.
+
+=item B<pop>:
+
+The I<pop> URI scheme is specified in RFC 2384. The scheme is used to
+reference a POP3 mailbox.
+
+C<URI> objects belonging to the pop scheme support the common, generic
+and server methods. In addition, they provide two methods to access the
+userinfo components: $uri->user and $uri->auth
+
+=item B<rlogin>:
+
+An old specification of the I<rlogin> URI scheme is found in RFC
+1738. C<URI> objects belonging to the rlogin scheme support the
+common, generic and server methods.
+
+=item B<rtsp>:
+
+The I<rtsp> URL specification can be found in section 3.2 of RFC 2326.
+C<URI> objects belonging to the rtsp scheme support the common,
+generic, and server methods, with the exception of userinfo and
+query-related sub-components.
+
+=item B<rtspu>:
+
+The I<rtspu> URI scheme is used to talk to RTSP servers over UDP
+instead of TCP. The syntax is the same as rtsp.
+
+=item B<rsync>:
+
+Information about rsync is available from http://rsync.samba.org.
+C<URI> objects belonging to the rsync scheme support the common,
+generic and server methods. In addition, they provide methods to
+access the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<sip>:
+
+The I<sip> URI specification is described in sections 19.1 and 25
+of RFC 3261. C<URI> objects belonging to the sip scheme support the
+common, generic, and server methods with the exception of path related
+sub-components. In addition, they provide two methods to get and set
+I<sip> parameters: $uri->params_form and $uri->params.
+
+=item B<sips>:
+
+See I<sip> scheme. Its syntax is the same as sip, but the default
+port is different.
+
+=item B<snews>:
+
+See I<news> scheme. Its syntax is the same as news, but the default
+port is different.
+
+=item B<telnet>:
+
+An old specification of the I<telnet> URI scheme is found in RFC
+1738. C<URI> objects belonging to the telnet scheme support the
+common, generic and server methods.
+
+=item B<tn3270>:
+
+These URIs are used like I<telnet> URIs but for connections to IBM
+mainframes. C<URI> objects belonging to the tn3270 scheme support the
+common, generic and server methods.
+
+=item B<ssh>:
+
+Information about ssh is available at http://www.openssh.com/.
+C<URI> objects belonging to the ssh scheme support the common,
+generic and server methods. In addition, they provide methods to
+access the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<urn>:
+
+The syntax of Uniform Resource Names is specified in RFC 2141. C<URI>
+objects belonging to the urn scheme provide the common methods, and also the
+methods $uri->nid and $uri->nss, which return the Namespace Identifier
+and the Namespace-Specific String respectively.
+
+The Namespace Identifier basically works like the Scheme identifier of
+URIs, and further divides the URN namespace. Namespace Identifier
+assignments are maintained at
+<http://www.iana.org/assignments/urn-namespaces>.
+
+Letter case is not significant for the Namespace Identifier. It is
+always returned in lower case by the $uri->nid method. The $uri->_nid
+method can be used if you want it in its original case.
+
+=item B<urn>:B<isbn>:
+
+The C<urn:isbn:> namespace contains International Standard Book
+Numbers (ISBNs) and is described in RFC 3187. A C<URI> object belonging
+to this namespace has the following extra methods (if the
+Business::ISBN module is available): $uri->isbn,
+$uri->isbn_publisher_code, $uri->isbn_group_code (formerly isbn_country_code,
+which is still supported by issues a deprecation warning), $uri->isbn_as_ean.
+
+=item B<urn>:B<oid>:
+
+The C<urn:oid:> namespace contains Object Identifiers (OIDs) and is
+described in RFC 3061. An object identifier consists of sequences of digits
+separated by dots. A C<URI> object belonging to this namespace has an
+additional method called $uri->oid that can be used to get/set the oid
+value. In a list context, oid numbers are returned as separate elements.
+
+=back
+
+=head1 CONFIGURATION VARIABLES
+
+The following configuration variables influence how the class and its
+methods behave:
+
+=over 4
+
+=item $URI::ABS_ALLOW_RELATIVE_SCHEME
+
+Some older parsers used to allow the scheme name to be present in the
+relative URL if it was the same as the base URL scheme. RFC 2396 says
+that this should be avoided, but you can enable this old behaviour by
+setting the $URI::ABS_ALLOW_RELATIVE_SCHEME variable to a TRUE value.
+The difference is demonstrated by the following examples:
+
+ URI->new("http:foo")->abs("http://host/a/b")
+ ==> "http:foo"
+
+ local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
+ URI->new("http:foo")->abs("http://host/a/b")
+ ==> "http:/host/a/foo"
+
+
+=item $URI::ABS_REMOTE_LEADING_DOTS
+
+You can also have the abs() method ignore excess ".."
+segments in the relative URI by setting $URI::ABS_REMOTE_LEADING_DOTS
+to a TRUE value. The difference is demonstrated by the following
+examples:
+
+ URI->new("../../../foo")->abs("http://host/a/b")
+ ==> "http://host/../../foo"
+
+ local $URI::ABS_REMOTE_LEADING_DOTS = 1;
+ URI->new("../../../foo")->abs("http://host/a/b")
+ ==> "http://host/foo"
+
+=item $URI::DEFAULT_QUERY_FORM_DELIMITER
+
+This value can be set to ";" to have the query form C<key=value> pairs
+delimited by ";" instead of "&" which is the default.
+
+=back
+
+=head1 BUGS
+
+Using regexp variables like $1 directly as arguments to the URI methods
+does not work too well with current perl implementations. I would argue
+that this is actually a bug in perl. The workaround is to quote
+them. Example:
+
+ /(...)/ || die;
+ $u->query("$1");
+
+=head1 PARSING URIs WITH REGEXP
+
+As an alternative to this module, the following (official) regular
+expression can be used to decode a URI:
+
+ my($scheme, $authority, $path, $query, $fragment) =
+ $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
+
+The C<URI::Split> module provides the function uri_split() as a
+readable alternative.
+
+=head1 SEE ALSO
+
+L<URI::file>, L<URI::WithBase>, L<URI::QueryParam>, L<URI::Escape>,
+L<URI::Split>, L<URI::Heuristic>
+
+RFC 2396: "Uniform Resource Identifiers (URI): Generic Syntax",
+Berners-Lee, Fielding, Masinter, August 1998.
+
+http://www.iana.org/assignments/uri-schemes
+
+http://www.iana.org/assignments/urn-namespaces
+
+http://www.w3.org/Addressing/
+
+=head1 COPYRIGHT
+
+Copyright 1995-2009 Gisle Aas.
+
+Copyright 1995 Martijn Koster.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHORS / ACKNOWLEDGMENTS
+
+This module is based on the C<URI::URL> module, which in turn was
+(distantly) based on the C<wwwurl.pl> code in the libwww-perl for
+perl4 developed by Roy Fielding, as part of the Arcadia project at the
+University of California, Irvine, with contributions from Brooks
+Cutter.
+
+C<URI::URL> was developed by Gisle Aas, Tim Bunce, Roy Fielding and
+Martijn Koster with input from other people on the libwww-perl mailing
+list.
+
+C<URI> and related subclasses was developed by Gisle Aas.
+
+=cut
View
218 extlib/lib/perl5/URI/Escape.pm
@@ -0,0 +1,218 @@
+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;
View
222 extlib/lib/perl5/URI/Heuristic.pm
@@ -0,0 +1,222 @@
+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;
View
44 extlib/lib/perl5/URI/IRI.pm
@@ -0,0 +1,44 @@
+package URI::IRI;
+
+# Experimental
+
+use strict;
+use URI ();
+
+use overload '""' => sub { shift->as_string };
+
+sub new {
+ my($class, $uri, $scheme) = @_;
+ utf8::upgrade($uri);
+ return bless {
+ uri => URI->new($uri, $scheme),
+ }, $class;
+}
+
+sub clone {
+ my $self = shift;
+ return bless {
+ uri => $self->{uri}->clone,
+ }, ref($self);
+}
+
+sub as_string {
+ my $self = shift;
+ return $self->{uri}->as_iri;
+}
+
+sub AUTOLOAD
+{
+ use vars qw($AUTOLOAD);
+ my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+
+ # We create the function here so that it will not need to be
+ # autoloaded the next time.
+ no strict 'refs';
+ *$method = sub { shift->{uri}->$method(@_) };
+ goto &$method;
+}
+
+sub DESTROY {} # avoid AUTOLOADing it
+
+1;
View
200 extlib/lib/perl5/URI/QueryParam.pm
@@ -0,0 +1,200 @@
+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
View
96 extlib/lib/perl5/URI/Split.pm
@@ -0,0 +1,96 @@
+package URI::Split;
+
+use strict;
+
+use vars qw(@ISA @EXPORT_OK);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(uri_split uri_join);
+
+use URI::Escape ();
+
+sub uri_split {
+ return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
+}
+
+sub uri_join {
+ my($scheme, $auth, $path, $query, $frag) = @_;
+ my $uri = defined($scheme) ? "$scheme:" : "";
+ $path = "" unless defined $path;
+ if (defined $auth) {
+ $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
+ $uri .= "//$auth";
+ $path = "/$path" if length($path) && $path !~ m,^/,;
+ }
+ elsif ($path =~ m,^//,) {
+ $uri .= "//"; # XXX force empty auth
+ }
+ unless (length $uri) {
+ $path =~ s,(:), URI::Escape::escape_char($1),e while $path =~ m,^[^:/?\#]+:,;
+ }
+ $path =~ s,([?\#]), URI::Escape::escape_char($1),eg;
+ $uri .= $path;
+ if (defined $query) {
+ $query =~ s,(\#), URI::Escape::escape_char($1),eg;
+ $uri .= "?$query";
+ }
+ $uri .= "#$frag" if defined $frag;
+ $uri;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::Split - Parse and compose URI strings
+
+=head1 SYNOPSIS
+
+ use URI::Split qw(uri_split uri_join);
+ ($scheme, $auth, $path, $query, $frag) = uri_split($uri);
+ $uri = uri_join($scheme, $auth, $path, $query, $frag);
+
+=head1 DESCRIPTION
+
+Provides functions to parse and compose URI
+strings. The following functions are provided:
+
+=over
+
+=item ($scheme, $auth, $path, $query, $frag) = uri_split($uri)
+
+Breaks up a URI string into its component
+parts. An C<undef> value is returned for those parts that are not
+present. The $path part is always present (but can be the empty
+string) and is thus never returned as C<undef>.
+
+No sensible value is returned if this function is called in a scalar
+context.
+
+=item $uri = uri_join($scheme, $auth, $path, $query, $frag)
+
+Puts together a URI string from its parts.
+Missing parts are signaled by passing C<undef> for the corresponding
+argument.
+
+Minimal escaping is applied to parts that contain reserved chars
+that would confuse a parser. For instance, any occurrence of '?' or '#'
+in $path is always escaped, as it would otherwise be parsed back
+as a query or fragment.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>, L<URI::Escape>
+
+=head1 COPYRIGHT
+
+Copyright 2003, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
View
305 extlib/lib/perl5/URI/URL.pm
@@ -0,0 +1,305 @@
+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
View
171 extlib/lib/perl5/URI/WithBase.pm
@@ -0,0 +1,171 @@
+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
View
6 extlib/lib/perl5/URI/_foreign.pm
@@ -0,0 +1,6 @@
+package URI::_foreign;
+
+require URI::_generic;
+@ISA=qw(URI::_generic);
+
+1;
View
249 extlib/lib/perl5/URI/_generic.pm
@@ -0,0 +1,249 @@
+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
+{