File Coverage

blib/lib/Test2/Tools/URL.pm
Criterion Covered Total %
statement 86 87 98.8
branch 26 32 81.2
condition 10 12 83.3
subroutine 22 22 100.0
pod 3 3 100.0
total 147 156 94.2


line stmt bran cond sub pod time code
1             package Test2::Tools::URL;
2              
3 2     2   257547 use strict;
  2         12  
  2         70  
4 2     2   11 use warnings;
  2         5  
  2         49  
5 2     2   41 use 5.008001;
  2         16  
6 2     2   12 use Carp ();
  2         3  
  2         28  
7 2     2   9 use Test2::Compare ();
  2         4  
  2         62  
8 2     2   14 use Test2::Compare::Hash ();
  2         4  
  2         30  
9 2     2   9 use Test2::Compare::String ();
  2         12  
  2         61  
10 2     2   12 use base qw( Exporter );
  2         4  
  2         971  
11              
12             our @EXPORT = qw( url url_base url_component );
13              
14             # ABSTRACT: Compare a URL in your Test2 test
15             our $VERSION = '0.04'; # VERSION
16              
17              
18             sub url (&)
19             {
20 25     25 1 186239 Test2::Compare::build('Test2::Tools::URL::Check', @_);
21             }
22              
23              
24             sub url_base ($)
25             {
26 3     3 1 1839 my($base) = @_;
27              
28 3         15 my $build = Test2::Compare::get_build();
29 3 100       16 if($build)
30 1         5 { $build->set_base($base) }
31             else
32 2         8 { Test2::Tools::URL::Check->set_global_base($base) }
33             }
34              
35              
36             sub url_component ($$)
37             {
38 27     27 1 828 my($name, $expect) = @_;
39            
40 27 50       189 Carp::croak("$name is not a valid URL component")
41             unless $name =~ /^(?:scheme|authority|userinfo|hostport|host|port|path|query|fragment)$/;
42            
43 27 50       60 my $build = Test2::Compare::get_build()or Carp::croak("No current build!");
44 27         150 $build->add_component($name, $expect);
45             }
46              
47             package Test2::Tools::URL::Check;
48              
49 2     2   18 use overload ();
  2         3  
  2         52  
50 2     2   1347 use URI 1.61;
  2         10176  
  2         74  
51 2     2   17 use Scalar::Util qw( blessed );
  2         6  
  2         145  
52 2     2   23 use base qw( Test2::Compare::Base );
  2         9  
  2         1602  
53              
54 18     18   7910 sub name { '' }
55              
56             my $global_base;
57              
58             sub _uri
59             {
60 36     36   85 my($self, $url) = @_;
61             $self->{base}
62             ? URI->new_abs("$url", $self->{base})
63 36 100       245 : $global_base
    100          
64             ? URI->new_abs("$url", $global_base)
65             : URI->new("$url");
66             }
67              
68             sub verify
69             {
70 25     25   5783 my($self, %params) = @_;
71 25         83 my($got, $exists) = @params{qw/ got exists /};
72            
73 25 50       81 return 0 unless $exists;
74 25 100       136 return 0 unless $got;
75 24 100 100     126 return 0 if ref($got) && !blessed($got);
76 20 100 100     94 return 0 if ref($got) && !overload::Method($got, '""');
77            
78 19         127 my $url = eval { $self->_uri($got) };
  19         54  
79 19 50       14063 return 0 if $@;
80 19 100       94 return 0 if ! $url->has_recognized_scheme;
81            
82 17         163 return 1;
83             }
84              
85             sub set_base
86             {
87 1     1   2 my($self, $base) = @_;
88 1         4 $self->{base} = $base;
89             }
90              
91             sub set_global_base
92             {
93 2     2   4 my($self, $base) = @_;
94 2         5 $global_base = $base;
95             }
96              
97             sub add_component
98             {
99 27     27   62 my($self, $name, $expect) = @_;
100 27         38 push @{ $self->{component} }, [ $name, $expect ];
  27         94  
101             }
102              
103             sub deltas
104             {
105 17     17   144 my($self, %args) = @_;
106 17         92 my($got, $convert, $seen) = @args{'got', 'convert', 'seen'};
107              
108 17         68 my $uri = $self->_uri($got);
109            
110 17         1828 my @deltas;
111            
112 17         44 foreach my $comp (@{ $self->{component} })
  17         57  
113             {
114 27         1020 my($name, $expect) = @$comp;
115            
116 27         52 my $method = $name;
117 27 100       104 $method = 'host_port' if $method eq 'hostport';
118 27         152 my $value = $uri->$method;
119 27         882 my $check = $convert->($expect);
120              
121 27 50 33     2324 if($^O eq 'MSWin32' && $method eq 'path')
122             {
123 0         0 $value =~ s{/([A-Z]:)}{$1};
124             }
125              
126 27 100 100     107 if($method eq 'query' && !$check->isa('Test2::Compare::String'))
127             {
128 4         19 my @query = $uri->query_form;
129 4 100       255 if($check->isa('Test2::Compare::Hash'))
    50          
130             {
131 2         9 my %query = @query;
132 2         8 $value = \%query;
133             }
134             elsif($check->isa('Test2::Compare::Array'))
135             {
136 2         6 $value = \@query;
137             }
138             }
139              
140              
141 27         122 push @deltas => $check->run(
142             id => [ HASH => $name ],
143             convert => $convert,
144             seen => $seen,
145             exists => defined $value,
146             got => $value,
147             );
148             }
149            
150 17         2284 @deltas;
151             }
152              
153             1;
154              
155             __END__