home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / URI / URL / _generic.pm next >
Encoding:
Text File  |  1997-04-07  |  14.6 KB  |  515 lines  |  [TEXT/McPL]
  1. #####################################################################
  2. #
  3. #       Internal pre-defined generic scheme support
  4. #
  5. # In this implementation all schemes are subclassed from
  6. # URI::URL::_generic. This turns out to have reasonable mileage.
  7. # See also draft-ietf-uri-relative-url-06.txt
  8.  
  9. package URI::URL::_generic;           # base support for generic-RL's
  10. require URI::URL;
  11. @ISA = qw(URI::URL);
  12.  
  13. use URI::Escape qw(uri_escape uri_unescape %escapes);
  14.  
  15.  
  16. sub new {                               # inherited by subclasses
  17.     my($class, $init, $base) = @_;
  18.     my $url = bless { }, $class;        # create empty object
  19.     $url->_parse($init);                # parse $init into components
  20.     $url->base($base) if $base;
  21.     $url;
  22. }
  23.  
  24.  
  25. # Generic-RL parser
  26. # See draft-ietf-uri-relative-url-06.txt Section 2
  27.  
  28. sub _parse {
  29.     my($self, $u, @comps) = @_;
  30.     return unless defined $u;
  31.  
  32.     # Deside which components to parse (scheme & path is manatory)
  33.     @comps = qw(netloc query params frag) unless (@comps);
  34.     my %parse = map {$_ => 1} @comps;
  35.  
  36.     # This parsing code is based on
  37.     #   draft-ietf-uri-relative-url-06.txt Section 2.4
  38.  
  39.     # 2.4.1
  40.     $self->{'frag'} = uri_unescape($1)
  41.       if $parse{'frag'} && $u =~ s/#(.*)$//;
  42.     # 2.4.2
  43.     $self->{'scheme'} = lc($1) if $u =~ s/^\s*([\w\+\.\-]+)://;
  44.     # 2.4.3
  45.     $self->netloc("$1")    # passing $1 directly fails if netloc is autoloaded
  46.       if $parse{'netloc'} && $u =~ s!^//([^/]*)!!;
  47.     # 2.4.4
  48.     $self->{'query'} = $1
  49.       if $parse{'query'} && $u =~ s/\?(.*)//;
  50.     # 2.4.5
  51.     $self->{'params'} = $1
  52.       if $parse{'params'} && $u =~ s/;(.*)//;
  53.  
  54.     # 2.4.6
  55.     #
  56.     # RFC 1738 says:
  57.     #
  58.     #     Note that the "/" between the host (or port) and the
  59.     #     url-path is NOT part of the url-path.
  60.     #
  61.     # however, RFC 1808, 2.4.6. says:
  62.     #
  63.     #    Even though the initial slash is not part of the URL path,
  64.     #    the parser must remember whether or not it was present so
  65.     #    that later processes can differentiate between relative
  66.     #    and absolute paths.  Often this is done by simply storing
  67.     #    he preceding slash along with the path.
  68.     #
  69.     # In version < 4.01 of URI::URL we used to strip the leading
  70.     # "/" when asked for $self->path().  This created problems for
  71.     # the consitency of the interface, so now we just consider the
  72.     # slash to be part of the path and we also make an empty path
  73.     # default to "/".
  74.  
  75.     # we don't test for $parse{path} becase it is mandatory
  76.     $self->{'path'} = $u;
  77. }
  78.  
  79.  
  80. # Generic-RL stringify
  81. #
  82. sub as_string
  83. {
  84.     my $self = shift;
  85.     return $self->{'_str'} if $self->{'_str'};
  86.  
  87.     my($scheme, $netloc, $frag) = @{$self}{qw(scheme netloc frag)};
  88.  
  89.     my $u = $self->full_path(1);  # path+params+query
  90.  
  91.     # rfc 1808 says:
  92.     #    Note that the fragment identifier (and the "#" that precedes
  93.     #    it) is not considered part of the URL.  However, since it is
  94.     #    commonly used within the same string context as a URL, a parser
  95.     #    must be able to recognize the fragment when it is present and
  96.     #    set it aside as part of the parsing process.
  97.     $u .= "#" . uri_escape($frag, $URI::URL::unsafe) if defined $frag;
  98.  
  99.     $u = "//$netloc$u" if defined $netloc;
  100.     $u = "$scheme:$u" if $scheme;
  101.     # Inline: uri_escape($u, $URI::URL::unsafe);
  102.     $u =~ s/([$URI::URL::unsafe])/$escapes{$1}/go;
  103.     $self->{'_str'} = $u;  # set cache and return
  104. }
  105.  
  106. # Generic-RL stringify full path "path;params?query"
  107. #
  108. sub full_path
  109. {
  110.     my($self, $dont_escape)  = @_;
  111.     my($path, $params, $query) = @{$self}{'path', 'params', 'query'};
  112.     my $p = '';
  113.     $p .= $path if defined $path;
  114.     # see comment in _parse 2.4.6 about the next line
  115.     $p = "/$p" if defined($self->{netloc}) && $p !~ m:^/:;
  116.     $p .= ";$params" if defined $params;
  117.     $p .= "?$query"  if defined $query;
  118.     return $p if $dont_escape;
  119.     # Inline: URI::Escape::uri_escape($p, $URI::URL::unsafe);
  120.     $p =~ s/([$URI::URL::unsafe])/$escapes{$1}/go;
  121.     $p;
  122. }
  123.  
  124. # default_port()
  125. #
  126. # subclasses will usually want to override this
  127. #
  128. sub default_port { undef; }
  129.  
  130.  
  131. #####################################################################
  132. #
  133. # Methods to handle URL's elements
  134.  
  135. # These methods always return the current value,
  136. # so you can use $url->path to read the current value.
  137. # If a new value is passed, e.g. $url->path('foo'),
  138. # it also sets the new value, and returns the previous value.
  139. # Use $url->path(undef) to set the value to undefined.
  140.  
  141. sub netloc {
  142.     my $self = shift;
  143.     my $old = $self->_elem('netloc', @_);
  144.     return $old unless @_;
  145.  
  146.     # update fields derived from netloc
  147.     my $nl = $self->{'netloc'} || '';
  148.     if ($nl =~ s/^([^:@]*):?(.*?)@//){
  149.     $self->{'user'}     = uri_unescape($1);
  150.     $self->{'password'} = uri_unescape($2) if $2 ne '';
  151.     }
  152.     if ($nl =~ /^([^:]*):?(\d*)$/){
  153.     my $port = $2;
  154.     # Since this happes so frequently, we inline this call:
  155.     #    my $host = uri_unescape($1);
  156.     my $host = $1;
  157.     $host =~ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg;
  158.     $self->{'host'} = $host;
  159.     if ($port ne '') {
  160.         $self->{'port'} = $port;
  161.         if ($self->default_port == $port) {
  162.         $self->{'netloc'} =~ s/:\d+//;
  163.         }
  164.     } elsif (defined $self->{'netloc'}) {
  165.         $self->{'netloc'} =~ s/:$//;  # handle empty port spec
  166.     }
  167.     }
  168.     $self->{'_str'} = '';
  169.     $old;
  170. }
  171.  
  172.  
  173. # A U T O  L O A D E R
  174. # Don't remove this comment, it keeps AutoSplit happy!!
  175. # @ISA = qw(AutoLoader)
  176. #
  177. # The rest of the methods are only loaded on demand.  Stubs are neccesary
  178. # for inheritance to work.
  179.  
  180. #sub netloc;  # because netloc is used by the _parse()
  181. sub user;
  182. sub password;
  183. sub host;
  184. sub port;
  185. sub _netloc_elem;
  186. sub epath;
  187. sub path;
  188. sub path_components;
  189. sub eparams;
  190. sub params;
  191. sub equery;
  192. sub query;
  193. sub frag;
  194. sub crack;
  195. sub abs;
  196. sub rel;
  197. sub eq;
  198.  
  199. 1;
  200. __END__
  201.  
  202.  
  203. # Fields derived from generic netloc:
  204. sub user     { shift->_netloc_elem('user',    @_); }
  205. sub password { shift->_netloc_elem('password',@_); }
  206. sub host     { shift->_netloc_elem('host',    @_); }
  207.  
  208. sub port {
  209.     my $self = shift;
  210.     my $old = $self->_netloc_elem('port', @_);
  211.     defined($old) ? $old : $self->default_port;
  212. }
  213.  
  214. sub _netloc_elem {
  215.     my($self, $elem, @val) = @_;
  216.     my $old = $self->_elem($elem, @val);
  217.     return $old unless @val;
  218.  
  219.     # update the 'netloc' element
  220.     my $nl = '';
  221.     my $host = $self->{'host'};
  222.     if (defined $host) {  # can't be any netloc without any host
  223.     my $user = $self->{'user'};
  224.     $nl .= uri_escape($user, $URI::URL::reserved) if defined $user;
  225.     $nl .= ":" . uri_escape($self->{'password'}, $URI::URL::reserved)
  226.       if defined($user) and defined($self->{'password'});
  227.     $nl .= '@' if length $nl;
  228.     $nl .= uri_escape($host, $URI::URL::reserved);
  229.     my $port = $self->{'port'};
  230.     $nl .= ":$port" if defined($port) && $port != $self->default_port;
  231.     }
  232.     $self->{'netloc'} = $nl;
  233.     $self->{'_str'} = '';
  234.     $old;
  235. }
  236.  
  237. sub epath {
  238.      my $self = shift;
  239.      my $old = $self->_elem('path', @_);
  240.      return '/' if !defined($old) || !length($old);
  241.      return "/$old" if $old !~ m|^/| && defined $self->{'netloc'};
  242.      $old;
  243. }
  244.  
  245. sub path {
  246.     my $self = shift;
  247.     my $old = $self->_elem('path',
  248.                map { uri_escape($_,
  249.                         $URI::URL::reserved_no_slash)
  250.                    } @_);
  251.  
  252.     if ($URI::URL::COMPAT_VER_3) {
  253.     # We used to get rid of the leading "/" in the path
  254.     if (defined $old) {
  255.         $old =~ s|^/||;
  256.         Carp::croak("Path components contain '/' (you must call epath)")
  257.         if $old =~ /%2[fF]/;
  258.         return uri_unescape($old);
  259.     }
  260.     return undef;
  261.     }
  262.  
  263.     return '/' if !defined($old) || !length($old);
  264.     Carp::croak("Path components contain '/' (you must call epath)")
  265.     if $old =~ /%2[fF]/ and !@_;
  266.     $old = "/$old" if $old !~ m|^/| && defined $self->{'netloc'};
  267.     return uri_unescape($old);
  268. }
  269.  
  270. sub path_components {
  271.     my $self = shift;
  272.     my $old = $self->{'path'};
  273.     $old = '' unless defined $old;
  274.     $old = "/$old" if $old !~ m|^/| && defined $self->{'netloc'};
  275.     if (@_) {
  276.     $self->_elem('path',
  277.              join("/", map { uri_escape($_,
  278.                         $URI::URL::reserved.".")
  279.                    } @_));
  280.     }
  281.     map { uri_unescape($_) } split("/", $old, -1);
  282. }
  283.  
  284. sub eparams  { shift->_elem('params',  @_); }
  285.  
  286. sub params {
  287.     my $self = shift;
  288.     my $old = $self->_elem('params', map {uri_escape($_,$URI::URL::reserved_no_form)} @_);
  289.     return uri_unescape($old) if defined $old;
  290.     undef;
  291. }
  292.  
  293. sub equery   { shift->_elem('query',   @_); }
  294.  
  295. sub query {
  296.     my $self = shift;
  297.     my $old = $self->_elem('query', map { uri_escape($_, $URI::URL::reserved_no_form) } @_);
  298.     if (defined $old) {
  299.     if ($old =~ /%(?:26|2[bB]|3[dD])/) {  # contains escaped '=' '&' or '+'
  300.         my $mess;
  301.         for ($old) {
  302.         $mess = "Query contains both '+' and '%2B'"
  303.           if /\+/ && /%2[bB]/;
  304.         $mess = "Form query contains escaped '=' or '&'"
  305.           if /=/  && /%(?:3[dD]|26)/;
  306.         }
  307.         if ($mess) {
  308.         Carp::croak("$mess (you must call equery)");
  309.         }
  310.     }
  311.     # Now it should be safe to unescape the string without loosing
  312.     # information
  313.     return uri_unescape($old);
  314.     }
  315.     undef;
  316.  
  317. }
  318.  
  319. # No efrag method because the fragment is always stored unescaped
  320. sub frag     { shift->_elem('frag', @_); }
  321.  
  322. sub crack
  323. {
  324.     my $self = shift;
  325.     return $self unless wantarray;
  326.     my @c = @{$self}{qw(scheme user password host port path params query frag)};
  327.     if (!$c[0]) {
  328.     # try to determine scheme
  329.     my $base = $self->base;
  330.     $c[0] = $base->scheme if $base;
  331.     $c[0] ||= 'http';  # last resort, default in URI::URL::new
  332.     }
  333.     $c[4] ||= $self->default_port;
  334.     @c;
  335. }
  336.  
  337. # Generic-RL: Resolving Relative URL into an Absolute URL
  338. #
  339. # Based on RFC1808 section 4
  340. #
  341. sub abs
  342. {
  343.     my($self, $base, $allow_scheme_in_relative_urls) = @_;
  344.     my $embed = $self->clone;
  345.  
  346.     $base = $self->base unless $base;      # default to default base
  347.     return $embed unless $base;            # we have no base (step1)
  348.  
  349.     $base = new URI::URL $base unless ref $base; # make obj if needed
  350.  
  351.     my($scheme, $host, $path, $params, $query, $frag) =
  352.     @{$embed}{qw(scheme host path params query frag)};
  353.  
  354.     # just use base if we are empty             (2a)
  355.     return $base->clone
  356.       unless grep(defined($_) && $_ ne '',
  357.           $scheme,$host,$port,$path,$params,$query,$frag);
  358.  
  359.     # if we have a scheme we must already be absolute   (2b),
  360.     #
  361.     # but sec. 5.2 also says: Some older parsers allow the scheme name
  362.     # to be present in a relative URL if it is the same as the base
  363.     # URL scheme.  This is considered to be a loophole in prior
  364.     # specifications of the partial URLs and should be avoided by
  365.     # future parsers.
  366.     #
  367.     # The old behavoir can be enabled by passing a TRUE value to the
  368.     # $allow_scheme_in_relative_urls parameter.
  369.     return $embed if $scheme &&
  370.       (!$allow_scheme_in_relative_urls || $scheme ne $base->{'scheme'});
  371.  
  372.     $embed->{'_str'} = '';                      # void cached string
  373.     $embed->{'scheme'} = $base->{'scheme'};     # (2c)
  374.  
  375.     return $embed if $embed->{'netloc'};        # (3)
  376.     $embed->netloc($base->{'netloc'});          # (3)
  377.  
  378.     return $embed if $path =~ m:^/:;            # (4)
  379.  
  380.     if ($path eq '') {                          # (5)
  381.     $embed->{'path'} = $base->{'path'};     # (5)
  382.  
  383.     return $embed if defined $embed->{'params'}; # (5a)
  384.     $embed->{'params'} = $base->{'params'};      # (5a)
  385.  
  386.     return $embed if defined $embed->{'query'};  # (5b)
  387.     $embed->{'query'} = $base->{'query'};        # (5b)
  388.  
  389.     return $embed;
  390.     }
  391.  
  392.     # (Step 6)  # draft 6 suggests stack based approach
  393.  
  394.     my $basepath = $base->{'path'};
  395.     my $relpath  = $embed->{'path'};
  396.  
  397.     $basepath =~ s!^/!!;
  398.     $basepath =~ s!/$!/.!;                # prevent empty segment
  399.     my @path = split('/', $basepath);     # base path into segments
  400.     pop(@path);                           # remove last segment
  401.  
  402.     $relpath =~ s!/$!/.!;                 # prevent empty segment
  403.  
  404.     push(@path, split('/', $relpath));    # append relative segments
  405.  
  406.     my @newpath = ();
  407.     my $isdir = 0;
  408.     my $segment;
  409.  
  410.     foreach $segment (@path) {            # left to right
  411.     if ($segment eq '.') {            # ignore "same" directory
  412.         $isdir = 1;
  413.     }
  414.     elsif ($segment eq '..') {
  415.         $isdir = 1;
  416.         my $last = pop(@newpath);
  417.         if (!defined $last) {         # nothing to pop
  418.         push(@newpath, $segment); # so must append
  419.         }
  420.         elsif ($last eq '..') {       # '..' cannot match '..'
  421.         # so put back again, and append
  422.         push(@newpath, $last, $segment);
  423.         }
  424.         #else
  425.         # it was a component,
  426.         # keep popped
  427.     } else {
  428.         $isdir = 0;
  429.         push(@newpath, $segment);
  430.     }
  431.     }
  432.  
  433.     $embed->{'path'} = '/' . join('/', @newpath) .
  434.     ($isdir && @newpath ? '/' : '');
  435.  
  436.     $embed;
  437. }
  438.  
  439. # The oposite of $url->abs.  Return a URL as much relative as possible
  440. sub rel {
  441.     my($self, $base) = @_;
  442.     my $rel = $self->clone;
  443.     $base = $self->base unless $base;
  444.     return $rel unless $base;
  445.     $base = new URI::URL $base unless ref $base;
  446.     $rel->base($base);
  447.  
  448.     my($scheme, $netloc, $path) = @{$rel}{qw(scheme netloc path)};
  449.     if (!defined($scheme) && !defined($netloc)) {
  450.     # it is already relative
  451.     return $rel;
  452.     }
  453.     
  454.     my($bscheme, $bnetloc, $bpath) = @{$base}{qw(scheme netloc path)};
  455.     for ($netloc, $bnetloc, $bpath) { $_ = '' unless defined }
  456.     $bpath = "/" unless length $bpath;  # a slash is default
  457.     unless ($scheme eq $bscheme && $netloc eq $bnetloc) {
  458.     # different location, can't make it relative
  459.     return $rel;
  460.     }
  461.  
  462.     # Make it relative by eliminating scheme and netloc
  463.     $rel->{'scheme'} = undef;
  464.     $rel->netloc(undef);
  465.  
  466.     # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
  467.     # It will remove all common initial path components.
  468.     while (1) {
  469.     #print "PATHS: $path $bpath\n";
  470.     my $i = index($path, '/');
  471.     last unless $i >=0 && $i == index($bpath, '/') &&
  472.                     substr($path,0,$i) eq substr($bpath,0,$i);
  473.     substr($path, 0, $i+1)  = '';
  474.     substr($bpath, 0, $i+1) = '';
  475.     }
  476.  
  477.     # Add one "../" for each path component left in the base path
  478.     $path = ('../' x $bpath =~ tr|/|/|) . $path;
  479.  
  480.     $rel->epath($path);
  481.     $rel;
  482. }
  483.  
  484.  
  485. # Compare two URLs
  486. sub eq {
  487.     my($self, $other) = @_;
  488.     local($^W) = 0; # avoid warnings if we compare undef values
  489.     $other = URI::URL->new($other, $self) unless ref $other;
  490.  
  491.     # Compare scheme and netloc
  492.     return 0 if ref($self) ne ref($other);                # must be same class
  493.     return 0 if $self->scheme ne $other->scheme;          # Always lower case
  494.     return 0 if lc($self->netloc) ne lc($other->netloc);  # Case-insensitive
  495.  
  496.     # Compare full_path:
  497.     # According to <draft-ietf-http-v11-spec-05>:
  498.     # Characters other than those in the "reserved" and "unsafe" sets
  499.     # are equivalent to their %XX encodings.
  500.     my $fp1 = $self->full_path;
  501.     my $fp2 = $other->full_path;
  502.     for ($fp1, $fp2) {
  503.     s,%([\dA-Fa-f]{2}),
  504.       my $x = $1;
  505.       my $c = chr(hex($x));
  506.       $c =~ /^[;\/?:\@&=+\"\#%<>\0-\040\177]/ ? "%\L$x" : $c;
  507.     ,eg;
  508.     }
  509.     return 0 if $fp1 ne $fp2;
  510.     return 0 if $self->frag ne $other->frag;
  511.     1;
  512. }
  513.  
  514. 1;
  515.