[svn:mod_parrot] r515 - mod_parrot/trunk/languages/perl6/lib/ModPerl6

Author: jhorwitz
Date: Thu Dec  4 09:14:48 2008
New Revision: 515

Modified:
   mod_parrot/trunk/languages/perl6/lib/ModPerl6/Registry.pm

Log:
ModPerl6::Registry handles ParseHeaders until we have an output filter to do it


Modified: mod_parrot/trunk/languages/perl6/lib/ModPerl6/Registry.pm
==============================================================================
--- mod_parrot/trunk/languages/perl6/lib/ModPerl6/Registry.pm	(original)
+++ mod_parrot/trunk/languages/perl6/lib/ModPerl6/Registry.pm	Thu Dec  4 09:14:48 2008
@@ -8,6 +8,7 @@
 use ModPerl6::Fudge;
 
 our %registry;
+regex header_regex { ^^ ([\w|'-']+) ':' <ws> (\N+) $$ };
 
 sub gen_module_name($path)
 {
@@ -17,8 +18,43 @@
     return "ModPerl6::Registry::Script::$name";
 }
 
+# this is temporary until mod_parrot supports output filters
+sub parse_headers($r, $buf is rw)
+{
+    my $headers_out = $r.headers_out();
+    my $top;
+    my $bottom;
+    if ($buf ~~ /^([\N+\n]+)\n(.*)/) {
+        $top = ~$0;
+        $bottom = ~$1;
+    }
+    else {
+        $top = $buf;
+        $bottom = '';
+    }
+    my $n = 0;
+    $top .= chomp;
+    while ($top ~~ /<header_regex>/) {
+        $n++;
+        my $key = $<header_regex>[0];
+        my $val = $<header_regex>[1];
+        given $key.lc {
+            when 'content-type' { $r.content_type($val); }
+            default { $headers_out.set($key, $val); }
+        }
+        $top .= subst(/<header_regex>/, '');
+    }
+
+    # modify the output only if we found headers
+    if ($n++) {
+        $buf = $bottom;
+    }
+}
+
 sub handler($r)
 {
+    my %cfg = ModParrot::Apache::Module::get_config("modparrot_perl6_module");
+
     my $script = $r.filename();
     unless (%registry{$script}) {
         my $data = slurp $script;
@@ -58,6 +94,10 @@
     my $buf = $interp.dump_stdout();
     $interp.capture_stdout(0);
 
+    if (%cfg<options><parseheaders>) {
+        parse_headers($r, $buf);
+    }
+
     # should probably be write()
     $r.puts($buf);