Opt: strdup -> xstrdup

[libucw.git] / ucw / perl / UCW / CGI.pm

diff --git a/ucw/perl/UCW/CGI.pm b/ucw/perl/UCW/CGI.pm
index 404d476eab512a02757896c8c6141109b270e8fd..7cb346391d6a1f89dd6ee78118c197df6624d3d0 100644 (file)
--- a/ucw/perl/UCW/CGI.pm
+++ b/ucw/perl/UCW/CGI.pm
@@ -1,56 +1,13 @@
 #      Poor Man's CGI Module for Perl
 #
 #      Poor Man's CGI Module for Perl
 #

-#      (c) 2002--2009 Martin Mares <mj@ucw.cz>
+#      (c) 2002--2011 Martin Mares <mj@ucw.cz>

 #      Slightly modified by Tomas Valla <tom@ucw.cz>
 #
 #      This software may be freely distributed and used according to the terms
 #      of the GNU Lesser General Public License.
 
 #      Slightly modified by Tomas Valla <tom@ucw.cz>
 #
 #      This software may be freely distributed and used according to the terms
 #      of the GNU Lesser General Public License.
 

-# FIXME:
-# - respond with proper HTTP error codes
-# - if we get invalid parameters, generate HTTP error or redirect
-

 package UCW::CGI;
 
 package UCW::CGI;
 

-# First of all, set up error handling, so that even errors during parsing
-# will be reported properly.
-
-# Variables to be set by the calling module:
-#      $UCW::CGI::error_mail           mail address of the script admin (optional)
-#                                      (this one has to be set in the BEGIN block!)
-#      $UCW::CGI::error_hook           function to be called for reporting errors
-
-my $error_reported;
-my $exit_code;
-my $debug = 0;
-
-sub report_bug($)
-{
-       if (!defined $error_reported) {
-               $error_reported = 1;
-               print STDERR $_[0];
-               if (defined($UCW::CGI::error_hook)) {
-                       &$UCW::CGI::error_hook($_[0]);
-               } else {
-                       print "Content-type: text/plain\n\n";
-                       print "Internal bug:\n";
-                       print $_[0], "\n";
-                       print "Please notify $UCW::CGI::error_mail\n" if defined $UCW::CGI::error_mail;
-               }
-       }
-       die;
-}
-
-BEGIN {
-       $SIG{__DIE__} = sub { report_bug($_[0]); };
-       $SIG{__WARN__} = sub { report_bug("WARNING: " . $_[0]); };
-       $exit_code = 0;
-}
-
-END {
-       $? = $exit_code;
-}
-

 use strict;
 use warnings;
 
 use strict;
 use warnings;
 


@@ -60,17 +17,31 @@ our @ISA = qw(Exporter);
 our @EXPORT = qw(&html_escape &url_escape &url_deescape &url_param_escape &url_param_deescape &self_ref &self_form &http_get);
 our @EXPORT_OK = qw();
 
 our @EXPORT = qw(&html_escape &url_escape &url_deescape &url_param_escape &url_param_deescape &self_ref &self_form &http_get);
 our @EXPORT_OK = qw();
 

