File Coverage

blib/lib/Rose/URI.pm

Criterion	Covered	Total	%
statement	185	214	86.4
branch	103	132	78.0
condition	18	45	40.0
subroutine	31	34	91.1
pod	17	20	85.0
total	354	445	79.5

package Rose::URI;

use strict;

use Carp();
use URI::Escape();

use Rose::Object;
our @ISA = qw(Rose::Object);

use overload
(
  '""'   => sub { shift->as_string },
  'bool' => sub { length shift->as_string },
   fallback => 1,
);

our $Make_URI;

our $SCHEME_RE = '[a-zA-Z][a-zA-Z0-9.+\-]*';

our $VERSION = '1.00';

# Class data
use Rose::Class::MakeMethods::Generic
(
  inheritable_scalar =>
  [
    'default_query_param_separator',
    'default_omit_empty_query_params',
  ],
);

# Object data
use Rose::Object::MakeMethods::Generic
(
  scalar =>
  [
    'username',
    'password',
    'scheme',
    'host',
    'port',
    'path',
    'fragment',
    'query_param_separator' => { interface => 'get_set_init' },
  ],
);

__PACKAGE__->default_query_param_separator('&');
__PACKAGE__->default_omit_empty_query_params(0);

sub init_query_param_separator { ref(shift)->default_query_param_separator }

sub new
{
  my($class) = shift;

  my $self =
  {
    username => '',
    password => '',
    scheme   => '',
    host     => '',
    port     => '',
    path     => '',
    query    => {},
    fragment => '',
  };

  bless $self, $class;

  $self->init(@_);

  return $self;
}

sub init
{
  my($self) = shift;

  if(@_ == 1)
  {
    $self->init_with_uri(@_);
  }
  else
  {
    $self->SUPER::init(@_);
  }
}

sub init_with_uri
{
  my($self) = shift;

  $self->$Make_URI($_[0]);
}

sub clone
{
  my($self) = shift;
  return bless _deep_copy($self), ref($self);
}

sub parse_query
{
  my($self, $query) = @_;

  $self->{'query_string'} = undef;

  unless(defined $query && $query =~ /\S/)
  {
    $self->{'query'} = { };
    return 1;
  }

  my @params;

  if(index($query, '&') >= 0)
  {
    @params = split(/&/, $query);
  }
  elsif(index($query, ';') >= 0)
  {
    @params = split(/;/, $query);
  }
  elsif(index($query, '=') < 0)
  {
    $self->{'query_string'} = __unescape_uri($query);
    $self->{'query'} = { $self->{'query_string'} => undef };
    return 1;
  }

  @params = ($query)  unless(@params);

  my %query;

  foreach my $item (@params)
  {
    my($param, $value) = map { __unescape_uri($_) } split(/=/, $item);

    $param = __unescape_uri($item)  unless(defined($param));

    if(exists $query{$param})
    {
      if(ref $query{$param})
      {
        push(@{$query{$param}}, $value);
      }
      else
      {
        $query{$param} = [ $query{$param}, $value ];
      }
    }
    else
    {
      $query{$param} = $value;
    }
  }

  $self->{'query'} = \%query;

  return 1;
}

sub query_hash
{
  my($self) = shift;

  return (wantarray) ? %{$self->{'query'}} : { %{$self->{'query'}} };
}

sub omit_empty_query_params
{
  my($self) = shift;

  if(@_)
  {
    return $self->{'omit_empty_query_params'} = $_[0] ? 1 : 0;
  }

  return defined $self->{'omit_empty_query_params'} ?
    $self->{'omit_empty_query_params'} : ref($self)->default_omit_empty_query_params;
}

sub query_param
{
  my($self) = shift;

  if(@_ == 1)
  {
    return $self->{'query'}{$_[0]}  if(exists $self->{'query'}{$_[0]});
    return;
  }
  elsif(@_ == 2)
  {
    $self->{'query_string'} = undef;

    if(ref $_[1])
    {
      return $self->{'query'}{$_[0]} = [ @{$_[1]} ];
    }

    return $self->{'query'}{$_[0]} = $_[1];
  }

  Carp::croak "query_param() takes either one or two arguments";
}

