Updates URL.pm file
Tim Bunce (Tim.Bunce@ig.co.uk)
Fri, 17 Mar 1995 20:19:13 +0000
----------
X-Sun-Data-Type: text
X-Sun-Data-Description: text
X-Sun-Data-Name: text
X-Sun-Content-Lines: 27
This is a major reworking with input from Martijn.
It seems that Martijn and I overlapped in some of our changes but it
turned out to be valuable anyway (Martijn and implemented a much better
Absolute URL test harness than mine for example).
Now, on to politics (small p :-)... In the pod text I've said:
=head1 WHAT A URL IS NOT
URL objects do not, and in my opinion (Tim Bunce) should not, know how
to 'get' or 'put' the resources they specify locations for, anymore
than a postal address 'knows' anything about the postal system. The
actual access/transfer should be achieved by some form of transport
agent class. The agent class should not be a subclass of URL.
I hope that's agreeable to the majority.
I'd really like to see the outstanding URL module issues resolved soon
because it's a critical module. Many other modules will want to be
passing url objects around. Even just defining/agreeing a subset of
it's functionality and interfaces would be a big step forward.
Regards,
Tim.
----------
X-Sun-Data-Type: default-app
X-Sun-Data-Name: URL.pm
X-Sun-Content-Lines: 856
#!/usr/local/bin/perl -w
package URL;
$rcsid = '$Id: URL.pm,v 1.6 1995/03/17 20:10:34 timbo Exp timbo $';
$rcsid = $rcsid;
######################################################################
=head1 NAME
URL - Uniform Resource Locators (absolute and relative)
=head1 SYNOPSIS
use URL;
# Constructors
$url1 = new URL 'http://www.nr.no/gisle.gif';
$url2 = new URL 'gisle.gif';
$url2->base('http://www.nr.no/');
$url3 = $url2->abs; # get absolute url using base
$url4 = $url2->abs('http://a.n.other.com/');
$url5 = $url4->clone;
$pwd = URL::localpath();
$dir = URL::localpath('/tmp');
$file = URL::localpath('/etc/motd');
# Printing
$urlstr = $url->str;
# Retrieving and storing common elements
$scheme = $url->scheme;
$host = $url->host;
$port = $url->port; # returns default if not defined
$path = $url->path;
$query = $url->query;
$frag = $url->frag;
$url->scheme('http');
$url->host('www.w3.org');
$url->port('80');
$url->path('/welcome.html');
$url->query('protocol info');
$url->frag('intro');
$value = $url->elem($name [, $new_value ]);
$defport= $url->default_port; # default port for scheme
# Escaping functions
$escaped = URL::escape($url);
$url = URL::unescape($escaped);
=head1 DESCRIPTION
URL objects represent URLs (RFC 1738). Both absolute and relative
URL's are supported.
URL objects are created by C<new>, which takes a string representation of
a URL or an existing URL object reference to be cloned. Specific
individual elements can then be accessed via the C<scheme>, C<host>,
C<port>, C<path>, C<query> and C<frag> methods. These methods can be
called with a value to set the element to that value, and always return
the old value. The C<elem> method provides a general interface to
access any element by name but it should be used with caution.
The C<abs> function attempts to return a new absolute URL object for
a given URL. In order to convert a relative URL into an absolute one a
I<base> URL is required. You can associate a default base with a URL
either by passing a C<base> to the C<new> method when a URL is created
or using the C<base> method on the object later. Alternatively you can
specify a once-off base as a parameter to the C<abs> method.
The C<new> method must be able to determine the scheme for the URL.
If a scheme is not specified in the URL it will use the scheme
specified by the parent URL. If no parent URL scheme is defined
then the C<new> will fail (die).
=head1 WHAT A URL IS NOT
URL objects do not, and in my opinion (Tim Bunce) should not, know how
to 'get' or 'put' the resources they specify locations for, anymore
than a postal address 'knows' anything about the postal system. The
actual access/transfer should be achieved by some form of transport
agent class. The agent class should not be a subclass of URL.
=head1 OUTSTANDING ISSUES
Class naming. Inheritance (use and abuse).
How to maintain consistency between netlock and user/host/port etc.
Should URL be stored in encoded or decoded format and related issues.
=head1 AUTHOR/ACKNOWLEDGMENTS
This module is based on the C<wwwurl.pl> code in the libwww-perl
distribution developed by Roy Fielding <fielding@ics.uci.edu>, as
part of the Arcadia project at the University of California, Irvine,
with contributions from Brooks Cutter.
Gisle Aas <aas@nr.no>, Tim Bunce <Tim.Bunce@ig.co.uk>, and Martijn
Koster <m.koster@nexor.co.uk> have contributed to the original Perl 5
version.
Tim Bunce switched the code to blessed hash refs and internal classes
for each scheme with optional support for new schemes to be loaded
dynamically. The test code was expanded and automated by both Tim
(parsing) and Martijn Koster (abs_test). Both Martijn and Tim
implemented relative URL support.
If you have any suggestions, bug reports, fixes, or enhancements,
send them to the libwww-perl mailing list at
<libwww-perl@ics.uci.edu>.
=head1 BUGS
None known
Running the module standalone will execute a self test.
=cut
######################################################################
# Perl resumes here
use Carp;
use Cwd;
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(escape unescape);
$Debug = 0;
my %KnownSchemes; # schemes we have initialised
use strict qw(subs refs);
######################################################################
# methods/functions
# new() -- Object's constructor
#
sub new
{
my($class, $init, $base) = @_;
$base = new URL $base if ($base and !ref $base);
my $this;
if (ref $init) {
$this = $init->clone;
} else {
$init =~ s/^\s+//; # remove leading space
$init =~ s/\s.*//; # remove anything after first word
# We need a scheme to determine which class to use
my($scheme) = $init =~ m/^([.+\-\w]+):/;
$scheme = $base->scheme if (!$scheme and $base);
croak "Unable to determine scheme for '$init'" unless $scheme;
$scheme = _check_scheme($scheme); # dies on failure (eg unsupportable)
# then hand-off to scheme specific sub-class
$this = "URL::$scheme"->new($init, $base);
}
$this->base($base) if $base;
return $this;
}
sub clone
{
my $self = shift;
bless { %$self }, ref $self;
}
# localpath() -- return a URL object that denotes a path on the
# local filesystem (current directory by default).
#
sub localpath
{
my($path) = @_;
($path = fastcwd()) =~ s:/?$:/: unless defined $path;
new URL "file://localhost$path";
}
sub dump
{
my $self = shift;
my($k, $v);
print "Dump of $self...\n";
foreach $k (sort keys %$self){
$v = $self->{$k};
$v = 'UNDEF' unless defined $v;
print " $k\t'$v'\n";
}
}
sub _check_scheme
{
my $scheme = lc(shift); # ensure lowercase and then validate
no strict qw(refs);
return $scheme if exists $KnownSchemes{$scheme}; # already setup
# force attempt to load support for unknown scheme, die on failure
unless (defined @{"URL::${scheme}::ISA"}){
require "URL/${scheme}.pm"
} else {
# silently require anyway so external files can update our code
eval { local($^W)=0; require "URL/${scheme}.pm" };
}
# setup overloading - experimental (needs cmp etc)
%{"URL::${scheme}::OVERLOAD"} = ( '""' => 'str' );
$KnownSchemes{$scheme} = 1;
$scheme;
}
# These methods always return the current value,
# so you can use $url->scheme to read the current value.
# If a new value is passed, e.g. $url->scheme('http'),
# it also sets the new value, and returns the previous value.
# Use $url->scheme(undef) to set the value to undefined.
sub base { shift->elem('_base', @_); }
# Generic-RL fields
sub scheme { shift->elem('scheme', @_); }
sub netloc { shift->elem('netloc', @_); }
sub path { shift->elem('path', @_); }
sub params { shift->elem('params', @_); }
sub query { shift->elem('query', @_); }
sub frag { shift->elem('frag', @_); }
# Fields derived from generic netloc
sub host { shift->elem('host', @_); }
sub port { shift->elem('port', @_); }
sub user { shift->elem('user', @_); }
sub password { shift->elem('password',@_); }
sub elem {
my($this, $element, @val) = @_;
my $old = $this->{$element};
$this->{$element} = $val[0] if @val;
return $old;
}
# unescape()
#
# 'http://web/this%20has%20spaces' -> 'http://web/this has spaces'
#
sub unescape
{
local($_) = @_;
$_ = $_->str if ref($_); # unescape doubles as a method
s/%([\dA-Fa-f][\dA-Fa-f])/pack("C",hex($1))/eg;
$_;
}
# escape()
#
# 'http://web/this has spaces' -> 'http://web/this%20has%20spaces'
#
sub escape # not a method
{
local($_) = @_;
s/([\x00-\x20"#%;<>?\x7F-\xFF])/sprintf("%%%02x",ord($1))/eg;
$_;
}
######################################################################
#
# Internal pre-defined basic scheme support
#
# In this implementation all schemes are subclassed from URL::generic.
# This turns out to have reasonable mileage.
# See also draft-ietf-uri-relative-url-05.txt
package URL::generic; # base support for generic-RL's
use Carp;
@ISA = qw(URL);
sub new { # inherited constructor
my($class, $init, $base) = @_;
my $u = $class->_parse($init);
URL::dump($u) if $URL::Debug;
bless $u, $class;
}
# Generic-RL parser
# See draft-ietf-uri-relative-url-05.txt Section 2
sub _parse {
my($self, $u) = @_;
my %u; # Following draft-ietf-uri-relative-url-05.txt Section 2.4
$u{url} = $u; # keep copy of original
$u{frag} = $1 if ($u =~ s/#(.*)$//); # 2.4.1
$u{scheme}=lc($1) if ($u =~ s/^\s*([\w\+\.\-]+)://); # 2.4.2
$u{netloc} = $1 if ($u =~ s!^//([^/]*)!!); # 2.4.3
$u{query} = $1 if ($u =~ s/\?(.*)//); # 2.4.4
$u{params} = $1 if ($u =~ s/;(.*)//); # 2.4.5
$u{path} = $u; # 2.4.6
# read netloc fields: "<user>:<password>@<host>:<port>"
_read_netloc(\%u);
\%u;
}
sub _read_netloc { # netloc -> user, password, host, post
my($self) = @_;
my $nl = $self->{netloc} || '';
$self->{user} = $1 if $nl =~ s/^([^:@]*):?([^@]*)?@//;
$self->{password} = $2 if $2;
$self->{host} = $1 if $nl =~ s/^([^:]*):?(\d*)?//;
$self->{port} = $2 if $2;
}
sub _write_netloc {
my($self) = @_;
my $nl = $self->{user} || '';
$nl .= ":$self->{password}" if $nl and $self->{password};
$nl .= "@$self->{host}";
$nl .= ":$self->{port}" if $self->{host};
$self->{netloc} = $nl;
}
# Generic-RL stringify
#
sub str
{
my $self = shift;
my($scheme, $address, $port) = @{$self}{qw(scheme host port)};
my $path = $self->full_path; # path+query+params+frag
if ($address){
$address .= ":$port" if ($port && $port != $self->default_port);
$path = "/$path" unless $path =~ m:^/:;
$path = "//$address$path";
}
my $urlstr = ($scheme) ? "$scheme:$path" : $path;
return $urlstr;
}
# Generic-RL stringify for "rel_path" (path+query+params+frag)
#
sub full_path
{
my($path, $params, $query, $frag)
= @{$_[0]}{qw(path params query frag) };
my $urlstr = ''; # does not include a slash
$urlstr .= $path if $path; # = fsegment *( "/" segment )
$urlstr .= ";$params" if $params; # = param *( ";" param )
$urlstr .= "?$query" if $query; # = *( uchar | reserved )
$urlstr .= "#$frag" if $frag; # = *( uchar | reserved )
return $urlstr;
}
# Generic-RL: Resolving Relative URL into an Absolute URL
#
# Based on draft-ietf-uri-relative-url-05.txt Section 4
#
sub abs
{
my($this, $base) = @_;
my $tmp;
my $embed = $this->clone;
$base = $this->base unless $base; # default to default base
return $embed unless $base; # we have no base (step1)
$base = new URL $base unless ref $base; # convert to obj if required
my @u = @{$embed}{qw(scheme host port path params query frag) };
my $empty = scalar(grep($_, @u)) == 0;
# just use base if we are empty (2a)
return $base->clone if $empty;
my($scheme, $host, $port, $path, $params, $query, $frag) = @u;
# if we have a scheme we must already be absolute (2b)
return $embed if $scheme;
$embed->{scheme} = $base->{scheme}; # (2c)
return $embed if $embed->{netloc}; # (3)
$embed->{netloc} = $base->{netloc}; # (3)
$embed->_read_netloc;
return $embed if $embed->{path} =~ m:^/:; # (4)
unless ($embed->{path}){ # (5)
$embed->{path} = $base->{path}; # (5)
return $embed if $embed->params; # (5a)
$embed->{params} = $base->{params}; # (5a)
return $embed if $embed->query; # (5b)
$embed->{query} = $base->{query}; # (5b)
return $embed;
}
my $path = $base->{path};
my $ep = $embed->{path};
$ep =~ s!^/!!; # XXX should this be?
if ($path !~ s!(.*)/.*$!$1/$ep!) {
$path = $ep;
}
$path =~ s!^\./!/!g; # a
$path =~ s!/\./!/!g;
$path =~ s!^\.$!/!; # b
$path =~ s!/\.$!/!;
while($path =~ s![^/]+/\.\./!!) { # c
;
}
$path =~ s![^/]+/\.\.$!!; # d
$embed->{path} = $path;
return $embed;
}
sub default_port {
undef
}
####################################################################
#
# Internal pre-defined basic scheme support
# Define the default ports for major net services
# From RFC 1738 "Uniform Resource Locators (URL)"
# Note that other Well Known Port Numbers are defined in
# the "Assigned Numbers" RFC (1700).
# XXX the rfc1700 ones should arguably use getservbyname
# or be in a Etc/Services.pm or something
package URL::file; @ISA = qw(URL::generic);
package URL::ftp; @ISA = qw(URL::generic);
sub default_port { 21 };
package URL::telnet; @ISA = qw(URL::generic);
sub default_port { 23 };
package URL::whois; @ISA = qw(URL::generic);
sub default_port { 43 };
package URL::gopher; @ISA = qw(URL::generic);
sub default_port { 70 };
sub gtype { shift->elem('gtype', @_); }
sub _parse {
my($self, $url) = @_;
my %u;
$u{scheme} = lc($1) if ($url =~ s/^\s*([\w\+\.\-]+)://);
$u{netloc} = $1 if $url =~ s!^//([^/]*)!!;
$u{'gtype'} = $1 if $url =~ s!^/(.)!!;
@u{qw(selector search string)} = split(/%09/, $url, 3);
\%u;
}
package URL::finger; @ISA = qw(URL::generic);
sub default_port { 79 };
package URL::http; @ISA = qw(URL::generic);
sub default_port { 80 };
package URL::nntp; @ISA = qw(URL::generic);
sub default_port { 119 };
sub _parse {
my($self, $init) = @_;
my $u = $self->URL::generic::_parse($init);
($u->{group}, $u->{digits}) = (split('/', $u->{path}))[1,2];
$u;
}
package URL::news; @ISA = qw(URL::generic);
sub _parse {
my($self, $url) = @_;
my %u;
$u{scheme} = lc($1) if ($url =~ s/^\s*([\w\+\.\-]+)://);
$u{grouppart} = $url;
$u{ ($url =~ m/\@/) ? 'article' : 'group' } = $url;
\%u;
}
package URL::wais; @ISA = qw(URL::generic);
sub default_port { 210 };
sub _parse {
my($self, $url) = @_;
my $u = $self->URL::generic::_parse($url);
@{$u}{qw(database wtype wpath)}
= (split(/\//, $u->{path}))[1,2,3];
$u;
}
package URL::webster; @ISA = qw(URL::generic);
sub default_port { 765 };
package URL::prospero; @ISA = qw(URL::generic);
sub default_port { 1525 }; # says rfc1738, section 3.11
package URL::mailto; @ISA = qw(URL::generic);
sub _parse {
my($self, $url) = @_;
my %u;
$u{scheme} = lc($1) if ($url =~ s/^\s*([\w\+\.\-]+)://);
$u{encoded822addr} = $url;
\%u;
}
package URL::rlogin; @ISA = qw(URL::generic);
package URL::tn3270; @ISA = qw(URL::generic);
package URL::g; @ISA = qw(URL::generic); # just for the tests
######################################################################
#
# If we're not use'd or require'd execute self-test.
# Handy for regression testing and as a quick reference :)
eval join('',<main::DATA>) || die $@ unless caller();
1;
__END__
package main;
use Carp;
import URL qw(escape unescape);
# Dies if an error has been detected.
# prints "ok" otherwise.
$| = 1;
$txt = '';
$err = "URL self test failed";
$errors = 0;
print "URL self test...\n";
sub fail {
warn @_,"\n";
++$errors;
}
abs_test(); exit 1;
# test retrieval methods
$tests = {
'hTTp://web1.net/a/b/c/welcome#intro'
=> { scheme => 'http', host=>'web1.net', port=>undef,
path=>'/a/b/c/welcome', frag=>'intro', query=>undef },
'http://web:1/a?query+text'
=> { scheme => 'http', host=>'web', port=>1,
path=>'/a', frag=>undef, query=>'query+text' },
'http://web.net'
=> { scheme => 'http', host=>'web.net', port=>undef,
path=>'', frag=>undef, query=>undef, user=>undef },
'ftp://usr:pswd@web:1234/a/b;type=i'
=> { host=>'web', port=>1234, path=>'/a/b',
user=>'usr', password=>'pswd', params=>'type=i' },
'gopher://web/2a_selector'
=> { gtype=>'2', selector=>'a_selector' },
'mailto:libwww-perl@ics.uci.edu'
=> { encoded822addr=>'libwww-perl@ics.uci.edu' },
'news:*' => { grouppart=>'*' },
'news:comp.lang.perl' => { group=>'comp.lang.perl' },
'news:perl-faq/module-list-1-794455075@ig.co.uk'
=> { article=>'perl-faq/module-list-1-794455075@ig.co.uk' },
'nntp://news.com/comp.lang.perl/42'
=> { group=>'comp.lang.perl', digits=>42 },
'telnet://usr:pswd@web:12345/'
=> { user=>'usr', password=>'pswd' },
'wais://web.net/db' => { database=>'db' },
'wais://web.net/db?query' => { database=>'db', query=>'query' },
'wais://usr:pswd@web.net/db/wt/wp'
=> { database=>'db', wtype=>'wt', wpath=>'wp', password=>'pswd' },
};
foreach $url_str (sort keys %$tests ){
warn "Testing '$url_str'\n";
my($url) = new URL $url_str;
$url_tests = $tests->{$url_str};
while( ($method, $exp) = each %$url_tests ){
my $res = $url->elem($method);
next if !defined($res) and !defined($exp);
$exp = 'UNDEF' unless defined $exp;
$res = 'UNDEF' unless defined $res;
if ($res eq $exp){
warn " $method ok (got '$res')\n" if $URL::Debug;
} else {
fail " $method FAILED: expected '$exp' got '$res'\n";
}
}
}
# test storage methods
$url = new URL 'http://web/';
$url->scheme('gopher');
$url->host('gop');
$url->port(71);
$url->path('1info');
$url->frag('this');
$url->query('key+word');
$txt = $url->str;
fail "'$txt' != 'gopher://gop:71/1info?key+word#this'"
unless $txt eq 'gopher://gop:71/1info?key+word#this';
$url->query(undef);
fail "set-to-undef failed" if defined($url->query);
# Test base url and relative->absolute conversions
$base = new URL "http://base.com:25";
$relu = new URL "hello.gif", $base;
# escaping functions
$url = new URL escape('http://web/this has spaces');
$txt = $url->str;
fail "'$txt' != 'http://web/this%20has%20spaces'"
unless $txt eq 'http://web/this%20has%20spaces';
$txt = unescape($url);
fail $err unless $txt eq 'http://web/this has spaces';
$txt = unescape(new URL 'http://web/this%20has%20space');
fail $err, $txt unless $txt eq 'http://web/this has space';
# test localpath
chdir('/tmp') or die $!;
$url = URL::localpath();
fail $err unless $url->str eq 'file://localhost/tmp/';
chdir('/') or die $!;
$url = URL::localpath('/tmp/');
fail $err unless $url->str eq 'file://localhost/tmp/';
die "$errors errors\n" if $errors;
print "URL self test ok ($URL::rcsid)\n";
sub abs_test {
# Tests from draft-ietf-uri-relative-url-05.txt
my $base = 'http://a/b/c/d;p?q#f';
# copied verbatim from the draft, parsed below
$absolute_tests = <<EOM;
5.1. Normal Examples
g:h = <URL:g:h>
g = <URL:http://a/b/c/g>
./g = <URL:http://a/b/c/g>
g/ = <URL:http://a/b/c/g/>
/g = <URL:http://a/g>
//g = <URL:http://g>
?y = <URL:http://a/b/c/d;p?y>
g?y = <URL:http://a/b/c/g?y>
g?y/./x = <URL:http://a/b/c/g?y/./x>
#s = <URL:http://a/b/c/d;p?q#s>
g#s = <URL:http://a/b/c/g#s>
g#s/./x = <URL:http://a/b/c/g#s/./x>
g?y#s = <URL:http://a/b/c/g?y#s>
;x = <URL:http://a/b/c/d;x>
g;x = <URL:http://a/b/c/g;x>
g;x?y#s = <URL:http://a/b/c/g;x?y#s>
. = <URL:http://a/b/c/>
./ = <URL:http://a/b/c/>
.. = <URL:http://a/b/>
../ = <URL:http://a/b/>
../g = <URL:http://a/b/g>
../.. = <URL:http://a/>
../../ = <URL:http://a/>
../../g = <URL:http://a/g>
5.2. Abnormal Examples
<> = <URL:http://a/b/c/d;p?q#f>
../../../g = <URL:http://a/../g>
/./g = <URL:http://a/./g>
/../g = <URL:http://a/../g>
g. = <URL:http://a/b/c/g.>
.g = <URL:http://a/b/c/.g>
g.. = <URL:http://a/b/c/g..>
..g = <URL:http://a/b/c/..g>
./../g = <URL:http://a/b/g>
./g/. = <URL:http://a/b/c/g/>
g/./h = <URL:http://a/b/c/g/h>
g/../h = <URL:http://a/b/c/h>
http:g = <URL:http:g>
http: = <URL:http:>
EOM
# convert text to list like
# @absolute_tests = ( ['g:h' => 'g:h'], ...)
for $line (split("\n", $absolute_tests)) {
next unless $line =~ /^\s/;
if ($line =~ /^\s+(\S+)\s*=\s*<URL:([^>]*)>/) {
my($rel, $abs) = ($1, $2);
$rel = '' if $rel eq '<>';
push(@absolute_tests, [$rel, $abs]);
}
else {
warn "illegal line '$line'";
}
}
for $test (@absolute_tests) {
my $rel = $test->[0];
my $abs = $test->[1];
printf(" %-10s + $base => $abs\n", $rel);
my $u = URL->new($rel, $base);
my $got = $u->abs;
my $abs = new URL $abs;
if ("$got" ne "$abs"){
warn "'$rel' '$base' -> '$got' expected '$abs'\n\n";
$u->dump;
$got->dump;
die "--- failed.\n";
}
}
print "absolute test ok\n";
print "$URL::rcsid ok\n";
}
# listeq()
#
# compare two lists with strings
# XXX is there no better way?
# used only in test()
#
sub listeq {
my($a, $b) = @_;
my $len = scalar(@{$a});
return 0 unless ($len == scalar(@{$b})); # check length
my $i;
for($i = 0; $i < $len; $i++) {
$a->[$i] = '' unless defined $a->[$i];
$b->[$i] = '' unless defined $b->[$i];
return 0 unless defined $a->[$i] and defined $b->[$i] and
$a->[$i] eq $b->[$i];
}
return 1;
}
1;
exit 0;