root/trunk/inc/URI/WithBase.pm

Revision 93, 3.7 kB (checked in by clinton, 4 years ago)

Bundle Test::WWW::Mechanize and (most) of its dependencies to allow testing, tid10737 tid10892

Line 
1 package URI::WithBase;
2
3 use strict;
4 use vars qw($AUTOLOAD $VERSION);
5 use URI;
6
7 $VERSION = "2.19";
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
Note: See TracBrowser for help on using the browser.