sub query_params
{
  my($self) = shift;

  return sort keys %{$self->{'query'}}  unless(@_);

  my $params = $self->query_param(@_);

  $params = (ref $params) ? [ @$params ] :
            (defined $params) ? [ $params ] : [];

  return (wantarray) ? @$params : $params;
}

sub query_param_add
{
  my($self, $name, $value) = @_;

  Carp::croak "query_add_param() takes two arguments"  unless(@_ == 3);

  my $params = $self->query_params($name);

  push(@$params, (ref $value) ? @$value : $value);

  $self->query_param($name => (@$params > 1) ? $params : $params->[0]);

  return (wantarray) ? @$params : $params;
}

sub query_param_exists
{
  my($self, $param) = @_;

  Carp::croak "Missing query param argument"  unless(defined $param);

  return exists $self->{'query'}{$param};
}

sub query_param_delete
{
  my($self) = shift;

  Carp::croak "query_param_delete() takes one or more arguments"  unless(@_);

  foreach my $param (@_)
  {
    if(defined $self->{'query_string'} && $param eq $self->{'query_string'})
    {
      $self->{'query_string'} = undef;
    }

    delete $self->{'query'}{$param};
  }
}

sub as_string
{
  my($self) = shift;

  my $scheme = $self->scheme;
  my $user   = $self->userinfo_escaped;
  my $port   = $self->port;
  my $query  = $self->query;
  my $frag   = __escape_uri($self->fragment);

  return ((length $scheme) ? "$scheme://" : '') .
         ((length $user) ? "$user\@" : '') .
         $self->host .
         ((length $port) ? ":$port" : '') .
         __escape_uri_whole($self->path) .
         ((length $query) ? "?$query" : '') .
         ((length $frag) ? "#$frag" : '');
}

sub query
{
  my($self) = shift;

  if(@_ == 1)
  {
    if(ref $_[0])
    {
      $self->{'query'} = _deep_copy($_[0])
    }
    else
    {
      $self->parse_query($_[0]);
    }
  }
  elsif(@_)
  {
    $self->{'query'} = _deep_copy({ @_ });
  }

  my $want = wantarray;

  return  unless(defined wantarray);

  if(defined $self->{'query_string'})
  {
    return __escape_uri($self->{'query_string'});
  }

  my(@query, $omit_empty);

  foreach my $param (sort keys %{$self->{'query'}})
  {
    my @values = $self->query_params($param);

    # Contortions to avoid calling this method in the common(?) case where
    # every query parameter has at least one value.
    if(!@values && !(defined $omit_empty ? $omit_empty : ($omit_empty = $self->omit_empty_query_params)))
    {
      @values = ('');
    }

    foreach my $value (@values)
    {
      push(@query, __escape_uri($param) . '=' . __escape_uri($value));
    }
  }

  return join($self->query_param_separator, @query);
}

