1 # Poor Man's CGI Module for Perl
3 # (c) 2002--2007 Martin Mares <mj@ucw.cz>
4 # Slightly modified by Tomas Valla <tom@ucw.cz>
6 # This software may be freely distributed and used according to the terms
7 # of the GNU Lesser General Public License.
10 # - respond with proper HTTP error codes
11 # - if we get invalid parameters, generate HTTP error or redirect
15 # First of all, set up error handling, so that even errors during parsing
16 # will be reported properly.
18 # Variables to be set by the calling module:
19 # $UCW::CGI::error_mail mail address of the script admin (optional)
20 # (this one has to be set in the BEGIN block!)
21 # $UCW::CGI::error_hook function to be called for reporting errors
29 if (!defined $error_reported) {
32 if (defined($UCW::CGI::error_hook)) {
33 &$UCW::CGI::error_hook($_[0]);
35 print "Content-type: text/plain\n\n";
36 print "Internal bug:\n";
38 print "Please notify $UCW::CGI::error_mail\n" if defined $UCW::CGI::error_mail;
45 $SIG{__DIE__} = sub { report_bug($_[0]); };
46 $SIG{__WARN__} = sub { report_bug("WARNING: " . $_[0]); };
59 our @ISA = qw(Exporter);
60 our @EXPORT = qw(&html_escape &url_escape &url_param_escape &self_ref &self_form &http_get);
61 our @EXPORT_OK = qw();
67 $x =~ s/([^-\$_.!*'(),0-9A-Za-z\x80-\xff])/"%".unpack('H2',$1)/ge;
71 sub url_param_escape($) {
87 ### Analysing RFC 822 Style Headers ###
89 sub rfc822_prepare($) {
91 # Convert all %'s and backslash escapes to %xx escapes
93 $x =~ s/\\(.)/"%".unpack("H2",$1)/ge;
94 # Remove all comments, beware, they can be nested (unterminated comments are closed at EOL automatically)
95 while ($x =~ s/^(("[^"]*"|[^"(])*(\([^)]*)*)(\([^()]*(\)|$))/$1 /) { }
96 # Remove quotes and escape dangerous characters inside (again closing at the end automatically)
97 $x =~ s{"([^"]*)("|$)}{my $z=$1; $z =~ s/([^0-9a-zA-Z%_-])/"%".unpack("H2",$1)/ge; $z;}ge;
98 # All control characters are properly escaped, tokens are clearly visible.
99 # Finally remove all unnecessary spaces.
102 $x =~ s{\s*([()<>@,;:\\"/\[\]?=])\s*}{$1}g;
106 sub rfc822_deescape($) {
108 $x =~ s/%(..)/pack("H2",$1)/ge;
112 ### Reading of HTTP headers ###
117 return $ENV{"HTTP_$h"} || $ENV{"$h"};
120 ### Parsing of Arguments ###
124 sub parse_arg_string($) {
127 foreach $_ (split /[&:]/,$s) {
128 (/^([^=]+)=(.*)$/) or next;
129 my $arg = $arg_table->{$1} or next;
132 s/%(..)/pack("H2",$1)/eg;
135 $arg->{'multiline'} || s/(\n|\t)/ /g;
138 if (my $rx = $arg->{'check'}) {
139 if (!/^$rx$/) { $_ = $arg->{'default'}; }
142 my $r = ref($arg->{'var'});
143 if ($r eq 'SCALAR') {
144 ${$arg->{'var'}} = $_;
145 } elsif ($r eq 'ARRAY') {
146 push @{$arg->{'var'}}, $_;
151 sub parse_multipart_form_data();
154 $arg_table = shift @_;
155 if (!defined $ENV{"GATEWAY_INTERFACE"}) {
156 print STDERR "Must be called as a CGI script.\n";
160 foreach my $a (values %$arg_table) {
161 my $r = ref($a->{'var'});
162 defined($a->{'default'}) or $a->{'default'}="";
163 if ($r eq 'SCALAR') {
164 ${$a->{'var'}} = $a->{'default'};
165 } elsif ($r eq 'ARRAY') {
169 my $method = $ENV{"REQUEST_METHOD"};
170 my $qs = $ENV{"QUERY_STRING"};
171 parse_arg_string($qs) if defined($qs);
172 if ($method eq "GET") {
173 } elsif ($method eq "POST") {
174 if ($ENV{"CONTENT_TYPE"} =~ /^application\/x-www-form-urlencoded\b/i) {
177 parse_arg_string($_);
179 } elsif ($ENV{"CONTENT_TYPE"} =~ /^multipart\/form-data\b/i) {
180 parse_multipart_form_data();
182 die "Unknown content type for POST data";
185 die "Unknown request method";
189 ### Parsing Multipart Form Data ###
195 my $mp_buffer_boundary;
198 sub refill_mp_data($) {
200 if ($mp_buffer_boundary >= $mp_buffer_i) {
201 return $mp_buffer_boundary - $mp_buffer_i;
202 } elsif ($mp_buffer_i + $more <= length($mp_buffer) - $boundary_len) {
206 $mp_buffer = substr($mp_buffer, $mp_buffer_i);
209 while ($mp_buffer_i + $more > length($mp_buffer) - $boundary_len) {
212 my $n = read(STDIN, $data, 2048);
219 $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
220 if ($mp_buffer_boundary >= 0) {
221 return $mp_buffer_boundary;
223 return length($mp_buffer);
225 return length($mp_buffer) - $boundary_len;
231 my ($allow_empty) = @_;
232 my $n = refill_mp_data(1024);
233 my $i = index($mp_buffer, "\r\n", $mp_buffer_i);
234 if ($i >= $mp_buffer_i && $i < $mp_buffer_i + $n - 1) {
235 my $s = substr($mp_buffer, $mp_buffer_i, $i - $mp_buffer_i);
236 $mp_buffer_i = $i + 2;
238 } elsif ($allow_empty) {
239 if ($n) { # An incomplete line
240 my $s = substr($mp_buffer, $mp_buffer_i, $n);
243 } else { # No more lines
247 die "Premature end of multipart POST data";
251 sub skip_mp_boundary() {
252 if ($mp_buffer_boundary != $mp_buffer_i) {
253 die "Premature end of multipart POST data";
255 $mp_buffer_boundary = -1;
257 my $b = get_mp_line(0);
258 print STDERR "SEP $b\n" if $debug;
259 $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
260 if ("\r\n$b" =~ /^$boundary--/) {
267 sub parse_mp_header() {
270 while ((my $l = get_mp_line(0)) ne "") {
271 print STDERR "HH $l\n" if $debug;
272 if (my ($name, $value) = ($l =~ /([A-Za-z0-9-]+)\s*:\s*(.*)/)) {
273 $name =~ tr/A-Z/a-z/;
274 $h->{$name} = $value;
276 } elsif ($l =~ /^\s+/ && $last) {
282 foreach my $n (keys %$h) {
283 $h->{$n} = rfc822_prepare($h->{$n});
284 print STDERR "H $n: $h->{$n}\n" if $debug;
286 return (keys %$h) ? $h : undef;
289 sub parse_multipart_form_data() {
290 # First of all, find the boundary string
291 my $ct = rfc822_prepare($ENV{"CONTENT_TYPE"});
292 if (!(($boundary) = ($ct =~ /^.*;boundary=([^; ]+)/))) {
293 die "Multipart content with no boundary string received";
295 $boundary = rfc822_deescape($boundary);
296 print STDERR "BOUNDARY IS $boundary\n" if $debug;
298 # BUG: IE 3.01 on Macintosh forgets to add the "--" at the start of the boundary string
299 # as the MIME specs preach. Workaround borrowed from CGI.pm in Perl distribution.
300 my $agent = http_get("User-agent") || "";
301 $boundary = "--$boundary" unless $agent =~ /MSIE\s+3\.0[12];\s*Mac/;
302 $boundary = "\r\n$boundary";
303 $boundary_len = length($boundary) + 2;
305 # Check upload size in advance
306 if (my $size = http_get("Content-Length")) {
308 foreach my $a (values %$arg_table) {
309 $max_allowed += $a->{"maxsize"} || 65536;
311 if ($size > $max_allowed) {
312 die "Maximum form data length exceeded";
316 # Initialize our buffering mechanism and part splitter
319 $mp_buffer_boundary = -1;
322 # Skip garbage before the 1st part
323 while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
324 skip_mp_boundary() || return;
326 # Process individual parts
328 print STDERR "NEXT PART\n" if $debug;
329 my $h = parse_mp_header();
330 my ($field, $cdisp, $a);
332 ($cdisp = $h->{"content-disposition"}) &&
333 $cdisp =~ /^form-data/ &&
334 (($field) = ($cdisp =~ /;name=([^;]+)/)) &&
335 ($a = $arg_table->{"$field"})) {
336 print STDERR "FIELD $field\n" if $debug;
337 if (defined $h->{"content-transfer-encoding"}) { die "Unexpected Content-Transfer-Encoding"; }
338 if (defined $a->{"var"}) {
339 while (defined (my $l = get_mp_line(1))) {
340 print STDERR "VALUE $l\n" if $debug;
341 parse_arg_string("$field=$l");
344 } elsif (defined $a->{"file"}) {
347 my $max_size = $a->{"maxsize"} || 1048576;
348 my @tmpargs = (undef, UNLINK => 1);
349 push @tmpargs, DIR => $a->{"tmpdir"} if defined $a->{"tmpdir"};
350 my ($fh, $fn) = File::Temp::tempfile(@tmpargs);
351 print STDERR "FILE UPLOAD to $fn\n" if $debug;
352 ${$a->{"file"}} = $fn;
353 ${$a->{"fh"}} = $fh if defined $a->{"fh"};
355 while (my $i = refill_mp_data(4096)) {
356 print $fh substr($mp_buffer, $mp_buffer_i, $i);
359 if ($total_size > $max_size) { die "Uploaded file too long"; }
361 $fh->flush(); # Don't close the handle, the file would disappear otherwise
365 print STDERR "SKIPPING\n" if $debug;
366 while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
367 } } while (skip_mp_boundary());
370 ### Generating Self-ref URL's ###
372 sub make_out_args($) {
373 my ($overrides) = @_;
375 foreach my $name (keys %$arg_table) {
376 my $arg = $arg_table->{$name};
377 defined($arg->{'var'}) || next;
378 defined($arg->{'pass'}) && !$arg->{'pass'} && !exists $overrides->{$name} && next;
380 if (!defined($value = $overrides->{$name})) {
381 if (exists $overrides->{$name}) {
382 $value = $arg->{'default'};
384 $value = ${$arg->{'var'}};
387 if ($value ne $arg->{'default'}) {
388 $out->{$name} = $value;
396 my $out = make_out_args(\%h);
397 return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out);
402 my $out = make_out_args(\%h);
403 return join('', map { "<input type=hidden name=$_ value='" . html_escape($out->{$_}) . "'>\n" } sort keys %$out);
410 if ($x !~ /^[a-zA-Z0-9%]+$/) {
411 $x =~ s/([\\\"])/\\$1/g;
417 sub set_cookie($$@) {
419 my $value = shift @_;
421 $other{'version'} = 1 unless defined $other{'version'};
422 print "Set-Cookie: $key=", cookie_esc($value);
423 foreach my $k (keys %other) {
424 print ";$k=", cookie_esc($other{$k});
429 sub parse_cookies() {
430 my $h = http_get("Cookie") or return ();
432 while (my ($padding,$name,$val,$xx,$rest) = ($h =~ /\s*([,;]\s*)*([^ =]+)=([^ =,;\"]*|\"([^\"\\]|\\.)*\")(\s.*|;.*|$)/)) {
436 $val =~ s/\\(.)/$1/g;
438 push @cook, $name, $val;