ucw/perl/UCW/CGI.pm

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