home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _9963e5f4763cc13d6889271191f0e34f < prev    next >
Text File  |  2000-03-15  |  6KB  |  305 lines
  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.02";
  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 compared to the C<URI> class interface exist:
  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.  See L<URI::WithBase>.
  217.  
  218. =item *
  219.  
  220. The URI::URL->newlocal class method is the same as URI::file->new_abs
  221.  
  222. =item *
  223.  
  224. URI::URL::strict(1)
  225.  
  226. =item *
  227.  
  228. $url->print_on method
  229.  
  230. =item *
  231.  
  232. $url->crack method
  233.  
  234. =item *
  235.  
  236. $url->full_path; same as ($uri->abs_path || "/")
  237.  
  238. =item *
  239.  
  240. $url->netloc; same as $uri->authority
  241.  
  242. =item *
  243.  
  244. $url->epath, $url->equery; same as $uri->path, $uri->query
  245.  
  246. =item *
  247.  
  248. $url->path and $url->query pass unescaped strings.
  249.  
  250. =item *
  251.  
  252. $url->path_components; same as $uri->path_segments (if you don't
  253. consider path segment parameters).
  254.  
  255. =item *
  256.  
  257. $url->params and $url->eparams methods.
  258.  
  259. =item *
  260.  
  261. $url->base method.  See L<URI::WithBase>.
  262.  
  263. =item *
  264.  
  265. $url->abs and $url->rel have an optional $base argument.  See
  266. L<URI::WithBase>.
  267.  
  268. =item *
  269.  
  270. $url->frag; same as $uri->fragment
  271.  
  272. =item *
  273.  
  274. $url->keywords; same as $uri->query_keywords;
  275.  
  276. =item *
  277.  
  278. $url->localpath with friends map to $uri->file
  279.  
  280. =item *
  281.  
  282. $url->address and $url->encoded822addr; same as $uri->to for mailto URI.
  283.  
  284. =item *
  285.  
  286. $url->groupart method for news URI.
  287.  
  288. =item *
  289.  
  290. $url->article; same as $uri->message
  291.  
  292. =back
  293.  
  294.  
  295.  
  296. =head1 SEE ALSO
  297.  
  298. L<URI>, L<URI::WithBase>
  299.  
  300. =head1 COPYRIGHT
  301.  
  302. Copyright 1998-1999 Gisle Aas.
  303.  
  304. =cut
  305.