lib/Web/Dispatch/ParamParser.pm

   1 package Web::Dispatch::ParamParser;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 sub UNPACKED_QUERY () { __PACKAGE__.'.unpacked_query' }
   7 sub UNPACKED_BODY () { __PACKAGE__.'.unpacked_body' }
   8 sub UNPACKED_BODY_OBJECT () { __PACKAGE__.'.unpacked_body_object' }
   9 sub UNPACKED_UPLOADS () { __PACKAGE__.'.unpacked_uploads' }
  10
  11 sub get_unpacked_query_from {
  12   return $_[0]->{+UNPACKED_QUERY} ||= do {
  13     _unpack_params($_[0]->{QUERY_STRING})
  14   };
  15 }
  16
  17 sub get_unpacked_body_from {
  18   return $_[0]->{+UNPACKED_BODY} ||= do {
  19     my $ct = lc($_[0]->{CONTENT_TYPE}||'');
  20     if (!$_[0]->{CONTENT_LENGTH}) {
  21       {}
  22     } elsif (index($ct, 'application/x-www-form-urlencoded') >= 0) {
  23       $_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH});
  24       _unpack_params($buf);
  25     } elsif (index($ct, 'multipart/form-data') >= 0) {
  26       my $p = get_unpacked_body_object_from($_[0])->param;
  27       # forcible arrayification
  28       +{
  29         map +(ref($p->{$_}) eq 'ARRAY'
  30                ? ($_ => $p->{$_})
  31                : ($_ => [ $p->{$_} ])
  32              ), keys %$p
  33       };
  34     } else {
  35       {}
  36     }
  37   };
  38 }
  39
  40 sub get_unpacked_body_object_from {
  41   # we may have no object at all - so use a single element arrayref for ||=
  42   return ($_[0]->{+UNPACKED_BODY_OBJECT} ||= do {
  43     if (!$_[0]->{CONTENT_LENGTH}) {
  44       [ undef ]
  45     } elsif (index(lc($_[0]->{CONTENT_TYPE}||''),'multipart/form-data')==-1) {
  46       [ undef ]
  47     } else {
  48       [ _make_http_body($_[0]) ]
  49     }
  50   })->[0];
  51 }
  52
  53 sub get_unpacked_uploads_from {
  54   $_[0]->{+UNPACKED_UPLOADS} ||= do {
  55     require Web::Dispatch::Upload; require HTTP::Headers;
  56     my ($final, $reason) = (
  57       {}, "field %s exists with value %s but body was not multipart/form-data"
  58     );
  59     if (my $body = get_unpacked_body_object_from($_[0])) {
  60       my $u = $body->upload;
  61       $reason = "field %s exists with value %s but was not an upload";
  62       foreach my $k (keys %$u) {
  63         foreach my $v (ref($u->{$k}) eq 'ARRAY' ? @{$u->{$k}} : $u->{$k}) {
  64           push(@{$final->{$k}||=[]}, Web::Dispatch::Upload->new(
  65             %{$v},
  66             headers => HTTP::Headers->new($v->{headers})
  67           ));
  68         }
  69       }
  70     }
  71     my $b = get_unpacked_body_from($_[0]);
  72     foreach my $k (keys %$b) {
  73       next if $final->{$k};
  74       foreach my $v (@{$b->{$k}}) {
  75         next unless $v;
  76         push(@{$final->{$k}||=[]}, Web::Dispatch::NotAnUpload->new(
  77           filename => $v,
  78           reason => sprintf($reason, $k, $v)
  79         ));
  80       }
  81     }
  82     $final;
  83   };
  84 }
  85
  86 {
  87   # shamelessly stolen from HTTP::Body::UrlEncoded by Christian Hansen
  88
  89   my $DECODE = qr/%([0-9a-fA-F]{2})/;
  90
  91   my %hex_chr;
  92
  93   foreach my $num ( 0 .. 255 ) {
  94     my $h = sprintf "%02X", $num;
  95     $hex_chr{ lc $h } = $hex_chr{ uc $h } = chr $num;
  96   }
  97
  98   sub _unpack_params {
  99     my %unpack;
 100     (my $params = $_[0]) =~ s/\+/ /g;
 101     my ($name, $value);
 102     foreach my $pair (split(/[&;](?:\s+)?/, $params)) {
 103       next unless (($name, $value) = split(/=/, $pair, 2)) == 2;
 104
 105       s/$DECODE/$hex_chr{$1}/gs for ($name, $value);
 106
 107       push(@{$unpack{$name}||=[]}, $value);
 108     }
 109     \%unpack;
 110   }
 111 }
 112
 113 {
 114   # shamelessly stolen from Plack::Request by miyagawa
 115
 116   sub _make_http_body {
 117
 118     # Can't actually do this yet, since Plack::Request deletes the
 119     # header structure out of the uploads in its copy of the body.
 120     # I suspect I need to supply miyagawa with a failing test.
 121
 122     #if (my $plack_body = $_[0]->{'plack.request.http.body'}) {
 123     #  # Plack already constructed one; probably wasteful to do it again
 124     #  return $plack_body;
 125     #}
 126
 127     require HTTP::Body;
 128     my $body = HTTP::Body->new(@{$_[0]}{qw(CONTENT_TYPE CONTENT_LENGTH)});
 129     $body->cleanup(1);
 130     my $spin = 0;
 131     my $input = $_[0]->{'psgi.input'};
 132     my $cl = $_[0]->{CONTENT_LENGTH};
 133     while ($cl) {
 134       $input->read(my $chunk, $cl < 8192 ? $cl : 8192);
 135       my $read = length $chunk;
 136       $cl -= $read;
 137       $body->add($chunk);
 138
 139       if ($read == 0 && $spin++ > 2000) {
 140         require Carp;
 141         Carp::croak("Bad Content-Length: maybe client disconnect? ($cl bytes remaining)");
 142       }
 143     }
 144     return $body;
 145   }
 146 }
 147
 148 1;