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