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
   9 sub get_unpacked_query_from {
  10   return $_[0]->{+UNPACKED_QUERY} ||= do {
  11     _unpack_params($_[0]->{QUERY_STRING})
  12   };
  13 }
  14
  15 sub get_unpacked_body_from {
  16   return $_[0]->{+UNPACKED_BODY} ||= do {
  17       ## would really like to check to make sure it processes charset stuff appropriately
  18       ## add tests for such.  Long story short, I'm looking at making sure we're good for this:
  19       ## https://gist.github.com/fc3d095dfd089762ed62
  20       if (index(lc($_[0]->{CONTENT_TYPE}||''), 'application/x-www-form-urlencoded') >= 0
  21         and defined $_[0]->{CONTENT_LENGTH}) {
  22       $_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH});
  23       _unpack_params($buf);
  24     } else {
  25       {}
  26     }
  27   };
  28 }
  29
  30
  31 {
  32   # shamelessly stolen from HTTP::Body::UrlEncoded by Christian Hansen
  33
  34   my $DECODE = qr/%([0-9a-fA-F]{2})/;
  35
  36   my %hex_chr;
  37
  38   foreach my $num ( 0 .. 255 ) {
  39     my $h = sprintf "%02X", $num;
  40     $hex_chr{ lc $h } = $hex_chr{ uc $h } = chr $num;
  41   }
  42
  43   sub _unpack_params {
  44     my %unpack;
  45     (my $params = $_[0]) =~ s/\+/ /g;
  46     my ($name, $value);
  47     foreach my $pair (split(/[&;](?:\s+)?/, $params)) {
  48       next unless (($name, $value) = split(/=/, $pair, 2)) == 2;
  49
  50       s/$DECODE/$hex_chr{$1}/gs for ($name, $value);
  51
  52       push(@{$unpack{$name}||=[]}, $value);
  53     }
  54     \%unpack;
  55   }
  56 }
  57
  58 1;