+# Configuration settings
+our $debug = 0;
+our $utf8_mode = 0;
+
+sub http_error($;@) {
+       my $err = shift @_;
+       print join("\n", "Status: $err", "Content-Type: text/plain", @_, "", $err, "");
+       exit;
+}
+

 ### Escaping ###
 
 sub url_escape($) {
        my $x = shift @_;
 ### Escaping ###
 
 sub url_escape($) {
        my $x = shift @_;

+       utf8::encode($x) if $utf8_mode;

        $x =~ s/([^-\$_.!*'(),0-9A-Za-z\x80-\xff])/"%".unpack('H2',$1)/ge;
        $x =~ s/([^-\$_.!*'(),0-9A-Za-z\x80-\xff])/"%".unpack('H2',$1)/ge;

+       utf8::decode($x) if $utf8_mode;

        return $x;
 }
 
 sub url_deescape($) {
        my $x = shift @_;
        return $x;
 }
 
 sub url_deescape($) {
        my $x = shift @_;

+       utf8::encode($x) if $utf8_mode;

        $x =~ s/%(..)/pack("H2",$1)/ge;
        $x =~ s/%(..)/pack("H2",$1)/ge;

+       utf8::decode($x) if $utf8_mode;

        return $x;
 }
 
        return $x;
 }
 


@@ -93,6 +64,7 @@ sub html_escape($) {
        $x =~ s/</&lt;/g;
        $x =~ s/>/&gt;/g;
        $x =~ s/"/&quot;/g;
        $x =~ s/</&lt;/g;
        $x =~ s/>/&gt;/g;
        $x =~ s/"/&quot;/g;

+       $x =~ s/'/&#39;/g;

        return $x;
 }
 
        return $x;
 }
 


@@ -125,75 +97,103 @@ sub rfc822_deescape($) {
 sub http_get($) {
        my $h = shift @_;
        $h =~ tr/a-z-/A-Z_/;
 sub http_get($) {
        my $h = shift @_;
        $h =~ tr/a-z-/A-Z_/;

-       return $ENV{"HTTP_$h"} || $ENV{"$h"};
+       return $ENV{"HTTP_$h"} // $ENV{"$h"};

 }
 
 ### Parsing of Arguments ###
 
 }
 
 ### Parsing of Arguments ###
 

-my $arg_table;
+my $main_arg_table;
+my %raw_args;

 
 

-sub parse_arg_string($) {
+sub parse_raw_args_ll($$) {
+       my ($arg, $s) = @_;
+       $s =~ s/\r\n/\n/g;
+       $s =~ s/\r/\n/g;
+       utf8::decode($s) if $utf8_mode;
+       push @{$raw_args{$arg}}, $s;
+}
+
+sub parse_raw_args($) {

        my ($s) = @_;
        $s =~ s/\s+//;
        my ($s) = @_;
        $s =~ s/\s+//;

-       foreach $_ (split /[&:]/,$s) {
+       for $_ (split /[&:]/, $s) {

                (/^([^=]+)=(.*)$/) or next;
                (/^([^=]+)=(.*)$/) or next;

-               my $arg = $arg_table->{$1} or next;
+               my $arg = $1;

                $_ = $2;
                s/\+/ /g;
                s/%(..)/pack("H2",$1)/eg;
                $_ = $2;
                s/\+/ /g;
                s/%(..)/pack("H2",$1)/eg;

-               s/\r\n/\n/g;
-               s/\r/\n/g;
-               $arg->{'multiline'} || s/(\n|\t)/ /g;
-               s/^\s+//;
-               s/\s+$//;
-               if (my $rx = $arg->{'check'}) {
-                       if (!/^$rx$/) { $_ = $arg->{'default'}; }
-               }
-
-               my $r = ref($arg->{'var'});
-               if ($r eq 'SCALAR') {
-                       ${$arg->{'var'}} = $_;
-               } elsif ($r eq 'ARRAY') {
-                       push @{$arg->{'var'}}, $_;
-               }
+               parse_raw_args_ll($arg, $_);

        }
 }
 
 sub parse_multipart_form_data();
 
        }
 }
 
 sub parse_multipart_form_data();
 

-sub parse_args($) {
-       $arg_table = shift @_;
+sub init_args() {

        if (!defined $ENV{"GATEWAY_INTERFACE"}) {
                print STDERR "Must be called as a CGI script.\n";
        if (!defined $ENV{"GATEWAY_INTERFACE"}) {
                print STDERR "Must be called as a CGI script.\n";

-               $exit_code = 1;
+               $UCW::CGI::ErrorHandler::exit_code = 1;

                exit;
        }
                exit;
        }

-       foreach my $a (values %$arg_table) {
-               my $r = ref($a->{'var'});
-               defined($a->{'default'}) or $a->{'default'}="";
-               if ($r eq 'SCALAR') {
-                       ${$a->{'var'}} = $a->{'default'};
-               } elsif ($r eq 'ARRAY') {
-                       @{$a->{'var'}} = ();
-               }
-       }
+

        my $method = $ENV{"REQUEST_METHOD"};
        my $method = $ENV{"REQUEST_METHOD"};

-       my $qs = $ENV{"QUERY_STRING"};
-       parse_arg_string($qs) if defined($qs);
-       if ($method eq "GET") {
+       if (my $qs = $ENV{"QUERY_STRING"}) {
+               parse_raw_args($qs);
+       }
+       if ($method eq "GET" || $method eq "HEAD") {

        } elsif ($method eq "POST") {
        } elsif ($method eq "POST") {

-               if ($ENV{"CONTENT_TYPE"} =~ /^application\/x-www-form-urlencoded\b/i) {
+               my $content_type = $ENV{"CONTENT_TYPE"} // "";
+               if ($content_type =~ /^application\/x-www-form-urlencoded\b/i) {

                        while (<STDIN>) {
                                chomp;
                        while (<STDIN>) {
                                chomp;

-                               parse_arg_string($_);
+                               parse_raw_args($_);

                        }
                        }

-               } elsif ($ENV{"CONTENT_TYPE"} =~ /^multipart\/form-data\b/i) {
+               } elsif ($content_type =~ /^multipart\/form-data\b/i) {

                        parse_multipart_form_data();
                } else {
                        parse_multipart_form_data();
                } else {

-                       die "Unknown content type for POST data";
+                       http_error "415 Unsupported Media Type";
+                       exit;

                }
        } else {
                }
        } else {

-               die "Unknown request method";
+               http_error "405 Method Not Allowed", "Allow: GET, HEAD, POST";
+       }
+}
+
+sub parse_args($) {                    # CAVEAT: attached files must be defined in the main arg table
+       my $args = shift @_;
+       if (!$main_arg_table) {
+               $main_arg_table = $args;
+               init_args();
+       }
+
+       for my $a (values %$args) {
+               my $r = ref($a->{'var'});
+               $a->{'default'} //= '';
+               if ($r eq 'SCALAR') {
+                       ${$a->{'var'}} = $a->{'default'};
+               } elsif ($r eq 'ARRAY') {
+                       @{$a->{'var'}} = ();
+               }
+       }
+
+       for my $arg (keys %$args) {
+               my $a = $args->{$arg};
+               defined($raw_args{$arg}) or next;
+               for (@{$raw_args{$arg}}) {
+                       $a->{'multiline'} or s/(\n|\t)/ /g;
+                       s/^\s+//;
+                       s/\s+$//;
+                       if (my $rx = $a->{'check'}) {
+                               if (!/^$rx$/) { $_ = $a->{'default'}; }
+                       }
+
+                       my $v = $a->{'var'};
+                       my $r = ref($v);
+                       if ($r eq 'SCALAR') {
+                               $$v = $_;
+                       } elsif ($r eq 'ARRAY') {
+                               push @$v, $_;
+                       }
+               }

        }
 }
 
        }
 }
 


@@ -255,13 +255,13 @@ sub get_mp_line($) {
                        return undef;
                }
        } else {
                        return undef;
                }
        } else {

-               die "Premature end of multipart POST data";
+               http_error "400 Bad Request: Premature end of multipart POST data";

        }
 }
 
 sub skip_mp_boundary() {
        if ($mp_buffer_boundary != $mp_buffer_i) {
        }
 }
 
 sub skip_mp_boundary() {
        if ($mp_buffer_boundary != $mp_buffer_i) {

-               die "Premature end of multipart POST data";
+               http_error "400 Bad Request: Premature end of multipart POST data";

        }
        $mp_buffer_boundary = -1;
        $mp_buffer_i += 2;
        }
        $mp_buffer_boundary = -1;
        $mp_buffer_i += 2;


@@ -300,15 +300,15 @@ sub parse_mp_header() {
 sub parse_multipart_form_data() {
        # First of all, find the boundary string
        my $ct = rfc822_prepare($ENV{"CONTENT_TYPE"});
 sub parse_multipart_form_data() {
        # First of all, find the boundary string
        my $ct = rfc822_prepare($ENV{"CONTENT_TYPE"});

-       if (!(($boundary) = ($ct =~ /^.*;boundary=([^; ]+)/))) {
-               die "Multipart content with no boundary string received";
+       if (!(($boundary) = ($ct =~ /^.*;\s*boundary=([^; ]+)/))) {
+               http_error "400 Bad Request: Multipart content with no boundary string received";

        }
        $boundary = rfc822_deescape($boundary);
        print STDERR "BOUNDARY IS $boundary\n" if $debug;
 
        # BUG: IE 3.01 on Macintosh forgets to add the "--" at the start of the boundary string
        # as the MIME specs preach. Workaround borrowed from CGI.pm in Perl distribution.
        }
        $boundary = rfc822_deescape($boundary);
        print STDERR "BOUNDARY IS $boundary\n" if $debug;
 
        # BUG: IE 3.01 on Macintosh forgets to add the "--" at the start of the boundary string
        # as the MIME specs preach. Workaround borrowed from CGI.pm in Perl distribution.

-       my $agent = http_get("User-agent") || "";
+       my $agent = http_get("User-Agent") // "";

        $boundary = "--$boundary" unless $agent =~ /MSIE\s+3\.0[12];\s*Mac/;
        $boundary = "\r\n$boundary";
        $boundary_len = length($boundary) + 2;
        $boundary = "--$boundary" unless $agent =~ /MSIE\s+3\.0[12];\s*Mac/;
        $boundary = "\r\n$boundary";
        $boundary_len = length($boundary) + 2;


@@ -316,11 +316,11 @@ sub parse_multipart_form_data() {
        # Check upload size in advance
        if (my $size = http_get("Content-Length")) {
                my $max_allowed = 0;
        # Check upload size in advance
        if (my $size = http_get("Content-Length")) {
                my $max_allowed = 0;

-               foreach my $a (values %$arg_table) {
+               foreach my $a (values %$main_arg_table) {

                        $max_allowed += $a->{"maxsize"} || 65536;
                }
                if ($size > $max_allowed) {
                        $max_allowed += $a->{"maxsize"} || 65536;
                }
                if ($size > $max_allowed) {

-                       die "Maximum form data length exceeded";
+                       http_error "413 Request Entity Too Large";

                }
        }
 
                }
        }
 


@@ -343,13 +343,15 @@ sub parse_multipart_form_data() {
                    ($cdisp = $h->{"content-disposition"}) &&
                    $cdisp =~ /^form-data/ &&
                    (($field) = ($cdisp =~ /;name=([^;]+)/)) &&
                    ($cdisp = $h->{"content-disposition"}) &&
                    $cdisp =~ /^form-data/ &&
                    (($field) = ($cdisp =~ /;name=([^;]+)/)) &&

-                   ($a = $arg_table->{"$field"})) {
+                   ($a = $main_arg_table->{"$field"})) {

                        print STDERR "FIELD $field\n" if $debug;
                        print STDERR "FIELD $field\n" if $debug;

-                       if (defined $h->{"content-transfer-encoding"}) { die "Unexpected Content-Transfer-Encoding"; }
+                       if (defined $h->{"content-transfer-encoding"}) {
+                               http_error "400 Bad Request: Unexpected Content-Transfer-Encoding";
+                       }

                        if (defined $a->{"var"}) {
                                while (defined (my $l = get_mp_line(1))) {
                                        print STDERR "VALUE $l\n" if $debug;
                        if (defined $a->{"var"}) {
                                while (defined (my $l = get_mp_line(1))) {
                                        print STDERR "VALUE $l\n" if $debug;

-                                       parse_arg_string("$field=$l");
+                                       parse_raw_args_ll($field, $l);

                                }
                                next PART;
                        } elsif (defined $a->{"file"}) {
                                }
                                next PART;
                        } elsif (defined $a->{"file"}) {


@@ -367,7 +369,7 @@ sub parse_multipart_form_data() {
                                        print $fh substr($mp_buffer, $mp_buffer_i, $i);
                                        $mp_buffer_i += $i;
                                        $total_size += $i;
                                        print $fh substr($mp_buffer, $mp_buffer_i, $i);
                                        $mp_buffer_i += $i;
                                        $total_size += $i;

-                                       if ($total_size > $max_size) { die "Uploaded file too long"; }
+                                       if ($total_size > $max_size) { http_error "413 Request Entity Too Large"; }

                                }
                                $fh->flush();   # Don't close the handle, the file would disappear otherwise
                                next PART;
                                }
                                $fh->flush();   # Don't close the handle, the file would disappear otherwise
                                next PART;


@@ -380,37 +382,43 @@ sub parse_multipart_form_data() {
 
 ### Generating Self-ref URL's ###
 
 
 ### Generating Self-ref URL's ###
 

-sub make_out_args($) {
-       my ($overrides) = @_;
+sub make_out_args(@) {         # Usage: make_out_args([arg_table, ...] name => value, ...)
+       my @arg_tables = ( $main_arg_table );
+       while (@_ && ref($_[0]) eq 'HASH') {
+               push @arg_tables, shift @_;
+       }
+       my %overrides = @_;

        my $out = {};
        my $out = {};

-       foreach my $name (keys %$arg_table) {
-               my $arg = $arg_table->{$name};
-               defined($arg->{'var'}) || next;
-               defined($arg->{'pass'}) && !$arg->{'pass'} && !exists $overrides->{$name} && next;
-               my $value;
-               if (!defined($value = $overrides->{$name})) {
-                       if (exists $overrides->{$name}) {
-                               $value = $arg->{'default'};
-                       } else {
-                               $value = ${$arg->{'var'}};
+       for my $table (@arg_tables) {
+               for my $name (keys %$table) {
+                       my $arg = $table->{$name};
+                       defined($arg->{'var'}) || next;
+                       defined($arg->{'pass'}) && !$arg->{'pass'} && !exists $overrides{$name} && next;
+                       defined $arg->{'default'} or $arg->{'default'} = "";
+                       my $value;
+                       if (!defined($value = $overrides{$name})) {
+                               if (exists $overrides{$name}) {
+                                       $value = $arg->{'default'};
+                               } else {
+                                       $value = ${$arg->{'var'}};
+                                       defined $value or $value = $arg->{'default'};
+                               }
+                       }
+                       if ($value ne $arg->{'default'}) {
+                               $out->{$name} = $value;

                        }
                        }

-               }
-               if ($value ne $arg->{'default'}) {
-                       $out->{$name} = $value;

                }
        }
        return $out;
 }
 
 sub self_ref(@) {
                }
        }
        return $out;
 }
 
 sub self_ref(@) {

-       my %h = @_;
-       my $out = make_out_args(\%h);
+       my $out = make_out_args(@_);

        return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out);
 }
 
 sub self_form(@) {
        return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out);
 }
 
 sub self_form(@) {

-       my %h = @_;
-       my $out = make_out_args(\%h);
+       my $out = make_out_args(@_);

        return join('', map { "<input type=hidden name=$_ value='" . html_escape($out->{$_}) . "'>\n" } sort keys %$out);
 }
 
        return join('', map { "<input type=hidden name=$_ value='" . html_escape($out->{$_}) . "'>\n" } sort keys %$out);
 }