1 # Poor Man's CGI Module for Perl
3 # (c) 2002--2017 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.
16 our @ISA = qw(Exporter);
17 our @EXPORT = qw(&html_escape &url_escape &url_deescape &url_param_escape &url_param_deescape &self_ref &self_form &http_get);
18 our @EXPORT_OK = qw();
20 # Configuration settings
26 print join("\n", "Status: $err", "Content-Type: text/plain", @_, "", $err, "");
35 utf8::encode($x) if $utf8_mode;
36 $x =~ s/([^-\$_.!*'(),0-9A-Za-z\x80-\xff])/"%".unpack('H2',$1)/ge;
37 utf8::decode($x) if $utf8_mode;
41 sub url_strict_escape($) {
45 $x =~ s/([^-\$_.!*'(),0-9A-Za-z])/"%".unpack('H2',$1)/ge;
52 utf8::encode($x) if $utf8_mode;
53 $x =~ s/%(..)/pack("H2",$1)/ge;
54 utf8::decode($x) if $utf8_mode;
58 sub url_param_escape($) {
61 utf8::encode($x) if $utf8_mode;
62 $x =~ s/([^-\$_.!*'(),0-9A-Za-z])/"%".unpack('H2',$1)/ge;
64 utf8::decode($x) if $utf8_mode;
68 sub url_param_deescape($) {
72 return url_deescape($x);
86 ### Analysing RFC 822 Style Headers ###
88 sub rfc822_prepare($) {
90 # Convert all %'s and backslash escapes to %xx escapes
92 $x =~ s/\\(.)/"%".unpack("H2",$1)/ge;
93 # Remove all comments, beware, they can be nested (unterminated comments are closed at EOL automatically)
94 while ($x =~ s/^(("[^"]*"|[^"(])*(\([^)]*)*)(\([^()]*(\)|$))/$1 /) { }
95 # Remove quotes and escape dangerous characters inside (again closing at the end automatically)
96 $x =~ s{"([^"]*)("|$)}{my $z=$1; $z =~ s/([^0-9a-zA-Z%_-])/"%".unpack("H2",$1)/ge; $z;}ge;
97 # All control characters are properly escaped, tokens are clearly visible.
98 # Finally remove all unnecessary spaces.
101 $x =~ s{\s*([()<>@,;:\\"/\[\]?=])\s*}{$1}g;
105 sub rfc822_deescape($) {
107 return url_deescape($x);
110 ### Reading of HTTP headers ###
115 return $ENV{"HTTP_$h"} // $ENV{"$h"};
118 ### Parsing of Arguments ###
123 sub parse_raw_args_ll($$) {
127 utf8::decode($s) if $utf8_mode;
128 push @{$raw_args{$arg}}, $s;
131 sub parse_raw_args($) {
134 for $_ (split /[&:]/, $s) {
135 (/^([^=]+)=(.*)$/) or next;
139 s/%(..)/pack("H2",$1)/eg;
140 parse_raw_args_ll($arg, $_);
144 sub parse_multipart_form_data();
147 if (!defined $ENV{"GATEWAY_INTERFACE"}) {
148 print STDERR "Must be called as a CGI script.\n";
149 $UCW::CGI::ErrorHandler::exit_code = 1;
153 my $method = $ENV{"REQUEST_METHOD"};
154 if (my $qs = $ENV{"QUERY_STRING"}) {
157 if ($method eq "GET" || $method eq "HEAD") {
158 } elsif ($method eq "POST") {
159 my $content_type = $ENV{"CONTENT_TYPE"} // "";
160 if ($content_type =~ /^application\/x-www-form-urlencoded\b/i) {
165 } elsif ($content_type =~ /^multipart\/form-data\b/i) {
166 parse_multipart_form_data();
168 http_error "415 Unsupported Media Type";
172 http_error "405 Method Not Allowed", "Allow: GET, HEAD, POST";
176 sub parse_args($) { # CAVEAT: attached files must be defined in the main arg table
178 if (!$main_arg_table) {
179 $main_arg_table = $args;
183 for my $a (values %$args) {
184 my $r = ref($a->{'var'});
185 $a->{'default'} //= '';
186 if ($r eq 'SCALAR') {
187 ${$a->{'var'}} = $a->{'default'};
188 } elsif ($r eq 'ARRAY') {
193 for my $arg (keys %$args) {
194 my $a = $args->{$arg};
195 defined($raw_args{$arg}) or next;
196 for (@{$raw_args{$arg}}) {
197 $a->{'multiline'} or s/(\n|\t)/ /g;
198 unless ($a->{'preserve_spaces'}) {
202 if (my $rx = $a->{'check'}) {
203 if (!/^$rx$/) { $_ = $a->{'default'}; }
208 if ($r eq 'SCALAR') {
210 } elsif ($r eq 'ARRAY') {
217 ### Parsing Multipart Form Data ###
223 my $mp_buffer_boundary;
226 sub refill_mp_data($) {
228 if ($mp_buffer_boundary >= $mp_buffer_i) {
229 return $mp_buffer_boundary - $mp_buffer_i;
230 } elsif ($mp_buffer_i + $more <= length($mp_buffer) - $boundary_len) {
234 $mp_buffer = substr($mp_buffer, $mp_buffer_i);
237 while ($mp_buffer_i + $more > length($mp_buffer) - $boundary_len) {
240 my $n = read(STDIN, $data, 2048);
247 $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
248 if ($mp_buffer_boundary >= 0) {
249 return $mp_buffer_boundary;
251 return length($mp_buffer);
253 return length($mp_buffer) - $boundary_len;
259 my ($allow_empty) = @_;
260 my $n = refill_mp_data(1024);
261 my $i = index($mp_buffer, "\r\n", $mp_buffer_i);
262 if ($i >= $mp_buffer_i && $i < $mp_buffer_i + $n - 1) {
263 my $s = substr($mp_buffer, $mp_buffer_i, $i - $mp_buffer_i);
264 $mp_buffer_i = $i + 2;
266 } elsif ($allow_empty) {
267 if ($n) { # An incomplete line
268 my $s = substr($mp_buffer, $mp_buffer_i, $n);
271 } else { # No more lines
275 http_error "400 Bad Request: Premature end of multipart POST data";
279 sub skip_mp_boundary() {
280 if ($mp_buffer_boundary != $mp_buffer_i) {
281 http_error "400 Bad Request: Premature end of multipart POST data";
283 $mp_buffer_boundary = -1;
285 my $b = get_mp_line(0);
286 print STDERR "SEP $b\n" if $debug;
287 $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
288 if (substr("\r\n$b", 0, $boundary_len) eq "$boundary--") {
295 sub parse_mp_header() {
298 while ((my $l = get_mp_line(0)) ne "") {
299 print STDERR "HH $l\n" if $debug;
300 if (my ($name, $value) = ($l =~ /([A-Za-z0-9-]+)\s*:\s*(.*)/)) {
301 $name =~ tr/A-Z/a-z/;
302 $h->{$name} = $value;
304 } elsif ($l =~ /^\s+/ && $last) {
310 foreach my $n (keys %$h) {
311 $h->{$n} = rfc822_prepare($h->{$n});
312 print STDERR "H $n: $h->{$n}\n" if $debug;
314 return (keys %$h) ? $h : undef;
317 sub parse_multipart_form_data() {
318 # First of all, find the boundary string
319 my $ct = rfc822_prepare($ENV{"CONTENT_TYPE"});
320 if (!(($boundary) = ($ct =~ /^.*;\s*boundary=([^; ]+)/))) {
321 http_error "400 Bad Request: Multipart content with no boundary string received";
323 $boundary = rfc822_deescape($boundary);
324 print STDERR "BOUNDARY IS $boundary\n" if $debug;
326 # BUG: IE 3.01 on Macintosh forgets to add the "--" at the start of the boundary string
327 # as the MIME specs preach. Workaround borrowed from CGI.pm in Perl distribution.
328 my $agent = http_get("User-Agent") // "";
329 $boundary = "--$boundary" unless $agent =~ /MSIE\s+3\.0[12];\s*Mac/;
330 $boundary = "\r\n$boundary";
331 $boundary_len = length($boundary) + 2;
333 # Check upload size in advance
334 if (my $size = http_get("Content-Length")) {
336 foreach my $a (values %$main_arg_table) {
337 $max_allowed += $a->{"maxsize"} || 65536;
339 if ($size > $max_allowed) {
340 http_error "413 Request Entity Too Large";
344 # Initialize our buffering mechanism and part splitter
347 $mp_buffer_boundary = -1;
350 # Skip garbage before the 1st part
351 while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
352 skip_mp_boundary() || return;
354 # Process individual parts
356 print STDERR "NEXT PART\n" if $debug;
357 my $h = parse_mp_header();
358 my ($field, $cdisp, $a);
360 ($cdisp = $h->{"content-disposition"}) &&
361 $cdisp =~ /^form-data/ &&
362 (($field) = ($cdisp =~ /;name=([^;]+)/)) &&
363 ($a = $main_arg_table->{"$field"})) {
364 print STDERR "FIELD $field\n" if $debug;
365 if (defined $h->{"content-transfer-encoding"}) {
366 http_error "400 Bad Request: Unexpected Content-Transfer-Encoding";
368 if (defined $a->{"var"}) {
369 while (defined (my $l = get_mp_line(1))) {
370 print STDERR "VALUE $l\n" if $debug;
371 parse_raw_args_ll($field, $l);
374 } elsif (defined $a->{"file"}) {
377 my $max_size = $a->{"maxsize"} || 1048576;
378 my @tmpargs = (undef, UNLINK => 1);
379 push @tmpargs, DIR => $a->{"tmpdir"} if defined $a->{"tmpdir"};
380 my ($fh, $fn) = File::Temp::tempfile(@tmpargs);
381 print STDERR "FILE UPLOAD to $fn\n" if $debug;
382 ${$a->{"file"}} = $fn;
383 ${$a->{"fh"}} = $fh if defined $a->{"fh"};
384 if (defined $a->{"filename"}){
385 my ($filename) = ($cdisp =~ /;filename=([^;]+)/);
386 (${$a->{"filename"}}) = rfc822_deescape($filename) if defined $filename;
389 while (my $i = refill_mp_data(4096)) {
390 print $fh substr($mp_buffer, $mp_buffer_i, $i);
393 if ($total_size > $max_size) { http_error "413 Request Entity Too Large"; }
395 $fh->flush(); # Don't close the handle, the file would disappear otherwise
399 print STDERR "SKIPPING\n" if $debug;
400 while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
401 } } while (skip_mp_boundary());
404 ### Generating Self-ref URL's ###
406 sub make_out_args(@) { # Usage: make_out_args([arg_table, ...] name => value, ...)
407 my @arg_tables = ( $main_arg_table );
408 while (@_ && ref($_[0]) eq 'HASH') {
409 push @arg_tables, shift @_;
413 for my $table (@arg_tables) {
414 for my $name (keys %$table) {
415 my $arg = $table->{$name};
416 defined($arg->{'var'}) || next;
417 defined($arg->{'pass'}) && !$arg->{'pass'} && !exists $overrides{$name} && next;
418 defined $arg->{'default'} or $arg->{'default'} = "";
420 if (!defined($value = $overrides{$name})) {
421 if (exists $overrides{$name}) {
422 $value = $arg->{'default'};
424 $value = ${$arg->{'var'}};
425 defined $value or $value = $arg->{'default'};
428 if ($value ne $arg->{'default'}) {
429 $out->{$name} = $value;
437 my $out = make_out_args(@_);
438 return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out);
442 my $out = make_out_args(@_);
443 return join('', map { "<input type=hidden name=$_ value='" . html_escape($out->{$_}) . "'>\n" } sort keys %$out);
448 sub set_cookie($$@) {
450 # Unfortunately, the support for the new cookie standard (RFC 2965) among
451 # web browsers is still very scarce, so we are still using the old Netscape
454 # Usage: set_cookie(name, value, option => value...), where options are:
456 # max-age maximal age in seconds
457 # domain domain name scope
458 # path path name scope
459 # secure if present, cookie applies only to SSL connections
460 # (in this case, the value should be undefined)
461 # discard if present with any value, the cookie is discarded
465 my $value = shift @_;
467 if (exists $other{'discard'}) {
468 delete $other{'discard'};
469 $other{'max-age'} = 0;
471 if (defined(my $age = $other{'max-age'})) {
472 delete $other{'max-age'};
473 my $exp = ($age ? (time + $age) : 0);
474 # Avoid problems with locales
475 my ($S,$M,$H,$d,$m,$y,$wd) = gmtime $exp;
476 my @wdays = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' );
477 my @mons = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
478 $other{'expires'} = sprintf("%s, %02d-%s-%d %02d:%02d:%02d GMT",
479 $wdays[$wd], $d, $mons[$m], $y+1900, $H, $M, $S);
482 print "Set-Cookie: $key=", url_strict_escape($value);
483 foreach my $k (keys %other) {
485 print "=", $other{$k} if defined $other{$k};
490 sub parse_cookies() {
491 my $h = http_get("Cookie") or return ();
493 foreach my $x (split /;\s*/, $h) {
494 my ($k,$v) = split /=/, $x;
495 $v = url_deescape($v) if defined $v;
496 push @cook, $k => $v;