File Coverage

blib/lib/Test2/Tools/URL.pm

Criterion	Covered	Total	%
statement	87	88	98.8
branch	26	32	81.2
condition	10	12	83.3
subroutine	23	23	100.0
pod	3	3	100.0
total	149	158	94.3

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 base qw( Exporter );

our @EXPORT = qw( url url_base url_component );

# ABSTRACT: Compare a URL in your Test2 test
our $VERSION = '0.05'; # 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) = @_;

  Carp::croak("$name is not a valid URL component")
    unless $name =~ /^(?:scheme|authority|userinfo|hostport|host|port|path|query|fragment)$/;

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

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) = @_;
  push @{ $self->{component} }, [ $name, $expect ];
}

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) = @$comp;

    my $method = $name;
    $method = 'host_port' if $method eq 'hostport';
    my $value = $uri->$method;
    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__