File Coverage

lib/Badger/URL.pm

Criterion	Covered	Total	%
statement	111	121	91.7
branch	44	62	70.9
condition	23	49	46.9
subroutine	21	23	91.3
pod	20	20	100.0
total	219	275	79.6

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://[e-mail]: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__