File Coverage

blib/lib/Test/URI.pm
Criterion Covered Total %
statement 38 48 79.1
branch 12 14 85.7
condition n/a
subroutine 11 14 78.5
pod 6 6 100.0
total 67 82 81.7


line stmt bran cond sub pod time code
1             package Test::URI;
2 4     4   64091 use strict;
  4         11  
  4         113  
3              
4 4     4   15 use vars qw(@EXPORT $VERSION);
  4         6  
  4         187  
5              
6 4     4   1936 use URI;
  4         17243  
  4         108  
7 4     4   23 use Exporter qw(import);
  4         5  
  4         90  
8 4     4   18 use Test::Builder;
  4         7  
  4         2118  
9              
10             my $Test = Test::Builder->new();
11              
12             @EXPORT = qw(uri_scheme_ok uri_host_ok uri_port_ok uri_fragment_ok
13             uri_path_ok);
14              
15             $VERSION = '1.083';
16              
17             =encoding utf8
18              
19             =head1 NAME
20              
21             Test::URI - Check Uniform Resource Identifiers
22              
23             =head1 SYNOPSIS
24              
25             use Test::More tests => 5;
26             use Test::URI;
27              
28             my $uri = 'http://www.example.com:8080/index.html#name'
29              
30             uri_scheme_ok( $uri, 'http' );
31             uri_host_ok( $uri, 'www.example.com' );
32             uri_port_ok( $uri, '8080' );
33             uri_path_ok( $uri, '/index.html' );
34             uri_fragment_ok( $uri, 'name' );
35              
36             =head1 DESCRIPTION
37              
38             Check various parts of Uniform Resource Locators
39              
40             =head1 FUNCTIONS
41              
42             =over 4
43              
44             =item uri_scheme_ok( STRING|URI, SCHEME )
45              
46             Ok is the STRING is a valid URI, in any format that
47             URI accepts, and the URI uses the same SCHEME (i.e.
48             protocol: http, ftp, ...). SCHEME is not case
49             sensitive.
50              
51             STRING can be an URI object.
52              
53             =cut
54              
55             sub uri_scheme_ok($$) {
56 26     26 1 58994 my $string = shift;
57 26         48 my $scheme = lc shift;
58              
59 26 100       81 my $uri = ref $string ? $string : URI->new( $string );
60              
61 26 100       17888 unless( UNIVERSAL::isa( $uri, 'URI' ) ) {
    50          
62 0         0 $Test->ok(0);
63 0         0 $Test->diag("URI [$string] does not appear to be valid");
64             }
65 0         0 elsif( $uri->scheme ne $scheme ) {
66 6         114 $Test->ok(0);
67 6         3801 $Test->diag("URI [$string] does not have the right scheme\n",
68             "\tExpected [$scheme]\n",
69             "\tGot [" . $uri->scheme . "]\n",
70             );
71             }
72             else {
73 20         722 $Test->ok(1);
74             }
75              
76             }
77              
78             =item uri_host_ok( STRING|URI, HOST )
79              
80             Ok is the STRING is a valid URI, in any format that
81             URI accepts, and the URI uses the same HOST. HOST
82             is not case sensitive.
83              
84             Not Ok is the URI scheme does not have a host portion.
85              
86             STRING can be an URI object.
87              
88             =cut
89              
90             sub uri_host_ok($$) {
91 23     23 1 15065 _methodx_ok( $_[0], $_[1], 'host' );
92             }
93              
94             =item uri_port_ok( STRING|URI, PORT )
95              
96             Ok is the STRING is a valid URI, in any format that
97             URI accepts, and the URI uses the same PORT.
98              
99             Not Ok is the URI scheme does not have a port portion.
100              
101             STRING can be an URI object.
102              
103             =cut
104              
105             my %Portless = map { $_, $_ } qw(mailto file);
106              
107             sub uri_port_ok($$)
108             {
109 22     22 1 19246 _methodx_ok( $_[0], $_[1], 'port' );
110             }
111              
112             =item uri_canonical_ok
113              
114             UNIMPLEMENTED. I'm not sure why I thought this should be a test.
115             If anyone else knows, I'll implement it.
116              
117             =cut
118              
119       0 1   sub uri_canonical_ok($$) {}
120              
121             =item uri_path_ok( STRING|URI, PATH )
122              
123             Ok is the STRING is a valid URI, in any format that
124             URI accepts, and the URI has the path PATH. Remember
125             that paths start with a /, even if it doesn't look
126             like there is anything after the host parts.
127              
128             STRING can be an URI object.
129              
130             =cut
131              
132             sub uri_path_ok($$) {
133 4     4 1 8442 _methodx_ok( $_[0], $_[1], 'path' );
134             }
135              
136             =item uri_fragment_ok( STRING|URI, FRAGMENT )
137              
138              
139             Ok is the STRING is a valid URI, in any format that
140             URI accepts, and the URI has the fragment FRAGMENT.
141              
142             STRING can be an URI object.
143              
144             =cut
145              
146             sub uri_fragment_ok($$)
147             {
148 4     4 1 8360 _methodx_ok( $_[0], $_[1], 'fragment' );
149             }
150              
151              
152             sub _methodx_ok($$$) {
153 53     53   73 my $string = shift;
154 53         64 my $expected = shift;
155 53         79 my $methodx = lc shift;
156              
157 53         79 local $Test::Builder::Level = $Test::Builder::Level + 1;
158              
159 53 100       150 my $uri = ref $string ? $string : URI->new( $string );
160              
161 53 100       15230 unless( UNIVERSAL::isa( $uri, 'URI' ) ) {
    100          
    50          
162 0           $Test->ok(0);
163 0           $Test->diag("URI [$string] does not appear to be valid");
164             }
165 0         0 elsif( not $uri->can( $methodx ) ) {
166 3         9 $Test->ok(0);
167 3         1837 my $scheme = $uri->scheme;
168 3         50 $Test->diag("$scheme schemes do not have a $methodx");
169             }
170 0         0 elsif( $uri->$methodx ne $expected ) {
171 12         260 $Test->ok(0);
172 12         7775 $Test->diag("URI [$string] does not have the right $methodx\n",
173             "\tExpected [$expected]\n",
174             "\tGot [" . $uri->$methodx . "]\n",
175             );
176             }
177             else {
178 38         1055 $Test->ok(1);
179             }
180             }
181              
182              
183 0     0     sub _same_thing_exactly { $_[0] eq $_[1] }
184 0     0     sub _same_thing_caseless { _same_think_exactly( map { lc } @_ ) }
  0            
185              
186             =back
187              
188             =head1 TO DO
189              
190             =over 4
191              
192             =item * add methods: uri_canonical_ok, uri_query_string_ok
193              
194             =item * add convenience methods such as uri_is_web, uri_is_ftp
195              
196             =back
197              
198             =head1 SOURCE AVAILABILITY
199              
200             This source is in GitHub
201              
202             https://github.com/briandfoy/test-uri
203              
204             =head1 AUTHOR
205              
206             brian d foy, C<< >>
207              
208             =head1 COPYRIGHT AND LICENSE
209              
210             Copyright © 2004-2021, brian d foy . All rights reserved.
211              
212             This program is free software; you can redistribute it and/or modify
213             it under the terms of the Artistic License 2.0.
214              
215             =cut
216              
217             1;