From: Charles McGarvey <chazmcgarvey@brokenzipper.com>
Date: Sun, 11 May 2014 07:50:06 +0000 (-0600)
Subject: add PSGI handler
X-Git-Url: https://git.brokenzipper.com/gitweb?a=commitdiff_plain;h=refs%2Fheads%2Fmaster;p=chaz%2Fp5-CGI-Ex

add PSGI handler
---

diff --git a/MANIFEST b/MANIFEST
index 61e40eb..fdebb94 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -16,6 +16,7 @@ lib/CGI/Ex/validate.js
 lib/CGI/Ex/Validate.pm
 lib/CGI/Ex/Validate.pod
 lib/CGI/Ex/yaml_load.js
+lib/CGI/Ex/App/PSGI.pm
 Makefile.PL
 MANIFEST
 MANIFEST.SKIP
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
index df427d3..33a3c04 100644
--- a/MANIFEST.SKIP
+++ b/MANIFEST.SKIP
@@ -14,3 +14,5 @@ WrapEx.pm
 cover_db
 Var.pm
 Tutorial.pod
+.git/
+.gitignore
diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm
index b18f5ee..1ce99a2 100644
--- a/lib/CGI/Ex.pm
+++ b/lib/CGI/Ex.pm
@@ -19,6 +19,7 @@ use vars qw($VERSION
             $PREFERRED_CGI_REQUIRED
             $AUTOLOAD
             $DEBUG_LOCATION_BOUNCE
+            $CURRENT
             @EXPORT @EXPORT_OK
             );
 use base qw(Exporter);
