home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / URI / URL.pm < prev    next >
Text File  |  2006-11-29  |  6KB  |  306 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.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
  306.