local-lib5/lib/perl5/HTTP/Server/Simple/CGI/Environment.pm

   1
   2 package HTTP::Server::Simple::CGI::Environment;
   3
   4 use strict;
   5 use warnings;
   6 use HTTP::Server::Simple;
   7
   8 use vars qw($VERSION %ENV_MAPPING);
   9 $VERSION = $HTTP::Server::Simple::VERSION;
  10
  11 my %clean_env = %ENV;
  12
  13 =head1 NAME
  14
  15 HTTP::Server::Simple::CGI::Environment - a HTTP::Server::Simple mixin to provide the CGI protocol
  16
  17 =head1 DESCRIPTION
  18
  19 This mixin abstracts the CGI protocol out from
  20 L<HTTP::Server::Simple::CGI> so that it's easier to provide your own
  21 CGI handlers with L<HTTP::Server::Simple> which B<don't> use CGI.pm
  22
  23 =head2 setup_environment
  24
  25 C<setup_environemnt> is usually called in the superclass's accept_hook
  26
  27 This routine in this sub-class clears the environment to the
  28 start-up state.
  29
  30 =cut
  31
  32 sub setup_environment {
  33     %ENV = (
  34         %clean_env,
  35         SERVER_SOFTWARE   => "HTTP::Server::Simple/$VERSION",
  36         GATEWAY_INTERFACE => 'CGI/1.1'
  37     );
  38 }
  39
  40 =head2 setup_server_url
  41
  42 Sets up the C<SERVER_URL> environment variable
  43
  44 =cut
  45
  46 sub setup_server_url {
  47     $ENV{SERVER_URL}
  48         ||= ( "http://" . ($ENV{SERVER_NAME} || 'localhost') . ":" . ( $ENV{SERVER_PORT}||80) . "/" );
  49 }
  50
  51 =head2 setup_environment_from_metadata
  52
  53 This method sets up CGI environment variables based on various
  54 meta-headers, like the protocol, remote host name, request path, etc.
  55
  56 See the docs in L<HTTP::Server::Simple> for more detail.
  57
  58 =cut
  59
  60 %ENV_MAPPING = (
  61     protocol     => "SERVER_PROTOCOL",
  62     localport    => "SERVER_PORT",
  63     localname    => "SERVER_NAME",
  64     path         => "PATH_INFO",
  65     request_uri  => "REQUEST_URI",
  66     method       => "REQUEST_METHOD",
  67     peeraddr     => "REMOTE_ADDR",
  68     peername     => "REMOTE_HOST",
  69     query_string => "QUERY_STRING",
  70 );
  71
  72 sub setup_environment_from_metadata {
  73     no warnings 'uninitialized';
  74     my $self = shift;
  75
  76     # XXX TODO: rather than clone functionality from the base class,
  77     # we should call super
  78     #
  79     while ( my ( $item, $value ) = splice @_, 0, 2 ) {
  80         if ( my $k = $ENV_MAPPING{$item} ) {
  81             $ENV{$k} = $value;
  82         }
  83     }
  84
  85     # Apache and lighttpd both do one layer of unescaping on
  86     # path_info; we should duplicate that.
  87     $ENV{PATH_INFO} = URI::Escape::uri_unescape($ENV{PATH_INFO});
  88 }
  89
  90 =head2  header
  91
  92 C<header> turns a single HTTP headers into CGI environment variables.
  93
  94 =cut
  95
  96 sub header {
  97     my $self  = shift;
  98     my $tag   = shift;
  99     my $value = shift;
 100
 101     $tag = uc($tag);
 102     $tag =~ s/^COOKIES$/COOKIE/;
 103     $tag =~ s/-/_/g;
 104     $tag = "HTTP_" . $tag
 105         unless $tag =~ m/^(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)$/;
 106
 107     if ( exists $ENV{$tag} ) {
 108         $ENV{$tag} .= ", $value";
 109     }
 110     else {
 111         $ENV{$tag} = $value;
 112     }
 113 }
 114
 115 1;