# Poor Man's CGI Module for Perl
#
-# (c) 2002--2007 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
-# 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;
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 @_;
+ defined $x or return;
+ 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 @_;
+ defined $x or return;
+ utf8::encode($x) if $utf8_mode;
$x =~ s/%(..)/pack("H2",$1)/ge;
+ utf8::decode($x) if $utf8_mode;
return $x;
}
sub url_param_escape($) {
my $x = shift @_;
+ defined $x or return;
$x = url_escape($x);
$x =~ s/%20/+/g;
return $x;
sub url_param_deescape($) {
my $x = shift @_;
+ defined $x or return;
$x =~ s/\+/ /g;
return url_deescape($x);
}
sub html_escape($) {
my $x = shift @_;
+ defined $x or return;
$x =~ s/&/&/g;
$x =~ s/</</g;
$x =~ s/>/>/g;
$x =~ s/"/"/g;
+ $x =~ s/'/'/g;
return $x;
}
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 ###
-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+//;
- foreach $_ (split /[&:]/,$s) {
+ for $_ (split /[&:]/, $s) {
(/^([^=]+)=(.*)$/) or next;
- my $arg = $arg_table->{$1} or next;
+ my $arg = $1;
$_ = $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_args($) {
- $arg_table = shift @_;
+sub init_args() {
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;
}
- 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 $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") {
- 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_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 {
- 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, 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, $_;
+ }
+ }
}
}
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;
my $b = get_mp_line(0);
print STDERR "SEP $b\n" if $debug;
$mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i);
- if ("\r\n$b" =~ /^$boundary--/) {
+ if (substr("\r\n$b", 0, $boundary_len) eq "$boundary--") {
return 0;
} else {
return 1;
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;
# 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) {
- die "Maximum form data length exceeded";
+ http_error "413 Request Entity Too Large";
}
}
($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;
- 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;
- parse_arg_string("$field=$l");
+ parse_raw_args_ll($field, $l);
}
next PART;
} elsif (defined $a->{"file"}) {
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;
### 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 = {};
- 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(@) {
- 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(@) {
- 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);
}