File Coverage

blib/lib/Apache/ASP/CGI.pm
Criterion Covered Total %
statement 105 121 86.8
branch 17 26 65.4
condition 13 24 54.2
subroutine 16 21 76.2
pod 0 14 0.0
total 151 206 73.3


line stmt bran cond sub pod time code
1              
2             package Apache::ASP::CGI;
3              
4             # this package emulates an Apache request object with a CGI backend
5              
6 14     14   458 use Apache::ASP;
  14         136  
  14         779  
7 14     14   271 use Apache::ASP::Request;
  14         168  
  14         399  
8 14     14   695 use Class::Struct;
  14         145  
  14         334  
9 14     14   399 use Apache::ASP::CGI::Table;
  14         159  
  14         311  
10              
11 14     14   387 use strict;
  14         167  
  14         294  
12 14     14   336 no strict qw(refs);
  14         487  
  14         187  
13 14     14   361 use vars qw($StructsDefined @END);
  14         123  
  14         280  
14             $StructsDefined = 0;
15              
16             sub do_self {
17 10     10 0 106     my $class = shift;
18              
19 10 100       123     if(defined($class)) {
20 8 100 66     160 if(ref $class or $class =~ /Apache::ASP::CGI/) {
21             # we called this OO style
22             } else {
23 6         210 unshift(@_, $class);
24 6         55 $class = undef;
25             }
26                 }
27              
28 10         126     my %config = @_;
29 10   100     161     $class ||= 'Apache::ASP::CGI';
30              
31 10         183     my $r = $class->init($0, @ARGV);
32 10         199     $r->dir_config->set('CgiDoSelf', 1);
33 10         122     $r->dir_config->set('NoState', 0);
34              
35             # init passed in config
36 10         143     for(keys %config) {
37 23         261 $r->dir_config->set($_, $config{$_});
38                 }
39              
40 10         154     &Apache::ASP::handler($r);
41              
42 10         870     $r;
43             }
44              
45             sub init {
46 17     17 0 215     my($class, $filename, @args) = @_;
47 17   50     189     $filename ||= $0;
48                 
49             # for('Class/Struct.pm') {
50             # next if require $_;
51             # die("can't load the $_ library. please make sure you installed it");
52             # }
53                 
54             # we define structs here so modperl users don't incur a runtime / memory
55 17 100       198     unless($StructsDefined) {
56 12         113 $StructsDefined = 1;
57 12         246 &Class::Struct::struct( 'Apache::ASP::CGI::connection' =>
58             {
59             'remote_ip' => "\$",
60             'auth_type' => "\$",
61             'user' => "\$",
62             'aborted' => "\$",
63             'fileno' => "\$",
64             }
65             );    
66              
67 12         2110 &Class::Struct::struct( 'Apache::ASP::CGI' =>
68             {
69             'connection'=> 'Apache::ASP::CGI::connection',
70             'content_type' => "\$",
71             'current_callback' => "\$",
72             'dir_config'=>    "Apache::ASP::CGI::Table",
73             'env'       => "\%",
74             'filename'  => "\$",
75             'get_basic_auth_pw' => "\$",
76             'headers_in' => "Apache::ASP::CGI::Table",
77             'headers_out'=>    "Apache::ASP::CGI::Table",
78             'err_headers_out' => "Apache::ASP::CGI::Table",
79             'subprocess_env'  => "Apache::ASP::CGI::Table",
80             'method'    => "\$",
81             'sent_header' => "\$",
82             'OUT'    => "\$",
83             }
84             );
85                 }
86              
87             # create struct
88 17         601     my $self = new();
89 17 50 33     286     if(defined $ENV{GATEWAY_INTERFACE} and $ENV{GATEWAY_INTERFACE} =~ /^CGI/) {
90             # nothing, don't need CGI object anymore
91                 } else {
92             # command line
93 17         254 my %args = @args;
94 17         361 $ENV{QUERY_STRING} = join('&', map { "$_=$args{$_}" } keys %args);
  0         0  
95                 }
96                 
97 17         324     $self->connection(Apache::ASP::CGI::connection->new);
98 17         388     $self->dir_config(Apache::ASP::CGI::Table->new);
99 17         220     $self->err_headers_out(Apache::ASP::CGI::Table->new);
100 17         442     $self->headers_out(Apache::ASP::CGI::Table->new);
101 17         205     $self->headers_in(Apache::ASP::CGI::Table->new);
102 17         208     $self->subprocess_env(Apache::ASP::CGI::Table->new);
103              
104 17         190     my $env = $self->subprocess_env;
105 17         4727     %$env = %ENV;
106              
107 17         782     $self->filename($filename);
108 17   33     219     $self->connection->remote_ip($ENV{REMOTE_HOST} || $ENV{REMOTE_ADDR} || '0.0.0.0');
      50        
109 17         198     $self->connection->aborted(0);
110 17         204     $self->current_callback('PerlHandler');
111              
112             # $self->headers_in->set('Cookie', $ENV{HTTP_COOKIE});
113 17         1223     for my $env_key ( sort keys %ENV ) {
114 1122 50 33     17384 if($env_key =~ /^HTTP_(.+)$/ or $env_key =~ /^(CONTENT_TYPE|CONTENT_LENGTH)$/) {
115 0         0 my $env_header_in = $1;
116 0         0 my $header_key = join('-', map { ucfirst(lc($_)) } split(/\_/, $env_header_in));
  0         0  
117 0         0 $self->headers_in->set($header_key, $ENV{$env_key});
118             }
119                 }
120              
121             # we kill the state for now stuff for now, as it's just leaving .state
122             # directories everywhere you run this stuff
123 17 50       558     defined($self->dir_config->get('NoState')) || $self->dir_config->set('NoState', 1);
124              
125 17   50     468     $self->method($ENV{REQUEST_METHOD} || 'GET');
126              
127 17         642     for my $env_key ( keys %ENV ) {
128 1122         21279 $self->env($env_key, $ENV{$env_key});
129                 }
130 17 50       484     $self->env('SCRIPT_NAME') || $self->env('SCRIPT_NAME', $filename);
131              
132             # fix truncated output in standalone CGI mode under Win32
133 17         368     binmode(STDOUT);
134              
135 17         336     bless $self, $class;
136             }
137              
138             sub init_dir_config {
139 6     6 0 187     my($self, %config) = @_;
140 6         104     my $dir_config = $self->dir_config;
141 6         101     %$dir_config = %config;
142 6         79     $dir_config;
143             }
144              
145             sub status {
146 6     6 0 53     my($self, $status) = @_;
147 6 50       55     if(defined($status)) {
148 6         58 $self->headers_out->set('status', $status);
149                 } else {
150 0         0 $self->headers_out->get('status');
151                 }
152             }
153              
154 0     0 0 0 sub cgi_env { %{$_[0]->env} ; }
  0         0  
