1package URI::WithBase; 2 3use strict; 4use vars qw($AUTOLOAD $VERSION); 5use URI; 6 7$VERSION = "2.19"; 8 9use overload '""' => "as_string", fallback => 1; 10 11sub as_string; # help overload find it 12 13sub new 14{ 15 my($class, $uri, $base) = @_; 16 my $ibase = $base; 17 if ($base && ref($base) && UNIVERSAL::isa($base, __PACKAGE__)) { 18 $base = $base->abs; 19 $ibase = $base->[0]; 20 } 21 bless [URI->new($uri, $ibase), $base], $class; 22} 23 24sub new_abs 25{ 26 my $class = shift; 27 my $self = $class->new(@_); 28 $self->abs; 29} 30 31sub _init 32{ 33 my $class = shift; 34 my($str, $scheme) = @_; 35 bless [URI->new($str, $scheme), undef], $class; 36} 37 38sub eq 39{ 40 my($self, $other) = @_; 41 $other = $other->[0] if UNIVERSAL::isa($other, __PACKAGE__); 42 $self->[0]->eq($other); 43} 44 45sub AUTOLOAD 46{ 47 my $self = shift; 48 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); 49 return if $method eq "DESTROY"; 50 $self->[0]->$method(@_); 51} 52 53sub can { # override UNIVERSAL::can 54 my $self = shift; 55 $self->SUPER::can(@_) || ( 56 ref($self) 57 ? $self->[0]->can(@_) 58 : undef 59 ) 60} 61 62sub base { 63 my $self = shift; 64 my $base = $self->[1]; 65 66 if (@_) { # set 67 my $new_base = shift; 68 # ensure absoluteness 69 $new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__); 70 $self->[1] = $new_base; 71 } 72 return unless defined wantarray; 73 74 # The base attribute supports 'lazy' conversion from URL strings 75 # to URL objects. Strings may be stored but when a string is 76 # fetched it will automatically be converted to a URL object. 77 # The main benefit is to make it much cheaper to say: 78 # URI::WithBase->new($random_url_string, 'http:') 79 if (defined($base) && !ref($base)) { 80 $base = ref($self)->new($base); 81 $self->[1] = $base unless @_; 82 } 83 $base; 84} 85 86sub clone 87{ 88 my $self = shift; 89 my $base = $self->[1]; 90 $base = $base->clone if ref($base); 91 bless [$self->[0]->clone, $base], ref($self); 92} 93 94sub abs 95{ 96 my $self = shift; 97 my $base = shift || $self->base || return $self->clone; 98 $base = $base->as_string if ref($base); 99 bless [$self->[0]->abs($base, @_), $base], ref($self); 100} 101 102sub rel 103{ 104 my $self = shift; 105 my $base = shift || $self->base || return $self->clone; 106 $base = $base->as_string if ref($base); 107 bless [$self->[0]->rel($base, @_), $base], ref($self); 108} 109 1101; 111 112__END__ 113 114=head1 NAME 115 116URI::WithBase - URIs which remember their base 117 118=head1 SYNOPSIS 119 120 $u1 = URI::WithBase->new($str, $base); 121 $u2 = $u1->abs; 122 123 $base = $u1->base; 124 $u1->base( $new_base ) 125 126=head1 DESCRIPTION 127 128This module provides the C<URI::WithBase> class. Objects of this class 129are like C<URI> objects, but can keep their base too. The base 130represents the context where this URI was found and can be used to 131absolutize or relativize the URI. All the methods described in L<URI> 132are supported for C<URI::WithBase> objects. 133 134The methods provided in addition to or modified from those of C<URI> are: 135 136=over 4 137 138=item $uri = URI::WithBase->new($str, [$base]) 139 140The constructor takes an optional base URI as the second argument. 141If provided, this argument initializes the base attribute. 142 143=item $uri->base( [$new_base] ) 144 145Can be used to get or set the value of the base attribute. 146The return value, which is the old value, is a URI object or C<undef>. 147 148=item $uri->abs( [$base_uri] ) 149 150The $base_uri argument is now made optional as the object carries its 151base with it. A new object is returned even if $uri is already 152absolute (while plain URI objects simply return themselves in 153that case). 154 155=item $uri->rel( [$base_uri] ) 156 157The $base_uri argument is now made optional as the object carries its 158base with it. A new object is always returned. 159 160=back 161 162 163=head1 SEE ALSO 164 165L<URI> 166 167=head1 COPYRIGHT 168 169Copyright 1998-2002 Gisle Aas. 170 171=cut 172