view release on metacpan or  search on metacpan

examples/fatpacked.plackup  view on Meta::CPAN

              %env,
              'psgi.version'      => [1,1],
              'psgi.url_scheme'   => ($env{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
              'psgi.input'        => $self->{stdin},
              'psgi.errors'       => 
                  ($self->{keep_stderr} ? \*STDERR : $self->{stderr}),
              'psgi.multithread'  => Plack::Util::FALSE,
              'psgi.multiprocess' => defined $proc_manager,
              'psgi.run_once'     => Plack::Util::FALSE,
              'psgi.streaming'    => Plack::Util::TRUE,
              'psgi.nonblocking'  => Plack::Util::FALSE,
              'psgix.harakiri'    => defined $proc_manager,
              'psgix.cleanup'     => 1,
              'psgix.cleanup.handlers' => [],
          };
  
          delete $env->{HTTP_CONTENT_TYPE};
          delete $env->{HTTP_CONTENT_LENGTH};
  
          # lighttpd munges multiple slashes in PATH_INFO into one. Try recovering it
          my $uri = URI->new("http://localhost" .  $env->{REQUEST_URI});
          $env->{PATH_INFO} = uri_unescape($uri->path);
          $env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E//;
  
          # root access for mod_fastcgi
          if (!exists $env->{PATH_INFO}) {
              $env->{PATH_INFO} = '';
          }
  
          # typical fastcgi_param from nginx might get empty values
          for my $key (qw(CONTENT_TYPE CONTENT_LENGTH)) {
              no warnings;
              delete $env->{$key} if exists $env->{$key} && $env->{$key} eq '';
          }
  
          if (defined(my $HTTP_AUTHORIZATION = $env->{Authorization})) {
              $env->{HTTP_AUTHORIZATION} = $HTTP_AUTHORIZATION;
          }
  
          my $res = Plack::Util::run_app $app, $env;
  
          if (ref $res eq 'ARRAY') {
              $self->_handle_response($res);
          }
          elsif (ref $res eq 'CODE') {
              $res->(sub {
                  $self->_handle_response($_[0]);
              });
          }
          else {
              die "Bad response $res";
          }
  
          # give pm_post_dispatch the chance to do things after the client thinks
          # the request is done
          $request->Finish;
  
          $proc_manager && $proc_manager->pm_post_dispatch();
  
          # When the fcgi-manager exits it sends a TERM signal to the workers.
          # However, if we're busy processing the cleanup handlers, testing
          # shows that the worker doesn't actually exit in that case.
          # Trapping the TERM signal and finshing up fixes that.
          my $exit_due_to_signal = 0;
          if ( @{ $env->{'psgix.cleanup.handlers'} || [] } ) {
              local $SIG{TERM} = sub { $exit_due_to_signal = 1 };
              for my $handler ( @{ $env->{'psgix.cleanup.handlers'} } ) {
                  $handler->($env);
              }
          }
  
          if ($proc_manager && $env->{'psgix.harakiri.commit'}) {
              $proc_manager->pm_exit("safe exit with harakiri");
          }
          elsif ($exit_due_to_signal) {
              $proc_manager && $proc_manager->pm_exit("safe exit due to signal");
              exit;    # want to exit, even without a $proc_manager
          }
      }
  }
  
  sub _handle_response {
      my ($self, $res) = @_;
  
      $self->{stdout}->autoflush(1);
      binmode $self->{stdout};
  
      my $hdrs;
      my $message = status_message($res->[0]);
      $hdrs = "Status: $res->[0] $message\015\012";
  
      my $headers = $res->[1];
      while (my ($k, $v) = splice @$headers, 0, 2) {
          $hdrs .= "$k: $v\015\012";
      }
      $hdrs .= "\015\012";
  
      print { $self->{stdout} } $hdrs;
  
      my $cb = sub { print { $self->{stdout} } $_[0] };
      my $body = $res->[2];
      if (defined $body) {
          Plack::Util::foreach($body, $cb);
      }
      else {
          return Plack::Util::inline_object
              write => $cb,
              close => sub { };
      }
  }
  
  sub daemon_fork {
      require POSIX;
      fork && exit;
  }
  
  sub daemon_detach {
      my $self = shift;
      print "FastCGI daemon started (pid $$)\n";
      open STDIN,  "+</dev/null" or die $!; ## no critic
      open STDOUT, ">&STDIN"     or die $!;