File Coverage

blib/lib/HTTP/Server/Simple/CGI.pm
Criterion Covered Total %
statement 12 39 30.7
branch 0 8 0.0
condition 0 6 0.0
subroutine 4 11 36.3
pod 7 7 100.0
total 23 71 32.3


line stmt bran cond sub pod time code
1              
2             package HTTP::Server::Simple::CGI;
3              
4 3     3   26079 use base qw(HTTP::Server::Simple HTTP::Server::Simple::CGI::Environment);
  3         4  
  3         1435  
5 3     3   12 use strict;
  3         5  
  3         63  
6 3     3   10 use warnings;
  3         4  
  3         63  
7              
8 3     3   9 use vars qw($default_doc $DEFAULT_CGI_INIT $DEFAULT_CGI_CLASS);
  3         3  
  3         1078  
9              
10             $DEFAULT_CGI_CLASS = "CGI";
11             $DEFAULT_CGI_INIT = sub { require CGI; CGI::initialize_globals()};
12              
13              
14             =head1 NAME
15              
16             HTTP::Server::Simple::CGI - CGI.pm-style version of HTTP::Server::Simple
17              
18             =head1 DESCRIPTION
19              
20             HTTP::Server::Simple was already simple, but some smart-ass pointed
21             out that there is no CGI in HTTP, and so this module was born to
22             isolate the CGI.pm-related parts of this handler.
23              
24              
25             =head2 accept_hook
26              
27             The accept_hook in this sub-class clears the environment to the
28             start-up state.
29              
30             =cut
31              
32             sub accept_hook {
33 0     0 1   my $self = shift;
34 0           $self->setup_environment(@_);
35             }
36              
37             =head2 post_setup_hook
38              
39             Initializes the global L object, as well as other environment
40             settings.
41              
42             =cut
43              
44             sub post_setup_hook {
45 0     0 1   my $self = shift;
46 0           $self->setup_server_url;
47 0 0         if ( my $init = $self->cgi_init ) {
48 0           $init->();
49             }
50             }
51              
52             =head2 cgi_class [Classname]
53              
54             Gets or sets the class to use for creating the C<$cgi> object passed to
55             C.
56              
57             Called with a single argument, it sets the coderef. Called with no arguments,
58             it returns this field's current value.
59              
60             To provide an initialization subroutine to be run in the post_setup_hook,
61             see L.
62              
63             e.g.
64              
65             $server->cgi_class('CGI');
66              
67             $server->cgi_init(sub {
68             require CGI;
69             CGI::initialize_globals();
70             });
71              
72             or, if you want to use L,
73              
74             $server->cgi_class('CGI::Simple');
75             $server->cgi_init(sub {
76             require CGI::Simple;
77             });
78              
79             =cut
80              
81             sub cgi_class {
82 0     0 1   my $self = shift;
83 0 0         if (@_) {
84 0           $self->{cgi_class} = shift;
85             }
86 0   0       return $self->{cgi_class} || $DEFAULT_CGI_CLASS;
87             }
88              
89             =head2 cgi_init [CODEREF]
90              
91             A coderef to run in the post_setup_hook.
92              
93             Called with a single argument, it sets the coderef. Called with no arguments,
94             it returns this field's current value.
95              
96             =cut
97              
98             sub cgi_init {
99 0     0 1   my $self = shift;
100 0 0         if (@_) {
101 0           $self->{cgi_init} = shift;
102             }
103 0   0       return $self->{cgi_init} || $DEFAULT_CGI_INIT;
104            
105             }
106              
107              
108             =head2 setup
109              
110             This method sets up CGI environment variables based on various
111             meta-headers, like the protocol, remote host name, request path, etc.
112              
113             See the docs in L for more detail.
114              
115             =cut
116              
117             sub setup {
118 0     0 1   my $self = shift;
119 0           $self->setup_environment_from_metadata(@_);
120             }
121              
122             =head2 handle_request CGI
123              
124             This routine is called whenever your server gets a request it can
125             handle.
126              
127             It's called with a CGI object that's been pre-initialized.
128             You want to override this method in your subclass
129              
130              
131             =cut
132              
133             $default_doc = ( join "", );
134              
135             sub handle_request {
136 0     0 1   my ( $self, $cgi ) = @_;
137              
138 0           print "HTTP/1.0 200 OK\r\n"; # probably OK by now
139 0           print "Content-Type: text/html\r\nContent-Length: ", length($default_doc),
140             "\r\n\r\n", $default_doc;
141             }
142              
143             =head2 handler
144              
145             Handler implemented as part of HTTP::Server::Simple API
146              
147             =cut
148              
149             sub handler {
150 0     0 1   my $self = shift;
151 0           my $cgi;
152 0           $cgi = $self->cgi_class->new;
153 0           eval { $self->handle_request($cgi) };
  0            
154 0 0         if ($@) {
155 0           my $error = $@;
156 0           warn $error;
157             }
158             }
159              
160             1;
161              
162             __DATA__