ucw/perl/UCW/CGI.pm

   1 #       Poor Man's CGI Module for Perl
   2 #
   3 #       (c) 2002--2017 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 require Exporter;
  15 our $VERSION = 1.0;
  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();
  19
  20 # Configuration settings
  21 our $debug = 0;
  22 our $utf8_mode = 0;
  23
  24 sub http_error($;@) {
  25         my $err = shift @_;
  26         print join("\n", "Status: $err", "Content-Type: text/plain", @_, "", $err, "");
  27         exit;
  28 }
  29
  30 ### Escaping ###
  31
  32 sub url_escape($) {
  33         my $x = shift @_;
  34         defined $x or return;
  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;
  38         return $x;
  39 }
  40
  41 sub url_strict_escape($) {
  42         my $x = shift @_;
  43         defined $x or return;
  44         utf8::encode($x);
  45         $x =~ s/([^-\$_.!*'(),0-9A-Za-z])/"%".unpack('H2',$1)/ge;
  46         return $x;
  47 }
  48
  49 sub url_deescape($) {
  50         my $x = shift @_;
  51         defined $x or return;
  52         utf8::encode($x) if $utf8_mode;
  53         $x =~ s/%(..)/pack("H2",$1)/ge;
  54         utf8::decode($x) if $utf8_mode;
  55         return $x;
  56 }
  57
  58 sub url_param_escape($) {
  59         my $x = shift @_;
  60         defined $x or return;
  61         utf8::encode($x) if $utf8_mode;
  62         $x =~ s/([^-\$_.!*'(),0-9A-Za-z])/"%".unpack('H2',$1)/ge;
  63         $x =~ s/%20/+/g;
  64         utf8::decode($x) if $utf8_mode;
  65         return $x;
  66 }
  67
  68 sub url_param_deescape($) {
  69         my $x = shift @_;
  70         defined $x or return;
  71         $x =~ s/\+/ /g;
  72         return url_deescape($x);
  73 }
  74
  75 sub html_escape($) {
  76         my $x = shift @_;
  77         defined $x or return;
  78         $x =~ s/&/&amp;/g;
  79         $x =~ s/</&lt;/g;
  80         $x =~ s/>/&gt;/g;
  81         $x =~ s/"/&quot;/g;
  82         $x =~ s/'/&#39;/g;
  83         return $x;
  84 }
  85
  86 ### Analysing RFC 822 Style Headers ###
  87
  88 sub rfc822_prepare($) {
  89         my $x = shift @_;
  90         # Convert all %'s and backslash escapes to %xx escapes
  91         $x =~ s/%/%25/g;
  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.
  99         $x =~ s/\s+/ /g;
 100         $x =~ s/(^ | $)//g;
 101         $x =~ s{\s*([()<>@,;:\\"/\[\]?=])\s*}{$1}g;
 102         return $x;
 103 }
 104
 105 sub rfc822_deescape($) {
 106         my $x = shift @_;
 107         return url_deescape($x);
 108 }
 109
 110 ### Reading of HTTP headers ###
 111
 112 sub http_get($) {
 113         my $h = shift @_;
 114         $h =~ tr/a-z-/A-Z_/;
 115         return $ENV{"HTTP_$h"} // $ENV{"$h"};
 116 }
 117
 118 ### Parsing of Arguments ###
 119
 120 my $main_arg_table;
 121 my %raw_args;
 122
 123 sub parse_raw_args_ll($$) {
 124         my ($arg, $s) = @_;
 125         $s =~ s/\r\n/\n/g;
 126         $s =~ s/\r/\n/g;
 127         utf8::decode($s) if $utf8_mode;
 128         push @{$raw_args{$arg}}, $s;
 129 }
 130
 131 sub parse_raw_args($) {
 132         my ($s) = @_;
 133         $s =~ s/\s+//;
 134         for $_ (split /[&:]/, $s) {
 135                 (/^([^=]+)=(.*)$/) or next;
 136                 my $arg = $1;
 137                 $_ = $2;
 138                 s/\+/ /g;
 139                 s/%(..)/pack("H2",$1)/eg;
 140                 parse_raw_args_ll($arg, $_);
 141         }
 142 }
 143
 144 sub parse_multipart_form_data();
 145
 146 sub init_args() {
 147         if (!defined $ENV{"GATEWAY_INTERFACE"}) {
 148                 print STDERR "Must be called as a CGI script.\n";
 149                 $UCW::CGI::ErrorHandler::exit_code = 1;
 150                 exit;
 151         }
 152
 153         my $method = $ENV{"REQUEST_METHOD"};
 154         if (my $qs = $ENV{"QUERY_STRING"}) {
 155                 parse_raw_args($qs);
 156         }
 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) {
 161                         while (<STDIN>) {
 162                                 chomp;
 163                                 parse_raw_args($_);
 164                         }
 165                 } elsif ($content_type =~ /^multipart\/form-data\b/i) {
 166                         parse_multipart_form_data();
 167                 } else {
 168                         http_error "415 Unsupported Media Type";
 169                         exit;
 170                 }
 171         } else {
 172                 http_error "405 Method Not Allowed", "Allow: GET, HEAD, POST";
 173         }
 174 }
 175
 176 sub parse_args($) {                     # CAVEAT: attached files must be defined in the main arg table
 177         my $args = shift @_;
 178         if (!$main_arg_table) {
 179                 $main_arg_table = $args;
 180                 init_args();
 181         }
 182
 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') {
 189                         @{$a->{'var'}} = ();
 190                 }
 191         }
 192
 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'}) {
 199                                 s/^\s+//;
 200                                 s/\s+$//;
 201                         }
 202                         if (my $rx = $a->{'check'}) {
 203                                 if (!/^$rx$/) { $_ = $a->{'default'}; }
 204                         }
 205
 206                         my $v = $a->{'var'};
 207                         my $r = ref($v);
 208                         if ($r eq 'SCALAR') {
 209                                 $$v = $_;
 210                         } elsif ($r eq 'ARRAY') {
 211                                 push @$v, $_;
 212                         }
 213                 }
 214         }
 215 }
 216
 217 ### Parsing Multipart Form Data ###
 218
 219 my $boundary;
 220 my $boundary_len;
 221 my $mp_buffer;
 222 my $mp_buffer_i;
 223 my $mp_buffer_boundary;
 224 my $mp_eof;
 225
 226 sub refill_mp_data($) {
 227         my ($more) = @_;
 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) {
 231                 return $more;
 232         } else {
 233                 if ($mp_buffer_i) {
 234                         $mp_buffer = substr($mp_buffer, $mp_buffer_i);
 235                         $mp_buffer_i = 0;
 236                 }
 237                 while ($mp_buffer_i + $more > length($mp_buffer) - $boundary_len) {
 238                         last if $mp_eof;
 239                         my $data;
 240                         my $n = read(STDIN, $data, 2048);
 241                         if ($n > 0) {
 242                                 $mp_buffer .= $data;
 243                         } else {
 244                                 $mp_eof = 1;
 245                         }
 246                 }
 247                 $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
 248                 if ($mp_buffer_boundary >= 0) {
 249                         return $mp_buffer_boundary;
 250                 } elsif ($mp_eof) {
 251                         return length($mp_buffer);
 252                 } else {
 253                         return length($mp_buffer) - $boundary_len;
 254                 }
 255         }
 256 }
 257
 258 sub get_mp_line($) {
 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;
 265                 return $s;
 266         } elsif ($allow_empty) {
 267                 if ($n) {                                                       # An incomplete line
 268                         my $s = substr($mp_buffer, $mp_buffer_i, $n);
 269                         $mp_buffer_i += $n;
 270                         return $s;
 271                 } else {                                                        # No more lines
 272                         return undef;
 273                 }
 274         } else {
 275                 http_error "400 Bad Request: Premature end of multipart POST data";
 276         }
 277 }
 278
 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";
 282         }
 283         $mp_buffer_boundary = -1;
 284         $mp_buffer_i += 2;
 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--") {
 289                 return 0;
 290         } else {
 291                 return 1;
 292         }
 293 }
 294
 295 sub parse_mp_header() {
 296         my $h = {};
 297         my $last;
 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;
 303                         $last = $name;
 304                 } elsif ($l =~ /^\s+/ && $last) {
 305                         $h->{$last} .= $l;
 306                 } else {
 307                         $last = undef;
 308                 }
 309         }
 310         foreach my $n (keys %$h) {
 311                 $h->{$n} = rfc822_prepare($h->{$n});
 312                 print STDERR "H $n: $h->{$n}\n" if $debug;
 313         }
 314         return (keys %$h) ? $h : undef;
 315 }
 316
 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";
 322         }
 323         $boundary = rfc822_deescape($boundary);
 324         print STDERR "BOUNDARY IS $boundary\n" if $debug;
 325
 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;
 332
 333         # Check upload size in advance
 334         if (my $size = http_get("Content-Length")) {
 335                 my $max_allowed = 0;
 336                 foreach my $a (values %$main_arg_table) {
 337                         $max_allowed += $a->{"maxsize"} || 65536;
 338                 }
 339                 if ($size > $max_allowed) {
 340                         http_error "413 Request Entity Too Large";
 341                 }
 342         }
 343
 344         # Initialize our buffering mechanism and part splitter
 345         $mp_buffer = "\r\n";
 346         $mp_buffer_i = 0;
 347         $mp_buffer_boundary = -1;
 348         $mp_eof = 0;
 349
 350         # Skip garbage before the 1st part
 351         while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
 352         skip_mp_boundary() || return;
 353
 354         # Process individual parts
 355         do { PART: {
 356                 print STDERR "NEXT PART\n" if $debug;
 357                 my $h = parse_mp_header();
 358                 my ($field, $cdisp, $a);
 359                 if ($h &&
 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";
 367                         }
 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);
 372                                 }
 373                                 next PART;
 374                         } elsif (defined $a->{"file"}) {
 375                                 require File::Temp;
 376                                 require IO::Handle;
 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;
 387                                 }
 388                                 my $total_size = 0;
 389                                 while (my $i = refill_mp_data(4096)) {
 390                                         print $fh substr($mp_buffer, $mp_buffer_i, $i);
 391                                         $mp_buffer_i += $i;
 392                                         $total_size += $i;
 393                                         if ($total_size > $max_size) { http_error "413 Request Entity Too Large"; }
 394                                 }
 395                                 $fh->flush();   # Don't close the handle, the file would disappear otherwise
 396                                 next PART;
 397                         }
 398                 }
 399                 print STDERR "SKIPPING\n" if $debug;
 400                 while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; }
 401         } } while (skip_mp_boundary());
 402 }
 403
 404 ### Generating Self-ref URL's ###
 405
 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 @_;
 410         }
 411         my %overrides = @_;
 412         my $out = {};
 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'} = "";
 419                         my $value;
 420                         if (!defined($value = $overrides{$name})) {
 421                                 if (exists $overrides{$name}) {
 422                                         $value = $arg->{'default'};
 423                                 } else {
 424                                         $value = ${$arg->{'var'}};
 425                                         defined $value or $value = $arg->{'default'};
 426                                 }
 427                         }
 428                         if ($value ne $arg->{'default'}) {
 429                                 $out->{$name} = $value;
 430                         }
 431                 }
 432         }
 433         return $out;
 434 }
 435
 436 sub self_ref(@) {
 437         my $out = make_out_args(@_);
 438         return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out);
 439 }
 440
 441 sub self_form(@) {
 442         my $out = make_out_args(@_);
 443         return join('', map { "<input type=hidden name=$_ value='" . html_escape($out->{$_}) . "'>\n" } sort keys %$out);
 444 }
 445
 446 ### Cookies
 447
 448 sub set_cookie($$@) {
 449         #
 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
 452         # specification.
 453         #
 454         # Usage: set_cookie(name, value, option => value...), where options are:
 455         #
 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
 462         #
 463
 464         my $key = shift @_;
 465         my $value = shift @_;
 466         my %other = @_;
 467         if (exists $other{'discard'}) {
 468                 delete $other{'discard'};
 469                 $other{'max-age'} = 0;
 470         }
 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);
 480         }
 481
 482         print "Set-Cookie: $key=", url_strict_escape($value);
 483         foreach my $k (keys %other) {
 484                 print "; $k";
 485                 print "=", $other{$k} if defined $other{$k};
 486         }
 487         print "\n";
 488 }
 489
 490 sub parse_cookies() {
 491         my $h = http_get("Cookie") or return ();
 492         my @cook = ();
 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;
 497         }
 498         return @cook;
 499 }
 500
 501 1;  # OK