@@ -218,6 +219,39 @@ sub cookies {
 
 ###----------------------------------------------------------------###
 
+### Get whether or not we are running as a PSGI app
+#   my $app = CGI::Ex::App::PSGI->psgi_app('Foo::Bar::App');
+#   $app->is_psgi; # is true
+sub is_psgi { shift->object->isa('CGI::PSGI') }
+
+### Allow for generating a PSGI response
+sub psgi_response {
+    my $self = shift;
+
+    $self->{psgi_responded} = 1;
+    $self->print_content_type;
+
+    if (my $location = $self->{psgi_location}) {
+        return [302, ['Content-Type' => 'text/html', Location => $location], ["Bounced to $location\n"]];
+    } else {
+        return [$self->{psgi_status} || 200, $self->{psgi_headers} || [], $self->{psgi_body} || ['']];
+    }
+}
+
+### Allow for sending a PSGI streaming/delayed response
+sub psgi_respond {
+    my $self = shift;
+    if ($self->{psgi_responder}) {
+        my $response = $self->psgi_response;
+        delete $response->[2];
+        $self->{psgi_writer} = $self->{psgi_responder}->($response);
+        delete $self->{psgi_responder};
+    }
+    $self->{psgi_writer};
+}
+
+###----------------------------------------------------------------###
+
 ### Allow for shared apache request object
 #   my $r = $cgix->apache_request
 #   $cgix->apache_request($r);
@@ -240,6 +274,30 @@ sub set_apache_request { shift->apache_request(shift) }
 
 ###----------------------------------------------------------------###
 
+### Portable method for printing the document content
+sub print_body {
+    my $self = shift || __PACKAGE__->new;
+
+    if ($self->is_psgi) {
+        if (my $writer = $self->psgi_respond) {
+            $writer->write($_) for (@_);
+        } else {
+            push @{$self->{psgi_body} ||= []}, $_ for (@_);
+        }
+    } else {
+        print <FH>;
+    }
+}
+
+### Portable method for getting environment variables
+sub env {
+    my $self = shift || __PACKAGE__->new;
+
+    $self->is_psgi ? $self->object->env : \%ENV;
+}
+
+###----------------------------------------------------------------###
+
 ### same signature as print_content_type
 sub content_type { &print_content_type }
 
@@ -259,7 +317,13 @@ sub print_content_type {
     }
     $type .= "; charset=$charset" if $charset && $charset =~ m|^[\w\-\.\:\+]+$|;
 
-    if (my $r = $self->apache_request) {
+    if ($self->is_psgi) {
+        if (! $self->env->{'cgix.content_typed'}) {
+            push @{$self->{psgi_headers} ||= []}, ('Content-Type' => $type);
+            $self->env->{'cgix.content_typed'} = '';
+        }
+        $self->env->{'cgix.content_typed'} .= sprintf("%s, %d\n", (caller)[1,2]);
+    } elsif (my $r = $self->apache_request) {
         return if $r->bytes_sent;
         $r->content_type($type);
         $r->send_http_header if $self->is_mod_perl_1;
@@ -278,7 +342,9 @@ sub print_content_type {
 sub content_typed {
     my $self = shift || __PACKAGE__->new;
 
-    if (my $r = $self->apache_request) {
+    if ($self->is_psgi) {
+        return $self->{psgi_responded};
+    } elsif (my $r = $self->apache_request) {
         return $r->bytes_sent;
     } else {
         return $ENV{'CONTENT_TYPED'} ? 1 : undef;
@@ -297,11 +363,14 @@ sub location_bounce {
 
     if ($self->content_typed) {
         if ($DEBUG_LOCATION_BOUNCE) {
-            print "<a class=debug href=\"$loc\">Location: $loc</a><br />\n";
+            $self->print_body("<a class=debug href=\"$loc\">Location: $loc</a><br />\n");
         } else {
-            print "<meta http-equiv=\"refresh\" content=\"0;url=$loc\" />\n";
+            $self->print_body("<meta http-equiv=\"refresh\" content=\"0;url=$loc\" />\n");
         }
 
+    } elsif ($self->is_psgi) {
+        $self->{psgi_location} = $loc;
+
     } elsif (my $r = $self->apache_request) {
         $r->status(302);
         if ($self->is_mod_perl_1) {
@@ -346,17 +415,17 @@ sub set_cookie {
     my $cookie = "" . $obj->cookie(%$args);
 
     if ($self->content_typed) {
-        print "<meta http-equiv=\"Set-Cookie\" content=\"$cookie\" />\n";
-    } else {
-        if (my $r = $self->apache_request) {
-            if ($self->is_mod_perl_1) {
-                $r->header_out("Set-cookie", $cookie);
-            } else {
-                $r->headers_out->add("Set-Cookie", $cookie);
-            }
+        $self->print_body("<meta http-equiv=\"Set-Cookie\" content=\"$cookie\" />\n");
+    } elsif ($self->is_psgi) {
+        push @{$self->{psgi_headers} ||= []}, ('Set-Cookie' => $cookie);
+    } elsif (my $r = $self->apache_request) {
+        if ($self->is_mod_perl_1) {
+            $r->header_out("Set-cookie", $cookie);
         } else {
-            print "Set-Cookie: $cookie\r\n";
+            $r->headers_out->add("Set-Cookie", $cookie);
         }
+    } else {
+        print "Set-Cookie: $cookie\r\n";
     }
 }
 
@@ -376,7 +445,9 @@ sub last_modified {
     $time = scalar gmtime time_calc($time);
 
     if ($self->content_typed) {
-        print "<meta http-equiv=\"$key\" content=\"$time\" />\n";
+        $self->print_body("<meta http-equiv=\"$key\" content=\"$time\" />\n");
+    } elsif ($self->is_psgi) {
+        push @{$self->{psgi_headers} ||= []}, ($key => $time);
     } elsif (my $r = $self->apache_request) {
         if ($self->is_mod_perl_1) {
             $r->header_out($key, $time);
@@ -434,7 +505,10 @@ sub send_status {
     if ($self->content_typed) {
         die "Cannot send a status ($code - $mesg) after content has been sent";
     }
-    if (my $r = $self->apache_request) {
+    if ($self->is_psgi) {
+        $self->{psgi_status} = $code;
+        $self->print_body($mesg);
+    } elsif (my $r = $self->apache_request) {
         $r->status($code);
         if ($self->is_mod_perl_1) {
             $r->content_type('text/html');
@@ -460,7 +534,9 @@ sub send_header {
     if ($self->content_typed) {
         die "Cannot send a header ($key - $val) after content has been sent";
     }
-    if (my $r = $self->apache_request) {
+    if ($self->is_psgi) {
+        push @{$self->{psgi_headers} ||= []}, ($key => $val);
+    } elsif (my $r = $self->apache_request) {
         if ($self->is_mod_perl_1) {
             $r->header_out($key, $val);
         } else {
@@ -501,7 +577,7 @@ sub print_js {
         if (! $self->content_typed) {
             $self->send_status(404, "JS File not found for print_js\n");
         } else {
-            print "<h1>JS File not found for print_js</h1>\n";
+            $self->print_body("<h1>JS File not found for print_js</h1>\n");
         }
         return;
     }
@@ -513,13 +589,13 @@ sub print_js {
         $self->print_content_type('application/x-javascript');
     }
 
-    return if $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'HEAD';
+    return if $self->env->{'REQUEST_METHOD'} && $self->env->{'REQUEST_METHOD'} eq 'HEAD';
 
     ### send the contents
     local *FH;
     open(FH, "<$js_file") || die "Couldn't open file  $js_file: $!";
     local $/ = undef;
-    print <FH>;
+    $self->print_body(<FH>);
     close FH;
 }
 
diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm
index 78a9d47..9b4f8c4 100644
--- a/lib/CGI/Ex/App.pm
+++ b/lib/CGI/Ex/App.pm
@@ -281,10 +281,10 @@ sub history            { $_[0]->{'history'}        ||= []           }
 sub js_step            { $_[0]->{'js_step'}        || 'js'          }
 sub login_step         { $_[0]->{'login_step'}     || '__login'     }
 sub mimetype           { $_[0]->{'mimetype'}       ||  'text/html'  }
-sub path_info          { $_[0]->{'path_info'}      ||  $ENV{'PATH_INFO'}   || '' }
+sub path_info          { defined $_[0]->{'path_info'}   ? $_[0]->{'path_info'}   :  $_[0]->cgix->env->{'PATH_INFO'}   || '' }
 sub path_info_map_base { $_[0]->{'path_info_map_base'} ||[[qr{/(\w+)}, $_[0]->step_key]] }
 sub recurse_limit      { $_[0]->{'recurse_limit'}  ||  15                   }
-sub script_name        { $_[0]->{'script_name'}    ||  $ENV{'SCRIPT_NAME'} || $0 }
+sub script_name        { defined $_[0]->{'script_name'} ? $_[0]->{'script_name'} :  $_[0]->cgix->env->{'SCRIPT_NAME'} || $0 }
 sub stash              { $_[0]->{'stash'}          ||= {}    }
 sub step_key           { $_[0]->{'step_key'}       || 'step' }
 sub template_args      { $_[0]->{'template_args'} }
@@ -781,7 +781,7 @@ sub prepare    { 1 } # false means show step
 sub print_out {
     my ($self, $step, $out) = @_;
     $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
-    print ref($out) eq 'SCALAR' ? $$out : $out;
+    $self->cgix->print_body(ref($out) eq 'SCALAR' ? $$out : $out);
 }
 
 sub ready_validate {
@@ -792,7 +792,7 @@ sub ready_validate {
             return (grep { exists $form->{$_} } @keys) ? 1 : 0;
         }
     }
-    return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
+    return ($self->cgix->env->{'REQUEST_METHOD'} && $self->cgix->env->{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
 }
 
 sub refine_path {
@@ -808,7 +808,7 @@ sub refine_path {
 sub set_ready_validate { # hook and method
     my $self = shift;
     my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
-    $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
+    $self->cgix->env->{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
     return $is_ready;
 }
 
diff --git a/lib/CGI/Ex/App/PSGI.pm b/lib/CGI/Ex/App/PSGI.pm
new file mode 100644
index 0000000..e5084d7
--- /dev/null
+++ b/lib/CGI/Ex/App/PSGI.pm
@@ -0,0 +1,58 @@
+package CGI::Ex::App::PSGI;
+
+use strict;
+use Plack::Util;
+use CGI::Ex;
+use CGI::PSGI;
+
+our $VERSION = '2.37';
+
+sub psgi_app {
+    my ($class, $app) = @_;
+
+    Plack::Util::load_class($app);
+    sub {
+        my $env = shift;
+        my $cgix = CGI::Ex->new(object => CGI::PSGI->new($env));
+        if ($env->{'psgi.streaming'}) {
+            sub {
+                local $CGI::Ex::CURRENT = $cgix;
+                local %ENV              = (%ENV, $class->cgi_environment($env));
+                local *STDIN            = $env->{'psgi.input'};
+                local *STDERR           = $env->{'psgi.errors'};
+
+                $cgix->{psgi_responder} = shift;
+                $app->new(
+                    cgix        => $cgix,
+                    script_name => $env->{SCRIPT_NAME},
+                    path_info   => $env->{PATH_INFO},
+                )->navigate->cgix->psgi_respond->close;
+            };
+        } else {
+            local $CGI::Ex::CURRENT = $cgix;
+            local %ENV              = (%ENV, $class->cgi_environment($env));
+            local *STDIN            = $env->{'psgi.input'};
+            local *STDERR           = $env->{'psgi.errors'};
+
+            $app->new(cgix => $cgix)->navigate->cgix->psgi_response;
+        }
+    };
+}
+
+### Convert a PSGI environment into a CGI environment.
+sub cgi_environment {
+    my ($class, $env) = @_;
+
+    my $environment = {
+        GATEWAY_INTERFACE   => 'CGI/1.1',
+        HTTPS               => $env->{'psgi.url_scheme'} eq 'https' ? 'ON' : 'OFF',
+        SERVER_SOFTWARE     => "CGI-Ex-App-PSGI/$VERSION",
+        REMOTE_ADDR         => '127.0.0.1',
+        REMOTE_HOST         => 'localhost',
+        map { $_ => $env->{$_} } grep { !/^psgix?\./ } keys %$env,
+    };
+
+    return wantarray ? %$environment : $environment;
+}
+
+1;
diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm
index 574eae5..d3f84b4 100644
--- a/lib/CGI/Ex/Dump.pm
+++ b/lib/CGI/Ex/Dump.pm
@@ -111,7 +111,7 @@ sub _what_is_this {
     return $html if $called eq 'dex_html';
     require CGI::Ex;
     CGI::Ex::print_content_type();
-    print $html;
+    ($CGI::Ex::CURRENT || CGI::Ex->new)->print_body($html);
   }
   return @_[0..$#_];
 }
diff --git a/lib/CGI/Ex/Validate.pm b/lib/CGI/Ex/Validate.pm
index 450fa2e..45c26f8 100644
--- a/lib/CGI/Ex/Validate.pm
+++ b/lib/CGI/Ex/Validate.pm
@@ -660,10 +660,11 @@ sub get_validation_keys {
 ###---------------------###
 
 sub generate_js {
+    my $self = shift;
+
     return "<!-- JS validation not supported in this browser $_ -->"
-        if $ENV{'HTTP_USER_AGENT'} && grep {$ENV{'HTTP_USER_AGENT'} =~ $_} @UNSUPPORTED_BROWSERS;
+        if $self->cgix->env->{'HTTP_USER_AGENT'} && grep {$self->cgix->env->{'HTTP_USER_AGENT'} =~ $_} @UNSUPPORTED_BROWSERS;
 
-    my $self = shift;
     my $val_hash = shift || croak "Missing validation hash";
     if (ref $val_hash ne 'HASH') {
         $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash;