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 package UCW::CGI;
  10
  11 use strict;
  12 use warnings;
  13
  14 BEGIN {
  15         # The somewhat hairy Perl export mechanism
  16         use Exporter();
  17         our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  18         $VERSION = 1.0;
  19         @ISA = qw(Exporter);
  20         @EXPORT = qw(&html_escape &url_escape &url_param_escape &self_ref &self_form);
  21         @EXPORT_OK = qw();
  22         %EXPORT_TAGS = ();
  23 }
  24
  25 ### Escaping ###
  26
  27 sub url_escape($) {
  28         my $x = shift @_;
  29         $x =~ s/([^-\$_.!*'(),0-9A-Za-z\x80-\xff])/"%".unpack('H2',$1)/ge;
  30         return $x;
  31 }
  32
  33 sub url_param_escape($) {
  34         my $x = shift @_;
  35         $x = url_escape($x);
  36         $x =~ s/%20/+/g;
  37         return $x;
  38 }
  39
  40 sub html_escape($) {
  41         my $x = shift @_;
  42         $x =~ s/&/&amp;/g;
  43         $x =~ s/</&lt;/g;
  44         $x =~ s/>/&gt;/g;
  45         $x =~ s/"/&quot;/g;
  46         return $x;
  47 }
  48
  49 ### Analysing RFC 822 Style Headers ###
  50
  51 sub rfc822_prepare($) {
  52         my $x = shift @_;
  53         # Convert all %'s and backslash escapes to %xx escapes
  54         $x =~ s/%/%25/g;
  55         $x =~ s/\\(.)/"%".unpack("H2",$1)/ge;
  56         # Remove all comments, beware, they can be nested (unterminated comments are closed at EOL automatically)
  57         while ($x =~ s/^(("[^"]*"|[^"(])*(\([^)]*)*)(\([^()]*(\)|$))/$1 /) { }
  58         # Remove quotes and escape dangerous characters inside (again closing at the end automatically)
  59         $x =~ s{"([^"]*)("|$)}{my $z=$1; $z =~ s/([^0-9a-zA-Z%_-])/"%".unpack("H2",$1)/ge; $z;}ge;
  60         # All control characters are properly escaped, tokens are clearly visible.
  61         # Finally remove all unnecessary spaces.
  62         $x =~ s/\s+/ /g;
  63         $x =~ s/(^ | $)//g;
  64         $x =~ s{\s*([()<>@,;:\\"/\[\]?=])\s*}{$1}g;
  65         return $x;
  66 }
  67
  68 sub rfc822_deescape($) {
  69         my $x = shift @_;
  70         $x =~ s/%(..)/pack("H2",$1)/ge;
  71         return $x;
  72 }
  73
  74 ### Reading of HTTP headers ###
  75
  76 sub http_get($) {
  77         my $h = shift @_;
  78         $h =~ tr/a-z-/A-Z_/;
  79         return $ENV{"HTTP_$h"} || $ENV{"$h"};
  80 }
  81
  82 ### Parsing of Arguments ###
  83
  84 our $arg_table;
  85
  86 sub parse_arg_string($) {
  87         my ($s) = @_;
  88         $s =~ s/\s+//;
  89         foreach $_ (split /[&:]/,$s) {
  90                 (/^([^=]+)=(.*)$/) or next;
  91                 my $arg = $arg_table->{$1} or next;
  92                 $_ = $2;
  93                 s/\+/ /g;
  94                 s/%(..)/pack("H2",$1)/eg;
  95                 s/\r\n/\n/g;
  96                 s/\r/\n/g;
  97                 $arg->{'multiline'} || s/(\n|\t)/ /g;
  98                 s/^\s+//;
  99                 s/\s+$//;
 100                 if (my $rx = $arg->{'check'}) {
 101                         if (!/^$rx$/) { $_ = $arg->{'default'}; }
 102                 }
 103
 104                 my $r = ref($arg->{'var'});
 105                 if ($r eq 'SCALAR') {
 106                         ${$arg->{'var'}} = $_;
 107                 } elsif ($r eq 'ARRAY') {
 108                         push @{$arg->{'var'}}, $_;
 109                 }
 110         }
 111 }
 112
 113 sub parse_multipart_form_data();
 114
 115 sub parse_args($) {
 116         $arg_table = shift @_;
 117         if (!defined $ENV{"GATEWAY_INTERFACE"}) {
 118                 print STDERR "Must be called as a CGI script.\n";
 119                 $exit_code = 1;
 120                 exit;
 121         }
 122         foreach my $a (values %$arg_table) {
 123                 my $r = ref($a->{'var'});
 124                 defined($a->{'default'}) or $a->{'default'}="";
 125                 if ($r eq 'SCALAR') {
 126                         ${$a->{'var'}} = $a->{'default'};
 127                 } elsif ($r eq 'ARRAY') {
 128                         @{$a->{'var'}} = ();
 129                 }
 130         }
 131         my $method = $ENV{"REQUEST_METHOD"};
 132         my $qs = $ENV{"QUERY_STRING"};
 133         parse_arg_string($qs) if defined($qs);
 134         if ($method eq "GET") {
 135         } elsif ($method eq "POST") {
 136                 if ($ENV{"CONTENT_TYPE"} =~ /^application\/x-www-form-urlencoded\b/i) {
 137                         while (<STDIN>) {
 138                                 chomp;
 139                                 parse_arg_string($_);
 140                         }
 141                 } elsif ($ENV{"CONTENT_TYPE"} =~ /^multipart\/form-data\b/i) {
 142                         parse_multipart_form_data();
 143                 } else {
 144                         die "Unknown content type for POST data";
 145                 }
 146         } else {
 147                 die "Unknown request method";
 148         }
 149 }
 150
 151 ### Parsing Multipart Form Data ###
 152
 153 my $boundary;
 154 my $boundary_len;
 155 my $mp_buffer;
 156 my $mp_buffer_i;
 157 my $mp_buffer_boundary;
 158 my $mp_eof;
 159
 160 sub refill_mp_data($) {
 161         my ($more) = @_;
 162         if ($mp_buffer_boundary >= $mp_buffer_i) {
 163                 return $mp_buffer_boundary - $mp_buffer_i;
 164         } elsif ($mp_buffer_i + $more <= length($mp_buffer) - $boundary_len) {
 165                 return $more;
 166         } else {
 167                 if ($mp_buffer_i) {
 168                         $mp_buffer = substr($mp_buffer, $mp_buffer_i);
 169                         $mp_buffer_i = 0;
 170                 }
 171                 while ($mp_buffer_i + $more > length($mp_buffer) - $boundary_len) {
 172                         last if $mp_eof;
 173                         my $data;
 174                         my $n = read(STDIN, $data, 2048);
 175                         if ($n > 0) {
 176                                 $mp_buffer .= $data;
 177                         } else {
 178                                 $mp_eof = 1;
 179                         }
 180                 }
 181                 $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
 182                 if ($mp_buffer_boundary >= 0) {
 183                         return $mp_buffer_boundary;
 184                 } elsif ($mp_eof) {
 185                         return length($mp_buffer);
 186                 } else {
 187                         return length($mp_buffer) - $boundary_len;
 188                 }
 189         }
 190 }
 191
 192 sub get_mp_line($) {
 193         my ($allow_empty) = @_;
 194         my $n = refill_mp_data(1024);
 195         my $i = index($mp_buffer, "\r\n", $mp_buffer_i);
 196         if ($i >= $mp_buffer_i && $i < $mp_buffer_i + $n - 1) {
 197                 my $s = substr($mp_buffer, $mp_buffer_i, $i - $mp_buffer_i);
 198                 $mp_buffer_i = $i + 2;
 199                 return $s;
 200         } elsif ($allow_empty) {
 201                 if ($n) {                                                       # An incomplete line
 202                         my $s = substr($mp_buffer, $mp_buffer_i, $n);
 203                         $mp_buffer_i += $n;
 204                         return $s;
 205                 } else {                                                        # No more lines
 206                         return undef;
 207                 }
 208         } else {
 209                 die "Premature end of multipart POST data";
 210         }
 211 }
 212
 213 sub skip_mp_boundary() {
 214         if ($mp_buffer_boundary != $mp_buffer_i) {
 215                 die "Premature end of multipart POST data";
 216         }
 217         $mp_buffer_boundary = -1;
 218         $mp_buffer_i += 2;
 219         my $b = get_mp_line(0);
 220         print STDERR "SEP $b\n" if $debug;
 221         $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
 222         if ("\r\n$b" =~ /^$boundary--/) {
 223                 return 0;
 224         } else {
 225                 return 1;
 226         }
 227 }
 228
 229 sub parse_mp_header() {
 230         my $h = {};
 231         my $last;
 232         while ((my $l = get_mp_line(0)) ne "") {
 233                 print STDERR "HH $l\n" if $debug;
 234                 if (my ($name, $value) = ($l =~ /([A-Za-z0-9-]+)\s*:\s*(.*)/)) {
 235                         $name =~ tr/A-Z/a-z/;
 236                         $h->{$name} = $value;
 237                         $last = $name;
 238                 } elsif ($l =~ /^\s+/ && $last) {
 239                         $h->{$last} .= $l;
 240                 } else {
 241                         $last = undef;
 242                 }
 243         }
 244         foreach my $n (keys %$h) {
 245                 $h->{$n} = rfc822_prepare($h->{$n});
 246                 print STDERR "H $n: $h->{$n}\n" if $debug;
 247         }
 248         return (keys %$h) ? $h : undef;
 249 }
 250
 251 sub parse_multipart_form_data() {
 252         # First of all, find the boundary string
 253         my $ct = rfc822_prepare($ENV{"CONTENT_TYPE"});
 254         if (!(($boundary) = ($ct =~ /^.*;boundary=([^; ]+)/))) {
 255                 die "Multipart content with no boundary string received";
 256         }
 257         $boundary = rfc822_deescape($boundary);
 258         print STDERR "BOUNDARY IS $boundary\n" if $debug;
 259
 260         # BUG: IE 3.01 on Macintosh forgets to add the "--" at the start of the boundary string
 261         # as the MIME specs preach. Workaround borrowed from CGI.pm in Perl distribution.
 262         my $agent = http_get("User-agent") || "";
 263         $boundary = "--$boundary" unless $agent =~ /MSIE\s+3\.0[12];\s*Mac/;
 264         $boundary = "\r\n$boundary";
 265         $boundary_len = length($boundary) + 2;
 266
 267         # Check upload size in advance
 268         if (my $size = http_get("Content-Length")) {
 269                 my $max_allowed = 0;
 270                 foreach my $a (values %$arg_table) {
 271                         $max_allowed += $a->{"maxsize"} || 65536;
 272                 }
 273                 if ($size > $max_allowed) {
 274                         die "Maximum form data length exceeded";
 275                 }
 276         }
 277
 278         # Initialize our buffering mechanism and part splitter
 279         $mp_buffer = "\r\n";
 280         $mp_buffer_i = 0;
 281         $mp_buffer_boundary = -1;
 282         $mp_eof = 0;
 283
 284         # Skip garbage before the 1st part
 285         while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
 286         skip_mp_boundary() || return;
 287
 288         # Process individual parts
 289         do { PART: {
 290                 print STDERR "NEXT PART\n" if $debug;
 291                 my $h = parse_mp_header();
 292                 my ($field, $cdisp, $a);
 293                 if ($h &&
 294                     ($cdisp = $h->{"content-disposition"}) &&
 295                     $cdisp =~ /^form-data/ &&
 296                     (($field) = ($cdisp =~ /;name=([^;]+)/)) &&
 297                     ($a = $arg_table->{"$field"})) {
 298                         print STDERR "FIELD $field\n" if $debug;
 299                         if (defined $h->{"content-transfer-encoding"}) { die "Unexpected Content-Transfer-Encoding"; }
 300                         if (defined $a->{"var"}) {
 301                                 while (defined (my $l = get_mp_line(1))) {
 302                                         print STDERR "VALUE $l\n" if $debug;
 303                                         parse_arg_string("$field=$l");
 304                                 }
 305                                 next PART;
 306                         } elsif (defined $a->{"file"}) {
 307                                 require File::Temp;
 308                                 require IO::Handle;
 309                                 my $max_size = $a->{"maxsize"} || 1048576;
 310                                 my @tmpargs = (undef, UNLINK => 1);
 311                                 push @tmpargs, DIR => $a->{"tmpdir"} if defined $a->{"tmpdir"};
 312                                 my ($fh, $fn) = File::Temp::tempfile(@tmpargs);
 313                                 print STDERR "FILE UPLOAD to $fn\n" if $debug;
 314                                 ${$a->{"file"}} = $fn;
 315                                 ${$a->{"fh"}} = $fh if defined $a->{"fh"};
 316                                 my $total_size = 0;
 317                                 while (my $i = refill_mp_data(4096)) {
 318                                         print $fh substr($mp_buffer, $mp_buffer_i, $i);
 319                                         $mp_buffer_i += $i;
 320                                         $total_size += $i;
 321                                         if ($total_size > $max_size) { die "Uploaded file too long"; }
 322                                 }
 323                                 $fh->flush();   # Don't close the handle, the file would disappear otherwise
 324                                 next PART;
 325                         }
 326                 }
 327                 print STDERR "SKIPPING\n" if $debug;
 328                 while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
 329         } } while (skip_mp_boundary());
 330 }
 331
 332 ### Generating Self-ref URL's ###
 333
 334 sub make_out_args($) {
 335         my ($overrides) = @_;
 336         my $out = {};
 337         foreach my $name (keys %$arg_table) {
 338                 my $arg = $arg_table->{$name};
 339                 defined($arg->{'var'}) || next;
 340                 defined($arg->{'pass'}) && !$arg->{'pass'} && !exists $overrides->{$name} && next;
 341                 my $value;
 342                 if (!defined($value = $overrides->{$name})) {
 343                         if (exists $overrides->{$name}) {
 344                                 $value = $arg->{'default'};
 345                         } else {
 346                                 $value = ${$arg->{'var'}};
 347                         }
 348                 }
 349                 if ($value ne $arg->{'default'}) {
 350                         $out->{$name} = $value;
 351                 }
 352         }
 353         return $out;
 354 }
 355
 356 sub self_ref(@) {
 357         my %h = @_;
 358         my $out = make_out_args(\%h);
 359         return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out);
 360 }
 361
 362 sub self_form(@) {
 363         my %h = @_;
 364         my $out = make_out_args(\%h);
 365         return join('', map { "<input type=hidden name=$_ value='" . html_escape($out->{$_}) . "'>\n" } sort keys %$out);
 366 }
 367
 368 ### Cookies
 369
 370 sub cookie_esc($) {
 371         my $x = shift @_;
 372         if ($x !~ /^[a-zA-Z0-9%]+$/) {
 373                 $x =~ s/([\\\"])/\\$1/g;
 374                 $x = "\"$x\"";
 375         }
 376         return $x;
 377 }
 378
 379 sub set_cookie($$@) {
 380         my $key = shift @_;
 381         my $value = shift @_;
 382         my %other = @_;
 383         $other{'version'} = 1 unless defined $other{'version'};
 384         print "Set-Cookie: $key=", cookie_esc($value);
 385         foreach my $k (keys %other) {
 386                 print ";$k=", cookie_esc($other{$k});
 387         }
 388         print "\n";
 389 }
 390
 391 sub parse_cookies() {
 392         my $h = http_get("Cookie") or return ();
 393         my @cook = ();
 394         while (my ($padding,$name,$val,$xx,$rest) = ($h =~ /\s*([,;]\s*)*([^ =]+)=([^ =,;\"]*|\"([^\"\\]|\\.)*\")(\s.*|;.*|$)/)) {
 395                 if ($val =~ /^\"/) {
 396                         $val =~ s/^\"//;
 397                         $val =~ s/\"$//;
 398                         $val =~ s/\\(.)/$1/g;
 399                 }
 400                 push @cook, $name, $val;
 401                 $h = $rest;
 402         }
 403         return @cook;
 404 }
 405
 406 1;  # OK