155              
156             sub send_http_header {
157 16     16 0 182     my($self) = @_;
158 16         342     my($k, $v, $header);
159                 
160 16         376     $self->sent_header(1);
161 16         364     $header = "Content-Type: " .$self->content_type()."\n";
162                 
163 16         203     for my $headers ($self->headers_out, $self->err_headers_out) {
164 32         1661         while(($k, $v) = each %$headers) {
165 40 50       490 next if ($k =~ /^content\-type$/i);
166 40 100       1129 if(ref $v) {
167             # if ref, then we have an array for cgi_header_out for cookies
168 1         10 for my $value (@$v) {
169 4   50     36 $value ||= '';
170 4         72 $header .= "$k: $value\n";
171             }
172             } else {
173 39   100     470 $v ||= '';
174 39         688 $header .= "$k: $v\n";
175             }
176             }
177                 }
178              
179 16         195     $header .= "\n";
180              
181 16         212     $self->print($header);
182             }
183              
184             sub send_cgi_header {
185 1     1 0 10     my($self, $header) = @_;
186              
187 1         16     $self->sent_header(1);
188 1         9     my(@left);
189 1         12     for(split(/\n/, $header)) {
190 1         15 my($name, $value) = split(/\:\s*/, $_, 2);
191 1 50       12 if($name =~ /content-type/i) {
192 0         0 $self->content_type($value);
193             } else {
194 1         13 push(@left, $_);
195             }
196                 }
197              
198 1         17     $self->print(join("\n", @left, ''));
199 1         15     $self->send_http_header();
200             }
201              
202             sub print {
203 16     16 0 220     shift;
204 16         351     local $| = 1;
205 16 50       182     print STDOUT map { ref($_) =~ /SCALAR/ ? $$_ : $_; } @_;
  16         1096  
206             }
207              
208             sub args {
209 18     18 0 225     my $self = shift;
210              
211 18 50       196     if(wantarray) {
212 0         0 my $params = Apache::ASP::Request->ParseParams($ENV{QUERY_STRING});
213 0         0 %$params;
214                 } else {
215 18         448 $ENV{QUERY_STRING};
216                 }
217             }
218             *content = *args;
219              
220             sub log_error {
221 0     0 0 0     my($self, @args) = @_;
222 0         0     print STDERR @args, "\n";
223             }
224              
225 19     19 0 251 sub register_cleanup { push(@END, $_[1]); }
226              
227             # gets called when the $r get's garbage collected
228             sub END {
229                 for ( @END ) {
230             next unless $_;
231             if(ref($_) && /CODE/) {
232             my $rv = eval { &$_ };
233             if($@) {
234             Apache::ASP::CGI->log_error("[ERROR] error executing register_cleanup code $_: $@");
235             }
236             }
237                 }
238             }
239              
240 0     0 0   sub soft_timeout { 1; };
241              
242             sub lookup_uri {
243 0     0 0       die('cannot call $Server->MapPath in CGI mode');
244             }
245              
246             sub custom_response {
247 0     0 0       die('$Response->ErrorDocument not implemented for CGI mode');
248             }
249              
250             1;
251