File Coverage

blib/lib/Test/Deep/URI.pm

Criterion	Covered	Total	%
statement	67	67	100.0
branch	24	24	100.0
condition	5	5	100.0
subroutine	13	13	100.0
pod	2	4	50.0
total	111	113	98.2

package Test::Deep::URI;

use strict;
use warnings;
use 5.008_005;
our $VERSION = '0.04';

# ABSTRACT: Easier testing of URIs for Test::Deep

use base qw(Exporter::Tiny);
our @EXPORT = qw(uri uri_qf);

use URI;
use Test::Deep ();
use Test::Deep::Cmp; # exports "new", other stuff.


################################################################################

sub uri {
    my ($expected_uri) = @_;
    return __PACKAGE__->new($expected_uri);
}

sub uri_qf {
    my ($expected_uri, $expected_query_form) = @_;
    my $self = __PACKAGE__->new($expected_uri, $expected_query_form);
}

sub init
{
    my ($self, $expected_uri, $expected_query_form) = @_;

    my $is_deep_qf = scalar(@_) == 3;

    if (! $is_deep_qf && ! defined $expected_uri) {
        warn "Missing argument to uri()!";
    }
    elsif ($is_deep_qf) {
        warn "Missing uri for uri_qf()!"
            unless defined $expected_uri;
        warn "Missing query form for uri_qf()!"
            unless defined $expected_query_form;
    }

    # URI objects act a little weird on URIs like "//host/path".
    # "/path" can be pulled via path(), but host() dies. Thus I'm
    # copying the host string if necessary.
    if (($expected_uri || '') =~ m{//([^/]+)/}) {
        $self->{host} = $1;
    }
    $self->{uri} = URI->new($expected_uri);
    if ($is_deep_qf) {
        $self->{is_deep_qf} = $is_deep_qf;
        $self->{expected_qf} = $expected_query_form;
    }
}

sub descend
{
    my ($self, $got) = @_;

    my $uri = $self->{uri};
    $got = URI->new($got);

    my @methods;
    push @methods, scheme   => $uri->scheme if $uri->scheme();
    local $@;
    eval {
        # Dies on partial URIs
        push @methods, host => $uri->host;
        # Don't need kludge
        delete $self->{host};
    };
    push @methods, path     => $uri->path;
    push @methods, fragment => $uri->fragment;

    my @expected = (
        $self->_get_expected_qf(),
        Test::Deep::methods(@methods)
    );
    my @received = (
        _to_hashref([ $got->query_form ]),
        $got,
    );

    # Kludge to test host!
    if ($self->{host}) {
        push @expected, $self->{host};
        push @received,
            ($got->can('host'))
                ? $got->host
                : $got =~ m{//([^/]+)/};
    }

    $self->data->{got} = $got;
    return Test::Deep::wrap(\@expected)->descend(\@received);
}

sub _get_expected_qf {
    my ($self) = @_;
    return $self->{expected_qf}
        if exists $self->{expected_qf};
    return _to_hashref([ $self->{uri}->query_form ]);
}

sub _to_hashref
{
    my ($list) = @_;
    my %hash;
    while (my ($key, $val) = splice(@$list, 0, 2))
    {
        if (exists $hash{$key}) {
            $hash{$key} = [ $hash{$key} ]
                unless ref $hash{$key};
            push @{$hash{$key}}, $val;
            next;
        }
        $hash{$key} = $val;
    }
    return \%hash;
}

1;
__END__