package Badger::URL;
use Badger::Class
version => 0.02,
debug => 0,
base => 'Badger::Base',
import => 'CLASS class',
utils => 'textlike is_object',
codec => 'uri', # we use URI encoding for parameters
as_text => \&text,
is_true => 1, # not sure about this
constants => 'HASH BLANK',
constant => {
SLASH => '/',
TEXT => 0,
SCHEME => 1,
AUTHORITY => 2,
USER => 3,
HOST => 4,
PORT => 5,
PATH => 6,
QUERY => 7,
FRAGMENT => 8,
PARAMS => 9,
},
alias => {
url => \&text,
},
exports => {
any => 'URL',
};
#------------------------------------------------------------------------
# Example URL:
#
# scheme authority path query fragment
# __ ___________________ _________ _________ __
# / \ / \/ \ / \ / \
# http://user@example.com:8042/over/there?name=ferret#nose
# \__/ \_________/ \__/
# user host port
#
#------------------------------------------------------------------------
our @ELEMENTS = qw(
scheme authority user host port path query fragment params
);
our $N_ELEMS = 1; # slot 0 holds source text, so slot 1 is first field
our $ELEMENT = {
map { $_ => $N_ELEMS++ }
@ELEMENTS
};
# regexen to match basic tokens
our $MATCH_SCHEME = qr{ ( [a-zA-Z][a-zA-Z0-9.+\-]* ) : }x;
our $MATCH_USER = qr{ ([^@]*) @ }x;
our $MATCH_HOST = qr{ ( [^:\/]* ) }x;
our $MATCH_PORT = qr{ : (\d*) }x;
our $MATCH_PATH = qr{ ( [^ \? \#]* ) }x;
our $MATCH_QUERY = qr{ \? ( [^ \#]* ) }x;
our $MATCH_FRAGMENT = qr{ \# ( .* ) }x;
# compound regexen to match authority
our $MATCH_AUTHORITY = qr{
// ( # $1 - authority
(?: $MATCH_USER )? # $2 - user
$MATCH_HOST # $3 - host
(?: $MATCH_PORT )? # $4 - port
)
}x;
# compound regexen to match complete URL
our $MATCH_URL = qr{
^ (?: $MATCH_SCHEME )? # $1 - scheme
(?: $MATCH_AUTHORITY )? # $2,$3,$4,$5 - authority,user,host,port
$MATCH_PATH # $6 - path
(?: $MATCH_QUERY )? # $7 - query
(?: $MATCH_FRAGMENT )? # $8 - fragment
}x;
#------------------------------------------------------------------------
# Constructor function and methods.
#------------------------------------------------------------------------
sub URL {
return CLASS unless @_;
return @_ == 1 && is_object(CLASS, $_[0])
? $_[0]->copy # copy existing URL object
: CLASS->new(@_); # or construct a new one
}
sub new {
my $class = shift;
my $args = @_ == 1 ? shift : { @_ };
my $self;
$class = ref $class || $class;
if (textlike $args) {
$self = bless [$args, $args =~ $MATCH_URL], $class;
}
elsif (ref $args eq HASH) {
$self = bless [ ], $class;
$self->set($args);
}
else {
return $class->error("Invalid URL specification: $_[0]");
}
return $self;
}
sub copy {
my $self = shift;
my $copy = bless [ @$self ], ref $self;
return @_
? $copy->set(@_)
: $copy;
}
sub set {
my $self = shift;
my $args = @_ && ref $_[0] eq HASH ? shift : { @_ };
my ($k, $v, $n);
while (($k, $v) = each %$args) {
$n = $ELEMENT->{ $k } || next;
$self->[$n] = $v;
}
# The authority is comprised of the user, host and port fields.
# We need to split any authority specified, or merge together the user,
# host and port if any of them have been changed
$self->split_authority
if exists $args->{ authority };
$self->join_authority
if exists $args->{ user }
or exists $args->{ host }
or exists $args->{ port };
# similar thing for query/params
$self->split_query
if exists $args->{ query };
$self->join_query
if exists $args->{ params };
# finally reconstruct the complete url
$self->join_url;
return $self;
}
#-----------------------------------------------------------------------
# split/join methods
#-----------------------------------------------------------------------
sub split_authority {
my $self = shift;
$self->[AUTHORITY] = BLANK
unless defined $self->[AUTHORITY];
# this regex shouldn't ever fail as everything is optional
@$self[AUTHORITY,USER,HOST,PORT]
= $self->[AUTHORITY] =~ $MATCH_AUTHORITY;
}
sub join_authority {
my $self = shift;
my ($user, $host, $port) = @$self[USER,HOST,PORT];
$user = (defined $user && length $user) ? $user . '@' : BLANK;
$port = (defined $port && length $port) ? ':' . $port : BLANK;
$host = BLANK unless defined $host;
return ($self->[AUTHORITY] = $user.$host.$port);
}
sub split_query {
my $self = shift;
$self->[QUERY] = ''
unless defined $self->[QUERY];
return ($self->[PARAMS] = {
map {
map { decode($_) }
split(/=/, $_, 2)
}
split(/[&;]/, $self->[QUERY])
});
}
sub join_query {
my $self = shift;
my $params = $self->[PARAMS] || { } ; # should we call split_query()?
return ($self->[QUERY] = join(
'&',
map { $_ . '=' . encode( $params->{ $_ } ) }
sort keys %$params # sorted makes debugging easier
));
}
sub join_url {
my $self = shift;
my $scheme = $self->[SCHEME];
my $auth = $self->[AUTHORITY];
my $query = $self->[QUERY];
my $frag = $self->[FRAGMENT];
$scheme = (defined $scheme && length $scheme) ? $scheme . ':' : BLANK;
$auth = (defined $auth && length $auth) ? '//' . $auth : BLANK;
$query = (defined $query && length $query) ? '?' . $query : BLANK;
$frag = (defined $frag && length $frag) ? '#' . $frag : BLANK;
return ($self->[TEXT] = $scheme.$auth.$self->[PATH].$query.$frag);
}
#-----------------------------------------------------------------------
# accessor/mutator methods
#-----------------------------------------------------------------------
sub text {
$_[0]->[TEXT];
}
sub scheme {
my $self = shift;
if (@_) {
$self->[SCHEME] = shift;
$self->join_url;
}
return $self->[SCHEME];
}
sub authority {
my $self = shift;
if (@_) {
$self->[AUTHORITY] = shift;
$self->split_authority;
$self->join_url;
}
return $self->[AUTHORITY];
}
sub query {
my $self = shift;
if (@_) {
$self->[QUERY] = shift;
$self->split_query;
$self->join_url;
}
return $self->[QUERY];
}
sub params {
my $self = shift;
my $params = $self->[PARAMS] || $self->split_query;
if (@_) {
my $extra = Badger::Utils::params(@_);
# NOTE: this doesn't account for multi-valued params
@$params{ keys %$extra } = values %$extra;
$self->join_query;
$self->join_url;
}
return $params;
}
sub server {
my $self = shift;
my $scheme = $self->[SCHEME];
my $auth = $self->[AUTHORITY];
$scheme = (defined $scheme && length $scheme) ? $scheme.':' : BLANK;
$auth = (defined $auth && length $auth) ? '//'.$auth : BLANK;
return $scheme.$auth;
}
sub service {
my $self = shift;
return $self->server
. $self->[PATH];
}
sub request {
my $self = shift;
my $service = $self->service;
my $query = $self->[QUERY];
$query = (defined $query && length $query) ? '?'.$query : BLANK;
return $self->service
. $query;
}
# This is a quick-hack implementation of relative() that bodges the paths.
# This should be replaced with a more robust implementation. It also needs
# to be integrated with the work on Badger::Filesystem::Universal.
sub relative {
my $self = shift;
my $path = join(SLASH, @_);
my $base = $self->[PATH];
$base =~ s{/$}{};
$path = join(SLASH, $base, $path)
unless $path =~ m{^/};
return $self->copy( path => $path );
}
sub absolute {
my $self = shift;
my $path = shift;
$path =~ s{^/*}{/};
return $self->copy( path => $path );
}
sub dump {
my $self = shift;
return '[URL:' . join('|', map { defined($_) ? $_ : '' } @$self) . ']';
}
#-----------------------------------------------------------------------
# generated accessor/mutator methods for those with similar functionality
#-----------------------------------------------------------------------
class->methods(
map {
my ($name, $slot) = @$_;
$name => sub {
my $self = shift;
if (@_) {
# if any of user, host or port are updated then we must
# reconstruct the authority and complete URL
$self->[$slot] = shift;
$self->join_authority;
$self->join_url;
}
return $self->[$slot];
}
}
[user => USER],
[host => HOST],
[port => PORT],
);
class->methods(
map {
my ($name, $slot) = @$_;
$name => sub {
my $self = shift;
if (@_) {
# if either of the path or fragment are updated then we
# must regenerate the complete URL
$self->[$slot] = shift;
$self->join_url;
}
return $self->[$slot];
}
}
[path => PATH],
[fragment => FRAGMENT],
);
1;
__END__
=head1 NAME
Badger::URL - representation of a Uniform Resource Locator (URL)
=head1 SYNOPSIS
use Badger::URL;
# all-in-one URL string
my $url = Badger::URL->new(
'http://abw@badgerpower.com:8080/under/ground?animal=badger#stripe'
);
# named parameters
my $url = Badger::URL->new(
scheme => 'http',
user => 'abw',
host => 'badgerpower.com',
port => '8080',
path => '/under/ground',
query => 'animal=badger',
fragment => 'stripe',
);
# methods to access standard W3C parts of URL
print $url->scheme; # http
print $url->authority; # abw@badgerpower.com:8080
print $url->user; # abw
print $url->host; # badgerpower.com
print $url->port; # 8080
print $url->path; # /under/ground
print $url->query; # animal=badger
print $uri->fragment; # stripe
# additional composite methods:
print $url->server;
# http://abw@badgerpower.com:8080
print $url->service;
# http://abw@badgerpower.com:8080/under/ground
print $url->request;
# http://abw@badgerpower.com:8080/under/ground?animal=badger
# method to return the whole URL
print $url->url();
# http://abw@badgerpower.com:8080/under/ground?animal=badger#stripe
# overloaded stringification operator calls url() method
print $url;
# http://abw@badgerpower.com:8080/under/ground?animal=badger#stripe
=head1 DESCRIPTION
This module implements an object for representing URLs. It can parse existing
URLs to break them down into their constituent parts, and also to generate
new or modified URLs.
The emphasis is on simplicity and convenience for tasks related to web
programming (e.g. dispatching web applications based on the URL, generating
URLs for redirects or embedding as links in HTML pages). If you want more
generic URI functionality then you should consider using the L<URI> module.
A URL looks like this:
http://abw@badgerpower.com:8080/under/ground?animal=badger#stripe
\__/ \______________________/\___________/ \___________/ \____/
| | | | |
scheme authority path query fragment
The C<authority> part can be broken down further:
abw@badgerpower.com:8080
\_/ \_____________/ \__/
| | |
user host port
A L<Badger::URL> object will parse a URL and store the component parts
internally. You can then change any of the individual parts and regenerate the
URL.
my $url = Badger::URL->new(
'http://badgerpower.com/'
);
$url->port('8080');
$url->path('/under/ground');
$url->query('animal=badger');
print $url; # http://badgerpower.com:8080/under/ground?animal=badger
=head1 METHODS
=head2 new($url)
This constructor method is used to create a new URL object.
my $url = Badger::URL->new(
'http://abw@badgerpower.com:8080/under/ground?animal=badger#stripe'
);
You can also specify the individual parts of the URL using named paramters.
my $url = Badger::URL->new(
scheme => 'http',
user => 'abw',
host => 'badgerpower.com',
port => '8080',
path => '/under/ground',
query => 'animal=badger',
fragment => 'stripe',
);
=head2 copy()
This method creates and returns a new C<Badger::URL> object as a copy of
the current one.
my $copy = $url->copy;
=head2 url()
Method to return the complete URL.
print $url->url;
# http://abw@badgerpower.com:8080/under/ground?animal=badger#stripe
This method is called automatically whenever the URL object is
stringified.
print $url; # same as above
=head2 text()
An alias for the L<url()> method.
=head2 scheme()
Method to get or set the scheme part of the URL.
$url = Badger::URL->new('http://badgerpower.com/);
print $url->scheme(); # http
$url->scheme('ftp');
print $url->scheme(); # ftp
=head2 authority()
Method to get or set the authority part of the URL. This is comprised of a
host with optional user and/or port.
$url->authority('badgerpower.com');
$url->authority('abw@badgerpower.com');
$url->authority('badgerpower.com:8080');
$url->authority('abw@badgerpower.com:8080');
print $url->authority(); # abw@badgerpower.com:8080
=head2 user()
Method to get or set the optional user in the authority part of the URL.
$url->user('fred');
print $url->user(); # fred
print $url->authority(); # fred@badgerpower.com:8080
=head2 host()
Get or set the host in the authority part of the URL.
$url->host('example.org');
print $url->host(); # example.org
print $url->authority(); # fred@example.org:8080
=head2 port()
Get or set the port in the authority part of the URL.
$url->port(1234);
print $url->port(); # 1234
print $url->authority(); # fred@example.org:1234
=head2 path()
Get or set the path part of the URL.
$url->path('/right/here');
print $url->path(); # /right/here
=head2 query()
Get or set the query part of the URL. The leading 'C<?>' is not
considered part of the query and should be should not be included when
setting a new query.
$url->query('animal=ferret');
print $url->query(); # animal=ferret
=head2 params()
Get or set the query parameters.
# get params
my $params = $url->params;
# set params
$url->params(
x => 10
);
=head2 fragment()
Get or set the fragment part of the URL. The leading '#' is not
considered part of the fragment and should be should not be included
when setting a new fragment.
$url->fragment('feet');
print $url->fragment(); # feet
=head2 server()
Returns a composite of the scheme and authority.
print $url->server();
# http://fred@example.org:1234
=head2 service()
Returns a composite of the server (scheme and authority) and path
(in other words, everything up to the query or fragment).
print $url->server();
# http://fred@example.org:1234/right/here
=head2 request()
Returns a composite of the service (scheme, authority and path) and
query (in other words, everything except the fragment).
print $url->request();
# http://fred@example.org:1234/right/here?animal=badger
=head2 relative($path)
Returns a new URL with the relative path specified.
my $base = Badger::URL->new('http://badgerpower.com/example');
my $rel = $base->relative('foo/bar');
print $rel; # http://badgerpower.com/example/foo/bar
=head2 absolute($path)
Returns a new URL with the absolute path specified. The leading C</> on
the path provided as an argument is option. It will be assumed if not
present.
my $base = Badger::URL->new('http://badgerpower.com/example');
my $rel = $base->absolute('foo/bar');
print $rel; # http://badgerpower.com/foo/bar
=head1 INTERNAL METHODS
=head2 set($items)
This method is used to set internal values.
=head2 join_authority()
This method reconstructs the C<authority> from the C<host>, C<port> and
C<user>.
=head2 join_query()
This method reconstructs the C<query> from the query parameters.
=head2 join_url()
This method reconstructs the complete URL from its constituent parts.
=head2 split_authority()
This method splits the C<authority> into C<host>, C<port> and C<user>.
=head2 split_query()
This method splits the C<query> string into query parameters.
=head2 dump()
Return a text representation of the structure of the URL object, for
debugging purposes.
=head1 EXPORTABLE SUBROUTINES
=head2 URL($url)
This constructor function can be used to create a new URL. If the argument
is already a C<Badger::URL> object then it is copied to create a new object.
Otherwise a new C<Badger::URL> object is created from scratch.
use Badger::URL 'URL';
my $url1 = URL('http://example.com/foo');
my $url2 = URL($url1);
=head1 AUTHOR
Andy Wardley L<http://wardley.org/>
=head1 COPYRIGHT
Copyright (C) 2001-2010 Andy Wardley. All Rights Reserved.
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=head1 SEE ALSO
L<URI>
=cut
# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: