lib/perl/CGI.pm

   1 #       Poor Man's CGI Module for Perl
   2 #
   3 #       (c) 2002--2007 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_param_escape &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_param_escape($) {
  72         my $x = shift @_;
  73         $x = url_escape($x);
  74         $x =~ s/%20/+/g;
  75         return $x;
  76 }
  77
  78 sub html_escape($) {
  79         my $x = shift @_;
  80         $x =~ s/&/&amp;/g;
  81         $x =~ s/</&lt;/g;
  82         $x =~ s/>/&gt;/g;
  83         $x =~ s/"/&quot;/g;
  84         return $x;
  85 }
  86
  87 ### Analysing RFC 822 Style Headers ###
  88
  89 sub rfc822_prepare($) {
  90         my $x = shift @_;
  91         # Convert all %'s and backslash escapes to %xx escapes
  92         $x =~ s/%/%25/g;
  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.
 100         $x =~ s/\s+/ /g;
 101         $x =~ s/(^ | $)//g;
 102         $x =~ s{\s*([()<>@,;:\\"/\[\]?=])\s*}{$1}g;
 103         return $x;
 104 }
 105
 106 sub rfc822_deescape($) {
 107         my $x = shift @_;
 108         $x =~ s/%(..)/pack("H2",$1)/ge;
 109         return $x;
 110 }
 111
 112 ### Reading of HTTP headers ###
 113
 114 sub http_get($) {
 115         my $h = shift @_;
 116         $h =~ tr/a-z-/A-Z_/;
 117         return $ENV{"HTTP_$h"} || $ENV{"$h"};
 118 }
 119
 120 ### Parsing of Arguments ###
 121
 122 my $arg_table;
 123
 124 sub parse_arg_string($) {
 125         my ($s) = @_;
 126         $s =~ s/\s+//;
 127         foreach $_ (split /[&:]/,$s) {
 128                 (/^([^=]+)=(.*)$/) or next;
 129                 my $arg = $arg_table->{$1} or next;
 130                 $_ = $2;
 131                 s/\+/ /g;
 132                 s/%(..)/pack("H2",$1)/eg;
 133                 s/\r\n/\n/g;
 134                 s/\r/\n/g;
 135                 $arg->{'multiline'} || s/(\n|\t)/ /g;
 136                 s/^\s+//;
 137                 s/\s+$//;
 138                 if (my $rx = $arg->{'check'}) {
 139                         if (!/^$rx$/) { $_ = $arg->{'default'}; }
 140                 }
 141
 142                 my $r = ref($arg->{'var'});
 143                 if ($r eq 'SCALAR') {
 144                         ${$arg->{'var'}} = $_;
 145                 } elsif ($r eq 'ARRAY') {
 146                         push @{$arg->{'var'}}, $_;
 147                 }
 148         }
 149 }
 150
 151 sub parse_multipart_form_data();
 152
 153 sub parse_args($) {
 154         $arg_table = shift @_;
 155         if (!defined $ENV{"GATEWAY_INTERFACE"}) {
 156                 print STDERR "Must be called as a CGI script.\n";
 157                 $exit_code = 1;
 158                 exit;
 159         }
 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') {
 166                         @{$a->{'var'}} = ();
 167                 }
 168         }
 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) {
 175                         while (<STDIN>) {
 176                                 chomp;
 177                                 parse_arg_string($_);
 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 ### Parsing Multipart Form Data ###
 190
 191 my $boundary;
 192 my $boundary_len;
 193 my $mp_buffer;
 194 my $mp_buffer_i;
 195 my $mp_buffer_boundary;
 196 my $mp_eof;
 197
 198 sub refill_mp_data($) {
 199         my ($more) = @_;
 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) {
 203                 return $more;
 204         } else {
 205                 if ($mp_buffer_i) {
 206                         $mp_buffer = substr($mp_buffer, $mp_buffer_i);
 207                         $mp_buffer_i = 0;
 208                 }
 209                 while ($mp_buffer_i + $more > length($mp_buffer) - $boundary_len) {
 210                         last if $mp_eof;
 211                         my $data;
 212                         my $n = read(STDIN, $data, 2048);
 213                         if ($n > 0) {
 214                                 $mp_buffer .= $data;
 215                         } else {
 216                                 $mp_eof = 1;
 217                         }
 218                 }
 219                 $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
 220                 if ($mp_buffer_boundary >= 0) {
 221                         return $mp_buffer_boundary;
 222                 } elsif ($mp_eof) {
 223                         return length($mp_buffer);
 224                 } else {
 225                         return length($mp_buffer) - $boundary_len;
 226                 }
 227         }
 228 }
 229
 230 sub get_mp_line($) {
 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;
 237                 return $s;
 238         } elsif ($allow_empty) {
 239                 if ($n) {                                                       # An incomplete line
 240                         my $s = substr($mp_buffer, $mp_buffer_i, $n);
 241                         $mp_buffer_i += $n;
 242                         return $s;
 243                 } else {                                                        # No more lines
 244                         return undef;
 245                 }
 246         } else {
 247                 die "Premature end of multipart POST data";
 248         }
 249 }
 250
 251 sub skip_mp_boundary() {
 252         if ($mp_buffer_boundary != $mp_buffer_i) {
 253                 die "Premature end of multipart POST data";
 254         }
 255         $mp_buffer_boundary = -1;
 256         $mp_buffer_i += 2;
 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--/) {
 261                 return 0;
 262         } else {
 263                 return 1;
 264         }
 265 }
 266
 267 sub parse_mp_header() {
 268         my $h = {};
 269         my $last;
 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;
 275                         $last = $name;
 276                 } elsif ($l =~ /^\s+/ && $last) {
 277                         $h->{$last} .= $l;
 278                 } else {
 279                         $last = undef;
 280                 }
 281         }
 282         foreach my $n (keys %$h) {
 283                 $h->{$n} = rfc822_prepare($h->{$n});
 284                 print STDERR "H $n: $h->{$n}\n" if $debug;
 285         }
 286         return (keys %$h) ? $h : undef;
 287 }
 288
 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";
 294         }
 295         $boundary = rfc822_deescape($boundary);
 296         print STDERR "BOUNDARY IS $boundary\n" if $debug;
 297
 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;
 304
 305         # Check upload size in advance
 306         if (my $size = http_get("Content-Length")) {
 307                 my $max_allowed = 0;
 308                 foreach my $a (values %$arg_table) {
 309                         $max_allowed += $a->{"maxsize"} || 65536;
 310                 }
 311                 if ($size > $max_allowed) {
 312                         die "Maximum form data length exceeded";
 313                 }
 314         }
 315
 316         # Initialize our buffering mechanism and part splitter
 317         $mp_buffer = "\r\n";
 318         $mp_buffer_i = 0;
 319         $mp_buffer_boundary = -1;
 320         $mp_eof = 0;
 321
 322         # Skip garbage before the 1st part
 323         while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
 324         skip_mp_boundary() || return;
 325
 326         # Process individual parts
 327         do { PART: {
 328                 print STDERR "NEXT PART\n" if $debug;
 329                 my $h = parse_mp_header();
 330                 my ($field, $cdisp, $a);
 331                 if ($h &&
 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");
 342                                 }
 343                                 next PART;
 344                         } elsif (defined $a->{"file"}) {
 345                                 require File::Temp;
 346                                 require IO::Handle;
 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"};
 354                                 my $total_size = 0;
 355                                 while (my $i = refill_mp_data(4096)) {
 356                                         print $fh substr($mp_buffer, $mp_buffer_i, $i);
 357                                         $mp_buffer_i += $i;
 358                                         $total_size += $i;
 359                                         if ($total_size > $max_size) { die "Uploaded file too long"; }
 360                                 }
 361                                 $fh->flush();   # Don't close the handle, the file would disappear otherwise
 362                                 next PART;
 363                         }
 364                 }
 365                 print STDERR "SKIPPING\n" if $debug;
 366                 while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
 367         } } while (skip_mp_boundary());
 368 }
 369
 370 ### Generating Self-ref URL's ###
 371
 372 sub make_out_args($) {
 373         my ($overrides) = @_;
 374         my $out = {};
 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;
 379                 my $value;
 380                 if (!defined($value = $overrides->{$name})) {
 381                         if (exists $overrides->{$name}) {
 382                                 $value = $arg->{'default'};
 383                         } else {
 384                                 $value = ${$arg->{'var'}};
 385                         }
 386                 }
 387                 if ($value ne $arg->{'default'}) {
 388                         $out->{$name} = $value;
 389                 }
 390         }
 391         return $out;
 392 }
 393
 394 sub self_ref(@) {
 395         my %h = @_;
 396         my $out = make_out_args(\%h);
 397         return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out);
 398 }
 399
 400 sub self_form(@) {
 401         my %h = @_;
 402         my $out = make_out_args(\%h);
 403         return join('', map { "<input type=hidden name=$_ value='" . html_escape($out->{$_}) . "'>\n" } sort keys %$out);
 404 }
 405
 406 ### Cookies
 407
 408 sub cookie_esc($) {
 409         my $x = shift @_;
 410         if ($x !~ /^[a-zA-Z0-9%]+$/) {
 411                 $x =~ s/([\\\"])/\\$1/g;
 412                 $x = "\"$x\"";
 413         }
 414         return $x;
 415 }
 416
 417 sub set_cookie($$@) {
 418         my $key = shift @_;
 419         my $value = shift @_;
 420         my %other = @_;
 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});
 425         }
 426         print "\n";
 427 }
 428
 429 sub parse_cookies() {
 430         my $h = http_get("Cookie") or return ();
 431         my @cook = ();
 432         while (my ($padding,$name,$val,$xx,$rest) = ($h =~ /\s*([,;]\s*)*([^ =]+)=([^ =,;\"]*|\"([^\"\\]|\\.)*\")(\s.*|;.*|$)/)) {
 433                 if ($val =~ /^\"/) {
 434                         $val =~ s/^\"//;
 435                         $val =~ s/\"$//;
 436                         $val =~ s/\\(.)/$1/g;
 437                 }
 438                 push @cook, $name, $val;
 439                 $h = $rest;
 440         }
 441         return @cook;
 442 }
 443
 444 1;  # OK