isolate param matching in Predicates

[catagits/Web-Simple.git] / lib / Web / Dispatch / ParamParser.pm

diff --git a/lib/Web/Dispatch/ParamParser.pm b/lib/Web/Dispatch/ParamParser.pm
new file mode 100644 (file)
index 0000000..c665502
--- /dev/null
+++ b/lib/Web/Dispatch/ParamParser.pm
@@ -0,0 +1,54 @@
+package Web::Dispatch::ParamParser;
+
+use strict;
+use warnings FATAL => 'all';
+
+sub UNPACKED_QUERY () { __PACKAGE__.'.unpacked_query' }
+sub UNPACKED_BODY () { __PACKAGE__.'.unpacked_body' }
+
+sub get_unpacked_query_from {
+  return $_[0]->{+UNPACKED_QUERY} ||= do {
+    _unpack_params($_[0]->{QUERY_STRING})
+  };
+}
+
+sub get_unpacked_body_from {
+  return $_[0]->{+UNPACKED_BODY} ||= do {
+    if (($_[0]->{CONTENT_TYPE}||'') eq 'application/x-www-form-urlencoded'
+        and defined $_[0]->{CONTENT_LENGTH}) {
+      $_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH});
+      _unpack_params($buf);
+    } else {
+      {}
+    }
+  };
+}
+
+{
+  # shamelessly stolen from HTTP::Body::UrlEncoded by Christian Hansen
+
+  my $DECODE = qr/%([0-9a-fA-F]{2})/;
+
+  my %hex_chr;
+
+  foreach my $num ( 0 .. 255 ) {
+    my $h = sprintf "%02X", $num;
+    $hex_chr{ lc $h } = $hex_chr{ uc $h } = chr $num;
+  }
+
+  sub _unpack_params {
+    my %unpack;
+    (my $params = $_[0]) =~ s/\+/ /g;
+    my ($name, $value);
+    foreach my $pair (split(/[&;](?:\s+)?/, $params)) {
+      next unless (($name, $value) = split(/=/, $pair, 2)) == 2;
+        
+      s/$DECODE/$hex_chr{$1}/gs for ($name, $value);
+
+      push(@{$unpack{$name}||=[]}, $value);
+    }
+    \%unpack;
+  }
+}
+
+1;