$PREFERRED_CGI_REQUIRED
$AUTOLOAD
$DEBUG_LOCATION_BOUNCE
+ $CURRENT
@EXPORT @EXPORT_OK
);
use base qw(Exporter);
###----------------------------------------------------------------###
+### 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);
###----------------------------------------------------------------###
+### 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 }
}
$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;
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;
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) {
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";
}
}
$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);
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');
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 {
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;
}
$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;
}
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'} }
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 {
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 {
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;
}
--- /dev/null
+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;
projects / chaz / p5-CGI-Ex / commitdiff
