1package URI::URL;
2
3require URI::WithBase;
4@ISA=qw(URI::WithBase);
5
6use strict;
7use vars qw(@EXPORT $VERSION);
8
9$VERSION = "5.03";
10
11# Provide as much as possible of the old URI::URL interface for backwards
12# compatibility...
13
14require Exporter;
15*import = \&Exporter::import;
16@EXPORT = qw(url);
17
18# Easy to use constructor
19sub url ($;$) { URI::URL->new(@_); }
20
21use URI::Escape qw(uri_unescape);
22
23sub new
24{
25    my $class = shift;
26    my $self = $class->SUPER::new(@_);
27    $self->[0] = $self->[0]->canonical;
28    $self;
29}
30
31sub newlocal
32{
33    my $class = shift;
34    require URI::file;
35    bless [URI::file->new_abs(shift)], $class;
36}
37
38{package URI::_foreign;
39    sub _init  # hope it is not defined
40    {
41	my $class = shift;
42	die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT;
43	$class->SUPER::_init(@_);
44    }
45}
46
47sub strict
48{
49    my $old = $URI::URL::STRICT;
50    $URI::URL::STRICT = shift if @_;
51    $old;
52}
53
54sub print_on
55{
56    my $self = shift;
57    require Data::Dumper;
58    print STDERR Data::Dumper::Dumper($self);
59}
60
61sub _try
62{
63    my $self = shift;
64    my $method = shift;
65    scalar(eval { $self->$method(@_) });
66}
67
68sub crack
69{
70    # should be overridden by subclasses
71    my $self = shift;
72    (scalar($self->scheme),
73     $self->_try("user"),
74     $self->_try("password"),
75     $self->_try("host"),
76     $self->_try("port"),
77     $self->_try("path"),
78     $self->_try("params"),
79     $self->_try("query"),
80     scalar($self->fragment),
81    )
82}
83
84sub full_path
85{
86    my $self = shift;
87    my $path = $self->path_query;
88    $path = "/" unless length $path;
89    $path;
90}
91
92sub netloc
93{
94    shift->authority(@_);
95}
96
97sub epath
98{
99    my $path = shift->SUPER::path(@_);
100    $path =~ s/;.*//;
101    $path;
102}
103
104sub eparams
105{
106    my $self = shift;
107    my @p = $self->path_segments;
108    return unless ref($p[-1]);
109    @p = @{$p[-1]};
110    shift @p;
111    join(";", @p);
112}
113
114sub params { shift->eparams(@_); }
115
116sub path {
117    my $self = shift;
118    my $old = $self->epath(@_);
119    return unless defined wantarray;
120    return '/' if !defined($old) || !length($old);
121    Carp::croak("Path components contain '/' (you must call epath)")
122	if $old =~ /%2[fF]/ and !@_;
123    $old = "/$old" if $old !~ m|^/| && defined $self->netloc;
124    return uri_unescape($old);
125}
126
127sub path_components {
128    shift->path_segments(@_);
129}
130
131sub query {
132    my $self = shift;
133    my $old = $self->equery(@_);
134    if (defined(wantarray) && defined($old)) {
135	if ($old =~ /%(?:26|2[bB]|3[dD])/) {  # contains escaped '=' '&' or '+'
136	    my $mess;
137	    for ($old) {
138		$mess = "Query contains both '+' and '%2B'"
139		  if /\+/ && /%2[bB]/;
140		$mess = "Form query contains escaped '=' or '&'"
141		  if /=/  && /%(?:3[dD]|26)/;
142	    }
143	    if ($mess) {
144		Carp::croak("$mess (you must call equery)");
145	    }
146	}
147	# Now it should be safe to unescape the string without loosing
148	# information
149	return uri_unescape($old);
150    }
151    undef;
152
153}
154
155sub abs
156{
157    my $self = shift;
158    my $base = shift;
159    my $allow_scheme = shift;
160    $allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME
161	unless defined $allow_scheme;
162    local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme;
163    local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS;
164    $self->SUPER::abs($base);
165}
166
167sub frag { shift->fragment(@_); }
168sub keywords { shift->query_keywords(@_); }
169
170# file:
171sub local_path { shift->file; }
172sub unix_path  { shift->file("unix"); }
173sub dos_path   { shift->file("dos");  }
174sub mac_path   { shift->file("mac");  }
175sub vms_path   { shift->file("vms");  }
176
177# mailto:
178sub address { shift->to(@_); }
179sub encoded822addr { shift->to(@_); }
180sub URI::mailto::authority { shift->to(@_); }  # make 'netloc' method work
181
182# news:
183sub groupart { shift->_group(@_); }
184sub article  { shift->message(@_); }
185
1861;
187
188__END__
189
190=head1 NAME
191
192URI::URL - Uniform Resource Locators
193
194=head1 SYNOPSIS
195
196 $u1 = URI::URL->new($str, $base);
197 $u2 = $u1->abs;
198
199=head1 DESCRIPTION
200
201This module is provided for backwards compatibility with modules that
202depend on the interface provided by the C<URI::URL> class that used to
203be distributed with the libwww-perl library.
204
205The following differences exist compared to the C<URI> class interface:
206
207=over 3
208
209=item *
210
211The URI::URL module exports the url() function as an alternate
212constructor interface.
213
214=item *
215
216The constructor takes an optional $base argument.  The C<URI::URL>
217class is a subclass of C<URI::WithBase>.
218
219=item *
220
221The URI::URL->newlocal class method is the same as URI::file->new_abs.
222
223=item *
224
225URI::URL::strict(1)
226
227=item *
228
229$url->print_on method
230
231=item *
232
233$url->crack method
234
235=item *
236
237$url->full_path: same as ($uri->abs_path || "/")
238
239=item *
240
241$url->netloc: same as $uri->authority
242
243=item *
244
245$url->epath, $url->equery: same as $uri->path, $uri->query
246
247=item *
248
249$url->path and $url->query pass unescaped strings.
250
251=item *
252
253$url->path_components: same as $uri->path_segments (if you don't
254consider path segment parameters)
255
256=item *
257
258$url->params and $url->eparams methods
259
260=item *
261
262$url->base method.  See L<URI::WithBase>.
263
264=item *
265
266$url->abs and $url->rel have an optional $base argument.  See
267L<URI::WithBase>.
268
269=item *
270
271$url->frag: same as $uri->fragment
272
273=item *
274
275$url->keywords: same as $uri->query_keywords
276
277=item *
278
279$url->localpath and friends map to $uri->file.
280
281=item *
282
283$url->address and $url->encoded822addr: same as $uri->to for mailto URI
284
285=item *
286
287$url->groupart method for news URI
288
289=item *
290
291$url->article: same as $uri->message
292
293=back
294
295
296
297=head1 SEE ALSO
298
299L<URI>, L<URI::WithBase>
300
301=head1 COPYRIGHT
302
303Copyright 1998-2000 Gisle Aas.
304
305=cut
306