local-lib5/lib/perl5/URI/WithBase.pm

   1 package URI::WithBase;
   2
   3 use strict;
   4 use vars qw($AUTOLOAD $VERSION);
   5 use URI;
   6
   7 $VERSION = "2.19";
   8
   9 use overload '""' => "as_string", fallback => 1;
  10
  11 sub as_string;  # help overload find it
  12
  13 sub new
  14 {
  15     my($class, $uri, $base) = @_;
  16     my $ibase = $base;
  17     if ($base && ref($base) && UNIVERSAL::isa($base, __PACKAGE__)) {
  18         $base = $base->abs;
  19         $ibase = $base->[0];
  20     }
  21     bless [URI->new($uri, $ibase), $base], $class;
  22 }
  23
  24 sub new_abs
  25 {
  26     my $class = shift;
  27     my $self = $class->new(@_);
  28     $self->abs;
  29 }
  30
  31 sub _init
  32 {
  33     my $class = shift;
  34     my($str, $scheme) = @_;
  35     bless [URI->new($str, $scheme), undef], $class;
  36 }
  37
  38 sub eq
  39 {
  40     my($self, $other) = @_;
  41     $other = $other->[0] if UNIVERSAL::isa($other, __PACKAGE__);
  42     $self->[0]->eq($other);
  43 }
  44
  45 sub AUTOLOAD
  46 {
  47     my $self = shift;
  48     my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
  49     return if $method eq "DESTROY";
  50     $self->[0]->$method(@_);
  51 }
  52
  53 sub can {                                  # override UNIVERSAL::can
  54     my $self = shift;
  55     $self->SUPER::can(@_) || (
  56       ref($self)
  57       ? $self->[0]->can(@_)
  58       : undef
  59     )
  60 }
  61
  62 sub base {
  63     my $self = shift;
  64     my $base  = $self->[1];
  65
  66     if (@_) { # set
  67         my $new_base = shift;
  68         # ensure absoluteness
  69         $new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__);
  70         $self->[1] = $new_base;
  71     }
  72     return unless defined wantarray;
  73
  74     # The base attribute supports 'lazy' conversion from URL strings
  75     # to URL objects. Strings may be stored but when a string is
  76     # fetched it will automatically be converted to a URL object.
  77     # The main benefit is to make it much cheaper to say:
  78     #   URI::WithBase->new($random_url_string, 'http:')
  79     if (defined($base) && !ref($base)) {
  80         $base = ref($self)->new($base);
  81         $self->[1] = $base unless @_;
  82     }
  83     $base;
  84 }
  85
  86 sub clone
  87 {
  88     my $self = shift;
  89     my $base = $self->[1];
  90     $base = $base->clone if ref($base);
  91     bless [$self->[0]->clone, $base], ref($self);
  92 }
  93
  94 sub abs
  95 {
  96     my $self = shift;
  97     my $base = shift || $self->base || return $self->clone;
  98     $base = $base->as_string if ref($base);
  99     bless [$self->[0]->abs($base, @_), $base], ref($self);
 100 }
 101
 102 sub rel
 103 {
 104     my $self = shift;
 105     my $base = shift || $self->base || return $self->clone;
 106     $base = $base->as_string if ref($base);
 107     bless [$self->[0]->rel($base, @_), $base], ref($self);
 108 }
 109
 110 1;
 111
 112 __END__
 113
 114 =head1 NAME
 115
 116 URI::WithBase - URIs which remember their base
 117
 118 =head1 SYNOPSIS
 119
 120  $u1 = URI::WithBase->new($str, $base);
 121  $u2 = $u1->abs;
 122
 123  $base = $u1->base;
 124  $u1->base( $new_base )
 125
 126 =head1 DESCRIPTION
 127
 128 This module provides the C<URI::WithBase> class.  Objects of this class
 129 are like C<URI> objects, but can keep their base too.  The base
 130 represents the context where this URI was found and can be used to
 131 absolutize or relativize the URI.  All the methods described in L<URI>
 132 are supported for C<URI::WithBase> objects.
 133
 134 The methods provided in addition to or modified from those of C<URI> are:
 135
 136 =over 4
 137
 138 =item $uri = URI::WithBase->new($str, [$base])
 139
 140 The constructor takes an optional base URI as the second argument.
 141 If provided, this argument initializes the base attribute.
 142
 143 =item $uri->base( [$new_base] )
 144
 145 Can be used to get or set the value of the base attribute.
 146 The return value, which is the old value, is a URI object or C<undef>.
 147
 148 =item $uri->abs( [$base_uri] )
 149
 150 The $base_uri argument is now made optional as the object carries its
 151 base with it.  A new object is returned even if $uri is already
 152 absolute (while plain URI objects simply return themselves in
 153 that case).
 154
 155 =item $uri->rel( [$base_uri] )
 156
 157 The $base_uri argument is now made optional as the object carries its
 158 base with it.  A new object is always returned.
 159
 160 =back
 161
 162
 163 =head1 SEE ALSO
 164
 165 L<URI>
 166
 167 =head1 COPYRIGHT
 168
 169 Copyright 1998-2002 Gisle Aas.
 170
 171 =cut