File Coverage

blib/lib/App/url.pm
Criterion Covered Total %
statement 14 23 60.8
branch n/a
condition n/a
subroutine 5 6 83.3
pod 1 1 100.0
total 20 30 66.6


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2 3     3   2535 use v5.26;
  3         9  
3              
4             package App::url;
5              
6             our $VERSION = '1.002';
7              
8 3     3   13 use Carp qw(carp);
  3         5  
  3         150  
9 3     3   796 use Mojo::Base -strict, -signatures;
  3         303392  
  3         37  
10 3     3   7842 use Mojo::URL;
  3         17083  
  3         20  
11 3     3   1389 use String::Sprintf;
  3         1272  
  3         2561  
12              
13             =encoding utf8
14              
15             =head1 NAME
16              
17             App::url - format a URL according to a sprintf-like template
18              
19             =head1 SYNOPSIS
20              
21             $ url '%h' http://www.example.com/a/b/c
22             www.example.com
23              
24             $ url '%H' http://www.example.com/a/b/c
25             www
26              
27             $ url '%P' http://www.example.com/a/b/c
28             /a/b/c
29              
30             $ url '%P' http://www.example.com/a/b/c
31             /a/b/c
32              
33             =head1 DESCRIPTION
34              
35             Decompose the URL and reformat it according to
36              
37             =head2 The formats
38              
39             =over 4
40              
41             =item * C<%a> - the path,
42              
43             =item * C<%f> - the fragment
44              
45             =item * C<%h> - the hostname, with domain info
46              
47             =item * C<%H> - the hostname without domain info
48              
49             =item * C<%i> - the hostname in punycode
50              
51             =item * C<%P> - the password of the userinfo portion
52              
53             =item * C<%p> - the port
54              
55             =item * C<%q> - the query string
56              
57             =item * C<%s> - the scheme
58              
59             =item * C<%S> - the public suffix
60              
61             =item * C<%u> - the complete URL
62              
63             =item * C<%U> - the username of the userinfo portion
64              
65             =back
66              
67             There are also some bonus formats unrelated to the URL:
68              
69             =over 4
70              
71             =item * C<%n> - newline
72              
73             =item * C<%t> - tab
74              
75             =item * C<%%> - literal percent
76              
77             =back
78              
79             =head2 Methods
80              
81             =over 4
82              
83             =item * run( TEMPLATE, ARRAY )
84              
85             Format each URL in ARRAY according to TEMPLATE and return an array
86             reference
87              
88             =back
89              
90             =head1 COPYRIGHT
91              
92             Copyright © 2020, brian d foy, all rights reserved.
93              
94             =head1 LICENSE
95              
96             You can use this code under the terms of the Artistic License 2.
97              
98             =cut
99              
100             our $VERSION = '1.001_01';
101              
102             my $formatter = String::Sprintf->formatter(
103             a => sub ( $w, $v, $V, $l ) { $V->[0]->path },
104             f => sub ( $w, $v, $V, $l ) { $V->[0]->fragment },
105             h => sub ( $w, $v, $V, $l ) { $V->[0]->host },
106             H => sub ( $w, $v, $V, $l ) { ( split /\./, $V->[0]->host )[0] },
107             i => sub ( $w, $v, $V, $l ) { $V->[0]->ihost },
108             p => sub ( $w, $v, $V, $l ) { $V->[0]->port },
109             P => sub ( $w, $v, $V, $l ) { $V->[0]->password },
110             'q' => sub ( $w, $v, $V, $l ) { $V->[0]->query },
111             's' => sub ( $w, $v, $V, $l ) { $V->[0]->protocol },
112              
113             S => sub ( $w, $v, $V, $l ) {
114             state $rc = eval { require Net::PublicSuffixList };
115             unless( $rc ) {
116             carp "%${l} requires Net::PublicSuffixList\n";
117             return;
118             }
119             state $psl = Net::PublicSuffixList->new;
120             my $hash = $psl->split_host( $V->[0]->host );
121             $hash->{suffix};
122             },
123              
124             U => sub ( $w, $v, $V, $l ) { $V->[0]->username },
125             u => sub ( $w, $v, $V, $l ) { $V->[0]->to_string },
126              
127             n => sub { "\n" },
128             t => sub { "\t" },
129             '%' => sub { '%' },
130              
131             '*' => sub ( $w, $v, $V, $l ) { warn "Invalid specifier <$l>\n" },
132             );
133              
134 0     0 1   sub run ( $class, $template, @urls ) {
  0            
  0            
  0            
  0            
135 0           my @strings;
136              
137 0           foreach my $url ( @urls ) {
138 0           push @strings, $formatter->sprintf( $template, Mojo::URL->new($url) );
139             }
140              
141 0           return \@strings;
142             }