vcs.maemo.org Git - pkg-perl/blob - deb-src/liburi-perl/liburi-perl-1.35.dfsg.1/URI/URL.pm

   1 package URI::URL;
   2
   3 require URI::WithBase;
   4 @ISA=qw(URI::WithBase);
   5
   6 use strict;
   7 use 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
  14 require Exporter;
  15 *import = \&Exporter::import;
  16 @EXPORT = qw(url);
  17
  18 # Easy to use constructor
  19 sub url ($;$) { URI::URL->new(@_); }
  20
  21 use URI::Escape qw(uri_unescape);
  22
  23 sub new
  24 {
  25     my $class = shift;
  26     my $self = $class->SUPER::new(@_);
  27     $self->[0] = $self->[0]->canonical;
  28     $self;
  29 }
  30
  31 sub 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
  47 sub strict
  48 {
  49     my $old = $URI::URL::STRICT;
  50     $URI::URL::STRICT = shift if @_;
  51     $old;
  52 }
  53
  54 sub print_on
  55 {
  56     my $self = shift;
  57     require Data::Dumper;
  58     print STDERR Data::Dumper::Dumper($self);
  59 }
  60
  61 sub _try
  62 {
  63     my $self = shift;
  64     my $method = shift;
  65     scalar(eval { $self->$method(@_) });
  66 }
  67
  68 sub 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
  84 sub full_path
  85 {
  86     my $self = shift;
  87     my $path = $self->path_query;
  88     $path = "/" unless length $path;
  89     $path;
  90 }
  91
  92 sub netloc
  93 {
  94     shift->authority(@_);
  95 }
  96
  97 sub epath
  98 {
  99     my $path = shift->SUPER::path(@_);
 100     $path =~ s/;.*//;
 101     $path;
 102 }
 103
 104 sub 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
 114 sub params { shift->eparams(@_); }
 115
 116 sub 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
 127 sub path_components {
 128     shift->path_segments(@_);
 129 }
 130
 131 sub 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
 155 sub 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
 167 sub frag { shift->fragment(@_); }
 168 sub keywords { shift->query_keywords(@_); }
 169
 170 # file:
 171 sub local_path { shift->file; }
 172 sub unix_path  { shift->file("unix"); }
 173 sub dos_path   { shift->file("dos");  }
 174 sub mac_path   { shift->file("mac");  }
 175 sub vms_path   { shift->file("vms");  }
 176
 177 # mailto:
 178 sub address { shift->to(@_); }
 179 sub encoded822addr { shift->to(@_); }
 180 sub URI::mailto::authority { shift->to(@_); }  # make 'netloc' method work
 181
 182 # news:
 183 sub groupart { shift->_group(@_); }
 184 sub article  { shift->message(@_); }
 185
 186 1;
 187
 188 __END__
 189
 190 =head1 NAME
 191
 192 URI::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
 201 This module is provided for backwards compatibility with modules that
 202 depend on the interface provided by the C<URI::URL> class that used to
 203 be distributed with the libwww-perl library.
 204
 205 The following differences exist compared to the C<URI> class interface:
 206
 207 =over 3
 208
 209 =item *
 210
 211 The URI::URL module exports the url() function as an alternate
 212 constructor interface.
 213
 214 =item *
 215
 216 The constructor takes an optional $base argument.  The C<URI::URL>
 217 class is a subclass of C<URI::WithBase>.
 218
 219 =item *
 220
 221 The URI::URL->newlocal class method is the same as URI::file->new_abs.
 222
 223 =item *
 224
 225 URI::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
 254 consider 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
 267 L<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
 299 L<URI>, L<URI::WithBase>
 300
 301 =head1 COPYRIGHT
 302
 303 Copyright 1998-2000 Gisle Aas.
 304
 305 =cut