File Coverage

blib/lib/URI/Simple.pm

Criterion	Covered	Total	%
statement	46	49	93.8
branch	9	12	75.0
condition	2	2	100.0
subroutine	10	10	100.0
pod	0	5	0.0
total	67	78	85.9

package URI::Simple;
use strict;
use warnings;

#==========================================================================
# Regex
#==========================================================================
our $VERSION = '1.00';
my $REGEX = {
    strictMode => 0,
    key => ["source","protocol","authority","userInfo","user","password","host","port","relative","path","directory","file","querystring","anchor"],

    q => {
	name => "query",
	parser => qr{(?:^|&)([^&=]*)=?([^&]*)}
    },

    parser => {
	strict => qr/^(?:([^:\/?#]+):)?(?:\/\/((?:(([^:@]*)(?::([^:@]*))?)?@)?([^:\/?#]*)(?::(\d*))?))?((((?:[^?#\/]*\/)*)([^?#]*))(?:\?([^#]*))?(?:#(.*))?)/,
	loose =>  qr/^(?:(?![^:@]+:[^:@\/]*@)([^:\/?#.]+):)?(?:\/\/)?((?:(([^:@]*)(?::([^:@]*))?)?@)?([^:\/?#]*)(?::(\d*))?)(((\/(?:[^?#](?![^?#\/]*\.[^?#\/.]+(?:[?#]|$)))*\/?)?([^?#\/]*))(?:\?([^#]*))?(?:#(.*))?)/
    }
};

#==========================================================================
# Quick Accessors on load
#==========================================================================
my @subs = ( @ { $REGEX->{key} },'query' );
foreach my $method (@subs){
    my $code = __PACKAGE__.'::'.$method;
    {
        no strict 'refs';
        *$code = sub {
            my $self = shift;
            return $method eq 'query' ? $self->{$method} : uri_decode($self->{$method});
        };
    }
}

sub new {
    my $class = shift;
    my $url = shift;
    my $isStrict = shift;
    return bless ( parseUri($url,$isStrict) , $class);
}

sub scheme { shift->{protocol} }
sub fragment { shift->{anchor} }

#==========================================================================
# Parsing sub
#==========================================================================
sub parseUri {
    my $str = shift;
    my $mode = shift;
    my $o = $REGEX;
    my $m = $o->{parser}->{ $mode ? "loose" : "strict" };
    my @m = _exec($m,$str);
    my $uri = {};
    my $i   = 14;
    while ($i--) { $uri->{ $o->{key}->[$i] } = $m[$i] || "" };
    $uri->{ $o->{q}->{name} } = {};
    my $p = $o->{q}->{parser};
    my @q = $uri->{ $o->{key}->[12] } =~ /$p/g;

    if ($1){
        while (@q){
            my $value = pop @q;
            my $key = pop @q;
            if ( $uri->{ $o->{q}->{name} }->{$key} ){
                if (ref $uri->{ $o->{q}->{name} }->{$key} eq 'ARRAY'){
                    push (  @{$uri->{ $o->{q}->{name} }->{$key}} , uri_decode($value) );
                } else {
                    $uri->{ $o->{q}->{name} }->{$key} = [$uri->{ $o->{q}->{name} }->{$key} , uri_decode($value) ];
                }
            } else {
                $uri->{ $o->{q}->{name} }->{$key} = uri_decode($value);
            }
        }
    }

    return $uri;
}

#==========================================================================
# javascript like exec function
#==========================================================================
sub _exec {
    my ($expr,$string) = @_;
    my @m = $string =~ $expr;

    #javascript exe method adds the whole matched strig
    #to the results array as index[0]
    if (@m){
	unshift @m, substr $string,$-[0],$+[0];
    }
    return @m;
}

sub uri_decode {
    $_[0] =~ tr/+/ /;
    $_[0] =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg;
    return $_[0];
}

1;

__END__