web/UCW/CGI.pm

   1 #       Poor Man's CGI Module for Perl
   2 #
   3 #       (c) 2002--2011 Martin Mares <mj@ucw.cz>
   4 #       Slightly modified by Tomas Valla <tom@ucw.cz>
   5 #
   6 #       This software may be freely distributed and used according to the terms
   7 #       of the GNU Lesser General Public License.
   8
   9 package UCW::CGI;
  10
  11 # First of all, set up error handling, so that even errors during parsing
  12 # will be reported properly.
  13
  14 # Variables to be set by the calling module:
  15 #       $UCW::CGI::error_mail           mail address of the script admin (optional)
  16 #                                       (this one has to be set in the BEGIN block!)
  17 #       $UCW::CGI::error_hook           function to be called for reporting errors
  18
  19 my $error_reported;
  20 my $exit_code;
  21 my $debug = 0;
  22
  23 sub report_bug($)
  24 {
  25         if (!defined $error_reported) {
  26                 $error_reported = 1;
  27                 print STDERR $_[0];
  28                 if (defined($UCW::CGI::error_hook)) {
  29                         &$UCW::CGI::error_hook($_[0]);
  30                 } else {
  31                         print "Content-Type: text/plain\n\n";
  32                         print "Internal bug:\n";
  33                         print $_[0], "\n";
  34                         print "Please notify $UCW::CGI::error_mail\n" if defined $UCW::CGI::error_mail;
  35                 }
  36         }
  37         die;
  38 }
  39
  40 BEGIN {
  41         $SIG{__DIE__} = sub { report_bug($_[0]); };
  42         $SIG{__WARN__} = sub { report_bug("WARNING: " . $_[0]); };
  43         $exit_code = 0;
  44 }
  45
  46 END {
  47         $? = $exit_code;
  48 }
  49
  50 use strict;
  51 use warnings;
  52
  53 require Exporter;
  54 our $VERSION = 1.0;
  55 our @ISA = qw(Exporter);
  56 our @EXPORT = qw(&html_escape &url_escape &url_deescape &url_param_escape &url_param_deescape &self_ref &self_form &http_get);
  57 our @EXPORT_OK = qw();
  58
  59 our $utf8_mode = 0;
  60
  61 sub http_error($;@) {
  62         my $err = shift @_;
  63         print join("\n", "Status: $err", "Content-Type: text/plain", @_, "", $err, "");
  64         exit;
  65 }
  66
  67 ### Escaping ###
  68
  69 sub url_escape($) {
  70         my $x = shift @_;
  71         utf8::encode($x) if $utf8_mode;
  72         $x =~ s/([^-\$_.!*'(),0-9A-Za-z\x80-\xff])/"%".unpack('H2',$1)/ge;
  73         utf8::decode($x) if $utf8_mode;
  74         return $x;
  75 }
  76
  77 sub url_deescape($) {
  78         my $x = shift @_;
  79         utf8::encode($x) if $utf8_mode;
  80         $x =~ s/%(..)/pack("H2",$1)/ge;
  81         utf8::decode($x) if $utf8_mode;
  82         return $x;
  83 }
  84
  85 sub url_param_escape($) {
  86         my $x = shift @_;
  87         $x = url_escape($x);
  88         $x =~ s/%20/+/g;
  89         return $x;
  90 }
  91
  92 sub url_param_deescape($) {
  93         my $x = shift @_;
  94         $x =~ s/\+/ /g;
  95         return url_deescape($x);
  96 }
  97
  98 sub html_escape($) {
  99         my $x = shift @_;
 100         $x =~ s/&/&amp;/g;
 101         $x =~ s/</&lt;/g;
 102         $x =~ s/>/&gt;/g;
 103         $x =~ s/"/&quot;/g;
 104         $x =~ s/'/&#39;/g;
 105         return $x;
 106 }
 107
 108 ### Analysing RFC 822 Style Headers ###
 109
 110 sub rfc822_prepare($) {
 111         my $x = shift @_;
 112         # Convert all %'s and backslash escapes to %xx escapes
 113         $x =~ s/%/%25/g;
 114         $x =~ s/\\(.)/"%".unpack("H2",$1)/ge;
 115         # Remove all comments, beware, they can be nested (unterminated comments are closed at EOL automatically)
 116         while ($x =~ s/^(("[^"]*"|[^"(])*(\([^)]*)*)(\([^()]*(\)|$))/$1 /) { }
 117         # Remove quotes and escape dangerous characters inside (again closing at the end automatically)
 118         $x =~ s{"([^"]*)("|$)}{my $z=$1; $z =~ s/([^0-9a-zA-Z%_-])/"%".unpack("H2",$1)/ge; $z;}ge;
 119         # All control characters are properly escaped, tokens are clearly visible.
 120         # Finally remove all unnecessary spaces.
 121         $x =~ s/\s+/ /g;
 122         $x =~ s/(^ | $)//g;
 123         $x =~ s{\s*([()<>@,;:\\"/\[\]?=])\s*}{$1}g;
 124         return $x;
 125 }
 126
 127 sub rfc822_deescape($) {
 128         my $x = shift @_;
 129         return url_deescape($x);
 130 }
 131
 132 ### Reading of HTTP headers ###
 133
 134 sub http_get($) {
 135         my $h = shift @_;
 136         $h =~ tr/a-z-/A-Z_/;
 137         return $ENV{"HTTP_$h"} // $ENV{"$h"};
 138 }
 139
 140 ### Parsing of Arguments ###
 141
 142 my $main_arg_table;
 143 my %raw_args;
 144
 145 sub parse_raw_args_ll($$) {
 146         my ($arg, $s) = @_;
 147         $s =~ s/\r\n/\n/g;
 148         $s =~ s/\r/\n/g;
 149         utf8::decode($s) if $utf8_mode;
 150         push @{$raw_args{$arg}}, $s;
 151 }
 152
 153 sub parse_raw_args($) {
 154         my ($s) = @_;
 155         $s =~ s/\s+//;
 156         for $_ (split /[&:]/, $s) {
 157                 (/^([^=]+)=(.*)$/) or next;
 158                 my $arg = $1;
 159                 $_ = $2;
 160                 s/\+/ /g;
 161                 s/%(..)/pack("H2",$1)/eg;
 162                 parse_raw_args_ll($arg, $_);
 163         }
 164 }
 165
 166 sub parse_multipart_form_data();
 167
 168 sub init_args() {
 169         if (!defined $ENV{"GATEWAY_INTERFACE"}) {
 170                 print STDERR "Must be called as a CGI script.\n";
 171                 $exit_code = 1;
 172                 exit;
 173         }
 174
 175         my $method = $ENV{"REQUEST_METHOD"};
 176         if (my $qs = $ENV{"QUERY_STRING"}) {
 177                 parse_raw_args($qs);
 178         }
 179         if ($method eq "GET" || $method eq "HEAD") {
 180         } elsif ($method eq "POST") {
 181                 my $content_type = $ENV{"CONTENT_TYPE"} // "";
 182                 if ($content_type =~ /^application\/x-www-form-urlencoded\b/i) {
 183                         while (<STDIN>) {
 184                                 chomp;
 185                                 parse_raw_args($_);
 186                         }
 187                 } elsif ($content_type =~ /^multipart\/form-data\b/i) {
 188                         parse_multipart_form_data();
 189                 } else {
 190                         http_error "415 Unsupported Media Type";
 191                         exit;
 192                 }
 193         } else {
 194                 http_error "405 Method Not Allowed", "Allow: GET, HEAD, PUT";
 195         }
 196 }
 197
 198 sub parse_args($) {                     # CAVEAT: attached files must be defined in the main arg table
 199         my $args = shift @_;
 200         if (!$main_arg_table) {
 201                 $main_arg_table = $args;
 202                 init_args();
 203         }
 204
 205         for my $a (values %$args) {
 206                 my $r = ref($a->{'var'});
 207                 defined($a->{'default'}) or $a->{'default'}="";
 208                 if ($r eq 'SCALAR') {
 209                         ${$a->{'var'}} = $a->{'default'};
 210                 } elsif ($r eq 'ARRAY') {
 211                         @{$a->{'var'}} = ();
 212                 }
 213         }
 214
 215         for my $arg (keys %$args) {
 216                 my $a = $args->{$arg};
 217                 defined($raw_args{$arg}) or next;
 218                 for (@{$raw_args{$arg}}) {
 219                         $a->{'multiline'} or s/(\n|\t)/ /g;
 220                         s/^\s+//;
 221                         s/\s+$//;
 222                         if (my $rx = $a->{'check'}) {
 223                                 if (!/^$rx$/) { $_ = $a->{'default'}; }
 224                         }
 225
 226                         my $v = $a->{'var'};
 227                         my $r = ref($v);
 228                         if ($r eq 'SCALAR') {
 229                                 $$v = $_;
 230                         } elsif ($r eq 'ARRAY') {
 231                                 push @$v, $_;
 232                         }
 233                 }
 234         }
 235 }
 236
 237 ### Parsing Multipart Form Data ###
 238
 239 my $boundary;
 240 my $boundary_len;
 241 my $mp_buffer;
 242 my $mp_buffer_i;
 243 my $mp_buffer_boundary;
 244 my $mp_eof;
 245
 246 sub refill_mp_data($) {
 247         my ($more) = @_;
 248         if ($mp_buffer_boundary >= $mp_buffer_i) {
 249                 return $mp_buffer_boundary - $mp_buffer_i;
 250         } elsif ($mp_buffer_i + $more <= length($mp_buffer) - $boundary_len) {
 251                 return $more;
 252         } else {
 253                 if ($mp_buffer_i) {
 254                         $mp_buffer = substr($mp_buffer, $mp_buffer_i);
 255                         $mp_buffer_i = 0;
 256                 }
 257                 while ($mp_buffer_i + $more > length($mp_buffer) - $boundary_len) {
 258                         last if $mp_eof;
 259                         my $data;
 260                         my $n = read(STDIN, $data, 2048);
 261                         if ($n > 0) {
 262                                 $mp_buffer .= $data;
 263                         } else {
 264                                 $mp_eof = 1;
 265                         }
 266                 }
 267                 $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
 268                 if ($mp_buffer_boundary >= 0) {
 269                         return $mp_buffer_boundary;
 270                 } elsif ($mp_eof) {
 271                         return length($mp_buffer);
 272                 } else {
 273                         return length($mp_buffer) - $boundary_len;
 274                 }
 275         }
 276 }
 277
 278 sub get_mp_line($) {
 279         my ($allow_empty) = @_;
 280         my $n = refill_mp_data(1024);
 281         my $i = index($mp_buffer, "\r\n", $mp_buffer_i);
 282         if ($i >= $mp_buffer_i && $i < $mp_buffer_i + $n - 1) {
 283                 my $s = substr($mp_buffer, $mp_buffer_i, $i - $mp_buffer_i);
 284                 $mp_buffer_i = $i + 2;
 285                 return $s;
 286         } elsif ($allow_empty) {
 287                 if ($n) {                                                       # An incomplete line
 288                         my $s = substr($mp_buffer, $mp_buffer_i, $n);
 289                         $mp_buffer_i += $n;
 290                         return $s;
 291                 } else {                                                        # No more lines
 292                         return undef;
 293                 }
 294         } else {
 295                 http_error "400 Bad Request: Premature end of multipart POST data";
 296         }
 297 }
 298
 299 sub skip_mp_boundary() {
 300         if ($mp_buffer_boundary != $mp_buffer_i) {
 301                 http_error "400 Bad Request: Premature end of multipart POST data";
 302         }
 303         $mp_buffer_boundary = -1;
 304         $mp_buffer_i += 2;
 305         my $b = get_mp_line(0);
 306         print STDERR "SEP $b\n" if $debug;
 307         $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
 308         if (substr("\r\n$b", 0, $boundary_len) eq "$boundary--") {
 309                 return 0;
 310         } else {
 311                 return 1;
 312         }
 313 }
 314
 315 sub parse_mp_header() {
 316         my $h = {};
 317         my $last;
 318         while ((my $l = get_mp_line(0)) ne "") {
 319                 print STDERR "HH $l\n" if $debug;
 320                 if (my ($name, $value) = ($l =~ /([A-Za-z0-9-]+)\s*:\s*(.*)/)) {
 321                         $name =~ tr/A-Z/a-z/;
 322                         $h->{$name} = $value;
 323                         $last = $name;
 324                 } elsif ($l =~ /^\s+/ && $last) {
 325                         $h->{$last} .= $l;
 326                 } else {
 327                         $last = undef;
 328                 }
 329         }
 330         foreach my $n (keys %$h) {
 331                 $h->{$n} = rfc822_prepare($h->{$n});
 332                 print STDERR "H $n: $h->{$n}\n" if $debug;
 333         }
 334         return (keys %$h) ? $h : undef;
 335 }
 336
 337 sub parse_multipart_form_data() {
 338         # First of all, find the boundary string
 339         my $ct = rfc822_prepare($ENV{"CONTENT_TYPE"});
 340         if (!(($boundary) = ($ct =~ /^.*;\s*boundary=([^; ]+)/))) {
 341                 http_error "400 Bad Request: Multipart content with no boundary string received";
 342         }
 343         $boundary = rfc822_deescape($boundary);
 344         print STDERR "BOUNDARY IS $boundary\n" if $debug;
 345
 346         # BUG: IE 3.01 on Macintosh forgets to add the "--" at the start of the boundary string
 347         # as the MIME specs preach. Workaround borrowed from CGI.pm in Perl distribution.
 348         my $agent = http_get("User-Agent") // "";
 349         $boundary = "--$boundary" unless $agent =~ /MSIE\s+3\.0[12];\s*Mac/;
 350         $boundary = "\r\n$boundary";
 351         $boundary_len = length($boundary) + 2;
 352
 353         # Check upload size in advance
 354         if (my $size = http_get("Content-Length")) {
 355                 my $max_allowed = 0;
 356                 foreach my $a (values %$main_arg_table) {
 357                         $max_allowed += $a->{"maxsize"} || 65536;
 358                 }
 359                 if ($size > $max_allowed) {
 360                         http_error "413 Request Entity Too Large";
 361                 }
 362         }
 363
 364         # Initialize our buffering mechanism and part splitter
 365         $mp_buffer = "\r\n";
 366         $mp_buffer_i = 0;
 367         $mp_buffer_boundary = -1;
 368         $mp_eof = 0;
 369
 370         # Skip garbage before the 1st part
 371         while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
 372         skip_mp_boundary() || return;
 373
 374         # Process individual parts
 375         do { PART: {
 376                 print STDERR "NEXT PART\n" if $debug;
 377                 my $h = parse_mp_header();
 378                 my ($field, $cdisp, $a);
 379                 if ($h &&
 380                     ($cdisp = $h->{"content-disposition"}) &&
 381                     $cdisp =~ /^form-data/ &&
 382                     (($field) = ($cdisp =~ /;name=([^;]+)/)) &&
 383                     ($a = $main_arg_table->{"$field"})) {
 384                         print STDERR "FIELD $field\n" if $debug;
 385                         if (defined $h->{"content-transfer-encoding"}) {
 386                                 http_error "400 Bad Request: Unexpected Content-Transfer-Encoding";
 387                         }
 388                         if (defined $a->{"var"}) {
 389                                 while (defined (my $l = get_mp_line(1))) {
 390                                         print STDERR "VALUE $l\n" if $debug;
 391                                         parse_raw_args_ll($field, $l);
 392                                 }
 393                                 next PART;
 394                         } elsif (defined $a->{"file"}) {
 395                                 require File::Temp;
 396                                 require IO::Handle;
 397                                 my $max_size = $a->{"maxsize"} || 1048576;
 398                                 my @tmpargs = (undef, UNLINK => 1);
 399                                 push @tmpargs, DIR => $a->{"tmpdir"} if defined $a->{"tmpdir"};
 400                                 my ($fh, $fn) = File::Temp::tempfile(@tmpargs);
 401                                 print STDERR "FILE UPLOAD to $fn\n" if $debug;
 402                                 ${$a->{"file"}} = $fn;
 403                                 ${$a->{"fh"}} = $fh if defined $a->{"fh"};
 404                                 my $total_size = 0;
 405                                 while (my $i = refill_mp_data(4096)) {
 406                                         print $fh substr($mp_buffer, $mp_buffer_i, $i);
 407                                         $mp_buffer_i += $i;
 408                                         $total_size += $i;
 409                                         if ($total_size > $max_size) { http_error "413 Request Entity Too Large"; }
 410                                 }
 411                                 $fh->flush();   # Don't close the handle, the file would disappear otherwise
 412                                 next PART;
 413                         }
 414                 }
 415                 print STDERR "SKIPPING\n" if $debug;
 416                 while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
 417         } } while (skip_mp_boundary());
 418 }
 419
 420 ### Generating Self-ref URL's ###
 421
 422 sub make_out_args(@) {          # Usage: make_out_args([arg_table, ...] name => value, ...)
 423         my @arg_tables = ( $main_arg_table );
 424         while (@_ && ref($_[0]) eq 'HASH') {
 425                 push @arg_tables, shift @_;
 426         }
 427         my %overrides = @_;
 428         my $out = {};
 429         for my $table (@arg_tables) {
 430                 for my $name (keys %$table) {
 431                         my $arg = $table->{$name};
 432                         defined($arg->{'var'}) || next;
 433                         defined($arg->{'pass'}) && !$arg->{'pass'} && !exists $overrides{$name} && next;
 434                         defined $arg->{'default'} or $arg->{'default'} = "";
 435                         my $value;
 436                         if (!defined($value = $overrides{$name})) {
 437                                 if (exists $overrides{$name}) {
 438                                         $value = $arg->{'default'};
 439                                 } else {
 440                                         $value = ${$arg->{'var'}};
 441                                         defined $value or $value = $arg->{'default'};
 442                                 }
 443                         }
 444                         if ($value ne $arg->{'default'}) {
 445                                 $out->{$name} = $value;
 446                         }
 447                 }
 448         }
 449         return $out;
 450 }
 451
 452 sub self_ref(@) {
 453         my $out = make_out_args(@_);
 454         return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out);
 455 }
 456
 457 sub self_form(@) {
 458         my $out = make_out_args(@_);
 459         return join('', map { "<input type=hidden name=$_ value='" . html_escape($out->{$_}) . "'>\n" } sort keys %$out);
 460 }
 461
 462 ### Cookies
 463
 464 sub set_cookie($$@) {
 465         #
 466         # Unfortunately, the support for the new cookie standard (RFC 2965) among
 467         # web browsers is still very scarce, so we are still using the old Netscape
 468         # specification.
 469         #
 470         # Usage: set_cookie(name, value, option => value...), where options are:
 471         #
 472         #       max-age         maximal age in seconds
 473         #       domain          domain name scope
 474         #       path            path name scope
 475         #       secure          if present, cookie applies only to SSL connections
 476         #                       (in this case, the value should be undefined)
 477         #       discard         if present with any value, the cookie is discarded
 478         #
 479
 480         my $key = shift @_;
 481         my $value = shift @_;
 482         my %other = @_;
 483         if (exists $other{'discard'}) {
 484                 delete $other{'discard'};
 485                 $other{'max-age'} = 0;
 486         }
 487         if (defined(my $age = $other{'max-age'})) {
 488                 delete $other{'max-age'};
 489                 my $exp = ($age ? (time + $age) : 0);
 490                 # Avoid problems with locales
 491                 my ($S,$M,$H,$d,$m,$y,$wd) = gmtime $exp;
 492                 my @wdays = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' );
 493                 my @mons = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
 494                 $other{'expires'} = sprintf("%s, %02d-%s-%d %02d:%02d:%02d GMT",
 495                         $wdays[$wd], $d, $mons[$m], $y+1900, $H, $M, $S);
 496         }
 497
 498         print "Set-Cookie: $key=", url_escape($value);
 499         foreach my $k (keys %other) {
 500                 print "; $k";
 501                 print "=", $other{$k} if defined $other{$k};
 502         }
 503         print "\n";
 504 }
 505
 506 sub parse_cookies() {
 507         my $h = http_get("Cookie") or return ();
 508         my @cook = ();
 509         foreach my $x (split /;\s*/, $h) {
 510                 my ($k,$v) = split /=/, $x;
 511                 $v = url_deescape($v) if defined $v;
 512                 push @cook, $k => $v;
 513         }
 514         return @cook;
 515 }
 516
 517 1;  # OK