diff -up perl-5.8.8/lib/CGI/Apache.pm.crr perl-5.8.8/lib/CGI/Apache.pm
diff -up perl-5.8.8/lib/CGI/Carp.pm.crr perl-5.8.8/lib/CGI/Carp.pm
--- perl-5.8.8/lib/CGI/Carp.pm.crr 2006-01-08 17:39:12.000000000 +0100
+++ perl-5.8.8/lib/CGI/Carp.pm 2008-03-27 15:23:36.000000000 +0100
@@ -102,7 +102,7 @@ CGI::Carp methods is called to prevent t
=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
-If you want to send fatal (die, confess) errors to the browser, ask to
+If you want to send fatal (die, confess) errors to the browser, ask to
import the special "fatalsToBrowser" subroutine:
use CGI::Carp qw(fatalsToBrowser);
@@ -114,6 +114,9 @@ occur in the early compile phase will be
Nonfatal errors will still be directed to the log file only (unless redirected
with carpout).
+Note that fatalsToBrowser does B<not> work with mod_perl version 2.0
+and higher.
+
=head2 Changing the default message
By default, the software error message is followed by a note to
@@ -142,6 +145,42 @@ of the error message that caused the scr
In order to correctly intercept compile-time errors, you should call
set_message() from within a BEGIN{} block.
+=head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS
+
+If fatalsToBrowser in conjunction with set_message does not provide
+you with all of the functionality you need, you can go one step
+further by specifying a function to be executed any time a script
+calls "die", has a syntax error, or dies unexpectedly at runtime
+with a line like "undef->explode();".
+
+ use CGI::Carp qw(set_die_handler);
+ BEGIN {
+ sub handle_errors {
+ my $msg = shift;
+ print "content-type: text/html\n\n";
+ print "<h1>Oh gosh</h1>";
+ print "<p>Got an error: $msg</p>";
+
+ #proceed to send an email to a system administrator,
+ #write a detailed message to the browser and/or a log,
+ #etc....
+ }
+ set_die_handler(\&handle_errors);
+ }
+
+Notice that if you use set_die_handler(), you must handle sending
+HTML headers to the browser yourself if you are printing a message.
+
+If you use set_die_handler(), you will most likely interfere with
+the behavior of fatalsToBrowser, so you must use this or that, not
+both.
+
+Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser),
+and there is only one SIG{__DIE__}. This means that if you are
+attempting to set SIG{__DIE__} yourself, you may interfere with
+this module's functionality, or this module may interfere with
+your module's functionality.
+
=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
It is now also possible to make non-fatal errors appear as HTML
@@ -204,6 +243,9 @@ non-overridden program name
=head1 CHANGE LOG
+1.29 Patch from Peter Whaite to fix the unfixable problem of CGI::Carp
+ not behaving correctly in an eval() context.
+
1.05 carpout() added and minor corrections by Marc Hedlund
<hedlund@best.com> on 11/26/95.
@@ -233,7 +275,7 @@ non-overridden program name
fatalsToBrowser() output.
1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern
- (hack alert!) in order to accomodate various combinations of Perl and
+ (hack alert!) in order to accommodate various combinations of Perl and
mod_perl.
1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
@@ -277,12 +319,13 @@ use File::Spec;
@ISA = qw(Exporter);
@EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_progname cluck ^name= die);
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_die_handler set_progname cluck ^name= die);
$main::SIG{__WARN__}=\&CGI::Carp::warn;
-$CGI::Carp::VERSION = '1.29';
-$CGI::Carp::CUSTOM_MSG = undef;
+$CGI::Carp::VERSION = '1.30_01';
+$CGI::Carp::CUSTOM_MSG = undef;
+$CGI::Carp::DIE_HANDLER = undef;
# fancy import routine detects and handles 'errorWrap' specially.
@@ -290,7 +333,6 @@ sub import {
my $pkg = shift;
my(%routines);
my(@name);
-
if (@name=grep(/^name=/,@_))
{
my($n) = (split(/=/,$name[0]))[1];
@@ -382,7 +424,22 @@ sub ineval {
sub die {
my ($arg,@rest) = @_;
- realdie ($arg,@rest) if ineval();
+
+ if ($DIE_HANDLER) {
+ &$DIE_HANDLER($arg,@rest);
+ }
+
+ if ( ineval() ) {
+ if (!ref($arg)) {
+ $arg = join("",($arg,@rest)) || "Died";
+ my($file,$line,$id) = id(1);
+ $arg .= " at $file line $line.\n" unless $arg=~/\n$/;
+ realdie($arg);
+ }
+ else {
+ realdie($arg,@rest);
+ }
+ }
if (!ref($arg)) {
$arg = join("", ($arg,@rest));
@@ -405,6 +462,25 @@ sub set_message {
return $CGI::Carp::CUSTOM_MSG;
}
+sub set_die_handler {
+
+ my ($handler) = shift;
+
+ #setting SIG{__DIE__} here is necessary to catch runtime
+ #errors which are not called by literally saying "die",
+ #such as the line "undef->explode();". however, doing this
+ #will interfere with fatalsToBrowser, which also sets
+ #SIG{__DIE__} in the import() function above (or the
+ #import() function above may interfere with this). for
+ #this reason, you should choose to either set the die
+ #handler here, or use fatalsToBrowser, not both.
+ $main::SIG{__DIE__} = $handler;
+
+ $CGI::Carp::DIE_HANDLER = $handler;
+
+ return $CGI::Carp::DIE_HANDLER;
+}
+
sub confess { CGI::Carp::die Carp::longmess @_; }
sub croak { CGI::Carp::die Carp::shortmess @_; }
sub carp { CGI::Carp::warn Carp::shortmess @_; }
@@ -499,6 +575,7 @@ END
print STDOUT $mess;
}
else {
+ print STDOUT "Status: 500\n";
print STDOUT "Content-type: text/html\n\n";
print STDOUT $mess;
}
diff -up perl-5.8.8/lib/CGI/Changes.crr perl-5.8.8/lib/CGI/Changes
--- perl-5.8.8/lib/CGI/Changes.crr 2005-12-09 02:40:04.000000000 +0100
+++ perl-5.8.8/lib/CGI/Changes 2008-04-23 15:08:05.000000000 +0200
@@ -1,3 +1,126 @@
+ Version 3.37
+ 1. Fix pragmas so that they persist over modperl invocations (e.g. RT 34761)
+ 2. Fixed handling of chunked multipart uploads; thanks to Michael Bernhardt
+ who reported and fixed the problem.
+
+ Version 3.36
+ 1. Fix CGI::Cookie to support cookies that are separated by "," instead of ";".
+
+ Version 3.35
+ 1. Resync with bleadperl, primarily fixing a bug in parsing semicolons in uploaded filenames.
+
+ Version 3.34
+ 1. Handle Unicode %uXXXX escapes properly -- patch from DANKOGAI@cpan.org
+ 2. Fix url() method to not choke on path names that contain regex characters.
+
+ Version 3.33
+ 1. Remove uninit variable warning when calling url(-relative=>1)
+ 2. Fix uninit variable warnings for two lc calls
+ 3. Fixed failure of tempfile upload due to sprintf() taint failure in perl 5.10
+
+ Version 3.32
+ 1. Patch from Miguel Santinho to prevent sending premature headers under mod_perl 2.0
+
+ Version 3.31
+ 1. Patch from Xavier Robin so that CGI::Carp issues a 500 Status code rather than a 200 status code.
+ 2. Patch from Alexander Klink to select correct temporary directory in OSX Leopard so that upload works.
+ 3. Possibly fixed "wrapped pack" error on 5.10 and higher.
+
+ Version 3.30
+ 1. Patch from Mike Barry to handle POSTDATA in the same way as PUT.
+ 2. Patch from Rafael Garcia-Suarez to correctly reencode unicode values as byte values.
+
+ Version 3.29
+ 1. The position of file handles is now reset to zero when CGI->new is called.
+ (Mark Stosberg)
+ 2. uploadInfo() now works across multiple object instances. Also, the first
+ tests for uploadInfo() were added as part of the fix. (CPAN bug 11895, with
+ contributions from drfrench and Mark Stosberg).
+
+ Version 3.28
+ 1. Applied patch from Allen Day that makes Cookie parsing RFC2109 compliant
+ (attribute/values can be separated by commas as well as semicolons).
+ 2. Applied patch from Stephan Struckmann that allows script_name() to be set correctly.
+ 3. Fixed problem with url(-full) in which port number appears twice.
+
+ Version 3.27
+ 1. Applied patch from Steve Taylor that allows checkbox_groups to be
+ disabled with a new -disabled=> option.
+
+ Version 3.26
+ 1. Fixed alternate stylesheet behavior so that it is insensitive to order of declarations.
+ 2. Patch from John Binns to allow users to provide a callback to CGI::Carp.
+ 3. Added "~" as an unreserved character in escape().
+ 4. Patch from Chris Fedde to prevent HTTP_HOST from inhibiting SERVER_PORT in url() generation.
+ 5. Fixed outdated documentation (and behavior) of -language in start_html -script option.
+ 6. Fixed bug in seconds calculation in CGI::Util::expire_calc.
+
+ Version 3.25
+ 1. Fixed the link to the Netscape frames page.
+ 2. Added ability to specify an alternate stylesheet.
+ 3. Add support for XForms POST submssion both as application/xml or as multipart/related
+
+ Version 3.24
+ 1. In startform(), if request_uri() returns undef, then falls back
+ to self_url(). This should rarely happen except when run outside of
+ the CGI environment.
+ 2. image button alignment options were mistakenly being capitalized, causing xhtml validation to fail.
+
+ Version 3.23
+ 1. Typo in upload() persisted, now fixed for real. Thanks to
+ Emanuele Zeppieri for correct patch and regression test.
+
+ Version 3.22
+ 1. Typo in upload() function broke uploads. Now fixed (CPAN bug 21126).
+
+ Version 3.21
+ 1. Don't try to read data at all when POST > $POST_MAX.
+ 2. Fixed bug that caused $cgi->param('name',undef,'value') to unset param('name') entirely.
+ 3. Fixed bug in which upload() sometimes returns empty. (CPAN bug #12694).
+ 4. Incorporated patch from BURAK@cpan.org to support HTTPcookies (CPAN bug 21019).
+
+ Version 3.20
+ 1. Patch from David Wheeler for CGI::Cookie->bake(). Uses mod_perl headers_out->add()
+ rather than headers_out->set().
+ 2. Fixed problem identified by Andrei Voronkov in which start_form() output was screwed
+ up when initial argument begins with a dash and subsequent arguments do not.
+ 3. Quashed uninitialized variable warnings coming from script_name(), url() and other
+ functions that require access to the PATH_INFO environment variable.
+
+ Version 3.19
+ 1. Added patch from Stephen Frost that allows one to suppress use of the temp file that is
+ created during uploads.
+ 2. Fixed problem noted by Martin Foster in which regular expression meta-character terms
+ in the path information were not quoted, causing URL parsing
+ to fail on URLs that contained metacharacters (such as +).
+ 3. More fixes to the url() method.
+ 4. Removed "hack to fix broken PATH_INFO in MSII".
+
+ Version 3.18
+ 1. Doc typo fixes.
+ 2. Patch from Steve Peters to default the document type to match the charset.
+ 3. Fixed param() so that param(-name=>'foo',-values=>[]) sets the parameter to empty list.
+
+ Version 3.17 Fri Feb 24 14:01:27 EST 2006
+ 1. Added patch from Mike Hanafey which caused 0 arguments to CGI::Cookie->new() to
+ be treated as empty.
+ 2. Patch to CGI::Carp from Peter Whaite to fix the unfixable problem of CGI::Carp
+ not behaving correctly in an eval() context.
+ 3. CGI::Fast->new() calls CGI->_reset_globals to avoid contamination of one session
+ with another's variables.
+ 4. Fixed upload failure on files that contain semicolons in their names.
+
+ Version 3.16 Wed Feb 8 13:29:11 EST 2006
+ 1. header() -charset option now works even when the MIME type is not "text".
+ 2. Fixed documentation for cookie() function and fastCGI.
+ 3. Upload filehandles now only closed automatically on Windows systems.
+ 4. Apache::Cookie compatibility fix from David Wheeler
+ 5. CGI::Carp->fatalsToBrowser() does not work correctly with
+ mod_perl 2. No workaround is known.
+ 6. Fixed text status code associated with 302 redirects. Should be "Found"
+ but was "Moved".
+ 7. Fixed charset in start_html() and header() to be in synch.
+
Version 3.15 Wed Dec 7 15:13:22 EST 2005
1. Remove extraneous "?" from self_url() when URI contains a ? but no query string.
diff -up perl-5.8.8/lib/CGI/Cookie.pm.crr perl-5.8.8/lib/CGI/Cookie.pm
--- perl-5.8.8/lib/CGI/Cookie.pm.crr 2008-06-09 09:54:55.000000000 +0200
+++ perl-5.8.8/lib/CGI/Cookie.pm 2008-03-28 18:15:51.000000000 +0100
@@ -13,9 +13,10 @@ package CGI::Cookie;
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
-$CGI::Cookie::VERSION='1.26';
+$CGI::Cookie::VERSION='1.29';
use CGI::Util qw(rearrange unescape escape);
+use CGI;
use overload '""' => \&as_string,
'cmp' => \&compare,
'fallback'=>1;
@@ -50,7 +51,7 @@ sub fetch {
my %results;
my($key,$value);
- my(@pairs) = split("; ?",$raw_cookie);
+ my @pairs = split("[;,] ?",$raw_cookie);
foreach (@pairs) {
s/\s*(.*?)\s*/$1/;
if (/^([^=]+)=(.*)/) {
@@ -87,7 +88,7 @@ sub parse {
my ($self,$raw_cookie) = @_;
my %results;
- my(@pairs) = split("; ?",$raw_cookie);
+ my @pairs = split("[;,] ?",$raw_cookie);
foreach (@pairs) {
s/\s*(.*?)\s*/$1/;
my($key,$value) = split("=",$_,2);
@@ -112,8 +113,11 @@ sub parse {
sub new {
my $class = shift;
$class = ref($class) if ref($class);
- my($name,$value,$path,$domain,$secure,$expires) =
- rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
+ # Ignore mod_perl request object--compatability with Apache::Cookie.
+ shift if ref $_[0]
+ && eval { $_[0]->isa('Apache::Request::Req') || $_[0]->isa('Apache') };
+ my($name,$value,$path,$domain,$secure,$expires,$httponly) =
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@_);
# Pull out our parameters.
my @values;
@@ -142,6 +146,7 @@ sub new {
$self->domain($domain) if defined $domain;
$self->secure($secure) if defined $secure;
$self->expires($expires) if defined $expires;
+ $self->httponly($httponly) if defined $httponly;
# $self->max_age($expires) if defined $expires;
return $self;
}
@@ -150,16 +155,17 @@ sub as_string {
my $self = shift;
return "" unless $self->name;
- my(@constant_values,$domain,$path,$expires,$max_age,$secure);
+ my(@constant_values,$domain,$path,$expires,$max_age,$secure,$httponly);
push(@constant_values,"domain=$domain") if $domain = $self->domain;
push(@constant_values,"path=$path") if $path = $self->path;
push(@constant_values,"expires=$expires") if $expires = $self->expires;
push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age;
push(@constant_values,"secure") if $secure = $self->secure;
+ push(@constant_values,"HttpOnly") if $httponly = $self->httponly;
my($key) = escape($self->name);
- my($cookie) = join("=",($key||''),join("&",map escape($_||''),$self->value));
+ my($cookie) = join("=",(defined $key ? $key : ''),join("&",map escape(defined $_ ? $_ : ''),$self->value));
return join("; ",$cookie,@constant_values);
}
@@ -169,6 +175,22 @@ sub compare {
return "$self" cmp $value;
}
+sub bake {
+ my ($self, $r) = @_;
+
+ $r ||= eval {
+ $MOD_PERL == 2
+ ? Apache2::RequestUtil->request()
+ : Apache->request
+ } if $MOD_PERL;
+ if ($r) {
+ $r->headers_out->add('Set-Cookie' => $self->as_string);
+ } else {
+ print CGI::header(-cookie => $self);
+ }
+
+}
+
# accessors
sub name {
my $self = shift;
@@ -231,6 +253,14 @@ sub path {
return $self->{'path'};
}
+
+sub httponly { # HttpOnly
+ my $self = shift;
+ my $httponly = shift;
+ $self->{'httponly'} = $httponly if defined $httponly;
+ return $self->{'httponly'};
+}
+
1;
=head1 NAME
@@ -317,11 +347,24 @@ that all scripts at your site will recei
If the "secure" attribute is set, the cookie will only be sent to your
script if the CGI request is occurring on a secure channel, such as SSL.
+=item B<4. httponly flag>
+
+If the "httponly" attribute is set, the cookie will only be accessible
+through HTTP Requests. This cookie will be inaccessible via JavaScript
+(to prevent XSS attacks).
+
+But, currently this feature only used and recognised by
+MS Internet Explorer 6 Service Pack 1 and later.
+
+See this URL for more information:
+
+L<http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp>
+
=back
=head2 Creating New Cookies
- $c = new CGI::Cookie(-name => 'foo',
+ my $c = new CGI::Cookie(-name => 'foo',
-value => 'bar',
-expires => '+3M',
-domain => '.capricorn.com',
@@ -351,11 +394,31 @@ pages at your site.
B<-secure> if set to a true value instructs the browser to return the
cookie only when a cryptographic protocol is in use.
+B<-httponly> if set to a true value, the cookie will not be accessible
+via JavaScript.
+
+For compatibility with Apache::Cookie, you may optionally pass in
+a mod_perl request object as the first argument to C<new()>. It will
+simply be ignored:
+
+ my $c = new CGI::Cookie($r,
+ -name => 'foo',
+ -value => ['bar','baz']);
+
=head2 Sending the Cookie to the Browser
-Within a CGI script you can send a cookie to the browser by creating
-one or more Set-Cookie: fields in the HTTP header. Here is a typical
-sequence:
+The simplest way to send a cookie to the browser is by calling the bake()
+method:
+
+ $c->bake;
+
+Under mod_perl, pass in an Apache request object:
+
+ $c->bake($r);
+
+If you want to set the cookie yourself, Within a CGI script you can send
+a cookie to the browser by creating one or more Set-Cookie: fields in the
+HTTP header. Here is a typical sequence:
my $c = new CGI::Cookie(-name => 'foo',
-value => ['bar','baz'],
@@ -407,7 +470,7 @@ same semantics as fetch(), but performs
You may also retrieve cookies that were stored in some external
form using the parse() class method:
- $COOKIES = `cat /var/run/www/Cookie_stash`;
+ $COOKIES = `cat /usr/tmp/Cookie_stash`;
%cookies = parse CGI::Cookie($COOKIES);
If you are in a mod_perl environment, you can save some overhead by
diff -up perl-5.8.8/lib/CGI/Fast.pm.crr perl-5.8.8/lib/CGI/Fast.pm
--- perl-5.8.8/lib/CGI/Fast.pm.crr 2004-01-13 17:28:04.000000000 +0100
+++ perl-5.8.8/lib/CGI/Fast.pm 2008-04-14 19:53:12.000000000 +0200
@@ -13,10 +13,7 @@ package CGI::Fast;
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
-# The most recent version and complete docs are available at:
-# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
-# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
-$CGI::Fast::VERSION='1.05';
+$CGI::Fast::VERSION='1.07';
use CGI;
use FCGI;
@@ -57,6 +54,8 @@ sub new {
return undef unless FCGI::accept() >= 0;
}
}
+ CGI->_reset_globals;
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
return $CGI::Q = $self->SUPER::new($initializer, @param);
}
@@ -94,22 +93,7 @@ will see large performance improvements.
=head1 OTHER PIECES OF THE PUZZLE
In order to use CGI::Fast you'll need a FastCGI-enabled Web
-server. Open Market's server is FastCGI-savvy. There are also
-freely redistributable FastCGI modules for NCSA httpd 1.5 and Apache.
-FastCGI-enabling modules for Microsoft Internet Information Server and
-Netscape Communications Server have been announced.
-
-In addition, you'll need a version of the Perl interpreter that has
-been linked with the FastCGI I/O library. Precompiled binaries are
-available for several platforms, including DEC Alpha, HP-UX and
-SPARC/Solaris, or you can rebuild Perl from source with patches
-provided in the FastCGI developer's kit. The FastCGI Perl interpreter
-can be used in place of your normal Perl without ill consequences.
-
-You can find FastCGI modules for Apache and NCSA httpd, precompiled
-Perl interpreters, and the FastCGI developer's kit all at URL:
-
- http://www.fastcgi.com/
+server. See http://www.fastcgi.com/ for details.
=head1 WRITING FASTCGI PERL SCRIPTS
diff -up perl-5.8.8/lib/CGI.pm.crr perl-5.8.8/lib/CGI.pm
--- perl-5.8.8/lib/CGI.pm.crr 2008-06-09 09:54:55.000000000 +0200
+++ perl-5.8.8/lib/CGI.pm 2008-04-23 15:08:23.000000000 +0200
@@ -18,8 +18,8 @@ use Carp 'croak';
# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: perl-5.8.8-CGI-3.37.patch,v 1.1 2008/06/09 08:38:00 mmaslano Exp $';
-$CGI::VERSION='3.15';
+$CGI::revision = '$Id: perl-5.8.8-CGI-3.37.patch,v 1.1 2008/06/09 08:38:00 mmaslano Exp $';
+$CGI::VERSION='3.37';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -37,9 +37,15 @@ use constant XHTML_DTD => ['-//W3C//DTD
$TAINTED = substr("$0$^X",0,0);
}
-$MOD_PERL = 0; # no mod_perl by default
+$MOD_PERL = 0; # no mod_perl by default
+
+#global settings
+$POST_MAX = -1; # no limit to uploaded files
+$DISABLE_UPLOADS = 0;
+
@SAVED_SYMBOLS = ();
+
# >>>>> Here are some globals that you might want to adjust <<<<<<
sub initialize_globals {
# Set this to 1 to enable copious autoloader debugging messages
@@ -90,13 +96,6 @@ sub initialize_globals {
# it can just be renamed, instead of read and written.
$CLOSE_UPLOAD_FILES = 0;
- # Set this to a positive value to limit the size of a POSTing
- # to a certain number of bytes:
- $POST_MAX = -1;
-
- # Change this to 1 to disable uploads entirely:
- $DISABLE_UPLOADS = 0;
-
# Automatically determined -- don't change
$EBCDIC = 0;
@@ -110,6 +109,9 @@ sub initialize_globals {
# use CGI qw(-no_undef_params);
$NO_UNDEF_PARAMS = 0;
+ # return everything as utf-8
+ $PARAM_UTF8 = 0;
+
# Other globals that you shouldn't worry about.
undef $Q;
$BEEN_THERE = 0;
@@ -118,6 +120,7 @@ sub initialize_globals {
undef %EXPORT;
undef $QUERY_CHARSET;
undef %QUERY_FIELDNAMES;
+ undef %QUERY_TMPFILES;
# prevent complaints by mod_perl
1;
@@ -329,6 +332,10 @@ sub new {
my $self = {};
bless $self,ref $class || $class || $DefaultClass;
+
+ # always use a tempfile
+ $self->{'use_tempfile'} = 1;
+
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'Apache')
||
@@ -339,12 +346,14 @@ sub new {
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'CODE'))) {
$self->upload_hook(shift @initializer, shift @initializer);
+ $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
}
if ($MOD_PERL) {
if ($MOD_PERL == 1) {
$self->r(Apache->request) unless $self->r;
my $r = $self->r;
$r->register_cleanup(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
}
else {
# XXX: once we have the new API
@@ -353,6 +362,7 @@ sub new {
my $r = $self->r;
$r->subprocess_env unless exists $ENV{REQUEST_METHOD};
$r->pool->cleanup_register(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
}
undef $NPH;
}
@@ -392,9 +402,10 @@ sub upload_hook {
} else {
$self = shift;
}
- my ($hook,$data) = @_;
+ my ($hook,$data,$use_tempfile) = @_;
$self->{'.upload_hook'} = $hook;
$self->{'.upload_data'} = $data;
+ $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
}
#### Method: param
@@ -427,7 +438,7 @@ sub param {
}
}
# If values is provided, then we set it.
- if (@values) {
+ if (@values or defined $value) {
$self->add_parameter($name);
$self->{$name}=[@values];
}
@@ -436,7 +447,15 @@ sub param {
}
return unless defined($name) && $self->{$name};
- return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
+
+ my @result = @{$self->{$name}};
+
+ if ($PARAM_UTF8) {
+ eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
+ @result = map {ref $_ ? $_ : Encode::decode(utf8=>$_) } @result;
+ }
+
+ return wantarray ? @result : $result[0];
}
sub self_or_default {
@@ -478,6 +497,8 @@ sub init {
my $self = shift;
my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+ my $is_xforms;
+
my $initializer = shift; # for backward compatibility
local($/) = "\n";
@@ -488,12 +509,20 @@ sub init {
# ourselves from the original query (which may be gone
# if it was read from STDIN originally.)
if (defined(@QUERY_PARAM) && !defined($initializer)) {
- foreach (@QUERY_PARAM) {
- $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
- }
- $self->charset($QUERY_CHARSET);
- $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
- return;
+ for my $name (@QUERY_PARAM) {
+ my $val = $QUERY_PARAM{$name}; # always an arrayref;
+ $self->param('-name'=>$name,'-value'=> $val);
+ if (defined $val and ref $val eq 'ARRAY') {
+ for my $fh (grep {defined(fileno($_))} @$val) {
+ seek($fh,0,0); # reset the filehandle.
+ }
+
+ }
+ }
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
+ $self->{'.tmpfiles'} = {%QUERY_TMPFILES};
+ return;
}
$meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
@@ -508,17 +537,10 @@ sub init {
# avoid unreasonably large postings
if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
- # quietly read and discard the post
- my $buffer;
- my $tmplength = $content_length;
- while($tmplength > 0) {
- my $maxbuffer = ($tmplength < 10000)?$tmplength:10000;
- my $bytesread = $MOD_PERL ? $self->r->read($buffer,$maxbuffer) : read(STDIN,$buffer,$maxbuffer);
- $tmplength -= $bytesread;
- }
- $self->cgi_error("413 Request entity too large");
- last METHOD;
- }
+ #discard the post, unread
+ $self->cgi_error("413 Request entity too large");
+ last METHOD;
+ }
# Process multipart postings, but only if the initializer is
# not defined.
@@ -532,9 +554,50 @@ sub init {
last METHOD;
}
+ # Process XForms postings. We know that we have XForms in the
+ # following cases:
+ # method eq 'POST' && content-type eq 'application/xml'
+ # method eq 'POST' && content-type =~ /multipart\/related.+start=/
+ # There are more cases, actually, but for now, we don't support other
+ # methods for XForm posts.
+ # In a XForm POST, the QUERY_STRING is parsed normally.
+ # If the content-type is 'application/xml', we just set the param
+ # XForms:Model (referring to the xml syntax) param containing the
+ # unparsed XML data.
+ # In the case of multipart/related we set XForms:Model as above, but
+ # the other parts are available as uploads with the Content-ID as the
+ # the key.
+ # See the URL below for XForms specs on this issue.
+ # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
+ if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
+ if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
+ my($param) = 'XForms:Model';
+ my($value) = '';
+ $self->add_parameter($param);
+ $self->read_from_client(\$value,$content_length,0)
+ if $content_length > 0;
+ push (@{$self->{$param}},$value);
+ $is_xforms = 1;
+ } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
+ my($boundary,$start) = ($1,$2);
+ my($param) = 'XForms:Model';
+ $self->add_parameter($param);
+ my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
+ push (@{$self->{$param}},$value);
+ if ($MOD_PERL) {
+ $query_string = $self->r->args;
+ } else {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
+ }
+ $is_xforms = 1;
+ }
+ }
+
+
# If initializer is defined, then read parameters
# from it.
- if (defined($initializer)) {
+ if (!$is_xforms && defined($initializer)) {
if (UNIVERSAL::isa($initializer,'CGI')) {
$query_string = $initializer->query_string;
last METHOD;
@@ -545,21 +608,6 @@ sub init {
}
last METHOD;
}
-
- if (defined($fh) && ($fh ne '')) {
- while (<$fh>) {
- chomp;
- last if /^=/;
- push(@lines,$_);
- }
- # massage back into standard format
- if ("@lines" =~ /=/) {
- $query_string=join("&",@lines);
- } else {
- $query_string=join("+",@lines);
- }
- last METHOD;
- }
if (defined($fh) && ($fh ne '')) {
while (<$fh>) {
@@ -585,7 +633,7 @@ sub init {
# If method is GET or HEAD, fetch the query from
# the environment.
- if ($meth=~/^(GET|HEAD)$/) {
+ if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
if ($MOD_PERL) {
$query_string = $self->r->args;
} else {
@@ -595,7 +643,7 @@ sub init {
last METHOD;
}
- if ($meth eq 'POST') {
+ if ($meth eq 'POST' || $meth eq 'PUT') {
$self->read_from_client(\$query_string,$content_length,0)
if $content_length > 0;
# Some people want to have their cake and eat it too!
@@ -621,11 +669,11 @@ sub init {
}
# YL: Begin Change for XML handler 10/19/2001
- if ($meth eq 'POST'
+ if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT')
&& defined($ENV{'CONTENT_TYPE'})
&& $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
&& $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
- my($param) = 'POSTDATA' ;
+ my($param) = $meth . 'DATA' ;
$self->add_parameter($param) ;
push (@{$self->{$param}},$query_string);
undef $query_string ;
@@ -710,6 +758,7 @@ sub save_request {
}
$QUERY_CHARSET = $self->charset;
%QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
+ %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
}
sub parse_params {
@@ -857,6 +906,7 @@ sub _setup_symbols {
$DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
$DEBUG=2, next if /^[:-][Dd]ebug$/;
$USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+ $PARAM_UTF8++, next if /^[:-]utf8$/;
$XHTML++, next if /^[:-]xhtml$/;
$XHTML=0, next if /^[:-]no_?xhtml$/;
$USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
@@ -1418,11 +1468,15 @@ sub header {
'ATTACHMENT','P3P'],@p);
$nph ||= $NPH;
+
+ $type ||= 'text/html' unless defined($type);
+
if (defined $charset) {
$self->charset($charset);
} else {
- $charset = $self->charset;
+ $charset = $self->charset if $type =~ /^text\//;
}
+ $charset ||= '';
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
@@ -1432,8 +1486,11 @@ sub header {
($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
- $type ||= 'text/html' unless defined($type);
- $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne '';
+ $type .= "; charset=$charset"
+ if $type ne ''
+ and $type !~ /\bcharset\b/
+ and defined $charset
+ and $charset ne '';
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
@@ -1465,7 +1522,7 @@ sub header {
push(@header,map {ucfirst $_} @other);
push(@header,"Content-Type: $type") if $type ne '';
my $header = join($CRLF,@header)."${CRLF}${CRLF}";
- if ($MOD_PERL and not $nph) {
+ if (($MOD_PERL >= 1) && !$nph) {
$self->r->send_cgi_header($header);
return '';
}
@@ -1499,7 +1556,7 @@ sub redirect {
my($self,@p) = self_or_default(@_);
my($url,$target,$status,$cookie,$nph,@other) =
rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
- $status = '302 Moved' unless defined $status;
+ $status = '302 Found' unless defined $status;
$url ||= $self->self_url;
my(@o);
foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
@@ -1546,7 +1603,7 @@ sub start_html {
$self->element_id(0);
$self->element_tab(0);
- $encoding = 'iso-8859-1' unless defined $encoding;
+ $encoding = lc($self->charset) unless defined $encoding;
# Need to sort out the DTD before it's okay to call escapeHTML().
my(@result,$xml_dtd);
@@ -1636,34 +1693,39 @@ END_OF_FUNC
sub _style {
my ($self,$style) = @_;
my (@result);
+
my $type = 'text/css';
+ my $rel = 'stylesheet';
+
my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
my @s = ref($style) eq 'ARRAY' ? @$style : $style;
+ my $other = '';
for my $s (@s) {
if (ref($s)) {
- my($src,$code,$verbatim,$stype,$foo,@other) =
- rearrange([qw(SRC CODE VERBATIM TYPE FOO)],
+ my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
+ rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
('-foo'=>'bar',
ref($s) eq 'ARRAY' ? @$s : %$s));
- $type = $stype if $stype;
- my $other = @other ? join ' ',@other : '';
+ my $type = defined $stype ? $stype : 'text/css';
+ my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
+ $other = "@other" if @other;
if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
{ # If it is, push a LINK tag for each one
foreach $src (@$src)
{
- push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
- : qq(<link rel="stylesheet" type="$type" href="$src"$other>)) if $src;
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
}
}
else
{ # Otherwise, push the single -src, if it exists.
- push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
- : qq(<link rel="stylesheet" type="$type" href="$src"$other>)
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>)
) if $src;
}
if ($verbatim) {
@@ -1675,8 +1737,8 @@ sub _style {
} else {
my $src = $s;
- push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
- : qq(<link rel="stylesheet" type="$type" href="$src"$other>));
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>));
}
}
@result;
@@ -1692,19 +1754,17 @@ sub _script {
foreach $script (@scripts) {
my($src,$code,$language);
if (ref($script)) { # script is a hash
- ($src,$code,$language, $type) =
- rearrange([SRC,CODE,LANGUAGE,TYPE],
+ ($src,$code,$type) =
+ rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
'-foo'=>'bar', # a trick to allow the '-' to be omitted
ref($script) eq 'ARRAY' ? @$script : %$script);
- # User may not have specified language
- $language ||= 'JavaScript';
- unless (defined $type) {
- $type = lc $language;
- # strip '1.2' from 'javascript1.2'
- $type =~ s/^(\D+).*$/text\/$1/;
+ $type ||= 'text/javascript';
+ unless ($type =~ m!\w+/\w+!) {
+ $type =~ s/[\d.]+$//;
+ $type = "text/$type";
}
} else {
- ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
+ ($src,$code,$type) = ('',$script, 'text/javascript');
}
my $comment = '//'; # javascript by default
@@ -1722,7 +1782,6 @@ sub _script {
}
my(@satts);
push(@satts,'src'=>$src) if $src;
- push(@satts,'language'=>$language) unless defined $type;
push(@satts,'type'=>$type);
$code = $cdata_start . $code . $cdata_end if defined $code;
push(@result,$self->script({@satts},$code || ''));
@@ -1776,13 +1835,13 @@ sub startform {
my($method,$action,$enctype,@other) =
rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = $self->escapeHTML(lc($method) || 'post');
+ $method = $self->escapeHTML(lc($method || 'post'));
$enctype = $self->escapeHTML($enctype || &URL_ENCODED);
if (defined $action) {
$action = $self->escapeHTML($action);
}
else {
- $action = $self->escapeHTML($self->request_uri);
+ $action = $self->escapeHTML($self->request_uri || $self->self_url);
}
$action = qq(action="$action");
my($other) = @other ? " @other" : '';
@@ -1812,9 +1871,7 @@ END_OF_FUNC
sub start_multipart_form {
my($self,@p) = self_or_default(@_);
if (defined($p[0]) && substr($p[0],0,1) eq '-') {
- my(%p) = @p;
- $p{'-enctype'}=&MULTIPART;
- return $self->startform(%p);
+ return $self->startform(-enctype=>&MULTIPART,@p);
} else {
my($method,$action,@other) =
rearrange([METHOD,ACTION],@p);
@@ -2094,8 +2151,9 @@ END_OF_FUNC
sub checkbox {
my($self,@p) = self_or_default(@_);
- my($name,$checked,$value,$label,$override,$tabindex,@other) =
- rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE],TABINDEX],@p);
+ my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) =
+ rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
+ [OVERRIDE,FORCE],TABINDEX],@p);
$value = defined $value ? $value : 'on';
@@ -2112,7 +2170,8 @@ sub checkbox {
my($other) = @other ? "@other " : '';
$tabindex = $self->element_tab($tabindex);
$self->register_parameter($name);
- return $XHTML ? CGI::label(qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
+ return $XHTML ? CGI::label($labelattributes,
+ qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
: qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
}
END_OF_FUNC
@@ -2139,9 +2198,11 @@ sub escapeHTML {
else {
$toencode =~ s{"}{"}gso;
}
- my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
- uc $self->{'.charset'} eq 'WINDOWS-1252';
- if ($latin) { # bug in some browsers
+ # Handle bug in some browsers with Latin charsets
+ if ($self->{'.charset'} &&
+ (uc($self->{'.charset'}) eq 'ISO-8859-1' ||
+ uc($self->{'.charset'}) eq 'WINDOWS-1252'))
+ {
$toencode =~ s{'}{'}gso;
$toencode =~ s{\x8b}{‹}gso;
$toencode =~ s{\x9b}{›}gso;
@@ -2274,17 +2335,17 @@ sub _box_group {
my $self = shift;
my $box_type = shift;
- my($name,$values,$defaults,$linebreak,$labels,$attributes,
- $rows,$columns,$rowheaders,$colheaders,
- $override,$nolabels,$tabindex,@other) =
- rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES,
- ROWS,[COLUMNS,COLS],ROWHEADERS,COLHEADERS,
- [OVERRIDE,FORCE],NOLABELS,TABINDEX
- ],@_);
- my($result,$checked);
+ my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
+ $attributes,$rows,$columns,$rowheaders,$colheaders,
+ $override,$nolabels,$tabindex,$disabled,@other) =
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
+ ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
+ [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
+ ],@_);
+
+ my($result,$checked,@elements,@values);
- my(@elements,@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
my %checked = $self->previous_or_default($name,$defaults,$override);
@@ -2304,10 +2365,21 @@ sub _box_group {
}
}
%tabs = map {$_=>$self->element_tab} @values unless %tabs;
-
my $other = @other ? "@other " : '';
my $radio_checked;
+
+ # for disabling groups of radio/checkbox buttons
+ my %disabled;
+ foreach (@{$disabled}) {
+ $disabled{$_}=1;
+ }
+
foreach (@values) {
+ my $disable="";
+ if ($disabled{$_}) {
+ $disable="disabled='1'";
+ }
+
my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
: $checked{$_});
my($break);
@@ -2322,16 +2394,18 @@ sub _box_group {
$label = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->escapeHTML($label,1);
+ $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
}
my $attribs = $self->_set_attributes($_, $attributes);
my $tab = $tabs{$_};
$_=$self->escapeHTML($_);
+
if ($XHTML) {
push @elements,
- CGI::label(
- qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs/>$label)).${break};
+ CGI::label($labelattributes,
+ qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
} else {
- push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs>${label}${break}/);
+ push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/);
}
}
$self->register_parameter($name);
@@ -2386,13 +2460,13 @@ sub popup_menu {
}
}
else {
- my $attribs = $self->_set_attributes($_, $attributes);
- my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- my($value) = $self->escapeHTML($_);
- $label=$self->escapeHTML($label,1);
- $result .= "<option $selectit${attribs}value=\"$value\">$label</option>\n";
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ my($value) = $self->escapeHTML($_);
+ $label=$self->escapeHTML($label,1);
+ $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
}
}
@@ -2495,6 +2569,7 @@ sub scrolling_list {
$size = $size || scalar(@values);
my(%selected) = $self->previous_or_default($name,$defaults,$override);
+
my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
@@ -2577,7 +2652,7 @@ sub image_button {
my($name,$src,$alignment,@other) =
rearrange([NAME,SRC,ALIGN],@p);
- my($align) = $alignment ? " align=\U\"$alignment\"" : '';
+ my($align) = $alignment ? " align=\L\"$alignment\"" : '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
@@ -2624,29 +2699,30 @@ sub url {
my $path = $self->path_info;
my $script_name = $self->script_name;
- my $request_uri = $self->request_uri || '';
+ my $request_uri = unescape($self->request_uri) || '';
my $query_str = $self->query_string;
- my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/;
+ my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
$uri =~ s/\?.*$//; # remove query string
- $uri =~ s/$path$// if defined $path; # remove path
+ $uri =~ s/\Q$path\E$// if defined $path; # remove path
if ($full) {
my $protocol = $self->protocol();
$url = "$protocol://";
- my $vh = http('x_forwarded_host') || http('host');
+ my $vh = http('x_forwarded_host') || http('host') || '';
+ $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
if ($vh) {
$url .= $vh;
} else {
$url .= server_name();
- my $port = $self->server_port;
- $url .= ":" . $port
- unless (lc($protocol) eq 'http' && $port == 80)
- || (lc($protocol) eq 'https' && $port == 443);
}
+ my $port = $self->server_port;
+ $url .= ":" . $port
+ unless (lc($protocol) eq 'http' && $port == 80)
+ || (lc($protocol) eq 'https' && $port == 443);
return $url if $base;
$url .= $uri;
} elsif ($relative) {
@@ -2657,6 +2733,7 @@ sub url {
$url .= $path if $path_info and defined $path;
$url .= "?$query_str" if $query and $query_str ne '';
+ $url ||= '';
$url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
return $url;
}
@@ -2678,8 +2755,8 @@ END_OF_FUNC
'cookie' => <<'END_OF_FUNC',
sub cookie {
my($self,@p) = self_or_default(@_);
- my($name,$value,$path,$domain,$secure,$expires) =
- rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
+ my($name,$value,$path,$domain,$secure,$expires,$httponly) =
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
require CGI::Cookie;
@@ -2707,6 +2784,7 @@ sub cookie {
push(@param,'-path'=>$path) if $path;
push(@param,'-expires'=>$expires) if $expires;
push(@param,'-secure'=>$secure) if $secure;
+ push(@param,'-httponly'=>$httponly) if $httponly;
return new CGI::Cookie(@param);
}
@@ -2752,9 +2830,6 @@ sub path_info {
} elsif (! defined($self->{'.path_info'}) ) {
my (undef,$path_info) = $self->_name_and_path_from_env;
$self->{'.path_info'} = $path_info || '';
- # hack to fix broken path info in IIS
- $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
-
}
return $self->{'.path_info'};
}
@@ -2766,11 +2841,10 @@ sub _name_and_path_from_env {
my $self = shift;
my $raw_script_name = $ENV{SCRIPT_NAME} || '';
my $raw_path_info = $ENV{PATH_INFO} || '';
- my $uri = $ENV{REQUEST_URI} || '';
+ my $uri = unescape($self->request_uri) || '';
- if ($raw_script_name =~ m/$raw_path_info$/) {
- $raw_script_name =~ s/$raw_path_info$//;
- }
+ my $protected = quotemeta($raw_path_info);
+ $raw_script_name =~ s/$protected$//;
my @uri_double_slashes = $uri =~ m^(/{2,}?)^g;
my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g;
@@ -2778,10 +2852,7 @@ sub _name_and_path_from_env {
my $apache_bug = @uri_double_slashes != @path_double_slashes;
return ($raw_script_name,$raw_path_info) unless $apache_bug;
- my $path_info_search = $raw_path_info;
- # these characters will not (necessarily) be escaped
- $path_info_search =~ s/([^a-zA-Z0-9$()':_.,+*\/;?=&-])/uc sprintf("%%%02x",ord($1))/eg;
- $path_info_search = quotemeta($path_info_search);
+ my $path_info_search = quotemeta($raw_path_info);
$path_info_search =~ s!/!/+!g;
if ($uri =~ m/^(.+)($path_info_search)/) {
return ($1,$2);
@@ -2988,7 +3059,7 @@ END_OF_FUNC
sub script_name {
my ($self,@p) = self_or_default(@_);
if (@p) {
- $self->{'.script_name'} = shift;
+ $self->{'.script_name'} = shift @p;
} elsif (!exists $self->{'.script_name'}) {
my ($script_name,$path_info) = $self->_name_and_path_from_env();
$self->{'.script_name'} = $script_name;
@@ -3224,10 +3295,10 @@ sub previous_or_default {
if (!$override && ($self->{'.fieldnames'}->{$name} ||
defined($self->param($name)) ) ) {
- grep($selected{$_}++,$self->param($name));
+ $selected{$_}++ for $self->param($name);
} elsif (defined($defaults) && ref($defaults) &&
(ref($defaults) eq 'ARRAY')) {
- grep($selected{$_}++,@{$defaults});
+ $selected{$_}++ for @{$defaults};
} else {
$selected{$defaults}++ if defined($defaults);
}
@@ -3308,11 +3379,15 @@ sub read_multipart {
return;
}
- my($param)= $header{'Content-Disposition'}=~/ name="([^;]*)"/;
+ my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
$param .= $TAINTED;
- # Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="([^;]*)"/;
+ # See RFC 1867, 2183, 2045
+ # NB: File content will be loaded into memory should
+ # content-disposition parsing fail.
+ my ($filename) = $header{'Content-Disposition'}
+ =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
+ $filename =~ s/^"([^"]*)"$/$1/;
# Test for Opera's multiple upload feature
my($multipart) = ( defined( $header{'Content-Type'} ) &&
$header{'Content-Type'} =~ /multipart\/mixed/ ) ?
@@ -3371,14 +3446,14 @@ sub read_multipart {
my ($data);
local($\) = '';
- my $totalbytes;
+ my $totalbytes = 0;
while (defined($data = $buffer->read)) {
if (defined $self->{'.upload_hook'})
{
$totalbytes += length($data);
&{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
}
- print $filehandle $data;
+ print $filehandle $data if ($self->{'use_tempfile'});
}
# back up to beginning of file
@@ -3408,10 +3483,114 @@ sub read_multipart {
}
END_OF_FUNC
+#####
+# subroutine: read_multipart_related
+#
+# Read multipart/related data and store it into our parameters. The
+# first parameter sets the start of the data. The part identified by
+# this Content-ID will not be stored as a file upload, but will be
+# returned by this method. All other parts will be available as file
+# uploads accessible by their Content-ID
+#####
+'read_multipart_related' => <<'END_OF_FUNC',
+sub read_multipart_related {
+ my($self,$start,$boundary,$length) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
+ return unless $buffer;
+ my(%header,$body);
+ my $filenumber = 0;
+ my $returnvalue;
+ while (!$buffer->eof) {
+ %header = $buffer->readHeader;
+
+ unless (%header) {
+ $self->cgi_error("400 Bad request (malformed multipart POST)");
+ return;
+ }
+
+ my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
+ $param .= $TAINTED;
+
+ # If this is the start part, then just read the data and assign it
+ # to our return variable.
+ if ( $param eq $start ) {
+ $returnvalue = $buffer->readBody;
+ $returnvalue .= $TAINTED;
+ next;
+ }
+
+ # add this parameter to our list
+ $self->add_parameter($param);
+
+ my ($tmpfile,$tmp,$filehandle);
+ UPLOADS: {
+ # If we get here, then we are dealing with a potentially large
+ # uploaded form. Save the data to a temporary file, then open
+ # the file for reading.
+
+ # skip the file if uploads disabled
+ if ($DISABLE_UPLOADS) {
+ while (defined($data = $buffer->read)) { }
+ last UPLOADS;
+ }
+
+ # choose a relatively unpredictable tmpfile sequence number
+ my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
+ for (my $cnt=10;$cnt>0;$cnt--) {
+ next unless $tmpfile = new CGITempFile($seqno);
+ $tmp = $tmpfile->as_string;
+ last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
+ $seqno += int rand(100);
+ }
+ die "CGI open of tmpfile: $!\n" unless defined $filehandle;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
+ && defined fileno($filehandle);
+
+ my ($data);
+ local($\) = '';
+ my $totalbytes;
+ while (defined($data = $buffer->read)) {
+ if (defined $self->{'.upload_hook'})
+ {
+ $totalbytes += length($data);
+ &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
+ }
+ print $filehandle $data if ($self->{'use_tempfile'});
+ }
+
+ # back up to beginning of file
+ seek($filehandle,0,0);
+
+ ## Close the filehandle if requested this allows a multipart MIME
+ ## upload to contain many files, and we won't die due to too many
+ ## open file handles. The user can access the files using the hash
+ ## below.
+ close $filehandle if $CLOSE_UPLOAD_FILES;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+
+ # Save some information about the uploaded file where we can get
+ # at it later.
+ # Use the typeglob as the key, as this is guaranteed to be
+ # unique for each filehandle. Don't use the file descriptor as
+ # this will be re-used for each filehandle if the
+ # close_upload_files feature is used.
+ $self->{'.tmpfiles'}->{$$filehandle}= {
+ hndl => $filehandle,
+ name => $tmpfile,
+ info => {%header},
+ };
+ push(@{$self->{$param}},$filehandle);
+ }
+ }
+ return $returnvalue;
+}
+END_OF_FUNC
+
+
'upload' =><<'END_OF_FUNC',
sub upload {
my($self,$param_name) = self_or_default(@_);
- my @param = grep(ref && defined(fileno($_)), $self->param($param_name));
+ my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
return unless @param;
return wantarray ? @param : $param[0];
}
@@ -3532,7 +3711,7 @@ sub new {
(my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
my $fv = ++$FH . $safename;
my $ref = \*{"Fh::$fv"};
- $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+ $file =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\-]+)$! || return;
my $safe = $1;
sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
unlink($safe) if $delete;
@@ -3604,7 +3783,7 @@ sub new {
}
my $self = {LENGTH=>$length,
- CHUNKED=>!defined $length,
+ CHUNKED=>!$length,
BOUNDARY=>$boundary,
INTERFACE=>$interface,
BUFFER=>'',
@@ -3868,10 +4047,10 @@ sub new {
my $filename;
find_tempdir() unless -w $TMPDIRECTORY;
for (my $i = 0; $i < $MAXTRIES; $i++) {
- last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
+ last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
}
# check that it is a more-or-less valid filename
- return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!;
+ return unless $filename =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\-]+)$!;
# this used to untaint, now it doesn't
# $filename = $1;
return bless \$filename;
@@ -3945,6 +4124,8 @@ CGI - Simple Common Gateway Interface Cl
hr;
}
+ print end_html;
+
=head1 ABSTRACT
This perl library uses perl5 objects to make it easy to create Web
@@ -4129,7 +4310,10 @@ HTML "standards".
$query = new CGI;
This will parse the input (from both POST and GET methods) and store
-it into a perl5 object called $query.
+it into a perl5 object called $query.
+
+Any filehandles from file uploads will have their position reset to
+the beginning of the file.
=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
@@ -4310,6 +4494,10 @@ it, use code like this:
my $data = $query->param('POSTDATA');
+Likewise if PUTed data can be retrieved with code like this:
+
+ my $data = $query->param('PUTDATA');
+
(If you don't know what the preceding means, don't worry about it. It
only affects people trying to use CGI for XML processing and other
specialized tasks.)
@@ -4590,7 +4778,7 @@ all.
This causes the indicated autoloaded methods to be compiled up front,
rather than deferred to later. This is useful for scripts that run
for an extended period of time under FastCGI or mod_perl, and for
-those destined to be crunched by Malcom Beattie's Perl compiler. Use
+those destined to be crunched by Malcolm Beattie's Perl compiler. Use
it in conjunction with the methods or method families you plan to use.
use CGI qw(-compile :standard :html3);
@@ -4645,6 +4833,16 @@ If start_html()'s -dtd parameter specifi
XHTML will automatically be disabled without needing to use this
pragma.
+=item -utf8
+
+This makes CGI.pm treat all parameters as UTF-8 strings. Use this with
+care, as it will interfere with the processing of binary uploads. It
+is better to manually select which fields are expected to return utf-8
+strings and convert them using code like this:
+
+ use Encode;
+ my $arg = decode utf8=>param('foo');
+
=item -nph
This makes CGI.pm produce a header appropriate for an NPH (no
@@ -5063,20 +5261,20 @@ Use the B<-noScript> parameter to pass s
browsers that do not have JavaScript (or browsers where JavaScript is turned
off).
-Netscape 3.0 recognizes several attributes of the <script> tag,
-including LANGUAGE and SRC. The latter is particularly interesting,
-as it allows you to keep the JavaScript code in a file or CGI script
-rather than cluttering up each page with the source. To use these
-attributes pass a HASH reference in the B<-script> parameter containing
-one or more of -language, -src, or -code:
+The <script> tag, has several attributes including "type" and src.
+The latter is particularly interesting, as it allows you to keep the
+JavaScript code in a file or CGI script rather than cluttering up each
+page with the source. To use these attributes pass a HASH reference
+in the B<-script> parameter containing one or more of -type, -src, or
+-code:
print $q->start_html(-title=>'The Riddle of the Sphinx',
- -script=>{-language=>'JAVASCRIPT',
+ -script=>{-type=>'JAVASCRIPT',
-src=>'/javascript/sphinx.js'}
);
print $q->(-title=>'The Riddle of the Sphinx',
- -script=>{-language=>'PERLSCRIPT',
+ -script=>{-type=>'PERLSCRIPT',
-code=>'print "hello world!\n;"'}
);
@@ -5084,32 +5282,27 @@ one or more of -language, -src, or -code
A final feature allows you to incorporate multiple <script> sections into the
header. Just pass the list of script sections as an array reference.
this allows you to specify different source files for different dialects
-of JavaScript. Example:
+of JavaScript. Example:
print $q->start_html(-title=>'The Riddle of the Sphinx',
-script=>[
- { -language => 'JavaScript1.0',
+ { -type => 'text/javascript',
-src => '/javascript/utilities10.js'
},
- { -language => 'JavaScript1.1',
+ { -type => 'text/javascript',
-src => '/javascript/utilities11.js'
},
- { -language => 'JavaScript1.2',
+ { -type => 'text/jscript',
-src => '/javascript/utilities12.js'
},
- { -language => 'JavaScript28.2',
+ { -type => 'text/ecmascript',
-src => '/javascript/utilities219.js'
}
]
);
-If this looks a bit extreme, take my advice and stick with straight CGI scripting.
-
-See
-
- http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
-
-for more information about JavaScript.
+The option "-language" is a synonym for -type, and is supported for
+backwad compatibility.
The old-style positional parameters are as follows:
@@ -5226,7 +5419,7 @@ Generate just the protocol and net locat
If Apache's mod_rewrite is turned on, then the script name and path
info probably won't match the request that the user sent. Set
-rewrite=>1 (default) to return URLs that match what the user sent
-(the original request URI). Set -rewrite->0 to return URLs that match
+(the original request URI). Set -rewrite=>0 to return URLs that match
the URL after mod_rewrite's rules have run. Because the additional
path information only makes sense in the context of the rewritten URL,
-rewrite is set to false when you request path info in the URL.
@@ -5838,6 +6031,12 @@ multiple upload fields.
This is the recommended idiom.
+For robust code, consider reseting the file handle position to beginning of the
+file. Inside of larger frameworks, other code may have already used the query
+object and changed the filehandle postion:
+
+ seek($fh,0,0); # reset postion to beginning of file.
+
When a file is uploaded the browser usually sends along some
information along with it in the format of headers. The information
usually includes the MIME content type. Future browsers may send
@@ -5879,7 +6078,7 @@ UPLOAD_HOOK facility available in Apache
that the first argument to the callback is an Apache::Upload object,
here it's the remote filename.
- $q = CGI->new(\&hook,$data);
+ $q = CGI->new(\&hook [,$data [,$use_tempfile]]);
sub hook
{
@@ -5887,10 +6086,19 @@ here it's the remote filename.
print "Read $bytes_read bytes of $filename\n";
}
+The $data field is optional; it lets you pass configuration
+information (e.g. a database handle) to your hook callback.
+
+The $use_tempfile field is a flag that lets you turn on and off
+CGI.pm's use of a temporary disk-based file during file upload. If you
+set this to a FALSE value (default true) then param('uploaded_file')
+will no longer work, and the only way to get at the uploaded data is
+via the hook you provide.
+
If using the function-oriented interface, call the CGI::upload_hook()
method before calling param() or any other CGI functions:
- CGI::upload_hook(\&hook,$data);
+ CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
This method is not exported by default. You will have to import it
explicitly if you wish to use it without the CGI:: prefix.
@@ -6032,7 +6240,7 @@ for each option element within the optgr
=item 5.
An optional fifth parameter (-novals) can be set to a true value and
-indicates to suppress the val attribut in each option element within
+indicates to suppress the val attribute in each option element within
the optgroup.
See the discussion on optgroup at W3C
@@ -6130,6 +6338,7 @@ selected items can be retrieved with:
-values=>['eenie','meenie','minie','moe'],
-default=>['eenie','moe'],
-linebreak=>'true',
+ -disabled => ['moe'],
-labels=>\%labels,
-attributes=>\%attributes);
@@ -6182,13 +6391,14 @@ printed next to them. If not provided,
default.
-Modern browsers can take advantage of the optional parameters
-B<-rows>, and B<-columns>. These parameters cause checkbox_group() to
-return an HTML3 compatible table containing the checkbox group
-formatted with the specified number of rows and columns. You can
-provide just the -columns parameter if you wish; checkbox_group will
-calculate the correct number of rows for you.
+The optional parameters B<-rows>, and B<-columns> cause
+checkbox_group() to return an HTML3 compatible table containing the
+checkbox group formatted with the specified number of rows and
+columns. You can provide just the -columns parameter if you wish;
+checkbox_group will calculate the correct number of rows for you.
+The option b<-disabled> takes an array of checkbox values and disables
+them by greying them out (this may not be supported by all browsers).
The optional B<-attributes> argument is provided to assign any of the
common HTML attributes to an individual menu item. It's a pointer to
@@ -6210,6 +6420,9 @@ are the tab indexes of each button. Exa
-tabindex => ['moe','minie','eenie','meenie'] # tab in this order
-tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
When the form is processed, all checked boxes will be returned as
a list under the parameter name 'group_name'. The values of the
"on" checkboxes can be retrieved with:
@@ -6340,7 +6553,7 @@ the -columns parameter if you wish; radi
correct number of rows for you.
To include row and column headings in the returned table, you
-can use the B<-rowheader> and B<-colheader> parameters. Both
+can use the B<-rowheaders> and B<-colheaders> parameters. Both
of these accept a pointer to an array of headings to use.
The headings are just decorative. They don't reorganize the
interpretation of the radio buttons -- they're still a single named
@@ -6367,6 +6580,9 @@ an associative array relating menu value
with the attribute's name as the key and the attribute's value as the
value.
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
When the form is processed, the selected radio button can
be retrieved using:
@@ -6647,6 +6863,7 @@ SSL session.
The cookie created by cookie() must be incorporated into the HTTP
header within the string returned by the header() method:
+ use CGI ':standard';
print header(-cookie=>$my_cookie);
To create multiple cookies, give header() an array reference:
@@ -6658,12 +6875,13 @@ To create multiple cookies, give header(
print header(-cookie=>[$cookie1,$cookie2]);
To retrieve a cookie, request it by name by calling cookie() method
-without the B<-value> parameter:
+without the B<-value> parameter. This example uses the object-oriented
+form:
use CGI;
$query = new CGI;
- $riddle = cookie('riddle_name');
- %answers = cookie('answers');
+ $riddle = $query->cookie('riddle_name');
+ %answers = $query->cookie('answers');
Cookies created with a single scalar value, such as the "riddle_name"
cookie, will be returned in that form. Cookies with array and hash
@@ -6679,6 +6897,11 @@ simple to turn a CGI parameter into a co
# vice-versa
param(-name=>'answers',-value=>[cookie('answers')]);
+If you call cookie() without any parameters, it will return a list of
+the names of all cookies passed to your script:
+
+ @cookies = cookie();
+
See the B<cookie.cgi> example script for some ideas on how to use
cookies effectively.
@@ -6701,7 +6924,7 @@ There is no specific support for creatin
in CGI.pm, but the HTML is very simple to write. See the frame
documentation in Netscape's home pages for details
- http://home.netscape.com/assist/net_sites/frames.html
+ http://wp.netscape.com/assist/net_sites/frames.html
=item 2. Specify the destination for the document in the HTTP header
@@ -6739,7 +6962,7 @@ Netscape versions 2.0 and higher incorpo
called JavaScript. Internet Explorer, 3.0 and higher, supports a
closely-related dialect called JScript. JavaScript isn't the same as
Java, and certainly isn't at all the same as Perl, which is a great
-pity. JavaScript allows you to programatically change the contents of
+pity. JavaScript allows you to programmatically change the contents of
fill-out forms, create new windows, and pop up dialog box from within
Netscape itself. From the point of view of CGI scripting, JavaScript
is quite useful for validating fill-out forms prior to submitting
@@ -6960,10 +7183,8 @@ Should you wish to incorporate a verbati
arbitrary formatting in the header, you may pass a -verbatim tag to
the -style hash, as follows:
-print start_html (-STYLE => {-verbatim => '@import
-url("/server-common/css/'.$cssFile.'");',
- -src => '/server-common/css/core.css'});
-</blockquote></pre>
+print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");',
+ -src => '/server-common/css/core.css'});
This will generate an HTML header that contains this:
@@ -6993,6 +7214,14 @@ and pass it to start_html() in the -head
Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
print start_html({-head=>\@h})
+To create primary and "alternate" stylesheet, use the B<-alternate> option:
+
+ start_html(-style=>{-src=>[
+ {-src=>'/styles/print.css'},
+ {-src=>'/styles/alt.css',-alternate=>1}
+ ]
+ });
+
=head1 DEBUGGING
If you are running the script from the command line or in the perl
@@ -7466,10 +7695,8 @@ of CGI.pm without rewriting your old scr
=head1 AUTHOR INFORMATION
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+The GD.pm interface is copyright 1995-2007, Lincoln D. Stein. It is
+distributed under GPL and the Artistic License 2.0.
Address bug reports and comments to: lstein@cshl.org. When sending
bug reports, please provide the version of CGI.pm, the version of
diff -up perl-5.8.8/lib/CGI/Pretty.pm.crr perl-5.8.8/lib/CGI/Pretty.pm
diff -up perl-5.8.8/lib/CGI/Push.pm.crr perl-5.8.8/lib/CGI/Push.pm
diff -up perl-5.8.8/lib/CGI/Switch.pm.crr perl-5.8.8/lib/CGI/Switch.pm
diff -up perl-5.8.8/lib/CGI/t/apache.t.crr perl-5.8.8/lib/CGI/t/apache.t
diff -up perl-5.8.8/lib/CGI/t/can.t.crr perl-5.8.8/lib/CGI/t/can.t
diff -up perl-5.8.8/lib/CGI/t/carp.t.crr perl-5.8.8/lib/CGI/t/carp.t
diff -up perl-5.8.8/lib/CGI/t/cookie.t.crr perl-5.8.8/lib/CGI/t/cookie.t
--- perl-5.8.8/lib/CGI/t/cookie.t.crr 2003-06-02 19:36:56.000000000 +0200
+++ perl-5.8.8/lib/CGI/t/cookie.t 2006-04-18 19:53:28.000000000 +0200
@@ -7,7 +7,7 @@ use strict;
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(blib/lib blib/arch);
-use Test::More tests => 86;
+use Test::More tests => 96;
use CGI::Util qw(escape unescape);
use POSIX qw(strftime);
@@ -325,3 +325,51 @@ my @test_cookie = (
ok(!$c->secure(0), 'secure attribute is cleared');
ok(!$c->secure, 'secure attribute is cleared');
}
+
+#-----------------------------------------------------------------------------
+# Apache2?::Cookie compatibility.
+#-----------------------------------------------------------------------------
+APACHEREQ: {
+ my $r = Apache::Faker->new;
+ isa_ok $r, 'Apache';
+ ok my $c = CGI::Cookie->new(
+ $r,
+ -name => 'Foo',
+ -value => 'Bar',
+ ), 'Pass an Apache object to the CGI::Cookie constructor';
+ isa_ok $c, 'CGI::Cookie';
+ ok $c->bake($r), 'Bake the cookie';
+ ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
+ 'bake() should call headers_out->set()';
+
+ $r = Apache2::Faker->new;
+ isa_ok $r, 'Apache2::RequestReq';
+ ok $c = CGI::Cookie->new(
+ $r,
+ -name => 'Foo',
+ -value => 'Bar',
+ ), 'Pass an Apache::RequestReq object to the CGI::Cookie constructor';
+ isa_ok $c, 'CGI::Cookie';
+ ok $c->bake($r), 'Bake the cookie';
+ ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
+ 'bake() should call headers_out->set()';
+}
+
+
+package Apache::Faker;
+sub new { bless {}, shift }
+sub isa {
+ my ($self, $pkg) = @_;
+ return $pkg eq 'Apache';
+}
+sub headers_out { shift }
+sub add { shift->{check} = \@_; }
+
+package Apache2::Faker;
+sub new { bless {}, shift }
+sub isa {
+ my ($self, $pkg) = @_;
+ return $pkg eq 'Apache2::RequestReq';
+}
+sub headers_out { shift }
+sub add { shift->{check} = \@_; }
diff -up perl-5.8.8/lib/CGI/t/fast.t.crr perl-5.8.8/lib/CGI/t/fast.t
diff -up perl-5.8.8/lib/CGI/t/form.t.crr perl-5.8.8/lib/CGI/t/form.t
--- perl-5.8.8/lib/CGI/t/form.t.crr 2005-12-07 03:31:13.000000000 +0100
+++ perl-5.8.8/lib/CGI/t/form.t 2007-02-24 00:02:28.000000000 +0100
@@ -4,7 +4,7 @@
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(. ./blib/lib ./blib/arch);
-use Test::More tests => 18;
+use Test::More tests => 19;
BEGIN { use_ok('CGI'); };
use CGI (':standard','-no_debug','-tabindex');
@@ -127,3 +127,10 @@ is(scrolling_list(-name => 'game',
<option selected="selected" value="cribbage">cribbage</option>
</select>',
'scrolling_list()');
+
+is(checkbox_group(-name => 'game',
+ -Values => [qw/checkers chess cribbage/],
+ -disabled => ['checkers']),
+ qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" tabindex="23" disabled='1'/><span style="color:gray">checkers</span></label> <label><input type="checkbox" name="game" value="chess" checked="checked" tabindex="24" />chess</label> <label><input type="checkbox" name="game" value="cribbage" tabindex="25" />cribbage</label>),
+ 'checkbox_group()');
+
diff -up perl-5.8.8/lib/CGI/t/function.t.crr perl-5.8.8/lib/CGI/t/function.t
--- perl-5.8.8/lib/CGI/t/function.t.crr 2003-06-02 19:36:59.000000000 +0200
+++ perl-5.8.8/lib/CGI/t/function.t 2006-05-30 18:07:55.000000000 +0200
@@ -4,9 +4,9 @@ use lib qw(t/lib);
# Test ability to retrieve HTTP request info
######################### We start with some black magic to print on failure.
-use lib '../blib/lib','../blib/arch';
+use lib '.','..','../blib/lib','../blib/arch';
-BEGIN {$| = 1; print "1..31\n"; }
+BEGIN {$| = 1; print "1..32\n"; }
END {print "not ok 1\n" unless $loaded;}
use Config;
use CGI (':standard','keywords');
@@ -102,10 +102,10 @@ if ($Config{d_fork}) {
print "ok 23 # Skip\n";
print "ok 24 # Skip\n";
}
-test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}Location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1");
+test(25,redirect('http://somewhere.else') eq "Status: 302 Found${CRLF}Location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1");
my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html');
-test(26,$h eq "Status: 302 Moved${CRLF}Location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
-test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}Location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
+test(26,$h eq "Status: 302 Found${CRLF}Location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
+test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Found${CRLF}Location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
test(28,escapeHTML('CGI') eq 'CGI','escapeHTML(CGI) failing again');
@@ -113,3 +113,5 @@ test(29, charset("UTF-8") && header() eq
test(30, !charset("") && header() eq "Content-Type: text/html${CRLF}${CRLF}", "Empty charset");
test(31, header(-foo=>'bar') eq "Foo: bar${CRLF}Content-Type: text/html${CRLF}${CRLF}", "Custom header");
+
+test(32, start_form(-action=>'one',name=>'two',onsubmit=>'three') eq qq(<form method="post" action="one" enctype="multipart/form-data" onsubmit="three" name="two">\n), "initial dash followed by undashed arguments");
diff -up perl-5.8.8/lib/CGI/t/html.t.crr perl-5.8.8/lib/CGI/t/html.t
--- perl-5.8.8/lib/CGI/t/html.t.crr 2005-04-03 17:23:43.000000000 +0200
+++ perl-5.8.8/lib/CGI/t/html.t 2005-12-27 20:14:54.000000000 +0100
@@ -10,7 +10,7 @@ $loaded = 1;
print "ok 1\n";
BEGIN {
- $| = 1; print "1..27\n";
+ $| = 1; print "1..28\n";
if( $] > 5.006 ) {
# no utf8
require utf8; # we contain Latin-1
@@ -110,3 +110,4 @@ test(25,$q->p({title=>"hello world&egrav
$q->autoEscape(0);
test(26,$q->p({title=>"hello worldè"},'hello á') eq '<p title="hello worldè">hello á</p>');
test(27,p({title=>"hello worldè"},'hello á') eq '<p title="hello world&egrave;">hello á</p>');
+test(28,header(-type=>'image/gif',-charset=>'UTF-8') eq "Content-Type: image/gif; charset=UTF-8${CRLF}${CRLF}","header()");
diff -up perl-5.8.8/lib/CGI/t/no_tabindex.t.crr perl-5.8.8/lib/CGI/t/no_tabindex.t
diff -up perl-5.8.8/lib/CGI/t/pretty.t.crr perl-5.8.8/lib/CGI/t/pretty.t
diff -up perl-5.8.8/lib/CGI/t/push.t.crr perl-5.8.8/lib/CGI/t/push.t
diff -up perl-5.8.8/lib/CGI/t/request.t.crr perl-5.8.8/lib/CGI/t/request.t
diff -up perl-5.8.8/lib/CGI/t/switch.t.crr perl-5.8.8/lib/CGI/t/switch.t
diff -up perl-5.8.8/lib/CGI/t/uploadInfo.t.crr perl-5.8.8/lib/CGI/t/uploadInfo.t
--- perl-5.8.8/lib/CGI/t/uploadInfo.t.crr 2008-06-09 10:00:36.000000000 +0200
+++ perl-5.8.8/lib/CGI/t/uploadInfo.t 2007-04-16 18:53:57.000000000 +0200
@@ -0,0 +1,76 @@
+#!/usr/local/bin/perl -w
+
+#################################################################
+# Emanuele Zeppieri, Mark Stosberg #
+# Shamelessly stolen from Data::FormValidator and CGI::Upload #
+#################################################################
+
+# Due to a bug in older versions of MakeMaker & Test::Harness, we must
+# ensure the blib's are in @INC, else we might use the core CGI.pm
+use lib qw(. ./blib/lib ./blib/arch);
+
+use strict;
+
+use Test::More 'no_plan';
+
+use CGI;
+
+#-----------------------------------------------------------------------------
+# %ENV setup.
+#-----------------------------------------------------------------------------
+
+%ENV = (
+ %ENV,
+ 'SCRIPT_NAME' => '/test.cgi',
+ 'SERVER_NAME' => 'perl.org',
+ 'HTTP_CONNECTION' => 'TE, close',
+ 'REQUEST_METHOD' => 'POST',
+ 'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
+ 'CONTENT_LENGTH' => 3285,
+ 'SCRIPT_FILENAME' => '/home/usr/test.cgi',
+ 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
+ 'HTTP_TE' => 'deflate,gzip;q=0.3',
+ 'QUERY_STRING' => '',
+ 'REMOTE_PORT' => '1855',
+ 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
+ 'SERVER_PORT' => '80',
+ 'REMOTE_ADDR' => '127.0.0.1',
+ 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
+ 'SERVER_PROTOCOL' => 'HTTP/1.1',
+ 'PATH' => '/usr/local/bin:/usr/bin:/bin',
+ 'REQUEST_URI' => '/test.cgi',
+ 'GATEWAY_INTERFACE' => 'CGI/1.1',
+ 'SCRIPT_URL' => '/test.cgi',
+ 'SERVER_ADDR' => '127.0.0.1',
+ 'DOCUMENT_ROOT' => '/home/develop',
+ 'HTTP_HOST' => 'www.perl.org'
+);
+
+#-----------------------------------------------------------------------------
+# Simulate the upload (really, multiple uploads contained in a single stream).
+#-----------------------------------------------------------------------------
+
+my $q;
+
+{
+ local *STDIN;
+ open STDIN, '<t/upload_post_text.txt'
+ or die 'missing test file t/upload_post_text.txt';
+ binmode STDIN;
+ $q = CGI->new;
+}
+
+{
+ my $test = "uploadInfo: basic test";
+ my $fh = $q->upload('300x300_gif');
+ is( $q->uploadInfo($fh)->{'Content-Type'}, "image/gif", $test);
+}
+
+my $q2 = CGI->new;
+
+{
+ my $test = "uploadInfo: works with second object instance";
+ my $fh = $q2->upload('300x300_gif');
+ is( $q2->uploadInfo($fh)->{'Content-Type'}, "image/gif", $test);
+}
+
diff -up perl-5.8.8/lib/CGI/t/upload_post_text.txt.crr perl-5.8.8/lib/CGI/t/upload_post_text.txt
Binary files perl-5.8.8/lib/CGI/t/upload_post_text.txt.crr and perl-5.8.8/lib/CGI/t/upload_post_text.txt differ
diff -up perl-5.8.8/lib/CGI/t/upload.t.crr perl-5.8.8/lib/CGI/t/upload.t
--- perl-5.8.8/lib/CGI/t/upload.t.crr 2008-06-09 10:00:20.000000000 +0200
+++ perl-5.8.8/lib/CGI/t/upload.t 2008-03-28 19:04:44.000000000 +0100
@@ -0,0 +1,138 @@
+#!/usr/local/bin/perl -w
+
+#################################################################
+# Emanuele Zeppieri, Mark Stosberg #
+# Shamelessly stolen from Data::FormValidator and CGI::Upload #
+#################################################################
+
+# Due to a bug in older versions of MakeMaker & Test::Harness, we must
+# ensure the blib's are in @INC, else we might use the core CGI.pm
+use lib qw(. ./blib/lib ./blib/arch);
+
+use strict;
+
+use Test::More 'no_plan';
+
+use CGI;
+
+#-----------------------------------------------------------------------------
+# %ENV setup.
+#-----------------------------------------------------------------------------
+
+%ENV = (
+ %ENV,
+ 'SCRIPT_NAME' => '/test.cgi',
+ 'SERVER_NAME' => 'perl.org',
+ 'HTTP_CONNECTION' => 'TE, close',
+ 'REQUEST_METHOD' => 'POST',
+ 'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
+ 'CONTENT_LENGTH' => 3285,
+ 'SCRIPT_FILENAME' => '/home/usr/test.cgi',
+ 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
+ 'HTTP_TE' => 'deflate,gzip;q=0.3',
+ 'QUERY_STRING' => '',
+ 'REMOTE_PORT' => '1855',
+ 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
+ 'SERVER_PORT' => '80',
+ 'REMOTE_ADDR' => '127.0.0.1',
+ 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
+ 'SERVER_PROTOCOL' => 'HTTP/1.1',
+ 'PATH' => '/usr/local/bin:/usr/bin:/bin',
+ 'REQUEST_URI' => '/test.cgi',
+ 'GATEWAY_INTERFACE' => 'CGI/1.1',
+ 'SCRIPT_URL' => '/test.cgi',
+ 'SERVER_ADDR' => '127.0.0.1',
+ 'DOCUMENT_ROOT' => '/home/develop',
+ 'HTTP_HOST' => 'www.perl.org'
+);
+
+#-----------------------------------------------------------------------------
+# Simulate the upload (really, multiple uploads contained in a single stream).
+#-----------------------------------------------------------------------------
+
+my $q;
+
+{
+ local *STDIN;
+ open STDIN, '<t/upload_post_text.txt'
+ or die 'missing test file t/upload_post_text.txt';
+ binmode STDIN;
+ $q = CGI->new;
+}
+
+#-----------------------------------------------------------------------------
+# Check that the file names retrieved by CGI are correct.
+#-----------------------------------------------------------------------------
+
+is( $q->param('does_not_exist_gif'), 'does_not_exist.gif', 'filename_2' );
+is( $q->param('100;100_gif') , '100;100.gif' , 'filename_3' );
+is( $q->param('300x300_gif') , '300x300.gif' , 'filename_4' );
+
+{
+ my $test = "multiple file names are handled right with same-named upload fields";
+ my @hello_names = $q->param('hello_world');
+ is ($hello_names[0],'goodbye_world.txt',$test. "...first file");
+ is ($hello_names[1],'hello_world.txt',$test. "...second file");
+}
+
+#-----------------------------------------------------------------------------
+# Now check that the upload method works.
+#-----------------------------------------------------------------------------
+
+ok( defined $q->upload('does_not_exist_gif'), 'upload_basic_2' );
+ok( defined $q->upload('100;100_gif') , 'upload_basic_3' );
+ok( defined $q->upload('300x300_gif') , 'upload_basic_4' );
+
+{
+ my $test = "file handles have expected length for multi-valued field. ";
+ my ($goodbye_fh,$hello_fh) = $q->upload('hello_world');
+
+ # Go to end of file;
+ seek($goodbye_fh,0,2);
+ # How long is the file?
+ is(tell($goodbye_fh), 15, "$test..first file");
+
+ # Go to end of file;
+ seek($hello_fh,0,2);
+ # How long is the file?
+ is(tell($hello_fh), 13, "$test..second file");
+
+}
+
+
+
+{
+ my $test = "300x300_gif has expected length";
+ my $fh1 = $q->upload('300x300_gif');
+ is(tell($fh1), 0, "First object: filehandle starts with position set at zero");
+
+ # Go to end of file;
+ seek($fh1,0,2);
+ # How long is the file?
+ is(tell($fh1), 1656, $test);
+}
+
+my $q2 = CGI->new;
+
+{
+ my $test = "Upload filehandles still work after calling CGI->new a second time";
+ $q->param('new','zoo');
+
+ is($q2->param('new'),undef,
+ "Reality Check: params set in one object instance don't appear in another instance");
+
+ my $fh2 = $q2->upload('300x300_gif');
+ is(tell($fh2), 0, "...so the state of a file handle shouldn't be carried to a new object instance, either.");
+ # Go to end of file;
+ seek($fh2,0,2);
+ # How long is the file?
+ is(tell($fh2), 1656, $test);
+}
+
+{
+ my $test = "multi-valued uploads are reset properly";
+ my ($dont_care, $hello_fh2) = $q2->upload('hello_world');
+ is(tell($hello_fh2), 0, $test);
+}
+
+# vim: nospell
diff -up perl-5.8.8/lib/CGI/t/util-58.t.crr perl-5.8.8/lib/CGI/t/util-58.t
diff -up perl-5.8.8/lib/CGI/t/util.t.crr perl-5.8.8/lib/CGI/t/util.t
--- perl-5.8.8/lib/CGI/t/util.t.crr 2003-06-02 19:37:04.000000000 +0200
+++ perl-5.8.8/lib/CGI/t/util.t 2006-12-01 16:35:20.000000000 +0100
@@ -5,7 +5,7 @@
######################### We start with some black magic to print on failure.
use lib '../blib/lib','../blib/arch';
-BEGIN {$| = 1; print "1..59\n"; }
+BEGIN {$| = 1; print "1..57\n"; }
END {print "not ok 1\n" unless $loaded;}
use Config;
use CGI::Util qw(escape unescape);
@@ -31,7 +31,7 @@ my %punct = (
':' => '3A', ';' => '3B', '<' => '3C', '=' => '3D',
'>' => '3E', '?' => '3F', '[' => '5B', '\\' => '5C',
']' => '5D', '^' => '5E', '`' => '60', # '_' => '5F',
- '{' => '7B', '|' => '7C', '}' => '7D', '~' => '7E',
+ '{' => '7B', '|' => '7C', '}' => '7D', # '~' => '7E',
);
# The sort order may not be ASCII on EBCDIC machines:
diff -up perl-5.8.8/lib/CGI/Util.pm.crr perl-5.8.8/lib/CGI/Util.pm
--- perl-5.8.8/lib/CGI/Util.pm.crr 2005-04-03 17:23:42.000000000 +0200
+++ perl-5.8.8/lib/CGI/Util.pm 2008-03-14 15:25:54.000000000 +0100
@@ -7,7 +7,7 @@ require Exporter;
@EXPORT_OK = qw(rearrange make_attributes unescape escape
expires ebcdic2ascii ascii2ebcdic);
-$VERSION = '1.5';
+$VERSION = '1.5_01';
$EBCDIC = "\t" ne "\011";
# (ord('^') == 95) for codepage 1047 as on os390, vmesa
@@ -141,8 +141,12 @@ sub simple_escape {
sub utf8_chr {
my $c = shift(@_);
- return chr($c) if $] >= 5.006;
-
+ if ($] >= 5.006){
+ require utf8;
+ my $u = chr($c);
+ utf8::encode($u); # drop utf8 flag
+ return $u;
+ }
if ($c < 0x80) {
return sprintf("%c", $c);
} elsif ($c < 0x800) {
@@ -189,6 +193,17 @@ sub unescape {
if ($EBCDIC) {
$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
} else {
+ # handle surrogate pairs first -- dankogai
+ $todecode =~ s{
+ %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
+ %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
+ }{
+ utf8_chr(
+ 0x10000
+ + (hex($1) - 0xD800) * 0x400
+ + (hex($2) - 0xDC00)
+ )
+ }gex;
$todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
}
@@ -200,12 +215,16 @@ sub escape {
shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
my $toencode = shift;
return undef unless defined($toencode);
+ $toencode = eval { pack("C*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode));
+
# force bytes while preserving backward compatibility -- dankogai
- $toencode = pack("C*", unpack("C*", $toencode));
+ # but commented out because it was breaking CGI::Compress -- lstein
+ # $toencode = eval { pack("U*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode));
+
if ($EBCDIC) {
- $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
+ $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
} else {
- $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+ $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
}
return $toencode;
}
@@ -258,13 +277,13 @@ sub expire_calc {
# specifying the date yourself
my($offset);
if (!$time || (lc($time) eq 'now')) {
- $offset = 0;
+ $offset = 0;
} elsif ($time=~/^\d+/) {
- return $time;
- } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
- $offset = ($mult{$2} || 1)*$1;
+ return $time;
+ } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
+ $offset = ($mult{$2} || 1)*$1;
} else {
- return $time;
+ return $time;
}
return (time+$offset);
}