Configure: Turned off -Winline

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

diff --git a/ucw/perl/UCW/CGI.pm b/ucw/perl/UCW/CGI.pm
index f7e033d11d90aab758fb4f556f6779728fe025bf..d2468b8fe48b121dd35fca862f5ebbc22d384a4d 100644 (file)
--- a/ucw/perl/UCW/CGI.pm
+++ b/ucw/perl/UCW/CGI.pm
@@ -1,15 +1,11 @@
 #      Poor Man's CGI Module for Perl
 #
-#      (c) 2002--2010 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.
 
-# FIXME:
-# - respond with proper HTTP error codes
-# - if we get invalid parameters, generate HTTP error or redirect
-
 package UCW::CGI;
 
 # First of all, set up error handling, so that even errors during parsing
@@ -32,7 +28,7 @@ sub report_bug($)
                if (defined($UCW::CGI::error_hook)) {
                        &$UCW::CGI::error_hook($_[0]);
                } else {
-                       print "Content-type: text/plain\n\n";
+                       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;
@@ -60,17 +56,29 @@ 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 $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 @_;
+       utf8::encode($x) if $utf8_mode;
        $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 @_;
+       utf8::encode($x) if $utf8_mode;
        $x =~ s/%(..)/pack("H2",$1)/ge;
+       utf8::decode($x) if $utf8_mode;
        return $x;
 }
 
@@ -126,7 +134,7 @@ sub rfc822_deescape($) {
 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 ###
@@ -138,6 +146,7 @@ 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;
 }
 
@@ -167,20 +176,22 @@ sub init_args() {
        if (my $qs = $ENV{"QUERY_STRING"}) {
                parse_raw_args($qs);
        }
-       if ($method eq "GET") {
+       if ($method eq "GET" || $method eq "HEAD") {
        } 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;
                                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 {
-                       die "Unknown content type for POST data";
+                       http_error "415 Unsupported Media Type";
+                       exit;
                }
        } else {
-               die "Unknown request method";
+               http_error "405 Method Not Allowed", "Allow: GET, HEAD, PUT";
        }
 }
 
@@ -281,13 +292,13 @@ sub get_mp_line($) {
                        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) {
-               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;
@@ -326,15 +337,15 @@ sub parse_mp_header() {
 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.
-       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;
@@ -346,7 +357,7 @@ sub parse_multipart_form_data() {
                        $max_allowed += $a->{"maxsize"} || 65536;
                }
                if ($size > $max_allowed) {
-                       die "Maximum form data length exceeded";
+                       http_error "413 Request Entity Too Large";
                }
        }
 
@@ -371,7 +382,9 @@ sub parse_multipart_form_data() {
                    (($field) = ($cdisp =~ /;name=([^;]+)/)) &&
                    ($a = $main_arg_table->{"$field"})) {
                        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;
@@ -393,7 +406,7 @@ sub parse_multipart_form_data() {
                                        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;