1 package HTTP
::AnyUA
::Util
;
2 # ABSTRACT: Utility subroutines for HTTP::AnyUA backends
7 our $VERSION = '0.900'; # VERSION
9 use Exporter
qw(import);
13 http_headers_to_native
14 native_to_http_request
15 coderef_content_to_string
24 sub _croak
{ require Carp
; Carp
::croak
(@_) }
25 sub _usage
{ _croak
("Usage: @_\n") }
28 sub coderef_content_to_string
{
31 return $content if !$content;
33 if (ref($content) eq 'CODE') {
34 # drain the request body
36 while (my $chunk = $content->()) {
46 sub native_to_http_request
{
49 my $args = shift || {};
52 my $content = $args->{content
}; # works as either scalar or coderef
55 for my $header (keys %{$args->{headers
} || {}}) {
56 my $value = $args->{headers
}{$header};
57 my @values = ref($value) eq 'ARRAY' ? @$value : ($value);
59 push @$headers, ($header => $v);
63 require HTTP
::Request
;
64 return HTTP
::Request-
>new($method, $url, $headers, $content);
68 sub http_headers_to_native
{
69 my $http_headers = shift;
73 for my $header ($http_headers->header_field_names) {
74 my @values = $http_headers->header($header);
75 $native->{lc($header)} = @values == 1 ? $values[0] : [@values];
82 sub internal_exception
{
83 my $e = shift or _usage
(q{internal_exception($exception)});
84 my $resp = shift || {};
88 $resp->{headers
}{'client-original-status'} = $resp->{status
} if $resp->{status
};
89 $resp->{headers
}{'client-original-reason'} = $resp->{reason
} if $resp->{reason
};
91 $resp->{success
} = '';
92 $resp->{status
} = 599;
93 $resp->{reason
} = 'Internal Exception';
94 $resp->{content
} = $e;
95 $resp->{headers
}{'content-type'} = 'text/plain';
96 $resp->{headers
}{'content-length'} = length $e;
102 # adapted from HTTP/Tiny.pm
104 my $url = shift or _usage
(q{split_url($url)});
106 # URI regex adapted from the URI module
107 my ($scheme, $host, $path_query) = $url =~ m
<\A
([^:/?#]+)://([^/?#]*)([^#]*)>
108 or die(qq
/Cannot parse URL: '$url'\n/);
110 $scheme = lc $scheme;
111 $path_query = "/$path_query" unless $path_query =~ m
<\A
/>;
114 if ( (my $i = index $host, '@') != -1 ) {
116 $auth = substr $host, 0, $i, ''; # take up to the @ for auth
117 substr $host, 0, 1, ''; # knock the @ off the host
119 # userinfo might be percent escaped, so recover real auth info
120 $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
122 my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
123 : $scheme eq 'http' ? 80
124 : $scheme eq 'https' ? 443
127 return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
131 # Date conversions adapted from HTTP::Date
132 # adapted from HTTP/Tiny.pm
133 my $DoW = 'Sun|Mon|Tue|Wed|Thu|Fri|Sat';
134 my $MoY = 'Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec';
136 my $time = shift or _usage
(q{http_date($time)});
137 my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
138 return sprintf('%s, %02d %s %04d %02d:%02d:%02d GMT',
139 substr($DoW,$wday*4,3),
140 $mday, substr($MoY,$mon*4,3), $year+1900,
146 # adapted from HTTP/Tiny.pm
147 sub parse_http_date
{
148 my $str = shift or _usage
(q{parse_http_date($str)});
150 if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
151 @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
153 elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
154 @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
156 elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
157 @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
161 my $t = @tl_parts ? Time
::Local
::timegm
(@tl_parts) : -1;
167 # URI escaping adapted from URI::Escape
168 # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
169 # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
170 # adapted from HTTP/Tiny.pm
171 my %escapes = map { chr($_) => sprintf('%%%02X', $_) } 0..255;
173 my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
176 my $str = shift or _usage
(q{uri_escape($str)});
181 $str = pack('U*', unpack('C*', $str)) # UTF-8 encode a byte string
182 if (length $str == do { use bytes
; length $str });
183 $str = pack('C*', unpack('C*', $str)); # clear UTF-8 flag
185 $str =~ s/($unsafe_char)/$escapes{$1}/ge;
190 # adapted from HTTP/Tiny.pm
191 sub www_form_urlencode
{
194 or _usage
(q{www_form_urlencode($dataref)});
195 (ref $data eq 'HASH' || ref $data eq 'ARRAY')
196 or _croak
("form data must be a hash or array reference\n");
198 my @params = ref $data eq 'HASH' ? %$data : @$data;
200 or _croak
("form data reference must have an even number of terms\n");
204 my ($key, $value) = splice(@params, 0, 2);
205 if (ref $value eq 'ARRAY') {
206 unshift @params, map { $key => $_ } @$value;
209 push @terms, join('=', map { uri_escape
($_) } $key, $value);
213 return join('&', ref($data) eq 'ARRAY' ? @terms : sort @terms);
226 HTTP::AnyUA::Util - Utility subroutines for HTTP::AnyUA backends
234 =head2 coderef_content_to_string
236 $content = coderef_content_to_string(\&code);
237 $content = coderef_content_to_string($content); # noop
239 Convert a coderef into a string of content by iteratively calling the coderef and concatenating the
240 chunks it provides until the coderef returns undef or an empty string.
242 =head2 native_to_http_request
244 $http_request = native_to_http_request($method, $url);
245 $http_request = native_to_http_request($method, $url, \%options);
247 Convert a "native" request tuple to an L<HTTP::Request> object.
249 =head2 http_headers_to_native
251 $headers = http_headers_to_native($http_headers);
253 Convert an L<HTTP::Headers> object to a "native" hashref.
255 =head2 internal_exception
257 $response = internal_exception($content);
258 $response = internal_exception($content, $response);
260 Create an internal exception response. If an existing response is passed, that response will have
261 its fields modified to become an internal exception.
265 ($scheme, $host, $port, $path_query, $auth) = split_url($url);
267 Split a URL into its components.
271 $http_date = http_date($epoch_time);
273 Convert an epoch time into a date format suitable for HTTP.
275 =head2 parse_http_date
277 $epoch_time = parse_http_date($http_date);
279 Convert an HTTP date into an epoch time. Returns undef if the date cannot be parsed.
283 $escaped = uri_escape($unescaped);
285 Escape a string for use in a URL query param or as C<application/x-www-form-urlencoded> data.
287 =head2 www_form_urlencode
289 $bytes = www_form_urlencode(\%form_data);
290 $bytes = www_form_urlencode(\@form_data);
292 Encode a hashref or arrayref as C<application/x-www-form-urlencoded> data.
296 Please report any bugs or feature requests on the bugtracker website
297 L<https://github.com/chazmcgarvey/HTTP-AnyUA/issues>
299 When submitting a bug or request, please include a test-file or a
300 patch to an existing test-file that illustrates the bug or desired
305 Charles McGarvey <chazmcgarvey@brokenzipper.com>
307 =head1 COPYRIGHT AND LICENSE
309 This software is copyright (c) 2017 by Charles McGarvey.
311 This is free software; you can redistribute it and/or modify it under
312 the same terms as the Perl 5 programming language system itself.