File Coverage

blib/lib/HTTP/AnyUA/Util.pm
Criterion Covered Total %
statement 36 109 33.0
branch 11 68 16.1
condition 2 13 15.3
subroutine 7 16 43.7
pod 10 10 100.0
total 66 216 30.5


line stmt bran cond sub pod time code
1             package HTTP::AnyUA::Util;
2             # ABSTRACT: Utility subroutines for HTTP::AnyUA backends and middleware
3              
4 18     18   115 use warnings;
  18         37  
  18         561  
5 18     18   101 use strict;
  18         31  
  18         1008  
6              
7             our $VERSION = '0.904'; # VERSION
8              
9 18     18   113 use Exporter qw(import);
  18         41  
  18         27781  
10              
11              
12             our @EXPORT_OK = qw(
13             http_headers_to_native
14             native_to_http_request
15             coderef_content_to_string
16             normalize_headers
17             internal_exception
18             http_date
19             parse_http_date
20             uri_escape
21             www_form_urlencode
22             );
23              
24              
25 0     0   0 sub _croak { require Carp; Carp::croak(@_) }
  0         0  
26 0     0   0 sub _usage { _croak("Usage: @_\n") }
27              
28              
29             sub coderef_content_to_string {
30 0     0 1 0 my $content = shift;
31              
32 0 0       0 return $content if !$content;
33              
34 0 0       0 if (ref($content) eq 'CODE') {
35             # drain the request body
36 0         0 my $body = '';
37 0         0 while (my $chunk = $content->()) {
38 0         0 $body .= $chunk;
39             }
40 0         0 $content = $body;
41             }
42              
43 0         0 return $content;
44             }
45              
46              
47             sub native_to_http_request {
48 0     0 1 0 my $method = shift;
49 0         0 my $url = shift;
50 0   0     0 my $args = shift || {};
51              
52 0         0 my $headers = [];
53 0         0 my $content = $args->{content}; # works as either scalar or coderef
54              
55             # flatten headers
56 0 0       0 for my $header (keys %{$args->{headers} || {}}) {
  0         0  
57 0         0 my $value = $args->{headers}{$header};
58 0 0       0 my @values = ref($value) eq 'ARRAY' ? @$value : ($value);
59 0         0 for my $v (@values) {
60 0         0 push @$headers, ($header => $v);
61             }
62             }
63              
64 0         0 require HTTP::Request;
65 0         0 return HTTP::Request->new($method, $url, $headers, $content);
66             }
67              
68              
69             sub http_headers_to_native {
70 0     0 1 0 my $http_headers = shift;
71              
72 0         0 my $native;
73              
74 0         0 for my $header ($http_headers->header_field_names) {
75 0         0 my @values = $http_headers->header($header);
76 0 0       0 $native->{lc($header)} = @values == 1 ? $values[0] : [@values];
77             }
78              
79 0         0 return $native;
80             }
81              
82              
83             sub normalize_headers {
84 9     9 1 18 my $headers_in = shift;
85              
86 9         15 my $headers = {};
87              
88 9 100       26 if (defined $headers_in) {
89 5 50       8 while (my ($key, $value) = each %{$headers_in || {}}) {
  12         43  
90 7         20 $headers->{lc($key)} = $value;
91             }
92             }
93              
94 9         29 return $headers;
95             }
96              
97              
98             sub internal_exception {
99 0 0   0 1 0 my $e = shift or _usage(q{internal_exception($exception)});
100 0   0     0 my $resp = shift || {};
101              
102 0         0 $e = "$e";
103              
104 0 0       0 $resp->{headers}{'client-original-status'} = $resp->{status} if $resp->{status};
105 0 0       0 $resp->{headers}{'client-original-reason'} = $resp->{reason} if $resp->{reason};
106              
107 0         0 $resp->{success} = '';
108 0         0 $resp->{status} = 599;
109 0         0 $resp->{reason} = 'Internal Exception';
110 0         0 $resp->{content} = $e;
111 0         0 $resp->{headers}{'content-type'} = 'text/plain';
112 0         0 $resp->{headers}{'content-length'} = length $e;
113              
114 0         0 return $resp;
115             }
116              
117              
118             # adapted from HTTP/Tiny.pm
119             sub split_url {
120 0 0   0 1 0 my $url = shift or _usage(q{split_url($url)});
121              
122             # URI regex adapted from the URI module
123 0 0       0 my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
124             or die(qq/Cannot parse URL: '$url'\n/);
125              
126 0         0 $scheme = lc $scheme;
127 0 0       0 $path_query = "/$path_query" unless $path_query =~ m<\A/>;
128              
129 0         0 my $auth = '';
130 0 0       0 if ( (my $i = index $host, '@') != -1 ) {
131             # user:pass@host
132 0         0 $auth = substr $host, 0, $i, ''; # take up to the @ for auth
133 0         0 substr $host, 0, 1, ''; # knock the @ off the host
134              
135             # userinfo might be percent escaped, so recover real auth info
136 0         0 $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  0         0  
137             }
138 0 0 0     0 my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
    0          
    0          
139             : $scheme eq 'http' ? 80
140             : $scheme eq 'https' ? 443
141             : undef;
142              
143 0 0       0 return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
144             }
145              
146              
147             # Date conversions adapted from HTTP::Date
148             # adapted from HTTP/Tiny.pm
149             my $DoW = 'Sun|Mon|Tue|Wed|Thu|Fri|Sat';
150             my $MoY = 'Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec';
151             sub http_date {
152 0 0   0 1 0 my $time = shift or _usage(q{http_date($time)});
153 0         0 my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
154 0         0 return sprintf('%s, %02d %s %04d %02d:%02d:%02d GMT',
155             substr($DoW,$wday*4,3),
156             $mday, substr($MoY,$mon*4,3), $year+1900,
157             $hour, $min, $sec
158             );
159             }
160              
161              
162             # adapted from HTTP/Tiny.pm
163             sub parse_http_date {
164 0 0   0 1 0 my $str = shift or _usage(q{parse_http_date($str)});
165 0         0 my @tl_parts;
166 0 0       0 if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
    0          
    0          
167 0         0 @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
168             }
169             elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
170 0         0 @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
171             }
172             elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
173 0         0 @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
174             }
175 0         0 require Time::Local;
176 0         0 return eval {
177 0 0       0 my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
178 0 0       0 $t < 0 ? undef : $t;
179             };
180             }
181              
182              
183             # URI escaping adapted from URI::Escape
184             # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
185             # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
186             # adapted from HTTP/Tiny.pm
187             my %escapes = map { chr($_) => sprintf('%%%02X', $_) } 0..255;
188             $escapes{' '} = '+';
189             my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
190              
191             sub uri_escape {
192 4 50   4 1 11 my $str = shift or _usage(q{uri_escape($str)});
193 4 50       10 if ($] ge '5.008') {
194 4         10 utf8::encode($str);
195             }
196             else {
197             $str = pack('U*', unpack('C*', $str)) # UTF-8 encode a byte string
198 18 0   18   11211 if (length $str == do { use bytes; length $str });
  18         270  
  18         93  
  0         0  
  0         0  
199 0         0 $str = pack('C*', unpack('C*', $str)); # clear UTF-8 flag
200             }
201 4         32 $str =~ s/($unsafe_char)/$escapes{$1}/ge;
  0         0  
202 4         16 return $str;
203             }
204              
205              
206             # adapted from HTTP/Tiny.pm
207             sub www_form_urlencode {
208 1     1 1 3 my $data = shift;
209 1 50 33     8 ($data && ref $data)
210             or _usage(q{www_form_urlencode($dataref)});
211 1 50 33     6 (ref $data eq 'HASH' || ref $data eq 'ARRAY')
212             or _croak("form data must be a hash or array reference\n");
213              
214 1 50       6 my @params = ref $data eq 'HASH' ? %$data : @$data;
215 1 50       4 @params % 2 == 0
216             or _croak("form data reference must have an even number of terms\n");
217              
218 1         2 my @terms;
219 1         4 while (@params) {
220 2         6 my ($key, $value) = splice(@params, 0, 2);
221 2 50       5 if (ref $value eq 'ARRAY') {
222 0         0 unshift @params, map { $key => $_ } @$value;
  0         0  
223             }
224             else {
225 2         5 push @terms, join('=', map { uri_escape($_) } $key, $value);
  4         18  
226             }
227             }
228              
229 1 50       26 return join('&', ref($data) eq 'ARRAY' ? @terms : sort @terms);
230             }
231              
232             1;
233              
234             __END__