Dogcows Code - chaz/p5-HTTP-AnyUA/blob - lib/HTTP/AnyUA/Util.pm

   1 package HTTP::AnyUA::Util;
   2 # ABSTRACT: Utility subroutines for HTTP::AnyUA backends
   3
   4 use warnings;
   5 use strict;
   6
   7 our $VERSION = '0.900'; # VERSION
   8
   9 use Exporter qw(import);
  10
  11
  12 our @EXPORT_OK = qw(
  13     http_headers_to_native
  14     native_to_http_request
  15     coderef_content_to_string
  16     internal_exception
  17     http_date
  18     parse_http_date
  19     uri_escape
  20     www_form_urlencode
  21 );
  22
  23
  24 sub _croak { require Carp; Carp::croak(@_) }
  25 sub _usage { _croak("Usage: @_\n") }
  26
  27
  28 sub coderef_content_to_string {
  29     my $content = shift;
  30
  31     return $content if !$content;
  32
  33     if (ref($content) eq 'CODE') {
  34         # drain the request body
  35         my $body = '';
  36         while (my $chunk = $content->()) {
  37             $body .= $chunk;
  38         }
  39         $content = $body;
  40     }
  41
  42     return $content;
  43 }
  44
  45
  46 sub native_to_http_request {
  47     my $method  = shift;
  48     my $url     = shift;
  49     my $args    = shift || {};
  50
  51     my $headers = [];
  52     my $content = $args->{content};     # works as either scalar or coderef
  53
  54     # flatten headers
  55     for my $header (keys %{$args->{headers} || {}}) {
  56         my $value  = $args->{headers}{$header};
  57         my @values = ref($value) eq 'ARRAY' ? @$value : ($value);
  58         for my $v (@values) {
  59             push @$headers, ($header => $v);
  60         }
  61     }
  62
  63     require HTTP::Request;
  64     return HTTP::Request->new($method, $url, $headers, $content);
  65 }
  66
  67
  68 sub http_headers_to_native {
  69     my $http_headers = shift;
  70
  71     my $native;
  72
  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];
  76     }
  77
  78     return $native;
  79 }
  80
  81
  82 sub internal_exception {
  83     my $e       = shift or _usage(q{internal_exception($exception)});
  84     my $resp    = shift || {};
  85
  86     $e = "$e";
  87
  88     $resp->{headers}{'client-original-status'} = $resp->{status} if $resp->{status};
  89     $resp->{headers}{'client-original-reason'} = $resp->{reason} if $resp->{reason};
  90
  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;
  97
  98     return $resp;
  99 }
 100
 101
 102 # adapted from HTTP/Tiny.pm
 103 sub split_url {
 104     my $url = shift or _usage(q{split_url($url)});
 105
 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/);
 109
 110     $scheme     = lc $scheme;
 111     $path_query = "/$path_query" unless $path_query =~ m<\A/>;
 112
 113     my $auth = '';
 114     if ( (my $i = index $host, '@') != -1 ) {
 115         # user:pass@host
 116         $auth = substr $host, 0, $i, ''; # take up to the @ for auth
 117         substr $host, 0, 1, '';          # knock the @ off the host
 118
 119         # userinfo might be percent escaped, so recover real auth info
 120         $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 121     }
 122     my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
 123              : $scheme eq 'http'                  ? 80
 124              : $scheme eq 'https'                 ? 443
 125              : undef;
 126
 127     return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
 128 }
 129
 130
 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';
 135 sub http_date {
 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,
 141         $hour, $min, $sec
 142     );
 143 }
 144
 145
 146 # adapted from HTTP/Tiny.pm
 147 sub parse_http_date {
 148     my $str = shift or _usage(q{parse_http_date($str)});
 149     my @tl_parts;
 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);
 152     }
 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);
 155     }
 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);
 158     }
 159     require Time::Local;
 160     return eval {
 161         my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
 162         $t < 0 ? undef : $t;
 163     };
 164 }
 165
 166
 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;
 172 $escapes{' '} = '+';
 173 my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
 174
 175 sub uri_escape {
 176     my $str = shift or _usage(q{uri_escape($str)});
 177     if ($] ge '5.008') {
 178         utf8::encode($str);
 179     }
 180     else {
 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
 184     }
 185     $str =~ s/($unsafe_char)/$escapes{$1}/ge;
 186     return $str;
 187 }
 188
 189
 190 # adapted from HTTP/Tiny.pm
 191 sub www_form_urlencode {
 192     my $data = shift;
 193     ($data && ref $data)
 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");
 197
 198     my @params = ref $data eq 'HASH' ? %$data : @$data;
 199     @params % 2 == 0
 200         or _croak("form data reference must have an even number of terms\n");
 201
 202     my @terms;
 203     while (@params) {
 204         my ($key, $value) = splice(@params, 0, 2);
 205         if (ref $value eq 'ARRAY') {
 206             unshift @params, map { $key => $_ } @$value;
 207         }
 208         else {
 209             push @terms, join('=', map { uri_escape($_) } $key, $value);
 210         }
 211     }
 212
 213     return join('&', ref($data) eq 'ARRAY' ? @terms : sort @terms);
 214 }
 215
 216 1;
 217
 218 __END__
 219
 220 =pod
 221
 222 =encoding UTF-8
 223
 224 =head1 NAME
 225
 226 HTTP::AnyUA::Util - Utility subroutines for HTTP::AnyUA backends
 227
 228 =head1 VERSION
 229
 230 version 0.900
 231
 232 =head1 FUNCTIONS
 233
 234 =head2 coderef_content_to_string
 235
 236     $content = coderef_content_to_string(\&code);
 237     $content = coderef_content_to_string($content);     # noop
 238
 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.
 241
 242 =head2 native_to_http_request
 243
 244     $http_request = native_to_http_request($method, $url);
 245     $http_request = native_to_http_request($method, $url, \%options);
 246
 247 Convert a "native" request tuple to an L<HTTP::Request> object.
 248
 249 =head2 http_headers_to_native
 250
 251     $headers = http_headers_to_native($http_headers);
 252
 253 Convert an L<HTTP::Headers> object to a "native" hashref.
 254
 255 =head2 internal_exception
 256
 257     $response = internal_exception($content);
 258     $response = internal_exception($content, $response);
 259
 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.
 262
 263 =head2 split_url
 264
 265     ($scheme, $host, $port, $path_query, $auth) = split_url($url);
 266
 267 Split a URL into its components.
 268
 269 =head2 http_date
 270
 271     $http_date = http_date($epoch_time);
 272
 273 Convert an epoch time into a date format suitable for HTTP.
 274
 275 =head2 parse_http_date
 276
 277     $epoch_time = parse_http_date($http_date);
 278
 279 Convert an HTTP date into an epoch time. Returns undef if the date cannot be parsed.
 280
 281 =head2 uri_escape
 282
 283     $escaped = uri_escape($unescaped);
 284
 285 Escape a string for use in a URL query param or as C<application/x-www-form-urlencoded> data.
 286
 287 =head2 www_form_urlencode
 288
 289     $bytes = www_form_urlencode(\%form_data);
 290     $bytes = www_form_urlencode(\@form_data);
 291
 292 Encode a hashref or arrayref as C<application/x-www-form-urlencoded> data.
 293
 294 =head1 BUGS
 295
 296 Please report any bugs or feature requests on the bugtracker website
 297 L<https://github.com/chazmcgarvey/HTTP-AnyUA/issues>
 298
 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
 301 feature.
 302
 303 =head1 AUTHOR
 304
 305 Charles McGarvey <chazmcgarvey@brokenzipper.com>
 306
 307 =head1 COPYRIGHT AND LICENSE
 308
 309 This software is copyright (c) 2017 by Charles McGarvey.
 310
 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.
 313
 314 =cut