home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _1331e4c10e7c382dadb1226afbf9aa10 < prev    next >
Encoding:
Text File  |  2000-03-15  |  2.9 KB  |  142 lines
  1. package URI::WithBase;
  2.  
  3. use strict;
  4. use vars qw($AUTOLOAD);
  5. use URI;
  6.  
  7. use overload '""' => "as_string", fallback => 1;
  8.  
  9. sub as_string;  # help overload find it
  10.  
  11. sub new
  12. {
  13.     my($class, $uri, $base) = @_;
  14.     my $ibase = $base;
  15.     if ($base && UNIVERSAL::isa($base, "URI::WithBase")) {
  16.     $base = $base->abs;
  17.     $ibase = $base->[0];
  18.     }
  19.     bless [URI->new($uri, $ibase), $base], $class;
  20. }
  21.  
  22. sub _init
  23. {
  24.     my $class = shift;
  25.     my($str, $scheme) = @_;
  26.     bless [URI->new($str, $scheme), undef], $class;
  27. }
  28.  
  29. sub eq
  30. {
  31.     my($self, $other) = @_;
  32.     $other = $other->[0] if UNIVERSAL::isa($other, "URI::WithBase");
  33.     $self->[0]->eq($other);
  34. }
  35.  
  36. sub AUTOLOAD
  37. {
  38.     my $self = shift;
  39.     my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
  40.     return if $method eq "DESTROY";
  41.     $self->[0]->$method(@_);
  42. }
  43.  
  44. sub base {
  45.     my $self = shift;
  46.     my $base  = $self->[1];
  47.  
  48.     if (@_) { # set
  49.     my $new_base = @_;
  50.     $new_base = $new_base->abs if ref($new_base);  # ensure absoluteness
  51.     $self->[1] = $new_base;
  52.     }
  53.     return unless defined wantarray;
  54.  
  55.     # The base attribute supports 'lazy' conversion from URL strings
  56.     # to URL objects. Strings may be stored but when a string is
  57.     # fetched it will automatically be converted to a URL object.
  58.     # The main benefit is to make it much cheaper to say:
  59.     #   URI::WithBase->new($random_url_string, 'http:')
  60.     if (defined($base) && !ref($base)) {
  61.     $base = URI->new($base);
  62.     $self->[1] = $base unless @_;
  63.     }
  64.     $base;
  65. }
  66.  
  67. sub clone
  68. {
  69.     my $self = shift;
  70.     bless [$self->[0]->clone, $self->[0]], ref($self);
  71. }
  72.  
  73. sub abs
  74. {
  75.     my $self = shift;
  76.     my $base = shift || $self->base || return $self->clone;
  77.     bless [$self->[0]->abs($base, @_), $base], ref($self);
  78. }
  79.  
  80. sub rel
  81. {
  82.     my $self = shift;
  83.     my $base = shift || $self->base || return $self->clone;
  84.     bless [$self->[0]->rel($base, @_), $base], ref($self);
  85. }
  86.  
  87. 1;
  88.  
  89. __END__
  90.  
  91. =head1 NAME
  92.  
  93. URI::WithBase - URI which remember their base
  94.  
  95. =head1 SYNOPSIS
  96.  
  97.  $u1 = URI::WithBase->new($str, $base);
  98.  $u2 = $u1->abs;
  99.  
  100.  $base = $u1->base;
  101.  $u1->base( $new_base )
  102.  
  103. =head1 DESCRIPTION
  104.  
  105. This module provide the C<URI::WithBase> class.  Objects of this class
  106. are like C<URI> objects, but can keep their base too.
  107.  
  108. The methods provided in addition to or modified from those of C<URI> are:
  109.  
  110. =over 4
  111.  
  112. =item $uri = URI::WithBase->new($str, [$base])
  113.  
  114. The constructor takes a an optional base URI as the second argument.
  115.  
  116. =item $uri->base( [$new_base] )
  117.  
  118. This method can be used to get or set the value of the base attribute.
  119.  
  120. =item $uri->abs( [$base_uri] )
  121.  
  122. The $base_uri argument is now made optional as the object carries it's
  123. base with it.
  124.  
  125. =item $uri->rel( [$base_uri] )
  126.  
  127. The $base_uri argument is now made optional as the object carries it's
  128. base with it.
  129.  
  130. =back
  131.  
  132.  
  133. =head1 SEE ALSO
  134.  
  135. L<URI>
  136.  
  137. =head1 COPYRIGHT
  138.  
  139. Copyright 1998 Gisle Aas.
  140.  
  141. =cut
  142.