File Coverage

blib/lib/Test2/Tools/URL.pm

Criterion	Covered	Total	%
statement	110	111	99.1
branch	38	44	86.3
condition	15	18	83.3
subroutine	31	31	100.0
pod	8	8	100.0
total	202	212	95.2

package Test2::Tools::URL;

use strict;
use warnings;
use 5.008001;
use Carp                   ();
use Test2::Compare         ();
use Test2::Compare::Hash   ();
use Test2::Compare::String ();
use Test2::Compare::Custom ();
use base qw( Exporter );

our @EXPORT = qw( url url_base url_component url_scheme url_host url_secure url_insecure url_mail_to );

# ABSTRACT: Compare a URL in your Test2 test
our $VERSION = '0.06'; # VERSION


sub url (&)
{
  Test2::Compare::build('Test2::Tools::URL::Check', @_);
}


sub url_base ($)
{
  my($base) = @_;

  my $build = Test2::Compare::get_build();
  if($build)
  { $build->set_base($base) }
  else
  { Test2::Tools::URL::Check->set_global_base($base) }
}


sub url_component ($$)
{
  my($name, $expect, $lc, $check_name) = @_;

  $check_name = 1 unless defined $check_name;
  if($check_name)
  {
    Carp::croak("$name is not a valid URL component")
      unless $name =~ /^(?:scheme|authority|userinfo|hostport|host|port|path|query|fragment|user|password|media_type|data)$/;
  }

  my $build = Test2::Compare::get_build()or Carp::croak("No current build!");
  $build->add_component($name, $expect, $lc);
}


sub url_scheme ($)
{
  unshift @_, 'scheme';
  goto &url_component;
}


sub url_host ($)
{
  @_ = ('host', $_[0], 1);
  goto &url_component;
}


sub url_secure ()
{
  my @caller = caller;
  my $test = Test2::Compare::Custom->new(
    code     => sub { defined $_ && ( ref $_ || $_ ) ? 1 : 0 },
    name     => 'TRUE',
    operator => 'TRUE()',
    file     => $caller[1],
    lines    => [$caller[2]],
  );
  @_ = ('secure', $test, undef, 0);
  goto &url_component;
}


sub url_insecure ()
{
  my @caller = caller;
  my $test = Test2::Compare::Custom->new(
    code => sub { my %p = @_; $p{got} ? 0 : $p{exists} },
    name => 'FALSE',
    operator => 'FALSE()',
    file     => $caller[1],
    lines    => [$caller[2]],
  );
  @_ = ('secure', $test, undef, 0);
  goto &url_component;
}


sub url_mail_to ($)
{
  @_ = ('to', $_[0], undef, 0);
  goto &url_component;
}

package Test2::Tools::URL::Check;

use overload ();
use URI 1.61;
use URI::QueryParam;
use Scalar::Util qw( blessed );
use base qw( Test2::Compare::Base );

sub name { '' }

my $global_base;

sub _uri
{
  my($self, $url) = @_;
  $self->{base}
    ? URI->new_abs("$url", $self->{base})
    : $global_base
      ? URI->new_abs("$url", $global_base)
      : URI->new("$url");
}

sub verify
{
  my($self, %params) = @_;
  my($got, $exists) = @params{qw/ got exists /};

  return 0 unless $exists;
  return 0 unless $got;
  return 0 if ref($got) && !blessed($got);
  return 0 if ref($got) && !overload::Method($got, '""');

  my $url = eval { $self->_uri($got) };
  return 0 if $@;
  return 0 if ! $url->has_recognized_scheme;

  return 1;
}

sub set_base
{
  my($self, $base) = @_;
  $self->{base} = $base;
}

sub set_global_base
{
  my($self, $base) = @_;
  $global_base = $base;
}

sub add_component
{
  my($self, $name, $expect, $lc) = @_;
  push @{ $self->{component} }, [ $name, $expect, $lc ];
}

sub deltas
{
  my($self, %args) = @_;
  my($got, $convert, $seen) = @args{'got', 'convert', 'seen'};

  my $uri = $self->_uri($got);

  my @deltas;

  foreach my $comp (@{ $self->{component} })
  {
    my($name, $expect, $lc) = @$comp;

    my $method = $name;
    $method = 'host_port' if $method eq 'hostport';
    my $value = $uri->can($method) ? $uri->$method : undef;
    $value = lc $value if $lc && defined $value;
    my $check = $convert->($expect);

    if($^O eq 'MSWin32' && $method eq 'path')
    {
      $value =~ s{/([A-Z]:)}{$1};
    }

    if($method eq 'query' && !$check->isa('Test2::Compare::String'))
    {
      if($check->isa('Test2::Compare::Hash'))
      {
        $value = $uri->query_form_hash;
      }
      elsif($check->isa('Test2::Compare::Array'))
      {
        $value = [ $uri->query_form ];
      }
    }


    push @deltas => $check->run(
      id      => [ HASH => $name ],
      convert => $convert,
      seen    => $seen,
      exists  => defined $value,
      got     => $value,
    );
  }

  @deltas;
}

1;

__END__