From 85fc25755c716b7cec223d72c8e8b0fe994e26d3 Mon Sep 17 00:00:00 2001 From: Charles McGarvey Date: Sun, 11 May 2014 01:50:06 -0600 Subject: [PATCH] add PSGI handler --- MANIFEST | 1 + MANIFEST.SKIP | 2 + lib/CGI/Ex.pm | 114 ++++++++++++++++++++++++++++++++++------- lib/CGI/Ex/App.pm | 10 ++-- lib/CGI/Ex/App/PSGI.pm | 58 +++++++++++++++++++++ lib/CGI/Ex/Dump.pm | 2 +- lib/CGI/Ex/Validate.pm | 5 +- 7 files changed, 165 insertions(+), 27 deletions(-) create mode 100644 lib/CGI/Ex/App/PSGI.pm 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 ; + } +} + +### 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 "Location: $loc
\n"; + $self->print_body("Location: $loc
\n"); } else { - print "\n"; + $self->print_body("\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 "\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("\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 "\n"; + $self->print_body("\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 "

JS File not found for print_js

\n"; + $self->print_body("

JS File not found for print_js

\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 ; + $self->print_body(); 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 "" - 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; -- 2.43.0