File Coverage

blib/lib/Apache/ASP/Request.pm
Criterion Covered Total %
statement 36 162 22.2
branch 6 84 7.1
condition 2 20 10.0
subroutine 6 16 37.5
pod 0 10 0.0
total 50 292 17.1


line stmt bran cond sub pod time code
1              
2             package Apache::ASP::Request;
3              
4 14     14   211 use Apache::ASP::Collection;
  14         201  
  14         3236  
5 14     14   263 use strict;
  14         131  
  14         216  
6              
7             sub new {
8 18     18 0 299     my $asp = shift;
9 18         369     my $r = $asp->{r};
10              
11 18   50     952     my $self = bless
12                   {
13                    asp => $asp,
14             # content => undef,
15             # Cookies => undef,
16             # FileUpload => undef,
17             # Form => undef,
18             # QueryString => undef,
19             # ServerVariables => undef,
20                    Method => $r->method || 'GET',
21                    TotalBytes => 0,
22                   };
23              
24             # calculate whether to read POST data here
25 18         519     my $request_binary_read = &config($asp, 'RequestBinaryRead', undef, 1);
26 18         241     $asp->{request_binary_read} = $request_binary_read;
27              
28             # set up the environment, including authentication info
29 18         198     my $env = { %{$r->subprocess_env}, %ENV };
  18         559  
30 18 50       705     if(&config($asp, 'AuthServerVariables')) {
31 0 0       0 if(defined $r->get_basic_auth_pw) {
32 0         0 my $c = $r->connection;
33             #X: this needs to be extended to support Digest authentication
34 0         0 $env->{AUTH_TYPE} = $c->auth_type;
35 0         0 $env->{AUTH_USER} = $c->user;
36 0         0 $env->{AUTH_NAME} = $r->auth_name;
37 0         0 $env->{REMOTE_USER} = $c->user;
38 0         0 $env->{AUTH_PASSWD} = $r->get_basic_auth_pw;
39             }
40                 }
41 18         266     $self->{'ServerVariables'} = bless $env, 'Apache::ASP::Collection';
42              
43             # assign no matter what so Form is always defined
44 18         249     my $form = {};
45 18         174     my %upload;
46 18         180     my $headers_in = $self->{asp}{headers_in};
47 18 50 33     359     if($self->{Method} eq 'POST' and $request_binary_read) {
48 0 0       0 $self->{TotalBytes} = defined($ENV{CONTENT_LENGTH}) ? $ENV{CONTENT_LENGTH} : $headers_in->get('Content-Length');
49 0 0       0 if($headers_in->get('Content-Type') =~ m|^multipart/form-data|) {
50             # do the logic here so that the normal form POST processing will not
51             # occur either
52 0         0 $asp->{file_upload_process} = &config($asp, 'FileUploadProcess', undef, 1);
53 0 0       0 if($asp->{file_upload_process}) {
54 0 0       0 if($asp->{file_upload_temp} = &config($asp, 'FileUploadTemp')) {
55 0         0 eval "use CGI;";
56             } else {
57             # default leaves no temp files for prying eyes
58 0         0 eval "use CGI qw(-private_tempfiles);";
59             }
60 0 0       0 if($@) {
61 0         0 $self->{asp}->Error("can't use file upload without CGI.pm: $@");
62 0         0 goto ASP_REQUEST_POST_READ_DONE;
63             }
64              
65             # new behavior for file uploads when FileUploadMax is exceeded,
66             # before it used to error abruptly, now it will simply skip the file
67             # upload data
68 0         0 local $CGI::DISABLE_UPLOADS = $CGI::DISABLE_UPLOADS;
69 0 0       0 if($asp->{file_upload_max} = &config($asp, 'FileUploadMax')) {
70 0 0       0 if($self->{TotalBytes} > $asp->{file_upload_max} ) {
71 0         0 $CGI::DISABLE_UPLOADS = 1;
72             }
73             }
74            
75             $asp->{dbg} && $asp->Debug("using CGI.pm version ".
76 0 0 0     0 (eval { CGI->VERSION } || $CGI::VERSION).
  0         0  
77             " for file upload support"
78             );
79              
80 0         0 my %form;
81 0         0 my $q = $self->{cgi} = new CGI;
82 0         0 $asp->Debug($q->param);
83 0         0 for(my @names = $q->param) {
84 0         0 my @params = $q->param($_);
85 0 0       0 $form{$_} = @params > 1 ? [ @params ] : $params[0];
86 0 0       0 if(ref($form{$_}) eq 'Fh') {
87 0         0 my $fh = $form{$_};
88 0 0       0 binmode $fh if $asp->{win32};
89 0         0 $upload{$_} = $q->uploadInfo($fh);
90 0 0       0 if($asp->{file_upload_temp}) {
91 0         0 $upload{$_}{TempFile} = $q->tmpFileName($fh);
92 0         0 $upload{$_}{TempFile} =~ s|^/+|/|;
93             }
94 0         0 $upload{$_}{BrowserFile} = "$fh";
95 0         0 $upload{$_}{FileHandle} = $fh;
96 0         0 $upload{$_}{ContentType} = $upload{$_}{'Content-Type'};
97             # tie the file upload reference to a collection... %upload
98             # may be many file uploads note.
99 0         0 $upload{$_} = bless $upload{$_}, 'Apache::ASP::Collection';
100 0 0       0 $asp->{dbg} && $asp->Debug("file upload field processed for \$Request->{FileUpload}{$_}", $upload{$_});
101             }
102             }
103 0         0 $form = \%form;
104             } else {
105 0         0 $self->{asp}->Debug("FileUploadProcess is disabled, file upload data in \$Request->BinaryRead");
106             }
107              
108             } else {
109             # Only tie to STDIN if we have cached contents
110             # don't untie *STDIN until DESTROY, so filtered handlers
111             # have an opportunity to use any cached contents that may exist
112 0 0       0 if(my $len = $self->{TotalBytes}) {
113 0   0     0 $self->{content} = $self->BinaryRead($len) || '';
114 0         0 tie(*STDIN, 'Apache::ASP::Request', $self);
115 0 0       0 if($headers_in->get('Content-Type') eq 'application/x-www-form-urlencoded') {
116 0         0 $form = &ParseParams($self, \$self->{content});
117             } else {
118 0         0 $form = {};
119             }
120             }
121             }
122                 }
123              
124             ASP_REQUEST_POST_READ_DONE:
125              
126 18         1064     $self->{'Form'} = bless $form, 'Apache::ASP::Collection';
127 18         242     $self->{'FileUpload'} = bless \%upload, 'Apache::ASP::Collection';
128 18         432     my $query = $r->args();
129 18 50       212     my $parsed_query = $query ? &ParseParams($self, \$query) : {};
130 18         304     $self->{'QueryString'} = bless $parsed_query, 'Apache::ASP::Collection';
131              
132 18 50       248     if(&config($asp, 'RequestParams')) {
133 0         0 $self->{'Params'} = bless { %$parsed_query, %$form }, 'Apache::ASP::Collection';
134                 }
135              
136             # do cookies now
137 18         178     my %cookies;
138 18 50       307     if(my $cookie = $headers_in->get('Cookie')) {
139 0   0     0 my @parts = split(/;\s*/, ($cookie || ''));
140 0         0 for(@parts) {
141 0         0 my($name, $value) = split(/\=/, $_, 2);
142 0         0 $name = &Unescape($self, $name);
143            
144 0 0       0 next if ($name eq $Apache::ASP::SessionCookieName);
145 0 0       0 next if $cookies{$name}; # skip dup's
146            
147 0 0       0 $cookies{$name} = ($value =~ /\=/) ?
148             &ParseParams($self, $value) : &Unescape($self, $value);
149             }
150                 }
151 18         480     $self->{Cookies} = bless \%cookies, 'Apache::ASP::Collection';
152              
153 18         490     $self;
154             }
155              
156             sub DESTROY {
157 24     24   236     my $self = shift;
158              
159 24 50       344     if($self->{cgi}) {
160             # make sure CGI file handles are freed
161 0         0 $self->{cgi}->DESTROY();
162 0         0 $self->{cgi} = undef;
163                 }
164              
165 24         378     for(keys %{$self->{FileUpload}}) {
  24         400  
166 0         0 my $upload = $self->{FileUpload}{$_};
167 0         0 $self->{Form}{$_} = undef;
168 0 0       0 if($upload->{FileHandle}) {
169 0         0 close $upload->{FileHandle};
170             # $self->{asp}->Debug("closing fh $upload->{FileHandle}");
171             }
172 0         0 $self->{FileUpload}{$_} = undef;
173                 }
174              
175 24         1298     %$self = ();
176             }
177              
178             # just returns itself
179 0     0   0 sub TIEHANDLE { $_[1] };
180              
181             # just spill the cache into the scalar, so multiple reads are
182             # fine... whoever is reading from the cached contents must
183             # be reading the whole thing just once for this to work,
184             # which is fine for CGI.pm
185             sub READ {
186 0     0   0     my $self = $_[0];
187 0   0     0     $_[1] ||= '';
188 0         0     $_[1] .= $self->{content};
189 0         0     $self->{ServerVariables}{CONTENT_LENGTH};
190             }
191              
192 0     0   0 sub BINMODE { };
193              
194             # COLLECTIONS, normal, Cookies are special, with the dictionary lookup
195             # directly aliased as this should be faster than autoloading
196 23     23 0 677 sub Form { shift->{Form}->Item(@_) }
197 0     0 0 0 sub FileUpload { shift->{FileUpload}->Item(@_) }
198 23     23 0 351 sub QueryString { shift->{QueryString}->Item(@_) }
199 0     0 0   sub ServerVariables { shift->{ServerVariables}->Item(@_) }
200              
201             sub Params {
202 0     0 0       my $self = shift;
203 0 0             $self->{Params}
204                   || die("\$Request->Params object does not exist, enable with 'PerlSetVar RequestParams 1'");
205 0               $self->{Params}->Item(@_);
206             }
207              
208             sub BinaryRead {
209 0     0 0       my($self, $length) = @_;
210 0               my $data;
211 0 0             return undef unless $self->{TotalBytes};
212              
213 0 0 0           if(ref(tied(*STDIN)) && tied(*STDIN)->isa('Apache::ASP::Request')) {
214 0 0         if($self->{TotalBytes}) {
215 0 0         if(defined $length) {
216 0           return substr($self->{content}, 0, $length);
217             } else {
218 0           return $self->{content}
219             }
220             } else {
221 0           return undef;
222             }
223                 } else {
224 0 0         defined($length) || ( $length = $self->{TotalBytes} );
225 0           my $asp = $self->{asp};
226 0           my $r = $asp->{r};
227 0 0         if(! $ENV{MOD_PERL}) {
228 0           my $rv = sysread(*STDIN, $data, $length, 0);
229 0 0         $asp->{dbg} && $asp->Debug("read $rv bytes from STDIN for CGI mode, tried $length bytes");
230             } else {
231 0           $r->read($data, $length);
232 0 0         $asp->{dbg} && $asp->Debug("read ".length($data)." bytes, tried $length bytes");
233             }
234 0           return $data;
235                 }
236             }
237              
238             sub Cookies {
239 0     0 0       my($self, $name, $key) = @_;
240              
241 0 0             if(! $name) {
    0          
242 0           $self->{Cookies};
243                 } elsif($key) {
244 0           $self->{Cookies}{$name}{$key};
245                 } else {
246             # when we just have the name, are we expecting a dictionary or not
247 0           my $cookie = $self->{Cookies}{$name};
248 0 0 0       if(ref $cookie && wantarray) {
249 0           return %$cookie;
250             } else {
251             # CollectionItem support here one day, to not return
252             # an undef object, CollectionItem needs tied hash support
253 0           return $cookie;
254             }
255                 }
256             }
257              
258             sub ParseParams {
259 0     0 0       my($self, $string) = @_;
260 0 0             ($string = $$string) if ref($string); ## faster if we pass a ref for a big string
261              
262 0               my %params;
263 0 0             defined($string) || return(\%params);
264 0               my @params = split /[\&\;]/, $string, -1;
265              
266             # we have to iterate through the params here to collect multiple values for
267             # the same param, say from a multiple select statement
268 0               for my $pair (@params) {
269 0           my($key, $value) = map {
270             # inline for greater efficiency
271             # &Unescape($self, $_)
272 0           my $todecode = $_;
273 0           $todecode =~ tr/+/ /; # pluses become spaces
274 0           $todecode =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
  0            
275 0           $todecode;
276             } split (/\=/, $pair, 2);
277 0 0         if(defined $params{$key}) {
278 0           my $collect = $params{$key};
279              
280 0 0         if(ref $collect) {
281             # we have already collected more than one param for that key
282 0           push(@{$collect}, $value);
  0            
283             } else {
284             # this is the second value for a key we've seen, start array
285 0           $params{$key} = [$collect, $value];
286             }
287             } else {
288             # normal use, one to one key value pairs, just set
289 0           $params{$key} = $value;
290             }
291                 }
292              
293 0               \%params;
294             }
295              
296             # unescape URL-encoded data
297             sub Unescape {
298 0     0 0       my $todecode = $_[1];
299 0               $todecode =~ tr/+/ /; # pluses become spaces
300 0               $todecode =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;