diff options
author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-07-25 01:06:42 +0000 |
---|---|---|
committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-07-25 01:06:42 +0000 |
commit | 9165b237ad8fae18b36d4d40d6e2ccfde7b136c7 (patch) | |
tree | 06530ddd6baa7e251c58b6b6729ed458da61a681 /lib | |
download | URI-tarball-master.tar.gz |
Diffstat (limited to 'lib')
53 files changed, 5429 insertions, 0 deletions
diff --git a/lib/URI.pm b/lib/URI.pm new file mode 100644 index 0000000..98cd575 --- /dev/null +++ b/lib/URI.pm @@ -0,0 +1,1155 @@ +package URI; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +our ($ABS_REMOTE_LEADING_DOTS, $ABS_ALLOW_RELATIVE_SCHEME, $DEFAULT_QUERY_FORM_DELIMITER); + +my %implements; # mapping from scheme to implementor class + +# Some "official" character classes + +our $reserved = q(;/?:@&=+$,[]); +our $mark = q(-_.!~*'()); #'; emacs +our $unreserved = "A-Za-z0-9\Q$mark\E"; +our $uric = quotemeta($reserved) . $unreserved . "%"; + +our $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; + utf8::downgrade($str); + 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 undef 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 TO_JSON { ${$_[0]} } + +sub _no_scheme_ok { 0 } + +sub _scheme +{ + my $self = shift; + + unless (@_) { + return undef 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 undef unless defined $scheme; + lc($scheme); +} + +sub has_recognized_scheme { + my $self = shift; + return ref($self) !~ /^URI::_(?:foreign|generic)\z/; +} + +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; + utf8::downgrade($new_opaque); + + $$self = defined($old_scheme) ? $old_scheme : ""; + $$self .= $new_opaque; + $$self .= $old_frag if defined $old_frag; + + $old_opaque; +} + +sub path { goto &opaque } # alias + + +sub fragment +{ + my $self = shift; + unless (@_) { + return undef 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; + utf8::downgrade($new_frag); + $$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]; } + +sub secure { 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. + +If the scheme isn't one of those that URI recognizes, you still get +an URI object back that you can access the generic methods on. The +C<< $uri->has_recognized_scheme >> method can be used to test for +this. + +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 (percent-encoded) 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->has_recognized_scheme + +Returns TRUE if the URI scheme is one that URI recognizes. + +It will also be TRUE for relative URLs where a recognized +scheme was provided to the constructor, even if C<< $uri->scheme >> +returns C<undef> for these. + +=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. + +=item $uri->secure + +Returns a TRUE value if the URI is considered to point to a resource on +a secure channel, such as an SSL or TLS encrypted one. + +=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. Unrecognized 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 allows a +mailto URI to contain multiple comma separated 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 L<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 L<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<sftp>: + +C<URI> objects belonging to the sftp 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 +L<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 + +There are some things that are not quite right: + +=over + +=item * + +Using regexp variables like $1 directly as arguments to the URI accessor 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"); + + +=item * + +The escaping (percent encoding) of chars in the 128 .. 255 range passed to the +URI constructor or when setting URI parts using the accessor methods depend on +the state of the internal UTF8 flag (see utf8::is_utf8) of the string passed. +If the UTF8 flag is set the UTF-8 encoded version of the character is percent +encoded. If the UTF8 flag isn't set the Latin-1 version (byte) of the +character is percent encoded. This basically exposes the internal encoding of +Perl strings. + +=back + +=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. + +L<http://www.iana.org/assignments/uri-schemes> + +L<http://www.iana.org/assignments/urn-namespaces> + +L<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 diff --git a/lib/URI/Escape.pm b/lib/URI/Escape.pm new file mode 100644 index 0000000..30f2b31 --- /dev/null +++ b/lib/URI/Escape.pm @@ -0,0 +1,220 @@ +package URI::Escape; + +use strict; +use warnings; + +=head1 NAME + +URI::Escape - Percent-encode and percent-decode unsafe characters + +=head1 SYNOPSIS + + use URI::Escape; + $safe = uri_escape("10% is enough\n"); + $verysafe = uri_escape("foo", "\0-\377"); + $str = uri_unescape($safe); + +=head1 DESCRIPTION + +This module provides functions to percent-encode and percent-decode URI strings as +defined by RFC 3986. Percent-encoding URI's is informally called "URI escaping". +This is the terminology used by this module, which predates the formalization of the +terms by the RFC by several years. + +A URI consists of a restricted set of characters. The restricted set +of characters consists of digits, letters, and a few graphic symbols +chosen from those common to most of the character encodings and input +facilities available to Internet users. They are made up of the +"unreserved" and "reserved" character sets as defined in RFC 3986. + + unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" + reserved = ":" / "/" / "?" / "#" / "[" / "]" / "@" + "!" / "$" / "&" / "'" / "(" / ")" + / "*" / "+" / "," / ";" / "=" + +In addition, any byte (octet) can be represented in a URI by an escape +sequence: a triplet consisting of the character "%" followed by two +hexadecimal digits. A byte can also be represented directly by a +character, using the US-ASCII character for that octet. + +Some of the characters are I<reserved> for use as delimiters or as +part of certain URI components. These must be escaped if they are to +be treated as ordinary data. Read RFC 3986 for further details. + +The functions provided (and exported by default) from this module are: + +=over 4 + +=item uri_escape( $string ) + +=item uri_escape( $string, $unsafe ) + +Replaces each unsafe character in the $string with the corresponding +escape sequence and returns the result. The $string argument should +be a string of bytes. The uri_escape() function will croak if given a +characters with code above 255. Use uri_escape_utf8() if you know you +have such chars or/and want chars in the 128 .. 255 range treated as +UTF-8. + +The uri_escape() function takes an optional second argument that +overrides the set of characters that are to be escaped. The set is +specified as a string that can be used in a regular expression +character class (between [ ]). E.g.: + + "\x00-\x1f\x7f-\xff" # all control and hi-bit characters + "a-z" # all lower case characters + "^A-Za-z" # everything not a letter + +The default set of characters to be escaped is all those which are +I<not> part of the C<unreserved> character class shown above as well +as the reserved characters. I.e. the default is: + + "^A-Za-z0-9\-\._~" + +=item uri_escape_utf8( $string ) + +=item uri_escape_utf8( $string, $unsafe ) + +Works like uri_escape(), but will encode chars as UTF-8 before +escaping them. This makes this function able to deal with characters +with code above 255 in $string. Note that chars in the 128 .. 255 +range will be escaped differently by this function compared to what +uri_escape() would. For chars in the 0 .. 127 range there is no +difference. + +Equivalent to: + + utf8::encode($string); + my $uri = uri_escape($string); + +Note: JavaScript has a function called escape() that produces the +sequence "%uXXXX" for chars in the 256 .. 65535 range. This function +has really nothing to do with URI escaping but some folks got confused +since it "does the right thing" in the 0 .. 255 range. Because of +this you sometimes see "URIs" with these kind of escapes. The +JavaScript encodeURIComponent() function is similar to uri_escape_utf8(). + +=item uri_unescape($string,...) + +Returns a string with each %XX sequence replaced with the actual byte +(octet). + +This does the same as: + + $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + +but does not modify the string in-place as this RE would. Using the +uri_unescape() function instead of the RE might make the code look +cleaner and is a few characters less to type. + +In a simple benchmark test I did, +calling the function (instead of the inline RE above) if a few chars +were unescaped was something like 40% slower, and something like 700% slower if none were. If +you are going to unescape a lot of times it might be a good idea to +inline the RE. + +If the uri_unescape() function is passed multiple strings, then each +one is returned unescaped. + +=back + +The module can also export the C<%escapes> hash, which contains the +mapping from all 256 bytes to the corresponding escape codes. Lookup +in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))> +each time. + +=head1 SEE ALSO + +L<URI> + + +=head1 COPYRIGHT + +Copyright 1995-2004 Gisle Aas. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +use Exporter 5.57 'import'; +our %escapes; +our @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8); +our @EXPORT_OK = qw(%escapes); +our $VERSION = "3.31"; + +use Carp (); + +# Build a char->hex map +for (0..255) { + $escapes{chr($_)} = sprintf("%%%02X", $_); +} + +my %subst; # compiled patterns + +my %Unsafe = ( + RFC2732 => qr/[^A-Za-z0-9\-_.!~*'()]/, + RFC3986 => qr/[^A-Za-z0-9\-\._~]/, +); + +sub uri_escape { + my($text, $patn) = @_; + return undef unless defined $text; + if (defined $patn){ + unless (exists $subst{$patn}) { + # Because we can't compile the regex we fake it with a cached sub + (my $tmp = $patn) =~ s,/,\\/,g; + eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1} || _fail_hi(\$1)/ge; }"; + Carp::croak("uri_escape: $@") if $@; + } + &{$subst{$patn}}($text); + } else { + $text =~ s/($Unsafe{RFC3986})/$escapes{$1} || _fail_hi($1)/ge; + } + $text; +} + +sub _fail_hi { + my $chr = shift; + Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr)); +} + +sub uri_escape_utf8 { + my $text = shift; + utf8::encode($text); + return uri_escape($text, @_); +} + +sub uri_unescape { + # Note from RFC1630: "Sequences which start with a percent sign + # but are not followed by two hexadecimal characters are reserved + # for future extension" + my $str = shift; + if (@_ && wantarray) { + # not executed for the common case of a single argument + my @str = ($str, @_); # need to copy + for (@str) { + s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + } + return @str; + } + $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str; + $str; +} + +# XXX FIXME escape_char is buggy as it assigns meaning to the string's storage format. +sub escape_char { + # Old versions of utf8::is_utf8() didn't properly handle magical vars (e.g. $1). + # The following forces a fetch to occur beforehand. + my $dummy = substr($_[0], 0, 0); + + if (utf8::is_utf8($_[0])) { + my $s = shift; + utf8::encode($s); + unshift(@_, $s); + } + + return join '', @URI::Escape::escapes{split //, $_[0]}; +} + +1; diff --git a/lib/URI/Heuristic.pm b/lib/URI/Heuristic.pm new file mode 100644 index 0000000..d4ace34 --- /dev/null +++ b/lib/URI/Heuristic.pm @@ -0,0 +1,253 @@ +package URI::Heuristic; + +=head1 NAME + +URI::Heuristic - Expand URI using heuristics + +=head1 SYNOPSIS + + use URI::Heuristic qw(uf_uristr); + $u = uf_uristr("perl"); # http://www.perl.com + $u = uf_uristr("www.sol.no/sol"); # http://www.sol.no/sol + $u = uf_uristr("aas"); # http://www.aas.no + $u = uf_uristr("ftp.funet.fi"); # ftp://ftp.funet.fi + $u = uf_uristr("/etc/passwd"); # file:/etc/passwd + +=head1 DESCRIPTION + +This module provides functions that expand strings into real absolute +URIs using some built-in heuristics. Strings that already represent +absolute URIs (i.e. that start with a C<scheme:> part) are never modified +and are returned unchanged. The main use of these functions is to +allow abbreviated URIs similar to what many web browsers allow for URIs +typed in by the user. + +The following functions are provided: + +=over 4 + +=item uf_uristr($str) + +Tries to make the argument string +into a proper absolute URI string. The "uf_" prefix stands for "User +Friendly". Under MacOS, it assumes that any string with a common URL +scheme (http, ftp, etc.) is a URL rather than a local path. So don't name +your volumes after common URL schemes and expect uf_uristr() to construct +valid file: URL's on those volumes for you, because it won't. + +=item uf_uri($str) + +Works the same way as uf_uristr() but +returns a C<URI> object. + +=back + +=head1 ENVIRONMENT + +If the hostname portion of a URI does not contain any dots, then +certain qualified guesses are made. These guesses are governed by +the following environment variables: + +=over 10 + +=item COUNTRY + +The two-letter country code (ISO 3166) for your location. If +the domain name of your host ends with two letters, then it is taken +to be the default country. See also L<Locale::Country>. + +=item HTTP_ACCEPT_LANGUAGE, LC_ALL, LANG + +If COUNTRY is not set, these standard environment variables are +examined and country (not language) information possibly found in them +is used as the default country. + +=item URL_GUESS_PATTERN + +Contains a space-separated list of URL patterns to try. The string +"ACME" is for some reason used as a placeholder for the host name in +the URL provided. Example: + + URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com" + export URL_GUESS_PATTERN + +Specifying URL_GUESS_PATTERN disables any guessing rules based on +country. An empty URL_GUESS_PATTERN disables any guessing that +involves host name lookups. + +=back + +=head1 COPYRIGHT + +Copyright 1997-1998, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +use strict; +use warnings; + +use Exporter 5.57 'import'; +our @EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr); +our $VERSION = "4.20"; + +our ($MY_COUNTRY, $DEBUG); + +sub MY_COUNTRY() { + for ($MY_COUNTRY) { + return $_ if defined; + + # First try the environment. + $_ = $ENV{COUNTRY}; + return $_ if defined; + + # Try the country part of LC_ALL and LANG from environment + my @srcs = ($ENV{LC_ALL}, $ENV{LANG}); + # ...and HTTP_ACCEPT_LANGUAGE before those if present + if (my $httplang = $ENV{HTTP_ACCEPT_LANGUAGE}) { + # TODO: q-value processing/ordering + for $httplang (split(/\s*,\s*/, $httplang)) { + if ($httplang =~ /^\s*([a-zA-Z]+)[_-]([a-zA-Z]{2})\s*$/) { + unshift(@srcs, "${1}_${2}"); + last; + } + } + } + for (@srcs) { + next unless defined; + return lc($1) if /^[a-zA-Z]+_([a-zA-Z]{2})(?:[.@]|$)/; + } + + # Last bit of domain name. This may access the network. + require Net::Domain; + my $fqdn = Net::Domain::hostfqdn(); + $_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/; + return $_ if defined; + + # Give up. Defined but false. + return ($_ = 0); + } +} + +our %LOCAL_GUESSING = +( + 'us' => [qw(www.ACME.gov www.ACME.mil)], + 'gb' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)], + 'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)], + 'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)], + # send corrections and new entries to <gisle@aas.no> +); +# Backwards compatibility; uk != United Kingdom in ISO 3166 +$LOCAL_GUESSING{uk} = $LOCAL_GUESSING{gb}; + + +sub uf_uristr ($) +{ + local($_) = @_; + print STDERR "uf_uristr: resolving $_\n" if $DEBUG; + return unless defined; + + s/^\s+//; + s/\s+$//; + + if (/^(www|web|home)[a-z0-9-]*(?:\.|$)/i) { + $_ = "http://$_"; + + } elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) { + $_ = lc($1) . "://$_"; + + } elsif ($^O ne "MacOS" && + (m,^/, || # absolute file name + m,^\.\.?/, || # relative file name + m,^[a-zA-Z]:[/\\],) # dosish file name + ) + { + $_ = "file:$_"; + + } elsif ($^O eq "MacOS" && m/:/) { + # potential MacOS file name + unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) { + require URI::file; + my $a = URI::file->new($_)->as_string; + $_ = ($a =~ m/^file:/) ? $a : "file:$a"; + } + } elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) { + $_ = "mailto:$_"; + + } elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) { # no scheme specified + if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) { + my $host = $1; + + my $scheme = "http"; + if (/^:(\d+)\b/) { + # Some more or less well known ports + if ($1 =~ /^[56789]?443$/) { + $scheme = "https"; + } elsif ($1 eq "21") { + $scheme = "ftp"; + } + } + + if ($host !~ /\./ && $host ne "localhost") { + my @guess; + if (exists $ENV{URL_GUESS_PATTERN}) { + @guess = map { s/\bACME\b/$host/; $_ } + split(' ', $ENV{URL_GUESS_PATTERN}); + } else { + if (MY_COUNTRY()) { + my $special = $LOCAL_GUESSING{MY_COUNTRY()}; + if ($special) { + my @special = @$special; + push(@guess, map { s/\bACME\b/$host/; $_ } + @special); + } else { + push(@guess, "www.$host." . MY_COUNTRY()); + } + } + push(@guess, map "www.$host.$_", + "com", "org", "net", "edu", "int"); + } + + + my $guess; + for $guess (@guess) { + print STDERR "uf_uristr: gethostbyname('$guess.')..." + if $DEBUG; + if (gethostbyname("$guess.")) { + print STDERR "yes\n" if $DEBUG; + $host = $guess; + last; + } + print STDERR "no\n" if $DEBUG; + } + } + $_ = "$scheme://$host$_"; + + } else { + # pure junk, just return it unchanged... + + } + } + print STDERR "uf_uristr: ==> $_\n" if $DEBUG; + + $_; +} + +sub uf_uri ($) +{ + require URI; + URI->new(uf_uristr($_[0])); +} + +# legacy +*uf_urlstr = \*uf_uristr; + +sub uf_url ($) +{ + require URI::URL; + URI::URL->new(uf_uristr($_[0])); +} + +1; diff --git a/lib/URI/IRI.pm b/lib/URI/IRI.pm new file mode 100644 index 0000000..8906399 --- /dev/null +++ b/lib/URI/IRI.pm @@ -0,0 +1,47 @@ +package URI::IRI; + +# Experimental + +use strict; +use warnings; +use URI (); + +use overload '""' => sub { shift->as_string }; + +our $VERSION = "1.69"; + +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; +} + +our $AUTOLOAD; +sub AUTOLOAD +{ + my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); + + # We create the function here so that it will not need to be + # autoloaded the next time. + no strict 'refs'; + *$method = sub { shift->{uri}->$method(@_) }; + goto &$method; +} + +sub DESTROY {} # avoid AUTOLOADing it + +1; diff --git a/lib/URI/QueryParam.pm b/lib/URI/QueryParam.pm new file mode 100644 index 0000000..7866f79 --- /dev/null +++ b/lib/URI/QueryParam.pm @@ -0,0 +1,207 @@ +package URI::QueryParam; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +sub URI::_query::query_param { + my $self = shift; + my @old = $self->query_form; + + if (@_ == 0) { + # get keys + my (%seen, $i); + return grep !($i++ % 2 || $seen{$_}++), @old; + } + + my $key = shift; + my @i = grep $_ % 2 == 0 && $old[$_] eq $key, 0 .. $#old; + + if (@_) { + my @new = @old; + my @new_i = @i; + my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; + + while (@new_i > @vals) { + splice @new, pop @new_i, 2; + } + if (@vals > @new_i) { + my $i = @new_i ? $new_i[-1] + 2 : @new; + my @splice = splice @vals, @new_i, @vals - @new_i; + + splice @new, $i, 0, map { $key => $_ } @splice; + } + if (@vals) { + #print "SET $new_i[0]\n"; + @new[ map $_ + 1, @new_i ] = @vals; + } + + $self->query_form(\@new); + } + + return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef; +} + +sub URI::_query::query_param_append { + my $self = shift; + my $key = shift; + my @vals = map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_; + $self->query_form($self->query_form, $key => \@vals); # XXX + return; +} + +sub URI::_query::query_param_delete { + my $self = shift; + my $key = shift; + my @old = $self->query_form; + my @vals; + + for (my $i = @old - 2; $i >= 0; $i -= 2) { + next if $old[$i] ne $key; + push(@vals, (splice(@old, $i, 2))[1]); + } + $self->query_form(\@old) if @vals; + return wantarray ? reverse @vals : $vals[-1]; +} + +sub URI::_query::query_form_hash { + my $self = shift; + my @old = $self->query_form; + if (@_) { + $self->query_form(@_ == 1 ? %{shift(@_)} : @_); + } + my %hash; + while (my($k, $v) = splice(@old, 0, 2)) { + if (exists $hash{$k}) { + for ($hash{$k}) { + $_ = [$_] unless ref($_) eq "ARRAY"; + push(@$_, $v); + } + } + else { + $hash{$k} = $v; + } + } + return \%hash; +} + +1; + +__END__ + +=head1 NAME + +URI::QueryParam - Additional query methods for URIs + +=head1 SYNOPSIS + + use URI; + use URI::QueryParam; + + $u = URI->new("", "http"); + $u->query_param(foo => 1, 2, 3); + print $u->query; # prints foo=1&foo=2&foo=3 + + for my $key ($u->query_param) { + print "$key: ", join(", ", $u->query_param($key)), "\n"; + } + +=head1 DESCRIPTION + +Loading the C<URI::QueryParam> module adds some extra methods to +URIs that support query methods. These methods provide an alternative +interface to the $u->query_form data. + +The query_param_* methods have deliberately been made identical to the +interface of the corresponding C<CGI.pm> methods. + +The following additional methods are made available: + +=over + +=item @keys = $u->query_param + +=item @values = $u->query_param( $key ) + +=item $first_value = $u->query_param( $key ) + +=item $u->query_param( $key, $value,... ) + +If $u->query_param is called with no arguments, it returns all the +distinct parameter keys of the URI. In a scalar context it returns the +number of distinct keys. + +When a $key argument is given, the method returns the parameter values with the +given key. In a scalar context, only the first parameter value is +returned. + +If additional arguments are given, they are used to update successive +parameters with the given key. If any of the values provided are +array references, then the array is dereferenced to get the actual +values. + +Please note that you can supply multiple values to this method, but you cannot +supply multiple keys. + +Do this: + + $uri->query_param( widget_id => 1, 5, 9 ); + +Do NOT do this: + + $uri->query_param( widget_id => 1, frobnicator_id => 99 ); + +=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/lib/URI/Split.pm b/lib/URI/Split.pm new file mode 100644 index 0000000..6762b3e --- /dev/null +++ b/lib/URI/Split.pm @@ -0,0 +1,97 @@ +package URI::Split; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use Exporter 5.57 'import'; +our @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/lib/URI/URL.pm b/lib/URI/URL.pm new file mode 100644 index 0000000..ba05eca --- /dev/null +++ b/lib/URI/URL.pm @@ -0,0 +1,303 @@ +package URI::URL; + +use strict; +use warnings; + +use parent 'URI::WithBase'; + +our $VERSION = "5.04"; + +# Provide as much as possible of the old URI::URL interface for backwards +# compatibility... + +use Exporter 5.57 'import'; +our @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 undef 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 losing + # 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/lib/URI/WithBase.pm b/lib/URI/WithBase.pm new file mode 100644 index 0000000..943b7b5 --- /dev/null +++ b/lib/URI/WithBase.pm @@ -0,0 +1,174 @@ +package URI::WithBase; + +use strict; +use warnings; + +use URI; +use Scalar::Util 'blessed'; + +our $VERSION = "2.20"; + +use overload '""' => "as_string", fallback => 1; + +sub as_string; # help overload find it + +sub new +{ + my($class, $uri, $base) = @_; + my $ibase = $base; + if ($base && blessed($base) && $base->isa(__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 blessed($other) and $other->isa(__PACKAGE__); + $self->[0]->eq($other); +} + +our $AUTOLOAD; +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/lib/URI/_foreign.pm b/lib/URI/_foreign.pm new file mode 100644 index 0000000..cad5c8d --- /dev/null +++ b/lib/URI/_foreign.pm @@ -0,0 +1,10 @@ +package URI::_foreign; + +use strict; +use warnings; + +use parent 'URI::_generic'; + +our $VERSION = "1.69"; + +1; diff --git a/lib/URI/_generic.pm b/lib/URI/_generic.pm new file mode 100644 index 0000000..42f6609 --- /dev/null +++ b/lib/URI/_generic.pm @@ -0,0 +1,256 @@ +package URI::_generic; + +use strict; +use warnings; + +use parent qw(URI URI::_query); + +use URI::Escape qw(uri_unescape); +use Carp (); + +our $VERSION = "1.69"; + +my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g; +my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g; + +sub _no_scheme_ok { 1 } + +sub authority +{ + my $self = shift; + $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die; + + if (@_) { + my $auth = shift; + $$self = $1; + my $rest = $3; + if (defined $auth) { + $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego; + utf8::downgrade($auth); + $$self .= "//$auth"; + } + _check_path($rest, $$self); + $$self .= $rest; + } + $2; +} + +sub path +{ + my $self = shift; + $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die; + + if (@_) { + $$self = $1; + my $rest = $3; + my $new_path = shift; + $new_path = "" unless defined $new_path; + $new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego; + utf8::downgrade($new_path); + _check_path($new_path, $$self); + $$self .= $new_path . $rest; + } + $2; +} + +sub path_query +{ + my $self = shift; + $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die; + + if (@_) { + $$self = $1; + my $rest = $3; + my $new_path = shift; + $new_path = "" unless defined $new_path; + $new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; + utf8::downgrade($new_path); + _check_path($new_path, $$self); + $$self .= $new_path . $rest; + } + $2; +} + +sub _check_path +{ + my($path, $pre) = @_; + my $prefix; + if ($pre =~ m,/,) { # authority present + $prefix = "/" if length($path) && $path !~ m,^[/?\#],; + } + else { + if ($path =~ m,^//,) { + Carp::carp("Path starting with double slash is confusing") + if $^W; + } + elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) { + Carp::carp("Path might look like scheme, './' prepended") + if $^W; + $prefix = "./"; + } + } + substr($_[0], 0, 0) = $prefix if defined $prefix; +} + +sub path_segments +{ + my $self = shift; + my $path = $self->path; + if (@_) { + my @arg = @_; # make a copy + for (@arg) { + if (ref($_)) { + my @seg = @$_; + $seg[0] =~ s/%/%25/g; + for (@seg) { s/;/%3B/g; } + $_ = join(";", @seg); + } + else { + s/%/%25/g; s/;/%3B/g; + } + s,/,%2F,g; + } + $self->path(join("/", @arg)); + } + return $path unless wantarray; + map {/;/ ? $self->_split_segment($_) + : uri_unescape($_) } + split('/', $path, -1); +} + + +sub _split_segment +{ + my $self = shift; + require URI::_segment; + URI::_segment->new(@_); +} + + +sub abs +{ + my $self = shift; + my $base = shift || Carp::croak("Missing base argument"); + + if (my $scheme = $self->scheme) { + return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME; + $base = URI->new($base) unless ref $base; + return $self unless $scheme eq $base->scheme; + } + + $base = URI->new($base) unless ref $base; + my $abs = $self->clone; + $abs->scheme($base->scheme); + return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o; + $abs->authority($base->authority); + + my $path = $self->path; + return $abs if $path =~ m,^/,; + + if (!length($path)) { + my $abs = $base->clone; + my $query = $self->query; + $abs->query($query) if defined $query; + my $fragment = $self->fragment; + $abs->fragment($fragment) if defined $fragment; + return $abs; + } + + my $p = $base->path; + $p =~ s,[^/]+$,,; + $p .= $path; + my @p = split('/', $p, -1); + shift(@p) if @p && !length($p[0]); + my $i = 1; + while ($i < @p) { + #print "$i ", join("/", @p), " ($p[$i])\n"; + if ($p[$i-1] eq ".") { + splice(@p, $i-1, 1); + $i-- if $i > 1; + } + elsif ($p[$i] eq ".." && $p[$i-1] ne "..") { + splice(@p, $i-1, 2); + if ($i > 1) { + $i--; + push(@p, "") if $i == @p; + } + } + else { + $i++; + } + } + $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/." + if ($URI::ABS_REMOTE_LEADING_DOTS) { + shift @p while @p && $p[0] =~ /^\.\.?$/; + } + $abs->path("/" . join("/", @p)); + $abs; +} + +# The opposite of $url->abs. Return a URI which is as relative as possible +sub rel { + my $self = shift; + my $base = shift || Carp::croak("Missing base argument"); + my $rel = $self->clone; + $base = URI->new($base) unless ref $base; + + #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)}; + my $scheme = $rel->scheme; + my $auth = $rel->canonical->authority; + my $path = $rel->path; + + if (!defined($scheme) && !defined($auth)) { + # it is already relative + return $rel; + } + + #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)}; + my $bscheme = $base->scheme; + my $bauth = $base->canonical->authority; + my $bpath = $base->path; + + for ($bscheme, $bauth, $auth) { + $_ = '' unless defined + } + + unless ($scheme eq $bscheme && $auth eq $bauth) { + # different location, can't make it relative + return $rel; + } + + for ($path, $bpath) { $_ = "/$_" unless m,^/,; } + + # Make it relative by eliminating scheme and authority + $rel->scheme(undef); + $rel->authority(undef); + + # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>. + # First we calculate common initial path components length ($li). + my $li = 1; + while (1) { + my $i = index($path, '/', $li); + last if $i < 0 || + $i != index($bpath, '/', $li) || + substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li); + $li=$i+1; + } + # then we nuke it from both paths + substr($path, 0,$li) = ''; + substr($bpath,0,$li) = ''; + + if ($path eq $bpath && + defined($rel->fragment) && + !defined($rel->query)) { + $rel->path(""); + } + else { + # Add one "../" for each path component left in the base path + $path = ('../' x $bpath =~ tr|/|/|) . $path; + $path = "./" if $path eq ""; + $rel->path($path); + } + + $rel; +} + +1; diff --git a/lib/URI/_idna.pm b/lib/URI/_idna.pm new file mode 100644 index 0000000..ce58db8 --- /dev/null +++ b/lib/URI/_idna.pm @@ -0,0 +1,91 @@ +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 warnings; + +use URI::_punycode qw(encode_punycode decode_punycode); +use Carp qw(croak); + +our $VERSION = "1.69"; + +BEGIN { + *URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS = $] < 5.008_003 + ? sub () { 1 } + : sub () { 0 } + ; +} + +my $ASCII = qr/^[\x00-\x7F]*\z/; + +sub encode { + my $idomain = shift; + my @labels = split(/\./, $idomain, -1); + my @last_empty; + push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq ""; + for (@labels) { + $_ = ToASCII($_); + } + + return eval 'join(".", @labels, @last_empty)' if URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS; + return join(".", @labels, @last_empty); +} + +sub decode { + my $domain = shift; + return join(".", map ToUnicode($_), split(/\./, $domain, -1)) +} + +sub nameprep { # XXX real implementation missing + my $label = shift; + $label = lc($label); + return $label; +} + +sub check_size { + my $label = shift; + croak "Label empty" if $label eq ""; + croak "Label too long" if length($label) > 63; + return $label; +} + +sub ToASCII { + my $label = shift; + return check_size($label) if $label =~ $ASCII; + + # Step 2: nameprep + $label = nameprep($label); + # Step 3: UseSTD3ASCIIRules is false + # Step 4: try ASCII again + return check_size($label) if $label =~ $ASCII; + + # Step 5: Check ACE prefix + if ($label =~ /^xn--/) { + croak "Label starts with ACE prefix"; + } + + # Step 6: Encode with PUNYCODE + $label = encode_punycode($label); + + # Step 7: Prepend ACE prefix + $label = "xn--$label"; + + # Step 8: Check size + return check_size($label); +} + +sub ToUnicode { + my $label = shift; + $label = nameprep($label) unless $label =~ $ASCII; + return $label unless $label =~ /^xn--/; + my $result = decode_punycode(substr($label, 4)); + my $label2 = ToASCII($result); + if (lc($label) ne $label2) { + croak "IDNA does not round-trip: '\L$label\E' vs '$label2'"; + } + return $result; +} + +1; diff --git a/lib/URI/_ldap.pm b/lib/URI/_ldap.pm new file mode 100644 index 0000000..02f468c --- /dev/null +++ b/lib/URI/_ldap.pm @@ -0,0 +1,140 @@ +# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package URI::_ldap; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +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 undef 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 undef unless defined wantarray && defined $old; + uri_unescape($old); # || "(objectClass=*)"; +} + +sub filter { + my $old = &_filter; + $old = "(objectClass=*)" unless length $old; + $old; +} + +sub extensions { + my $self = shift; + my @ext; + while (@_) { + my $key = shift; + my $value = shift; + push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value)); + } + @ext = join(",", @ext) if @ext; + my $old = _ldap_elem($self,3, @ext); + return $old unless wantarray; + map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old); +} + +sub canonical +{ + my $self = shift; + my $other = $self->_nonldap_canonical; + + # The stuff below is not as efficient as one might hope... + + $other = $other->clone if $other == $self; + + $other->dn(_normalize_dn($other->dn)); + + # Should really know about mixed case "postalAddress", etc... + $other->attributes(map lc, $other->attributes); + + # Lowercase scope, remove default + my $old_scope = $other->scope; + my $new_scope = lc($old_scope); + $new_scope = "" if $new_scope eq "base"; + $other->scope($new_scope) if $new_scope ne $old_scope; + + # Remove filter if default + my $old_filter = $other->filter; + $other->filter("") if lc($old_filter) eq "(objectclass=*)" || + lc($old_filter) eq "objectclass=*"; + + # Lowercase extensions types and deal with known extension values + my @ext = $other->extensions; + for (my $i = 0; $i < @ext; $i += 2) { + my $etype = $ext[$i] = lc($ext[$i]); + if ($etype =~ /^!?bindname$/) { + $ext[$i+1] = _normalize_dn($ext[$i+1]); + } + } + $other->extensions(@ext) if @ext; + + $other; +} + +sub _normalize_dn # RFC 2253 +{ + my $dn = shift; + + return $dn; + # The code below will fail if the "+" or "," is embedding in a quoted + # string or simply escaped... + + my @dn = split(/([+,])/, $dn); + for (@dn) { + s/^([a-zA-Z]+=)/lc($1)/e; + } + join("", @dn); +} + +1; diff --git a/lib/URI/_login.pm b/lib/URI/_login.pm new file mode 100644 index 0000000..ef58e24 --- /dev/null +++ b/lib/URI/_login.pm @@ -0,0 +1,13 @@ +package URI::_login; + +use strict; +use warnings; + +use parent qw(URI::_server URI::_userpass); + +our $VERSION = "1.69"; + +# Generic terminal logins. This is used as a base class for 'telnet', +# 'tn3270', and 'rlogin' URL schemes. + +1; diff --git a/lib/URI/_punycode.pm b/lib/URI/_punycode.pm new file mode 100644 index 0000000..f54eee5 --- /dev/null +++ b/lib/URI/_punycode.pm @@ -0,0 +1,203 @@ +package URI::_punycode; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use Exporter 'import'; +our @EXPORT = qw(encode_punycode decode_punycode); + +use integer; + +our $DEBUG = 0; + +use constant BASE => 36; +use constant TMIN => 1; +use constant TMAX => 26; +use constant SKEW => 38; +use constant DAMP => 700; +use constant INITIAL_BIAS => 72; +use constant INITIAL_N => 128; + +my $Delimiter = chr 0x2D; +my $BasicRE = qr/[\x00-\x7f]/; + +sub _croak { require Carp; Carp::croak(@_); } + +sub digit_value { + my $code = shift; + return ord($code) - ord("A") if $code =~ /[A-Z]/; + return ord($code) - ord("a") if $code =~ /[a-z]/; + return ord($code) - ord("0") + 26 if $code =~ /[0-9]/; + return; +} + +sub code_point { + my $digit = shift; + return $digit + ord('a') if 0 <= $digit && $digit <= 25; + return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36; + die 'NOT COME HERE'; +} + +sub adapt { + my($delta, $numpoints, $firsttime) = @_; + $delta = $firsttime ? $delta / DAMP : $delta / 2; + $delta += $delta / $numpoints; + my $k = 0; + while ($delta > ((BASE - TMIN) * TMAX) / 2) { + $delta /= BASE - TMIN; + $k += BASE; + } + return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW)); +} + +sub decode_punycode { + my $code = shift; + + my $n = INITIAL_N; + my $i = 0; + my $bias = INITIAL_BIAS; + my @output; + + if ($code =~ s/(.*)$Delimiter//o) { + push @output, map ord, split //, $1; + return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o; + } + + while ($code) { + my $oldi = $i; + my $w = 1; + LOOP: + for (my $k = BASE; 1; $k += BASE) { + my $cp = substr($code, 0, 1, ''); + my $digit = digit_value($cp); + defined $digit or return _croak("invalid punycode input"); + $i += $digit * $w; + my $t = ($k <= $bias) ? TMIN + : ($k >= $bias + TMAX) ? TMAX : $k - $bias; + last LOOP if $digit < $t; + $w *= (BASE - $t); + } + $bias = adapt($i - $oldi, @output + 1, $oldi == 0); + warn "bias becomes $bias" if $DEBUG; + $n += $i / (@output + 1); + $i = $i % (@output + 1); + splice(@output, $i, 0, $n); + warn join " ", map sprintf('%04x', $_), @output if $DEBUG; + $i++; + } + return join '', map chr, @output; +} + +sub encode_punycode { + my $input = shift; + my @input = split //, $input; + + my $n = INITIAL_N; + my $delta = 0; + my $bias = INITIAL_BIAS; + + my @output; + my @basic = grep /$BasicRE/, @input; + my $h = my $b = @basic; + push @output, @basic; + push @output, $Delimiter if $b && $h < @input; + warn "basic codepoints: (@output)" if $DEBUG; + + while ($h < @input) { + my $m = min(grep { $_ >= $n } map ord, @input); + warn sprintf "next code point to insert is %04x", $m if $DEBUG; + $delta += ($m - $n) * ($h + 1); + $n = $m; + for my $i (@input) { + my $c = ord($i); + $delta++ if $c < $n; + if ($c == $n) { + my $q = $delta; + LOOP: + for (my $k = BASE; 1; $k += BASE) { + my $t = ($k <= $bias) ? TMIN : + ($k >= $bias + TMAX) ? TMAX : $k - $bias; + last LOOP if $q < $t; + my $cp = code_point($t + (($q - $t) % (BASE - $t))); + push @output, chr($cp); + $q = ($q - $t) / (BASE - $t); + } + push @output, chr(code_point($q)); + $bias = adapt($delta, $h + 1, $h == $b); + warn "bias becomes $bias" if $DEBUG; + $delta = 0; + $h++; + } + } + $delta++; + $n++; + } + return join '', @output; +} + +sub min { + my $min = shift; + for (@_) { $min = $_ if $_ <= $min } + return $min; +} + +1; +__END__ + +=head1 NAME + +URI::_punycode - encodes Unicode string in Punycode + +=head1 SYNOPSIS + + use URI::_punycode; + $punycode = encode_punycode($unicode); + $unicode = decode_punycode($punycode); + +=head1 DESCRIPTION + +URI::_punycode is a module to encode / decode Unicode strings into +Punycode, an efficient encoding of Unicode for use with IDNA. + +This module requires Perl 5.6.0 or over to handle UTF8 flagged Unicode +strings. + +=head1 FUNCTIONS + +This module exports following functions by default. + +=over 4 + +=item encode_punycode + + $punycode = encode_punycode($unicode); + +takes Unicode string (UTF8-flagged variable) and returns Punycode +encoding for it. + +=item decode_punycode + + $unicode = decode_punycode($punycode) + +takes Punycode encoding and returns original Unicode string. + +=back + +These functions throw exceptions on failure. You can catch 'em via +C<eval>. + +=head1 AUTHOR + +Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt> is the author of +IDNA::Punycode v0.02 which was the basis for this module. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<IDNA::Punycode>, RFC 3492 + +=cut diff --git a/lib/URI/_query.pm b/lib/URI/_query.pm new file mode 100644 index 0000000..a5976a3 --- /dev/null +++ b/lib/URI/_query.pm @@ -0,0 +1,97 @@ +package URI::_query; + +use strict; +use warnings; + +use URI (); +use URI::Escape qw(uri_unescape); + +our $VERSION = "1.69"; + +sub query +{ + my $self = shift; + $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die; + + if (@_) { + my $q = shift; + $$self = $1; + if (defined $q) { + $q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; + utf8::downgrade($q); + $$self .= "?$q"; + } + $$self .= $3; + } + $2; +} + +# Handle ...?foo=bar&bar=foo type of query +sub query_form { + my $self = shift; + my $old = $self->query; + if (@_) { + # Try to set query string + my $delim; + my $r = $_[0]; + if (ref($r) eq "ARRAY") { + $delim = $_[1]; + @_ = @$r; + } + elsif (ref($r) eq "HASH") { + $delim = $_[1]; + @_ = map { $_ => $r->{$_} } sort keys %$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 +sub equery { goto &query } + +1; diff --git a/lib/URI/_segment.pm b/lib/URI/_segment.pm new file mode 100644 index 0000000..3b27289 --- /dev/null +++ b/lib/URI/_segment.pm @@ -0,0 +1,24 @@ +package URI::_segment; + +# Represents a generic path_segment so that it can be treated as +# a string too. + +use strict; +use warnings; + +use URI::Escape qw(uri_unescape); + +use overload '""' => sub { $_[0]->[0] }, + fallback => 1; + +our $VERSION = "1.69"; + +sub new +{ + my $class = shift; + my @segment = split(';', shift, -1); + $segment[0] = uri_unescape($segment[0]); + bless \@segment, $class; +} + +1; diff --git a/lib/URI/_server.pm b/lib/URI/_server.pm new file mode 100644 index 0000000..4df158e --- /dev/null +++ b/lib/URI/_server.pm @@ -0,0 +1,166 @@ +package URI::_server; + +use strict; +use warnings; + +use parent 'URI::_generic'; + +use URI::Escape qw(uri_unescape); + +our $VERSION = "1.69"; + +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/lib/URI/_userpass.pm b/lib/URI/_userpass.pm new file mode 100644 index 0000000..6d260c0 --- /dev/null +++ b/lib/URI/_userpass.pm @@ -0,0 +1,55 @@ +package URI::_userpass; + +use strict; +use warnings; + +use URI::Escape qw(uri_unescape); + +our $VERSION = "1.69"; + +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 undef 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 undef unless defined $info; + return undef unless $info =~ s/^[^:]*://; + uri_unescape($info); +} + +1; diff --git a/lib/URI/data.pm b/lib/URI/data.pm new file mode 100644 index 0000000..7848502 --- /dev/null +++ b/lib/URI/data.pm @@ -0,0 +1,142 @@ +package URI::data; # RFC 2397 + +use strict; +use warnings; + +use parent 'URI'; + +our $VERSION = '1.69'; + +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/lib/URI/file.pm b/lib/URI/file.pm new file mode 100644 index 0000000..d76ddf2 --- /dev/null +++ b/lib/URI/file.pm @@ -0,0 +1,327 @@ +package URI::file; + +use strict; +use warnings; + +use parent 'URI::_generic'; +our $VERSION = "4.21"; + +use URI::Escape qw(uri_unescape); + +our $DEFAULT_AUTHORITY = ""; + +# Map from $^O values to implementation classes. The Unix +# class is the default. +our %OS_CLASS = ( + os2 => "OS2", + mac => "Mac", + MacOS => "Mac", + MSWin32 => "Win32", + win32 => "Win32", + msdos => "FAT", + dos => "FAT", + qnx => "QNX", +); + +sub os_class +{ + my($OS) = shift || $^O; + + my $class = "URI::file::" . ($OS_CLASS{$OS} || "Unix"); + no strict 'refs'; + unless (%{"$class\::"}) { + eval "require $class"; + die $@ if $@; + } + $class; +} + +sub host { uri_unescape(shift->authority(@_)) } + +sub new +{ + my($class, $path, $os) = @_; + os_class($os)->new($path); +} + +sub new_abs +{ + my $class = shift; + my $file = $class->new(@_); + return $file->abs($class->cwd) unless $$file =~ /^file:/; + $file; +} + +sub cwd +{ + my $class = shift; + require Cwd; + my $cwd = Cwd::cwd(); + $cwd = VMS::Filespec::unixpath($cwd) if $^O eq 'VMS'; + $cwd = $class->new($cwd); + $cwd .= "/" unless substr($cwd, -1, 1) eq "/"; + $cwd; +} + +sub canonical { + my $self = shift; + my $other = $self->SUPER::canonical; + + my $scheme = $other->scheme; + my $auth = $other->authority; + return $other if !defined($scheme) && !defined($auth); # relative + + if (!defined($auth) || + $auth eq "" || + lc($auth) eq "localhost" || + (defined($DEFAULT_AUTHORITY) && lc($auth) eq lc($DEFAULT_AUTHORITY)) + ) + { + # avoid cloning if $auth already match + if ((defined($auth) || defined($DEFAULT_AUTHORITY)) && + (!defined($auth) || !defined($DEFAULT_AUTHORITY) || $auth ne $DEFAULT_AUTHORITY) + ) + { + $other = $other->clone if $self == $other; + $other->authority($DEFAULT_AUTHORITY); + } + } + + $other; +} + +sub file +{ + my($self, $os) = @_; + os_class($os)->file($self); +} + +sub dir +{ + my($self, $os) = @_; + os_class($os)->dir($self); +} + +1; + +__END__ + +=head1 NAME + +URI::file - URI that maps to local file names + +=head1 SYNOPSIS + + use URI::file; + + $u1 = URI->new("file:/foo/bar"); + $u2 = URI->new("foo/bar", "file"); + + $u3 = URI::file->new($path); + $u4 = URI::file->new("c:\\windows\\", "win32"); + + $u1->file; + $u1->file("mac"); + +=head1 DESCRIPTION + +The C<URI::file> class supports C<URI> objects belonging to the I<file> +URI scheme. This scheme allows us to map the conventional file names +found on various computer systems to the URI name space. An old +specification of the I<file> URI scheme is found in RFC 1738. Some +older background information is also in RFC 1630. There are no newer +specifications as far as I know. + +If you simply want to construct I<file> URI objects from URI strings, +use the normal C<URI> constructor. If you want to construct I<file> +URI objects from the actual file names used by various systems, then +use one of the following C<URI::file> constructors: + +=over 4 + +=item $u = URI::file->new( $filename, [$os] ) + +Maps a file name to the I<file:> URI name space, creates a URI object +and returns it. The $filename is interpreted as belonging to the +indicated operating system ($os), which defaults to the value of the +$^O variable. The $filename can be either absolute or relative, and +the corresponding type of URI object for $os is returned. + +=item $u = URI::file->new_abs( $filename, [$os] ) + +Same as URI::file->new, but makes sure that the URI returned +represents an absolute file name. If the $filename argument is +relative, then the name is resolved relative to the current directory, +i.e. this constructor is really the same as: + + URI::file->new($filename)->abs(URI::file->cwd); + +=item $u = URI::file->cwd + +Returns a I<file> URI that represents the current working directory. +See L<Cwd>. + +=back + +The following methods are supported for I<file> URI (in addition to +the common and generic methods described in L<URI>): + +=over 4 + +=item $u->file( [$os] ) + +Returns a file name. It maps from the URI name space +to the file name space of the indicated operating system. + +It might return C<undef> if the name can not be represented in the +indicated file system. + +=item $u->dir( [$os] ) + +Some systems use a different form for names of directories than for plain +files. Use this method if you know you want to use the name for +a directory. + +=back + +The C<URI::file> module can be used to map generic file names to names +suitable for the current system. As such, it can work as a nice +replacement for the C<File::Spec> module. For instance, the following +code translates the UNIX-style file name F<Foo/Bar.pm> to a name +suitable for the local system: + + $file = URI::file->new("Foo/Bar.pm", "unix")->file; + die "Can't map filename Foo/Bar.pm for $^O" unless defined $file; + open(FILE, $file) || die "Can't open '$file': $!"; + # do something with FILE + +=head1 MAPPING NOTES + +Most computer systems today have hierarchically organized file systems. +Mapping the names used in these systems to the generic URI syntax +allows us to work with relative file URIs that behave as they should +when resolved using the generic algorithm for URIs (specified in RFC +2396). Mapping a file name to the generic URI syntax involves mapping +the path separator character to "/" and encoding any reserved +characters that appear in the path segments of the file name. If +path segments consisting of the strings "." or ".." have a +different meaning than what is specified for generic URIs, then these +must be encoded as well. + +If the file system has device, volume or drive specifications as +the root of the name space, then it makes sense to map them to the +authority field of the generic URI syntax. This makes sure that +relative URIs can not be resolved "above" them, i.e. generally how +relative file names work in those systems. + +Another common use of the authority field is to encode the host on which +this file name is valid. The host name "localhost" is special and +generally has the same meaning as a missing or empty authority +field. This use is in conflict with using it as a device +specification, but can often be resolved for device specifications +having characters not legal in plain host names. + +File name to URI mapping in normally not one-to-one. There are +usually many URIs that map to any given file name. For instance, an +authority of "localhost" maps the same as a URI with a missing or empty +authority. + +Example 1: The Mac classic (Mac OS 9 and earlier) used ":" as path separator, +but not in the same way as a generic URI. ":foo" was a relative name. "foo:bar" +was an absolute name. Also, path segments could contain the "/" character as well +as the literal "." or "..". So the mapping looks like this: + + Mac classic URI + ---------- ------------------- + :foo:bar <==> foo/bar + : <==> ./ + ::foo:bar <==> ../foo/bar + ::: <==> ../../ + foo:bar <==> file:/foo/bar + foo:bar: <==> file:/foo/bar/ + .. <==> %2E%2E + <undef> <== / + foo/ <== file:/foo%2F + ./foo.txt <== file:/.%2Ffoo.txt + +Note that if you want a relative URL, you *must* begin the path with a :. Any +path that begins with [^:] is treated as absolute. + +Example 2: The UNIX file system is easy to map, as it uses the same path +separator as URIs, has a single root, and segments of "." and ".." +have the same meaning. URIs that have the character "\0" or "/" as +part of any path segment can not be turned into valid UNIX file names. + + UNIX URI + ---------- ------------------ + foo/bar <==> foo/bar + /foo/bar <==> file:/foo/bar + /foo/bar <== file://localhost/foo/bar + file: ==> ./file: + <undef> <== file:/fo%00/bar + / <==> file:/ + +=cut + + +RFC 1630 + + [...] + + There is clearly a danger of confusion that a link made to a local + file should be followed by someone on a different system, with + unexpected and possibly harmful results. Therefore, the convention + is that even a "file" URL is provided with a host part. This allows + a client on another system to know that it cannot access the file + system, or perhaps to use some other local mechanism to access the + file. + + The special value "localhost" is used in the host field to indicate + that the filename should really be used on whatever host one is. + This for example allows links to be made to files which are + distributed on many machines, or to "your unix local password file" + subject of course to consistency across the users of the data. + + A void host field is equivalent to "localhost". + +=head1 CONFIGURATION VARIABLES + +The following configuration variables influence how the class and its +methods behave: + +=over + +=item %URI::file::OS_CLASS + +This hash maps OS identifiers to implementation classes. You might +want to add or modify this if you want to plug in your own file +handler class. Normally the keys should match the $^O values in use. + +If there is no mapping then the "Unix" implementation is used. + +=item $URI::file::DEFAULT_AUTHORITY + +This determine what "authority" string to include in absolute file +URIs. It defaults to "". If you prefer verbose URIs you might set it +to be "localhost". + +Setting this value to C<undef> force behaviour compatible to URI v1.31 +and earlier. In this mode host names in UNC paths and drive letters +are mapped to the authority component on Windows, while we produce +authority-less URIs on Unix. + +=back + + +=head1 SEE ALSO + +L<URI>, L<File::Spec>, L<perlport> + +=head1 COPYRIGHT + +Copyright 1995-1998,2004 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/lib/URI/file/Base.pm b/lib/URI/file/Base.pm new file mode 100644 index 0000000..ebf24aa --- /dev/null +++ b/lib/URI/file/Base.pm @@ -0,0 +1,84 @@ +package URI::file::Base; + +use strict; +use warnings; + +use URI::Escape qw(); + +our $VERSION = "1.69"; + +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/lib/URI/file/FAT.pm b/lib/URI/file/FAT.pm new file mode 100644 index 0000000..2d78275 --- /dev/null +++ b/lib/URI/file/FAT.pm @@ -0,0 +1,27 @@ +package URI::file::FAT; + +use strict; +use warnings; + +use parent 'URI::file::Win32'; + +our $VERSION = "1.69"; + +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/lib/URI/file/Mac.pm b/lib/URI/file/Mac.pm new file mode 100644 index 0000000..4d8e766 --- /dev/null +++ b/lib/URI/file/Mac.pm @@ -0,0 +1,121 @@ +package URI::file::Mac; + +use strict; +use warnings; + +use parent 'URI::file::Base'; + +use URI::Escape qw(uri_unescape); + +our $VERSION = "1.69"; + +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/lib/URI/file/OS2.pm b/lib/URI/file/OS2.pm new file mode 100644 index 0000000..f451f9e --- /dev/null +++ b/lib/URI/file/OS2.pm @@ -0,0 +1,32 @@ +package URI::file::OS2; + +use strict; +use warnings; + +use parent 'URI::file::Win32'; + +our $VERSION = "1.69"; + +# 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/lib/URI/file/QNX.pm b/lib/URI/file/QNX.pm new file mode 100644 index 0000000..1d725e4 --- /dev/null +++ b/lib/URI/file/QNX.pm @@ -0,0 +1,20 @@ +package URI::file::QNX; + +use strict; +use warnings; + +use parent 'URI::file::Unix'; + +our $VERSION = "1.69"; + +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/lib/URI/file/Unix.pm b/lib/URI/file/Unix.pm new file mode 100644 index 0000000..b06acc7 --- /dev/null +++ b/lib/URI/file/Unix.pm @@ -0,0 +1,58 @@ +package URI::file::Unix; + +use strict; +use warnings; + +use parent 'URI::file::Base'; + +use URI::Escape qw(uri_unescape); + +our $VERSION = "1.69"; + +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/lib/URI/file/Win32.pm b/lib/URI/file/Win32.pm new file mode 100644 index 0000000..f00b9c9 --- /dev/null +++ b/lib/URI/file/Win32.pm @@ -0,0 +1,87 @@ +package URI::file::Win32; + +use strict; +use warnings; + +use parent 'URI::file::Base'; + +use URI::Escape qw(uri_unescape); + +our $VERSION = "1.69"; + +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/lib/URI/ftp.pm b/lib/URI/ftp.pm new file mode 100644 index 0000000..7d6848f --- /dev/null +++ b/lib/URI/ftp.pm @@ -0,0 +1,46 @@ +package URI::ftp; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent qw(URI::_server URI::_userpass); + +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/lib/URI/gopher.pm b/lib/URI/gopher.pm new file mode 100644 index 0000000..d9f7eb5 --- /dev/null +++ b/lib/URI/gopher.pm @@ -0,0 +1,97 @@ +package URI::gopher; # <draft-murali-url-gopher>, Dec 4, 1996 + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::_server'; + +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; +} + +sub gtype { goto &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/lib/URI/http.pm b/lib/URI/http.pm new file mode 100644 index 0000000..a7e921a --- /dev/null +++ b/lib/URI/http.pm @@ -0,0 +1,27 @@ +package URI::http; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::_server'; + +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/lib/URI/https.pm b/lib/URI/https.pm new file mode 100644 index 0000000..e346b30 --- /dev/null +++ b/lib/URI/https.pm @@ -0,0 +1,14 @@ +package URI::https; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::http'; + +sub default_port { 443 } + +sub secure { 1 } + +1; diff --git a/lib/URI/ldap.pm b/lib/URI/ldap.pm new file mode 100644 index 0000000..60e7f2b --- /dev/null +++ b/lib/URI/ldap.pm @@ -0,0 +1,120 @@ +# 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 warnings; + +our $VERSION = "1.69"; + +use parent qw(URI::_ldap URI::_server); + +sub default_port { 389 } + +sub _nonldap_canonical { + my $self = shift; + $self->URI::_server::canonical(@_); +} + +1; + +__END__ + +=head1 NAME + +URI::ldap - LDAP Uniform Resource Locators + +=head1 SYNOPSIS + + use URI; + + $uri = URI->new("ldap:$uri_string"); + $dn = $uri->dn; + $filter = $uri->filter; + @attr = $uri->attributes; + $scope = $uri->scope; + %extn = $uri->extensions; + + $uri = URI->new("ldap:"); # start empty + $uri->host("ldap.itd.umich.edu"); + $uri->dn("o=University of Michigan,c=US"); + $uri->attributes(qw(postalAddress)); + $uri->scope('sub'); + $uri->filter('(cn=Babs Jensen)'); + print $uri->as_string,"\n"; + +=head1 DESCRIPTION + +C<URI::ldap> provides an interface to parse an LDAP URI into its +constituent parts and also to build a URI as described in +RFC 2255. + +=head1 METHODS + +C<URI::ldap> supports all the generic and server methods defined by +L<URI>, plus the following. + +Each of the following methods can be used to set or get the value in +the URI. The values are passed in unescaped form. None of these +return undefined values, but elements without a default can be empty. +If arguments are given, then a new value is set for the given part +of the URI. + +=over 4 + +=item $uri->dn( [$new_dn] ) + +Sets or gets the I<Distinguished Name> part of the URI. The DN +identifies the base object of the LDAP search. + +=item $uri->attributes( [@new_attrs] ) + +Sets or gets the list of attribute names which are +returned by the search. + +=item $uri->scope( [$new_scope] ) + +Sets or gets the scope to be used by the search. The value can be one of +C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the +return value defaults to C<"base">. + +=item $uri->_scope( [$new_scope] ) + +Same as scope(), but does not default to anything. + +=item $uri->filter( [$new_filter] ) + +Sets or gets the filter to be used by the search. If none is given in +the URI then the return value defaults to C<"(objectClass=*)">. + +=item $uri->_filter( [$new_filter] ) + +Same as filter(), but does not default to anything. + +=item $uri->extensions( [$etype => $evalue,...] ) + +Sets or gets the extensions used for the search. The list passed should +be in the form etype1 => evalue1, etype2 => evalue2,... This is also +the form of list that is returned. + +=back + +=head1 SEE ALSO + +L<http://tools.ietf.org/html/rfc2255> + +=head1 AUTHOR + +Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +Slightly modified by Gisle Aas to fit into the URI distribution. + +=head1 COPYRIGHT + +Copyright (c) 1998 Graham Barr. All rights reserved. This program is +free software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +=cut diff --git a/lib/URI/ldapi.pm b/lib/URI/ldapi.pm new file mode 100644 index 0000000..12a0b08 --- /dev/null +++ b/lib/URI/ldapi.pm @@ -0,0 +1,29 @@ +package URI::ldapi; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 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/lib/URI/ldaps.pm b/lib/URI/ldaps.pm new file mode 100644 index 0000000..80a96d3 --- /dev/null +++ b/lib/URI/ldaps.pm @@ -0,0 +1,14 @@ +package URI::ldaps; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::ldap'; + +sub default_port { 636 } + +sub secure { 1 } + +1; diff --git a/lib/URI/mailto.pm b/lib/URI/mailto.pm new file mode 100644 index 0000000..0e94463 --- /dev/null +++ b/lib/URI/mailto.pm @@ -0,0 +1,73 @@ +package URI::mailto; # RFC 2368 + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent qw(URI URI::_query); + +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/lib/URI/mms.pm b/lib/URI/mms.pm new file mode 100644 index 0000000..c9af387 --- /dev/null +++ b/lib/URI/mms.pm @@ -0,0 +1,12 @@ +package URI::mms; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::http'; + +sub default_port { 1755 } + +1; diff --git a/lib/URI/news.pm b/lib/URI/news.pm new file mode 100644 index 0000000..77e2c18 --- /dev/null +++ b/lib/URI/news.pm @@ -0,0 +1,71 @@ +package URI::news; # draft-gilman-news-url-01 + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::_server'; + +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 undef unless $old =~ /\@/; + return $old; +} + +1; diff --git a/lib/URI/nntp.pm b/lib/URI/nntp.pm new file mode 100644 index 0000000..73dc629 --- /dev/null +++ b/lib/URI/nntp.pm @@ -0,0 +1,10 @@ +package URI::nntp; # draft-gilman-news-url-01 + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::news'; + +1; diff --git a/lib/URI/pop.pm b/lib/URI/pop.pm new file mode 100644 index 0000000..cfc5e11 --- /dev/null +++ b/lib/URI/pop.pm @@ -0,0 +1,71 @@ +package URI::pop; # RFC 2384 + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::_server'; + +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 undef 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 undef unless defined $old; + $old =~ s/^[^;]*//; + return uri_unescape($1) if $old =~ /;auth=(.*)/i; + return; +} + +1; diff --git a/lib/URI/rlogin.pm b/lib/URI/rlogin.pm new file mode 100644 index 0000000..5ed141b --- /dev/null +++ b/lib/URI/rlogin.pm @@ -0,0 +1,12 @@ +package URI::rlogin; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::_login'; + +sub default_port { 513 } + +1; diff --git a/lib/URI/rsync.pm b/lib/URI/rsync.pm new file mode 100644 index 0000000..9cb649a --- /dev/null +++ b/lib/URI/rsync.pm @@ -0,0 +1,14 @@ +package URI::rsync; # http://rsync.samba.org/ + +# rsync://[USER@]HOST[:PORT]/SRC + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent qw(URI::_server URI::_userpass); + +sub default_port { 873 } + +1; diff --git a/lib/URI/rtsp.pm b/lib/URI/rtsp.pm new file mode 100644 index 0000000..fa82efc --- /dev/null +++ b/lib/URI/rtsp.pm @@ -0,0 +1,12 @@ +package URI::rtsp; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::http'; + +sub default_port { 554 } + +1; diff --git a/lib/URI/rtspu.pm b/lib/URI/rtspu.pm new file mode 100644 index 0000000..b91fb80 --- /dev/null +++ b/lib/URI/rtspu.pm @@ -0,0 +1,12 @@ +package URI::rtspu; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::rtsp'; + +sub default_port { 554 } + +1; diff --git a/lib/URI/sftp.pm b/lib/URI/sftp.pm new file mode 100644 index 0000000..03bf9b3 --- /dev/null +++ b/lib/URI/sftp.pm @@ -0,0 +1,10 @@ +package URI::sftp; + +use strict; +use warnings; + +use parent 'URI::ssh'; + +our $VERSION = "1.69"; + +1; diff --git a/lib/URI/sip.pm b/lib/URI/sip.pm new file mode 100644 index 0000000..7b27a9f --- /dev/null +++ b/lib/URI/sip.pm @@ -0,0 +1,85 @@ +# +# 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; + +use strict; +use warnings; + +use parent qw(URI::_server URI::_userpass); + +use URI::Escape qw(uri_unescape); + +our $VERSION = "1.69"; + +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/lib/URI/sips.pm b/lib/URI/sips.pm new file mode 100644 index 0000000..767067f --- /dev/null +++ b/lib/URI/sips.pm @@ -0,0 +1,14 @@ +package URI::sips; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::sip'; + +sub default_port { 5061 } + +sub secure { 1 } + +1; diff --git a/lib/URI/snews.pm b/lib/URI/snews.pm new file mode 100644 index 0000000..de1d515 --- /dev/null +++ b/lib/URI/snews.pm @@ -0,0 +1,14 @@ +package URI::snews; # draft-gilman-news-url-01 + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::news'; + +sub default_port { 563 } + +sub secure { 1 } + +1; diff --git a/lib/URI/ssh.pm b/lib/URI/ssh.pm new file mode 100644 index 0000000..396c7a7 --- /dev/null +++ b/lib/URI/ssh.pm @@ -0,0 +1,16 @@ +package URI::ssh; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::_login'; + +# ssh://[USER@]HOST[:PORT]/SRC + +sub default_port { 22 } + +sub secure { 1 } + +1; diff --git a/lib/URI/telnet.pm b/lib/URI/telnet.pm new file mode 100644 index 0000000..b86d9aa --- /dev/null +++ b/lib/URI/telnet.pm @@ -0,0 +1,12 @@ +package URI::telnet; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::_login'; + +sub default_port { 23 } + +1; diff --git a/lib/URI/tn3270.pm b/lib/URI/tn3270.pm new file mode 100644 index 0000000..fb60acc --- /dev/null +++ b/lib/URI/tn3270.pm @@ -0,0 +1,12 @@ +package URI::tn3270; + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::_login'; + +sub default_port { 23 } + +1; diff --git a/lib/URI/urn.pm b/lib/URI/urn.pm new file mode 100644 index 0000000..fe744f8 --- /dev/null +++ b/lib/URI/urn.pm @@ -0,0 +1,100 @@ +package URI::urn; # RFC 2141 + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI'; + +use Carp qw(carp); + +my %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/lib/URI/urn/isbn.pm b/lib/URI/urn/isbn.pm new file mode 100644 index 0000000..b335044 --- /dev/null +++ b/lib/URI/urn/isbn.pm @@ -0,0 +1,103 @@ +package URI::urn::isbn; # RFC 3187 + +use strict; +use warnings; + +use parent 'URI::urn'; + +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/lib/URI/urn/oid.pm b/lib/URI/urn/oid.pm new file mode 100644 index 0000000..ceb8322 --- /dev/null +++ b/lib/URI/urn/oid.pm @@ -0,0 +1,20 @@ +package URI::urn::oid; # RFC 2061 + +use strict; +use warnings; + +our $VERSION = "1.69"; + +use parent 'URI::urn'; + +sub oid { + my $self = shift; + my $old = $self->nss; + if (@_) { + $self->nss(join(".", @_)); + } + return split(/\./, $old) if wantarray; + return $old; +} + +1; |