1 | package URI::WithBase;
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 | use vars qw($AUTOLOAD $VERSION);
|
---|
5 | use URI;
|
---|
6 |
|
---|
7 | $VERSION = "2.20";
|
---|
8 |
|
---|
9 | use overload '""' => "as_string", fallback => 1;
|
---|
10 |
|
---|
11 | sub as_string; # help overload find it
|
---|
12 |
|
---|
13 | sub 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 |
|
---|
24 | sub new_abs
|
---|
25 | {
|
---|
26 | my $class = shift;
|
---|
27 | my $self = $class->new(@_);
|
---|
28 | $self->abs;
|
---|
29 | }
|
---|
30 |
|
---|
31 | sub _init
|
---|
32 | {
|
---|
33 | my $class = shift;
|
---|
34 | my($str, $scheme) = @_;
|
---|
35 | bless [URI->new($str, $scheme), undef], $class;
|
---|
36 | }
|
---|
37 |
|
---|
38 | sub eq
|
---|
39 | {
|
---|
40 | my($self, $other) = @_;
|
---|
41 | $other = $other->[0] if UNIVERSAL::isa($other, __PACKAGE__);
|
---|
42 | $self->[0]->eq($other);
|
---|
43 | }
|
---|
44 |
|
---|
45 | sub 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 |
|
---|
53 | sub can { # override UNIVERSAL::can
|
---|
54 | my $self = shift;
|
---|
55 | $self->SUPER::can(@_) || (
|
---|
56 | ref($self)
|
---|
57 | ? $self->[0]->can(@_)
|
---|
58 | : undef
|
---|
59 | )
|
---|
60 | }
|
---|
61 |
|
---|
62 | sub 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 |
|
---|
86 | sub 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 |
|
---|
94 | sub 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 |
|
---|
102 | sub 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 |
|
---|
110 | 1;
|
---|
111 |
|
---|
112 | __END__
|
---|
113 |
|
---|
114 | =head1 NAME
|
---|
115 |
|
---|
116 | URI::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 |
|
---|
128 | This module provides the C<URI::WithBase> class. Objects of this class
|
---|
129 | are like C<URI> objects, but can keep their base too. The base
|
---|
130 | represents the context where this URI was found and can be used to
|
---|
131 | absolutize or relativize the URI. All the methods described in L<URI>
|
---|
132 | are supported for C<URI::WithBase> objects.
|
---|
133 |
|
---|
134 | The 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 |
|
---|
140 | The constructor takes an optional base URI as the second argument.
|
---|
141 | If provided, this argument initializes the base attribute.
|
---|
142 |
|
---|
143 | =item $uri->base( [$new_base] )
|
---|
144 |
|
---|
145 | Can be used to get or set the value of the base attribute.
|
---|
146 | The return value, which is the old value, is a URI object or C<undef>.
|
---|
147 |
|
---|
148 | =item $uri->abs( [$base_uri] )
|
---|
149 |
|
---|
150 | The $base_uri argument is now made optional as the object carries its
|
---|
151 | base with it. A new object is returned even if $uri is already
|
---|
152 | absolute (while plain URI objects simply return themselves in
|
---|
153 | that case).
|
---|
154 |
|
---|
155 | =item $uri->rel( [$base_uri] )
|
---|
156 |
|
---|
157 | The $base_uri argument is now made optional as the object carries its
|
---|
158 | base with it. A new object is always returned.
|
---|
159 |
|
---|
160 | =back
|
---|
161 |
|
---|
162 |
|
---|
163 | =head1 SEE ALSO
|
---|
164 |
|
---|
165 | L<URI>
|
---|
166 |
|
---|
167 | =head1 COPYRIGHT
|
---|
168 |
|
---|
169 | Copyright 1998-2002 Gisle Aas.
|
---|
170 |
|
---|
171 | =cut
|
---|