The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

BPS / HTTP-Server-Simple-0.52 / lib / HTTP / Server / Simple / CGI / Environment.pm 

            

              
1
2
3
4
5
6
7
8
9
10
—
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
—
38
39
40
41
42
43
44
45
46
47
48
—
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
—
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115

              
package HTTP::Server::Simple::CGI::Environment;
use strict;
use warnings;
use HTTP::Server::Simple;
use vars qw(%ENV_MAPPING);
my %clean_env = %ENV;
=head1 NAME
HTTP::Server::Simple::CGI::Environment - a HTTP::Server::Simple mixin to provide the CGI protocol
=head1 DESCRIPTION
This mixin abstracts the CGI protocol out from
L<HTTP::Server::Simple::CGI> so that it's easier to provide your own
CGI handlers with L<HTTP::Server::Simple> which B<don't> use CGI.pm
=head2 setup_environment
C<setup_environemnt> is usually called in the superclass's accept_hook
This routine in this sub-class clears the environment to the
start-up state.
=cut
sub setup_environment {
    %ENV = (
        %clean_env,
        SERVER_SOFTWARE   => "HTTP::Server::Simple/$HTTP::Server::Simple::VERSION",
        GATEWAY_INTERFACE => 'CGI/1.1'
    );
}
=head2 setup_server_url
Sets up the C<SERVER_URL> environment variable
=cut
sub setup_server_url {
    $ENV{SERVER_URL}
        ||= ( "http://" . ($ENV{SERVER_NAME} || 'localhost') . ":" . ( $ENV{SERVER_PORT}||80) . "/" );
}
=head2 setup_environment_from_metadata
This method sets up CGI environment variables based on various
meta-headers, like the protocol, remote host name, request path, etc.
See the docs in L<HTTP::Server::Simple> for more detail.
=cut
%ENV_MAPPING = (
    protocol     => "SERVER_PROTOCOL",
    localport    => "SERVER_PORT",
    localname    => "SERVER_NAME",
    path         => "PATH_INFO",
    request_uri  => "REQUEST_URI",
    method       => "REQUEST_METHOD",
    peeraddr     => "REMOTE_ADDR",
    peername     => "REMOTE_HOST",
    peerport     => "REMOTE_PORT",
    query_string => "QUERY_STRING",
);
sub setup_environment_from_metadata {
    no warnings 'uninitialized';
    my $self = shift;
    # XXX TODO: rather than clone functionality from the base class,
    # we should call super
    #
    while ( my ( $item, $value ) = splice @_, 0, 2 ) {
        if ( my $k = $ENV_MAPPING{$item} ) {
            $ENV{$k} = $value;
        }
    }
    # Apache and lighttpd both do one layer of unescaping on
    # path_info; we should duplicate that.
    $ENV{PATH_INFO} =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
}
=head2  header
C<header> turns a single HTTP headers into CGI environment variables.
=cut
sub header {
    my $self  = shift;
    my $tag   = shift;
    my $value = shift;
    $tag = uc($tag);
    $tag =~ s/^COOKIES$/COOKIE/;
    $tag =~ s/-/_/g;
    $tag = "HTTP_" . $tag
        unless $tag =~ m/^CONTENT_(?:LENGTH|TYPE)$/;
    if ( exists $ENV{$tag} ) {
        $ENV{$tag} .= $tag eq 'HTTP_COOKIE' ? "; $value" : ", $value";
    }
    else {
        $ENV{$tag} = $value;
    }
}
1;