sub query_form
{
  my($self) = shift;

  if(@_)
  {
    $self->{'query_string'} = undef;
    $self->{'query'} = { };

    for(my $i = 0; $i < $#_; $i += 2)
    {
      $self->query_param_add($_[$i] => $_[$i + 1]);
    }
  }

  return  unless(defined(wantarray));

  my @query;

  foreach my $param ($self->query_params)
  {
    foreach my $value ($self->query_params($param))
    {
      push(@query, $param, $value);
    }
  }

  return @query;
}

sub abs
{
  my($self, $base) = @_;

  return $self  unless($base && !length $self->scheme);

  my $new = $self->as_string;

  $new  =~ s{^/}{};
  $base =~ s{/$}{};

  return Rose::URI->new("/$new")  unless($base =~ m{^$SCHEME_RE://}o);
  return Rose::URI->new("$base/$new");
}

sub rel
{
  my($self, $base) = @_;

  return $self  unless($base);

  my $uri = $self->as_string;

  if($uri =~ m{^$base/?})
  {
    $uri =~ s{^$base/?}{};

    return Rose::URI->new($uri);
  }

  return $self;
}

sub userinfo
{
  my($self) = shift;

  my $user = $self->username;
  my $pass = $self->password;

  if(length $user && length $pass)
  {
    return join(':', $user, $pass);
  }

  return $user  if(length $user);
  return '';
}

sub userinfo_escaped
{
  my($self) = shift;

  my $user = __escape_uri($self->username);
  my $pass = __escape_uri($self->password);

  if(length $user && length $pass)
  {
    return join(':', $user, $pass);
  }

  return $user  if(length $user);
  return '';
}

sub __uri_from_apache_uri
{
  my($self) = shift;

  my $uri = Apache::URI->parse(Apache->request, @_);

  $self->{'username'} = $uri->user     || '';
  $self->{'password'} = $uri->password || '';
  $self->{'scheme'}   = $uri->scheme   || '';
  $self->{'host'}     = $uri->hostname || '';
  $self->{'port'}     = $uri->port     || '';
  $self->{'path'}     = $uri->path     || '';
  $self->{'fragment'} = $uri->fragment || '';

  $self->parse_query($uri->query);

  return $uri;
}

sub __uri_from_uri
{
  my($self) = shift;

  my $uri = URI->new(@_);

  if($uri->can('user'))
  {
    $self->{'username'} = $uri->user;
  }
  elsif($uri->can('userinfo'))
  {
    if(my $userinfo = $uri->userinfo)
    {
      if(my($user, $pass) = split(':', $userinfo))
      {
        $self->{'username'} = __unescape_uri($user);
        $self->{'password'} = __unescape_uri($pass);
      }
    }
  }

  $self->{'scheme'}   = __unescape_uri($uri->scheme   || '');
  $self->{'host'}     = __unescape_uri($uri->host     || '')  if($uri->can('host'));
  $self->{'port'}     = __unescape_uri($uri->_port    || '')  if($uri->can('_port'));
  $self->{'path'}     = __unescape_uri($uri->path     || '')  if($uri->can('path'));
  $self->{'fragment'} = __unescape_uri($uri->fragment || '');

  $self->parse_query($uri->query);

  return $uri;
}

if(exists $ENV{'MOD_PERL'} && require mod_perl && $mod_perl::VERSION < 1.99)
{
  require Apache;
  require Apache::URI;
  require Apache::Util;

  *__escape_uri   = \&Apache::Util::escape_uri;
  *__unescape_uri = \&Apache::Util::unescape_uri_info;

  $Make_URI = \&__uri_from_apache_uri;
}
else
{
  *__escape_uri   = \&URI::Escape::uri_escape;
  *__unescape_uri = sub
  {
    my $e = URI::Escape::uri_unescape(@_);

    $e =~ s/\+/ /g;

    return $e;
  };

  require URI;
  $Make_URI = \&__uri_from_uri;
}

sub __escape_uri_whole
{
  URI::Escape::uri_escape($_[0],
    (@_ > 1) ? (defined $_[1] ? $_[1] : ()) : q(^A-Za-z0-9\-_.,'!~*#?&()/?@\:\[\]=));
}

# Based on code from Clone::PP
sub _deep_copy
{
  my($data) = shift;

  my $ref_type = ref $data or return $data;

  my $copy;

  if($ref_type eq 'HASH')
  {
    $copy = {};
    %$copy = map { !ref($_) ? $_ : _deep_copy($_) } %$data;
  }
  elsif($ref_type eq 'ARRAY')
  {
    $copy = [];
    @$copy = map { !ref($_) ? $_ : _deep_copy($_) } @$data;
  }
  elsif($ref_type eq 'REF' or $ref_type eq 'SCALAR')
  {
    $copy = \(my $var = '');
    $$copy = _deep_copy($$data);
  }
  elsif($ref_type->isa(__PACKAGE__)) # cloning
  {
    $copy = _deep_copy({ %{$data} });
  }
  else
  {
    $copy = $data;
  }

  return $copy;
}

1;

__END__