Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/App/PSGI.pm

   1 package CGI::Ex::App::PSGI;
   2
   3 use strict;
   4 use Plack::Util;
   5 use CGI::Ex;
   6 use CGI::PSGI;
   7
   8 our $VERSION = '2.37';
   9
  10 sub psgi_app {
  11     my ($class, $app) = @_;
  12
  13     Plack::Util::load_class($app);
  14     sub {
  15         my $env = shift;
  16         my $cgix = CGI::Ex->new(object => CGI::PSGI->new($env));
  17         if ($env->{'psgi.streaming'}) {
  18             sub {
  19                 local $CGI::Ex::CURRENT = $cgix;
  20                 local %ENV              = (%ENV, $class->cgi_environment($env));
  21                 local *STDIN            = $env->{'psgi.input'};
  22                 local *STDERR           = $env->{'psgi.errors'};
  23
  24                 $cgix->{psgi_responder} = shift;
  25                 $app->new(
  26                     cgix        => $cgix,
  27                     script_name => $env->{SCRIPT_NAME},
  28                     path_info   => $env->{PATH_INFO},
  29                 )->navigate->cgix->psgi_respond->close;
  30             };
  31         } else {
  32             local $CGI::Ex::CURRENT = $cgix;
  33             local %ENV              = (%ENV, $class->cgi_environment($env));
  34             local *STDIN            = $env->{'psgi.input'};
  35             local *STDERR           = $env->{'psgi.errors'};
  36
  37             $app->new(cgix => $cgix)->navigate->cgix->psgi_response;
  38         }
  39     };
  40 }
  41
  42 ### Convert a PSGI environment into a CGI environment.
  43 sub cgi_environment {
  44     my ($class, $env) = @_;
  45
  46     my $environment = {
  47         GATEWAY_INTERFACE   => 'CGI/1.1',
  48         HTTPS               => $env->{'psgi.url_scheme'} eq 'https' ? 'ON' : 'OFF',
  49         SERVER_SOFTWARE     => "CGI-Ex-App-PSGI/$VERSION",
  50         REMOTE_ADDR         => '127.0.0.1',
  51         REMOTE_HOST         => 'localhost',
  52         map { $_ => $env->{$_} } grep { !/^psgix?\./ } keys %$env,
  53     };
  54
  55     return wantarray ? %$environment : $environment;
  56 }
  57
  58 1;