lib/Web/Dispatch/ParamParser.pm

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