File Coverage

lib/Test/WWW/Mechanize/Driver/Util.pm
Criterion Covered Total %
statement 47 72 65.2
branch 25 66 37.8
condition 9 46 19.5
subroutine 8 9 88.8
pod 4 4 100.0
total 93 197 47.2


line stmt bran cond sub pod time code
1             package Test::WWW::Mechanize::Driver::Util;
2 10     10   324375 use strict; use warnings;
  10     10   78  
  10         285  
  10         51  
  10         21  
  10         1052  
3             our $VERSION = 0.2;
4              
5             require Exporter;
6             our @ISA = qw(Exporter);
7             our %EXPORT_TAGS;
8             our @EXPORT_OK = qw/ cat TRUE HAS build_uri /;
9             $EXPORT_TAGS{all} = \@EXPORT_OK;
10              
11 10     10   5882 use URI ();
  10         84165  
  10         237  
12 10     10   4683 use URI::QueryParam ();
  10         8281  
  10         274  
13 10     10   68 use Scalar::Util qw/ reftype /;
  10         19  
  10         8965  
14              
15             =pod
16              
17             =head1 NAME
18              
19             Test::WWW::Mechanize::Driver::Util - Useful utilities
20              
21             =head1 USAGE
22              
23             =cut
24              
25             =head3 build_uri
26              
27             build_uri( $uri, \%params )
28              
29             Append parameters to a uri. Parameters whose values are array refs will
30             expand to include all values.
31              
32             Example:
33              
34             my %params = ( foo => "What's up, doc?",
35             b => [ 1, 2, 3 ]
36             );
37             my $uri = build_uri( "http://example.com/index.pl?foo=bar", \%params );
38             # $uri eq "http://example.com/index.pl?foo=bar&foo=What's+up%2C+Doc%3F$b=1&b=2&b=3
39              
40             =cut
41              
42             sub build_uri {
43 18     18 1 5003 my ($u, $p) = @_;
44 18 100       85 return $u unless $p;
45 3         14 my $uri = URI->new($u);
46              
47 3         268 while (my ($k, $v) = each %$p) {
48 3 50 33     51 $uri->query_param_append($k, (reftype($v) and 'ARRAY' eq reftype($v)) ? @$v : $v);
49             }
50              
51 3         402 return $uri->as_string
52             }
53              
54             #-----------------------------------------------------------------
55             # BEGIN Dean::Util code version 1.046
56             #
57             # use Dean::Util qw/ INCLUDE_POD cat TRUE HAS /;
58              
59              
60             =head3 cat
61              
62             my $stuff = cat $file;
63             my $stuff = cat \$mode, $file;
64              
65             Read in the entirety of a file. If requested in list context, the lines are
66             returned. In scalar context, the file is returned as one large string. If a
67             string reference C<$mode> is provided as a first argument it will be taken
68             as the file mode (the default is "E<lt>").
69              
70             =cut
71              
72             #BEGIN: cat
73             sub cat {
74 0 0   0 1 0 my $mode = (ref($_[0]) eq 'SCALAR') ? ${shift()} : "<";
  0         0  
75 0 0       0 my $f = (@_) ? $_[0] : $_;
76 0 0       0 open my $F, $mode, $f or die "Can't open $f for reading: $!";
77 0 0       0 if (wantarray) {
78 0         0 my @x = <$F>; close $F; return @x;
  0         0  
  0         0  
79             } else {
80 0         0 local $/ = undef; my $x = <$F>; close $F; return $x;
  0         0  
  0         0  
  0         0  
81             }
82             }
83             #END: cat
84              
85              
86             =head3 TRUE
87              
88             TRUE $hash_ref, qw| key1 arbitrarily/deep/key |;
89             TRUE $hash_ref, @paths, { sep => $separator, false_pat => $pattern };
90              
91             Safely test for deep key truth. Recursion happens by splitting on
92             C<$separator> ("/" by default, set C<$separator> to C<undef> to disable
93             this behavior), there is no means for escaping. Returns true only if all
94             keys exist and are true. Values matched by C<$pattern> (C<^(?i:false)$> by
95             default) as well as an empty list or empty hash will all cause 0 to be
96             returned. Array refs are allowed if corresponding path components are
97             numeric.
98              
99             =cut
100              
101             #BEGIN: TRUE
102             sub TRUE {
103 433     433 1 840 my $x = shift;
104 433 50       806 return 0 unless ref($x);
105 433         661 my $o = {};
106 433 50 33     1395 $o = pop if @_ and 'HASH' eq ref($_[-1]);
107 433 50       1100 $$o{sep} = '/' unless exists $$o{sep};
108 433 50 33     949 $$o{false_pat} = '^(?i:false)$' unless exists $$o{false_pat} and defined $$o{false_pat};
109 433         717 for (@_) {
110 433 50       3876 my @x = ('ARRAY' eq ref) ? @$_ : defined($$o{sep}) ? split($$o{sep}, $_) : ($_);
    50          
111 433 50       1100 if (ref($x) eq 'ARRAY') {
112 0 0 0     0 ($#{$x} >= $x[0] and $$x[$x[0]]) or return 0;
  0         0  
113 0 0 0     0 return 0 if !ref($$x[$x[0]]) and $$x[$x[0]] =~ /$$o{false_pat}/;
114 0 0 0     0 @{$$x[$x[0]]} or return 0 if ref($$x[$x[0]]) eq 'ARRAY';
  0         0  
115 0 0 0     0 %{$$x[$x[0]]} or return 0 if ref($$x[$x[0]]) eq 'HASH';
  0         0  
116 0 0 0     0 TRUE($$x[$x[0]], [@x[1..$#x]], $o) or return 0 if @x > 1;
117             } else {
118 433 100 66     2673 (exists $$x{$x[0]} and $$x{$x[0]}) or return 0;
119 120 50 33     642 return 0 if !ref($$x{$x[0]}) and $$x{$x[0]} =~ /$$o{false_pat}/;
120 120 50 0     303 @{$$x{$x[0]}} or return 0 if ref($$x{$x[0]}) eq 'ARRAY';
  0         0  
121 120 50 0     254 %{$$x{$x[0]}} or return 0 if ref($$x{$x[0]}) eq 'HASH';
  0         0  
122 120 50 0     368 TRUE($$x{$x[0]}, [@x[1..$#x]], $o) or return 0 if @x > 1;
123             }
124             }
125 120         491 return 1;
126             }
127             #END: TRUE
128              
129              
130             =head3 HAS
131              
132             HAS $hash_ref, qw| key1 arbitrarily/deep/key |;
133             HAS $hash_ref, @paths, { sep => $separator };
134              
135             Safely test for deep key definedness. Recursion happens by splitting on
136             C<$separator> ("/" by default), there is no means for escaping. Returns
137             true only if all keys exist and are defined. Array refs are allowed if
138             corresponding path components are numeric.
139              
140             =cut
141              
142             #BEGIN: HAS
143             sub HAS {
144 86     86 1 153 my $x = shift;
145 86 50       232 return 0 unless ref($x);
146 86         159 my $o = {};
147 86 50 33     396 $o = pop if @_ and 'HASH' eq ref($_[-1]);
148 86 50       305 $$o{sep} = '/' unless exists $$o{sep};
149 86         185 for (@_) {
150 86 50       1126 my @x = ('ARRAY' eq ref) ? @$_ : defined($$o{sep}) ? split($$o{sep}, $_) : ($_);
    50          
151 86 50       296 if (ref($x) eq 'ARRAY') {
152 0 0 0     0 ($#{$x} >= $x[0] and defined $$x[$x[0]]) or return 0;
  0         0  
153 0 0 0     0 HAS($$x[$x[0]], [@x[1..$#x]], $o) or return 0 if @x > 1;
154             } else {
155 86 100 66     583 (exists $$x{$x[0]} and defined $$x{$x[0]}) or return 0;
156 46 50 0     161 HAS($$x{$x[0]}, [@x[1..$#x]], $o) or return 0 if @x > 1;
157             }
158             }
159 46         326 return 1;
160             }
161             #END: HAS
162              
163             #
164             # END Dean::Util code version 1.046
165             #-----------------------------------------------------------------
166              
167             1;
168              
169             =head1 AUTHOR
170              
171             Dean Serenevy
172             dean@serenevy.net
173             https://serenevy.net/
174              
175             =head1 COPYRIGHT
176              
177             This software is hereby placed into the public domain. If you use this
178             code, a simple comment in your code giving credit and an email letting me
179             know that you find it useful would be courteous but is not required.
180              
181             The software is provided "as is" without warranty of any kind, either
182             expressed or implied including, but not limited to, the implied warranties
183             of merchantability and fitness for a particular purpose. In no event shall
184             the authors or copyright holders be liable for any claim, damages or other
185             liability, whether in an action of contract, tort or otherwise, arising
186             from, out of or in connection with the software or the use or other
187             dealings in the software.
188              
189             =head1 SEE ALSO
190              
191             perl(1).
192              
193             =cut