X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=61118bdd8735649e9b06d9bfa2d7c4e936578e1c;hb=d9f203a5233af6609a4b98c6d12d865eadc274ea;hp=2ae635ead24a11eaf77344aae4a1da9180b138cc;hpb=47e3cabda9bbdb8cfcaa856cd58b1452b57cb369;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CGI.pm b/lib/CGI.pm index 2ae635e..61118bd 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -1,5 +1,6 @@ package CGI; -require 5.001; +require 5.004; +use Carp 'croak'; # See the bottom of this file for the POD documentation. Search for the # string '=head'. @@ -8,42 +9,130 @@ require 5.001; # documentation in manual or html file format (these utilities are part of the # Perl 5 distribution). -# Copyright 1995-1997 Lincoln D. Stein. All rights reserved. +# Copyright 1995-1998 Lincoln D. Stein. All rights reserved. # It may be used and modified freely, but I do request that this copyright # notice remain attached to the file. You may modify this module as you # 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/ +# http://stein.cshl.org/WWW/software/CGI/ -# Set this to 1 to enable copious autoloader debugging messages -$AUTOLOAD_DEBUG=0; +$CGI::revision = '$Id: CGI.pm,v 1.263 2009/02/11 16:56:37 lstein Exp $'; +$CGI::VERSION='3.43'; -# Set this to 1 to enable NPH scripts -# or: -# 1) use CGI qw(:nph) -# 2) $CGI::nph(1) -# 3) print header(-nph=>1) -$NPH=0; +# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. +# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. +# $CGITempFile::TMPDIRECTORY = '/usr/tmp'; +use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); -$CGI::revision = '$Id: CGI.pm,v 2.35 1997/4/20 20:19 lstein Exp $'; -$CGI::VERSION='2.35'; +#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN', +# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd']; -# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG -# $OS = 'UNIX'; -# $OS = 'MACINTOSH'; -# $OS = 'WINDOWS'; -# $OS = 'VMS'; -# $OS = 'OS2'; +use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', + 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd']; -# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. -# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. -# $TempFile::TMPDIRECTORY = '/usr/tmp'; +{ + local $^W = 0; + $TAINTED = substr("$0$^X",0,0); +} + +$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 + $AUTOLOAD_DEBUG = 0; + + # Set this to 1 to generate XTML-compatible output + $XHTML = 1; + + # Change this to the preferred DTD to print in start_html() + # or use default_dtd('text of DTD to use'); + $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN', + 'http://www.w3.org/TR/html4/loose.dtd' ] ; + + # Set this to 1 to enable NOSTICKY scripts + # or: + # 1) use CGI qw(-nosticky) + # 2) $CGI::nosticky(1) + $NOSTICKY = 0; + + # Set this to 1 to enable NPH scripts + # or: + # 1) use CGI qw(-nph) + # 2) CGI::nph(1) + # 3) print header(-nph=>1) + $NPH = 0; + + # Set this to 1 to enable debugging from @ARGV + # Set to 2 to enable debugging from STDIN + $DEBUG = 1; + + # Set this to 1 to make the temporary files created + # during file uploads safe from prying eyes + # or do... + # 1) use CGI qw(:private_tempfiles) + # 2) CGI::private_tempfiles(1); + $PRIVATE_TEMPFILES = 0; + + # Set this to 1 to generate automatic tab indexes + $TABINDEX = 0; + + # Set this to 1 to cause files uploaded in multipart documents + # to be closed, instead of caching the file handle + # or: + # 1) use CGI qw(:close_upload_files) + # 2) $CGI::close_upload_files(1); + # Uploads with many files run out of file handles. + # Also, for performance, since the file is already on disk, + # it can just be renamed, instead of read and written. + $CLOSE_UPLOAD_FILES = 0; + + # Automatically determined -- don't change + $EBCDIC = 0; + + # Change this to 1 to suppress redundant HTTP headers + $HEADERS_ONCE = 0; + + # separate the name=value pairs by semicolons rather than ampersands + $USE_PARAM_SEMICOLONS = 1; + + # Do not include undefined params parsed from query string + # 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; + $DTD_PUBLIC_IDENTIFIER = ""; + undef @QUERY_PARAM; + undef %EXPORT; + undef $QUERY_CHARSET; + undef %QUERY_FIELDNAMES; + undef %QUERY_TMPFILES; + + # prevent complaints by mod_perl + 1; +} # ------------------ START OF THE LIBRARY ------------ +*end_form = \&endform; + +# make mod_perlhappy +initialize_globals(); + # FIGURE OUT THE OS WE'RE RUNNING UNDER # Some systems support the $^O variable. If not # available then require() the Config library @@ -53,100 +142,162 @@ unless ($OS) { $OS = $Config::Config{'osname'}; } } -if ($OS=~/Win/i) { - $OS = 'WINDOWS'; -} elsif ($OS=~/vms/i) { - $OS = 'VMS'; -} elsif ($OS=~/Mac/i) { +if ($OS =~ /^MSWin/i) { + $OS = 'WINDOWS'; +} elsif ($OS =~ /^VMS/i) { + $OS = 'VMS'; +} elsif ($OS =~ /^dos/i) { + $OS = 'DOS'; +} elsif ($OS =~ /^MacOS/i) { $OS = 'MACINTOSH'; -} elsif ($OS=~/os2/i) { +} elsif ($OS =~ /^os2/i) { $OS = 'OS2'; +} elsif ($OS =~ /^epoc/i) { + $OS = 'EPOC'; +} elsif ($OS =~ /^cygwin/i) { + $OS = 'CYGWIN'; } else { $OS = 'UNIX'; } # Some OS logic. Binary mode enabled on DOS, NT and VMS -$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/; +$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/; # This is the default class for the CGI object to use when all else fails. $DefaultClass = 'CGI' unless defined $CGI::DefaultClass; + # This is where to look for autoloaded routines. $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; # The path separator is a slash, backslash or semicolon, depending # on the paltform. $SL = { - UNIX=>'/', - OS2=>'\\', - WINDOWS=>'\\', - MACINTOSH=>':', - VMS=>'\\' + UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', + WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/' }->{$OS}; +# This no longer seems to be necessary # Turn on NPH scripts by default when running under IIS server! -$NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; +# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; +$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; # Turn on special checking for Doug MacEachern's modperl -if (defined($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) { - $NPH++; - $| = 1; - $SEQNO = 1; +if (exists $ENV{MOD_PERL}) { + # mod_perl handlers may run system() on scripts using CGI.pm; + # Make sure so we don't get fooled by inherited $ENV{MOD_PERL} + if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $MOD_PERL = 2; + require Apache2::Response; + require Apache2::RequestRec; + require Apache2::RequestUtil; + require Apache2::RequestIO; + require APR::Pool; + } else { + $MOD_PERL = 1; + require Apache; + } } -# This is really "\r\n", but the meaning of \n is different -# in MacPerl, so we resort to octal here. -$CRLF = "\015\012"; +# Turn on special checking for ActiveState's PerlEx +$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + +# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning +# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF +# and sometimes CR). The most popular VMS web server +# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't +# use ASCII, so \015\012 means something different. I find this all +# really annoying. +$EBCDIC = "\t" ne "\011"; +if ($OS eq 'VMS') { + $CRLF = "\n"; +} elsif ($EBCDIC) { + $CRLF= "\r\n"; +} else { + $CRLF = "\015\012"; +} if ($needs_binmode) { - $CGI::DefaultClass->binmode(main::STDOUT); - $CGI::DefaultClass->binmode(main::STDIN); - $CGI::DefaultClass->binmode(main::STDERR); + $CGI::DefaultClass->binmode(\*main::STDOUT); + $CGI::DefaultClass->binmode(\*main::STDIN); + $CGI::DefaultClass->binmode(\*main::STDERR); } -# Cute feature, but it broke when the overload mechanism changed... -# %OVERLOAD = ('""'=>'as_string'); - %EXPORT_TAGS = ( - ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em - tt i b blockquote pre img a address cite samp dfn html head - base body link nextid title meta kbd start_html end_html - input Select option/], - ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/], - ':netscape'=>[qw/blink frameset frame script font fontsize center/], - ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group - submit reset defaults radio_group popup_menu button autoEscape - scrolling_list image_button start_form end_form startform endform - start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], - ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump - raw_cookie request_method query_string accept user_agent remote_host - remote_addr referer server_name server_software server_port server_protocol - virtual_host remote_ident auth_type http - remote_user user_name header redirect import_names put/], - ':ssl' => [qw/https/], - ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/], - ':html' => [qw/:html2 :html3 :netscape/], - ':standard' => [qw/:html2 :form :cgi/], - ':all' => [qw/:html2 :html3 :netscape :form :cgi/] - ); + ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em + tt u i b blockquote pre img a address cite samp dfn html head + base body Link nextid title meta kbd start_html end_html + input Select option comment charset escapeHTML/], + ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param nobr + embed basefont style span layer ilayer font frameset frame script small big Area Map/], + ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe + ins label legend noframes noscript object optgroup Q + thead tbody tfoot/], + ':netscape'=>[qw/blink fontsize center/], + ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group + submit reset defaults radio_group popup_menu button autoEscape + scrolling_list image_button start_form end_form startform endform + start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], + ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name + cookie Dump + raw_cookie request_method query_string Accept user_agent remote_host content_type + remote_addr referer server_name server_software server_port server_protocol virtual_port + virtual_host remote_ident auth_type http append + save_parameters restore_parameters param_fetch + remote_user user_name header redirect import_names put + Delete Delete_all url_param cgi_error/], + ':ssl' => [qw/https/], + ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], + ':html' => [qw/:html2 :html3 :html4 :netscape/], + ':standard' => [qw/:html2 :html3 :html4 :form :cgi/], + ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/], + ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/] + ); + +# Custom 'can' method for both autoloaded and non-autoloaded subroutines. +# Author: Cees Hek + +sub can { + my($class, $method) = @_; + + # See if UNIVERSAL::can finds it. + + if (my $func = $class -> SUPER::can($method) ){ + return $func; + } + + # Try to compile the function. + + eval { + # _compile looks at $AUTOLOAD for the function name. + + local $AUTOLOAD = join "::", $class, $method; + &_compile; + }; + + # Now that the function is loaded (if it exists) + # just use UNIVERSAL::can again to do the work. + + return $class -> SUPER::can($method); +} # to import symbols into caller sub import { my $self = shift; + + # This causes modules to clash. + undef %EXPORT_OK; + undef %EXPORT; + + $self->_setup_symbols(@_); my ($callpack, $callfile, $callline) = caller; - foreach (@_) { - $NPH++, next if $_ eq ':nph'; - foreach (&expand_tags($_)) { - tr/a-zA-Z0-9_//cd; # don't allow weird function names - $EXPORT{$_}++; - } - } + # To allow overriding, search through the packages # Till we find one in which the correct subroutine is defined. my @packages = ($self,@{"$self\:\:ISA"}); - foreach $sym (keys %EXPORT) { + for $sym (keys %EXPORT) { my $pck; my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass; - foreach $pck (@packages) { + for $pck (@packages) { if (defined(&{"$pck\:\:$sym"})) { $def = $pck; last; @@ -156,11 +307,17 @@ sub import { } } +sub compile { + my $pack = shift; + $pack->_setup_symbols('-compile',@_); +} + sub expand_tags { my($tag) = @_; + return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; my(@r); return ($tag) unless $EXPORT_TAGS{$tag}; - foreach (@{$EXPORT_TAGS{$tag}}) { + for (@{$EXPORT_TAGS{$tag}}) { push(@r,&expand_tags($_)); } return @r; @@ -171,18 +328,85 @@ sub expand_tags { # for an existing query string, and initialize itself, if so. #### sub new { - my($class,$initializer) = @_; - my $self = {}; - bless $self,ref $class || $class || $DefaultClass; - $CGI::DefaultClass->_reset_globals() if $MOD_PERL; - $initializer = to_filehandle($initializer) if $initializer; - $self->init($initializer); - return $self; + my($class,@initializer) = @_; + 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') + || + UNIVERSAL::isa($initializer[0],'Apache2::RequestRec') + )) { + $self->r(shift @initializer); + } + 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 + # will do a real PerlOptions -SetupEnv check + $self->r(Apache2::RequestUtil->request) unless $self->r; + 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; + } + $self->_reset_globals if $PERLEX; + $self->init(@initializer); + return $self; +} + +# We provide a DESTROY method so that we can ensure that +# temporary files are closed (via Fh->DESTROY) before they +# are unlinked (via CGITempFile->DESTROY) because it is not +# possible to unlink an open file on Win32. We explicitly +# call DESTROY on each, rather than just undefing them and +# letting Perl DESTROY them by garbage collection, in case the +# user is still holding any reference to them as well. +sub DESTROY { + my $self = shift; + if ($OS eq 'WINDOWS') { + for my $href (values %{$self->{'.tmpfiles'}}) { + $href->{hndl}->DESTROY if defined $href->{hndl}; + $href->{name}->DESTROY if defined $href->{name}; + } + } +} + +sub r { + my $self = shift; + my $r = $self->{'.r'}; + $self->{'.r'} = shift if @_; + $r; } -# We provide a DESTROY method so that the autoloader -# doesn't bother trying to find it. -sub DESTROY { } +sub upload_hook { + my $self; + if (ref $_[0] eq 'CODE') { + $CGI::Q = $self = $CGI::DefaultClass->new(@_); + } else { + $self = shift; + } + my ($hook,$data,$use_tempfile) = @_; + $self->{'.upload_hook'} = $hook; + $self->{'.upload_data'} = $data; + $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile; +} #### Method: param # Returns the value(s)of a named parameter. @@ -203,117 +427,59 @@ sub param { # For compatibility between old calling style and use_named_parameters() style, # we have to special case for a single parameter present. if (@p > 1) { - ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); + ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); my(@values); - if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) { + if (substr($p[0],0,1) eq '-') { @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); } else { - foreach ($value,@other) { + for ($value,@other) { push(@values,$_) if defined($_); } } # If values is provided, then we set it. - if (@values) { + if (@values or defined $value) { $self->add_parameter($name); - $self->{$name}=[@values]; + $self->{param}{$name}=[@values]; } } else { $name = $p[0]; } - return () unless defined($name) && $self->{$name}; - return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; -} + return unless defined($name) && $self->{param}{$name}; -#### Method: delete -# Deletes the named parameter entirely. -#### -sub delete { - my($self,$name) = self_or_default(@_); - delete $self->{$name}; - delete $self->{'.fieldnames'}->{$name}; - @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); - return wantarray ? () : undef; + my @result = @{$self->{param}{$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 { - return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI'); + return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); unless (defined($_[0]) && - ref($_[0]) && - (ref($_[0]) eq 'CGI' || - eval "\$_[0]->isaCGI()")) { # optimize for the common case - $CGI::DefaultClass->_reset_globals() - if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request(); + (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case + ) { $Q = $CGI::DefaultClass->new unless defined($Q); unshift(@_,$Q); } - return @_; -} - -sub _new_request { - return undef unless (defined(Apache->seqno()) or eval { require Apache }); - if (Apache->seqno() != $SEQNO) { - $SEQNO = Apache->seqno(); - return 1; - } else { - return undef; - } -} - -sub _reset_globals { - undef $Q; - undef @QUERY_PARAM; + return wantarray ? @_ : $Q; } sub self_or_CGI { local $^W=0; # prevent a warning if (defined($_[0]) && (substr(ref($_[0]),0,3) eq 'CGI' - || eval "\$_[0]->isaCGI()")) { + || UNIVERSAL::isa($_[0],'CGI'))) { return @_; } else { return ($DefaultClass,@_); } } -sub isaCGI { - return 1; -} - -#### Method: import_names -# Import all parameters into the given namespace. -# Assumes namespace 'Q' if not specified -#### -sub import_names { - my($self,$namespace) = self_or_default(@_); - $namespace = 'Q' unless defined($namespace); - die "Can't import names into 'main'\n" - if $namespace eq 'main'; - my($param,@value,$var); - foreach $param ($self->param) { - # protect against silly names - ($var = $param)=~tr/a-zA-Z0-9_/_/c; - $var = "${namespace}::$var"; - @value = $self->param($param); - @{$var} = @value; - ${$var} = $value[0]; - } -} - -#### Method: use_named_parameters -# Force CGI.pm to use named parameter-style method calls -# rather than positional parameters. The same effect -# will happen automatically if the first parameter -# begins with a -. -sub use_named_parameters { - my($self,$use_named) = self_or_default(@_); - return $self->{'.named'} unless defined ($use_named); - - # stupidity to avoid annoying warnings - return $self->{'.named'}=$use_named; -} - ######################################## # THESE METHODS ARE MORE OR LESS PRIVATE # GO TO THE __DATA__ SECTION TO SEE MORE @@ -322,156 +488,243 @@ sub use_named_parameters { # Initialize the query object from the environment. # If a parameter list is found, this object will be set -# to an associative array in which parameter names are keys +# to a hash in which parameter names are keys # and the values are stored as lists # If a keyword list is found, this method creates a bogus # parameter list with the single parameter 'keywords'. sub init { - my($self,$initializer) = @_; - my($query_string,@lines); - my($meth) = ''; + my $self = shift; + my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); + + my $is_xforms; + + my $initializer = shift; # for backward compatibility + local($/) = "\n"; + + # set autoescaping on by default + $self->{'escape'} = 1; # if we get called more than once, we want to initialize # 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{$_}); - } - 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'}); + $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; + + $fh = to_filehandle($initializer) if $initializer; + + # set charset to the safe ISO-8859-1 + $self->charset('ISO-8859-1'); - # If initializer is defined, then read parameters - # from it. METHOD: { - if (defined($initializer)) { - if (ref($initializer) && ref($initializer) eq 'HASH') { - foreach (keys %$initializer) { - $self->param('-name'=>$_,'-value'=>$initializer->{$_}); - } + # avoid unreasonably large postings + if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { + #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. + if ($meth eq 'POST' + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| + && !defined($initializer) + ) { + my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; + $self->read_multipart($boundary,$content_length); + 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}{$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}{$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 (!$is_xforms && defined($initializer)) { + if (UNIVERSAL::isa($initializer,'CGI')) { + $query_string = $initializer->query_string; last METHOD; } - - $initializer = $$initializer if ref($initializer); - if (defined(fileno($initializer))) { - while (<$initializer>) { - chomp; - last if /^=/; - push(@lines,$_); - } - # massage back into standard format - if ("@lines" =~ /=/) { - $query_string=join("&",@lines); - } else { - $query_string=join("+",@lines); + if (ref($initializer) && ref($initializer) eq 'HASH') { + for (keys %$initializer) { + $self->param('-name'=>$_,'-value'=>$initializer->{$_}); } 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; + } + + # last chance -- treat it as a string + $initializer = $$initializer if ref($initializer) eq 'SCALAR'; $query_string = $initializer; + last METHOD; } - # If method is GET or HEAD, fetch the query from - # the environment. - if ($meth=~/^(GET|HEAD)$/) { - $query_string = $ENV{'QUERY_STRING'}; - last METHOD; - } - - # If the method is POST, fetch the query from standard - # input. - if ($meth eq 'POST') { - - if (defined($ENV{'CONTENT_TYPE'}) - && - $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) { - my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/; - $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'}); + # If method is GET or HEAD, fetch the query from + # the environment. + if ($is_xforms || $meth=~/^(GET|HEAD)$/) { + if ($MOD_PERL) { + $query_string = $self->r->args; } else { - - $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0) - if $ENV{'CONTENT_LENGTH'} > 0; - + $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; + $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'}; } + last METHOD; + } + + 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! # Uncomment this line to have the contents of the query string # APPENDED to the POST data. - # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'}; + # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; last METHOD; } - - # If neither is set, assume we're being debugged offline. + + # If $meth is not of GET, POST or HEAD, assume we're being debugged offline. # Check the command line and then the standard input for data. # We use the shellwords package in order to behave the way that # UN*X programmers expect. - $query_string = &read_from_cmdline; + if ($DEBUG) + { + my $cmdline_ret = read_from_cmdline(); + $query_string = $cmdline_ret->{'query_string'}; + if (defined($cmdline_ret->{'subpath'})) + { + $self->path_info($cmdline_ret->{'subpath'}); + } + } } - + +# YL: Begin Change for XML handler 10/19/2001 + 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) = $meth . 'DATA' ; + $self->add_parameter($param) ; + push (@{$self->{param}{$param}},$query_string); + undef $query_string ; + } +# YL: End Change for XML handler 10/19/2001 + # We now have the query string in hand. We do slightly # different things for keyword lists and parameter lists. - if ($query_string) { - if ($query_string =~ /=/) { + if (defined $query_string && length $query_string) { + if ($query_string =~ /[&=;]/) { $self->parse_params($query_string); } else { $self->add_parameter('keywords'); - $self->{'keywords'} = [$self->parse_keywordlist($query_string)]; + $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)]; } } # Special case. Erase everything if there is a field named # .defaults. if ($self->param('.defaults')) { - undef %{$self}; + $self->delete_all(); } - # Associative array containing our defined fieldnames + # hash containing our defined fieldnames $self->{'.fieldnames'} = {}; - foreach ($self->param('.cgifields')) { + for ($self->param('.cgifields')) { $self->{'.fieldnames'}->{$_}++; } # Clear out our default submission button flag if present $self->delete('.submit'); $self->delete('.cgifields'); - $self->save_request unless $initializer; + $self->save_request unless defined $initializer; } - # FUNCTIONS TO OVERRIDE: - # Turn a string into a filehandle sub to_filehandle { - my $string = shift; - if ($string && !ref($string)) { - my($package) = caller(1); - my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string"; - return $tmp if defined(fileno($tmp)); + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } } - return $string; -} - -# Create a new multipart buffer -sub new_MultipartBuffer { - my($self,$boundary,$length,$filehandle) = @_; - return MultipartBuffer->new($self,$boundary,$length,$filehandle); -} - -# Read data from a file handle -sub read_from_client { - my($self, $fh, $buff, $len, $offset) = @_; - local $^W=0; # prevent a warning - return read($fh, $$buff, $len, $offset); -} - -# put a filehandle into binary mode (DOS) -sub binmode { - binmode($_[1]); + return undef; } # send output to the browser @@ -486,19 +739,11 @@ sub print { CORE::print(@_); } -# unescape URL-encoded data -sub unescape { - my($todecode) = @_; - $todecode =~ tr/+/ /; # pluses become spaces - $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; - return $todecode; -} - -# URL-encode data -sub escape { - my($toencode) = @_; - $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg; - return $toencode; +# get/set last cgi_error +sub cgi_error { + my ($self,$err) = self_or_default(@_); + $self->{'.cgi_error'} = $err if defined $err; + return $self->{'.cgi_error'}; } sub save_request { @@ -507,36 +752,36 @@ sub save_request { # again, we initialize ourselves in exactly the same way. This allows # us to have several of these objects. @QUERY_PARAM = $self->param; # save list of parameters - foreach (@QUERY_PARAM) { - $QUERY_PARAM{$_}=$self->{$_}; + for (@QUERY_PARAM) { + next unless defined $_; + $QUERY_PARAM{$_}=$self->{param}{$_}; } -} - -sub parse_keywordlist { - my($self,$tosplit) = @_; - $tosplit = &unescape($tosplit); # unescape the keywords - $tosplit=~tr/+/ /; # pluses to spaces - my(@keywords) = split(/\s+/,$tosplit); - return @keywords; + $QUERY_CHARSET = $self->charset; + %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; + %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} }; } sub parse_params { my($self,$tosplit) = @_; - my(@pairs) = split('&',$tosplit); + my(@pairs) = split(/[&;]/,$tosplit); my($param,$value); - foreach (@pairs) { - ($param,$value) = split('='); - $param = &unescape($param); - $value = &unescape($value); + for (@pairs) { + ($param,$value) = split('=',$_,2); + next unless defined $param; + next if $NO_UNDEF_PARAMS and not defined $value; + $value = '' unless defined $value; + $param = unescape($param); + $value = unescape($value); $self->add_parameter($param); - push (@{$self->{$param}},$value); + push (@{$self->{param}{$param}},$value); } } sub add_parameter { my($self,$param)=@_; + return unless defined $param; push (@{$self->{'.parameters'}},$param) - unless defined($self->{$param}); + unless defined($self->{param}{$param}); } sub all_parameters { @@ -546,88 +791,171 @@ sub all_parameters { return @{$self->{'.parameters'}}; } -#### Method as_string -# -# synonym for "dump" -#### -sub as_string { - &dump(@_); +# put a filehandle into binary mode (DOS) +sub binmode { + return unless defined($_[1]) && defined fileno($_[1]); + CORE::binmode($_[1]); +} + +sub _make_tag_func { + my ($self,$tagname) = @_; + my $func = qq( + sub $tagname { + my (\$q,\$a,\@rest) = self_or_default(\@_); + my(\$attr) = ''; + if (ref(\$a) && ref(\$a) eq 'HASH') { + my(\@attr) = make_attributes(\$a,\$q->{'escape'}); + \$attr = " \@attr" if \@attr; + } else { + unshift \@rest,\$a if defined \$a; + } + ); + if ($tagname=~/start_(\w+)/i) { + $func .= qq! return "<\L$1\E\$attr>";} !; + } elsif ($tagname=~/end_(\w+)/i) { + $func .= qq! return "<\L/$1\E>"; } !; + } else { + $func .= qq# + return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest; + my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L\E"); + my \@result = map { "\$tag\$_\$untag" } + (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest"; + return "\@result"; + }#; + } +return $func; } sub AUTOLOAD { print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG; + my $func = &_compile; + goto &$func; +} + +sub _compile { my($func) = $AUTOLOAD; - my($pack,$func_name) = $func=~/(.+)::([^:]+)$/; - $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass - unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); - - my($sub) = \%{"$pack\:\:SUBS"}; - unless (%$sub) { - my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; - eval "package $pack; $$auto"; - die $@ if $@; - } - my($code) = $sub->{$func_name}; - - $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); - if (!$code) { - if ($EXPORT{':any'} || - $EXPORT{$func_name} || - (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) - && $EXPORT_OK{$func_name}) { - $code = $sub->{'HTML_FUNC'}; - $code=~s/func_name/$func_name/mg; - } - } - die "Undefined subroutine $AUTOLOAD\n" unless $code; - eval "package $pack; $code"; - if ($@) { - $@ =~ s/ at .*\n//; - die $@; - } - goto &{"$pack\:\:$func_name"}; + my($pack,$func_name); + { + local($1,$2); # this fixes an obscure variable suicide problem. + $func=~/(.+)::([^:]+)$/; + ($pack,$func_name) = ($1,$2); + $pack=~s/::SUPER$//; # fix another obscure problem + $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass + unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); + + my($sub) = \%{"$pack\:\:SUBS"}; + unless (%$sub) { + my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; + local ($@,$!); + eval "package $pack; $$auto"; + croak("$AUTOLOAD: $@") if $@; + $$auto = ''; # Free the unneeded storage (but don't undef it!!!) + } + my($code) = $sub->{$func_name}; + + $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); + if (!$code) { + (my $base = $func_name) =~ s/^(start_|end_)//i; + if ($EXPORT{':any'} || + $EXPORT{'-any'} || + $EXPORT{$base} || + (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) + && $EXPORT_OK{$base}) { + $code = $CGI::DefaultClass->_make_tag_func($func_name); + } + } + croak("Undefined subroutine $AUTOLOAD\n") unless $code; + local ($@,$!); + eval "package $pack; $code"; + if ($@) { + $@ =~ s/ at .*\n//; + croak("$AUTOLOAD: $@"); + } + } + CORE::delete($sub->{$func_name}); #free storage + return "$pack\:\:$func_name"; } -# PRIVATE SUBROUTINE -# Smart rearrangement of parameters to allow named parameter -# calling. We do the rearangement if: -# 1. The first parameter begins with a - -# 2. The use_named_parameters() method returns true -sub rearrange { - my($self,$order,@param) = @_; - return () unless @param; - - return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-') - || $self->use_named_parameters; +sub _selected { + my $self = shift; + my $value = shift; + return '' unless $value; + return $XHTML ? qq(selected="selected" ) : qq(selected ); +} - my $i; - for ($i=0;$i<@param;$i+=2) { - $param[$i]=~s/^\-//; # get rid of initial - if present - $param[$i]=~tr/a-z/A-Z/; # parameters are upper case - } - - my(%param) = @param; # convert into associative array - my(@return_array); - - my($key)=''; - foreach $key (@$order) { - my($value); - # this is an awful hack to fix spurious warnings when the - # -w switch is set. - if (ref($key) && ref($key) eq 'ARRAY') { - foreach (@$key) { - last if defined($value); - $value = $param{$_}; - delete $param{$_}; - } - } else { - $value = $param{$key}; - delete $param{$key}; +sub _checked { + my $self = shift; + my $value = shift; + return '' unless $value; + return $XHTML ? qq(checked="checked" ) : qq(checked ); +} + +sub _reset_globals { initialize_globals(); } + +sub _setup_symbols { + my $self = shift; + my $compile = 0; + + # to avoid reexporting unwanted variables + undef %EXPORT; + + for (@_) { + $HEADERS_ONCE++, next if /^[:-]unique_headers$/; + $NPH++, next if /^[:-]nph$/; + $NOSTICKY++, next if /^[:-]nosticky$/; + $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$/; + $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; + $TABINDEX++, next if /^[:-]tabindex$/; + $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; + $EXPORT{$_}++, next if /^[:-]any$/; + $compile++, next if /^[:-]compile$/; + $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/; + + # This is probably extremely evil code -- to be deleted some day. + if (/^[-]autoload$/) { + my($pkg) = caller(1); + *{"${pkg}::AUTOLOAD"} = sub { + my($routine) = $AUTOLOAD; + $routine =~ s/^.*::/CGI::/; + &$routine; + }; + next; + } + + for (&expand_tags($_)) { + tr/a-zA-Z0-9_//cd; # don't allow weird function names + $EXPORT{$_}++; } - push(@return_array,$value); } - push (@return_array,$self->make_attributes(\%param)) if %param; - return (@return_array); + _compile_all(keys %EXPORT) if $compile; + @SAVED_SYMBOLS = @_; +} + +sub charset { + my ($self,$charset) = self_or_default(@_); + $self->{'.charset'} = $charset if defined $charset; + $self->{'.charset'}; +} + +sub element_id { + my ($self,$new_value) = self_or_default(@_); + $self->{'.elid'} = $new_value if defined $new_value; + sprintf('%010d',$self->{'.elid'}++); +} + +sub element_tab { + my ($self,$new_value) = self_or_default(@_); + $self->{'.etab'} ||= 1; + $self->{'.etab'} = $new_value if defined $new_value; + my $tab = $self->{'.etab'}++; + return '' unless $TABINDEX or defined $new_value; + return qq(tabindex="$tab" ); } ############################################################################### @@ -646,32 +974,76 @@ END_OF_FUNC sub MULTIPART { 'multipart/form-data'; } END_OF_FUNC -'HTML_FUNC' => <<'END_OF_FUNC', -sub func_name { +'SERVER_PUSH' => <<'END_OF_FUNC', +sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; } +END_OF_FUNC + +'new_MultipartBuffer' => <<'END_OF_FUNC', +# Create a new multipart buffer +sub new_MultipartBuffer { + my($self,$boundary,$length) = @_; + return MultipartBuffer->new($self,$boundary,$length); +} +END_OF_FUNC - # handle various cases in which we're called - # most of this bizarre stuff is to avoid -w errors - shift if $_[0] && - (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) || - (ref($_[0]) && - (substr(ref($_[0]),0,3) eq 'CGI' || - eval "\$_[0]->isaCGI()")); +'read_from_client' => <<'END_OF_FUNC', +# Read data from a file handle +sub read_from_client { + my($self, $buff, $len, $offset) = @_; + local $^W=0; # prevent a warning + return $MOD_PERL + ? $self->r->read($$buff, $len, $offset) + : read(\*STDIN, $$buff, $len, $offset); +} +END_OF_FUNC - my($attr) = ''; - if (ref($_[0]) && ref($_[0]) eq 'HASH') { - my(@attr) = CGI::make_attributes('',shift); - $attr = " @attr" if @attr; +'delete' => <<'END_OF_FUNC', +#### Method: delete +# Deletes the named parameter entirely. +#### +sub delete { + my($self,@p) = self_or_default(@_); + my(@names) = rearrange([NAME],@p); + my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names; + my %to_delete; + for my $name (@to_delete) + { + CORE::delete $self->{param}{$name}; + CORE::delete $self->{'.fieldnames'}->{$name}; + $to_delete{$name}++; } - my($tag,$untag) = ("\U","\U\E"); - return $tag unless @_; - if (ref($_[0]) eq 'ARRAY') { - my(@r); - foreach (@{$_[0]}) { - push(@r,"$tag$_$untag"); + @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); + return; +} +END_OF_FUNC + +#### Method: import_names +# Import all parameters into the given namespace. +# Assumes namespace 'Q' if not specified +#### +'import_names' => <<'END_OF_FUNC', +sub import_names { + my($self,$namespace,$delete) = self_or_default(@_); + $namespace = 'Q' unless defined($namespace); + die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; + if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { + # can anyone find an easier way to do this? + for (keys %{"${namespace}::"}) { + local *symbol = "${namespace}::${_}"; + undef $symbol; + undef @symbol; + undef %symbol; } - return "@r"; - } else { - return "$tag@_$untag"; + } + my($param,@value,$var); + for $param ($self->param) { + # protect against silly names + ($var = $param)=~tr/a-zA-Z0-9_/_/c; + $var =~ s/^(?=\d)/_/; + local *symbol = "${namespace}::$var"; + @value = $self->param($param); + @symbol = @value; + $symbol = $value[0]; } } END_OF_FUNC @@ -685,14 +1057,26 @@ END_OF_FUNC sub keywords { my($self,@values) = self_or_default(@_); # If values is provided, then we set it. - $self->{'keywords'}=[@values] if @values; - my(@result) = @{$self->{'keywords'}}; + $self->{param}{'keywords'}=[@values] if @values; + my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : (); @result; } END_OF_FUNC # These are some tie() interfaces for compatibility # with Steve Brenner's cgi-lib.pl routines +'Vars' => <<'END_OF_FUNC', +sub Vars { + my $q = shift; + my %in; + tie(%in,CGI,$q); + return %in if wantarray; + return \%in; +} +END_OF_FUNC + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines 'ReadParse' => <<'END_OF_FUNC', sub ReadParse { local(*in); @@ -703,6 +1087,7 @@ sub ReadParse { *in=*{"${pkg}::in"}; } tie(%in,CGI); + return scalar(keys %in); } END_OF_FUNC @@ -748,14 +1133,23 @@ sub MethPost { END_OF_FUNC 'TIEHASH' => <<'END_OF_FUNC', -sub TIEHASH { - return new CGI; +sub TIEHASH { + my $class = shift; + my $arg = $_[0]; + if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) { + return $arg; + } + return $Q ||= $class->new(@_); } END_OF_FUNC 'STORE' => <<'END_OF_FUNC', sub STORE { - $_[0]->param($_[1],split("\0",$_[2])); + my $self = shift; + my $tag = shift; + my $vals = shift; + my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; + $self->param(-name=>$tag,-value=>\@vals); } END_OF_FUNC @@ -782,7 +1176,7 @@ END_OF_FUNC 'EXISTS' => <<'END_OF_FUNC', sub EXISTS { - exists $_[0]->{$_[1]}; + exists $_[0]->{param}{$_[1]}; } END_OF_FUNC @@ -804,12 +1198,12 @@ END_OF_FUNC #### 'append' => <<'EOF', sub append { - my($self,@p) = @_; - my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p); + my($self,@p) = self_or_default(@_); + my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); if (@values) { $self->add_parameter($name); - push(@{$self->{$name}},@values); + push(@{$self->{param}{$name}},@values); } return $self->param($name); } @@ -821,17 +1215,34 @@ EOF 'delete_all' => <<'EOF', sub delete_all { my($self) = self_or_default(@_); - undef %{$self}; + my @param = $self->param(); + $self->delete(@param); } EOF -#### Method: autoescape -# If you want to turn off the autoescaping features, -# call this method with undef as the argument -'autoEscape' => <<'END_OF_FUNC', -sub autoEscape { - my($self,$escape) = self_or_default(@_); - $self->{'dontescape'}=!$escape; +'Delete' => <<'EOF', +sub Delete { + my($self,@p) = self_or_default(@_); + $self->delete(@p); +} +EOF + +'Delete_all' => <<'EOF', +sub Delete_all { + my($self,@p) = self_or_default(@_); + $self->delete_all(@p); +} +EOF + +#### Method: autoescape +# If you want to turn off the autoescaping features, +# call this method with undef as the argument +'autoEscape' => <<'END_OF_FUNC', +sub autoEscape { + my($self,$escape) = self_or_default(@_); + my $d = $self->{'escape'}; + $self->{'escape'} = $escape; + $d; } END_OF_FUNC @@ -845,47 +1256,73 @@ sub version { } END_OF_FUNC -'make_attributes' => <<'END_OF_FUNC', -sub make_attributes { - my($self,$attr) = @_; - return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; - my(@att); - foreach (keys %{$attr}) { - my($key) = $_; - $key=~s/^\-//; # get rid of initial - if present - $key=~tr/a-z/A-Z/; # parameters are upper case - push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/); +#### Method: url_param +# Return a parameter in the QUERY_STRING, regardless of +# whether this was a POST or a GET +#### +'url_param' => <<'END_OF_FUNC', +sub url_param { + my ($self,@p) = self_or_default(@_); + my $name = shift(@p); + return undef unless exists($ENV{QUERY_STRING}); + unless (exists($self->{'.url_param'})) { + $self->{'.url_param'}={}; # empty hash + if ($ENV{QUERY_STRING} =~ /=/) { + my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); + my($param,$value); + for (@pairs) { + ($param,$value) = split('=',$_,2); + $param = unescape($param); + $value = unescape($value); + push(@{$self->{'.url_param'}->{$param}},$value); + } + } else { + $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})]; + } } - return @att; + return keys %{$self->{'.url_param'}} unless defined($name); + return () unless $self->{'.url_param'}->{$name}; + return wantarray ? @{$self->{'.url_param'}->{$name}} + : $self->{'.url_param'}->{$name}->[0]; } END_OF_FUNC -#### Method: dump +#### Method: Dump # Returns a string in which all the known parameter/value # pairs are represented as nested lists, mainly for the purposes # of debugging. #### -'dump' => <<'END_OF_FUNC', -sub dump { +'Dump' => <<'END_OF_FUNC', +sub Dump { my($self) = self_or_default(@_); my($param,$value,@result); - return '' unless $self->param; - push(@result,""); return join("\n",@result); } END_OF_FUNC +#### Method as_string +# +# synonym for "dump" +#### +'as_string' => <<'END_OF_FUNC', +sub as_string { + &Dump(@_); +} +END_OF_FUNC #### Method: save # Write values out to a filehandle in such a way that they can @@ -894,23 +1331,125 @@ END_OF_FUNC 'save' => <<'END_OF_FUNC', sub save { my($self,$filehandle) = self_or_default(@_); - my($param); - my($package) = caller; -# Check that this still works! -# $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; $filehandle = to_filehandle($filehandle); - foreach $param ($self->param) { - my($escaped_param) = &escape($param); + my($param); + local($,) = ''; # set print field separator back to a sane value + local($\) = ''; # set output line separator to a sane value + for $param ($self->param) { + my($escaped_param) = escape($param); my($value); - foreach $value ($self->param($param)) { - print $filehandle "$escaped_param=",escape($value),"\n"; + for $value ($self->param($param)) { + print $filehandle "$escaped_param=",escape("$value"),"\n"; } } + for (keys %{$self->{'.fieldnames'}}) { + print $filehandle ".cgifields=",escape("$_"),"\n"; + } print $filehandle "=\n"; # end of record } END_OF_FUNC +#### Method: save_parameters +# An alias for save() that is a better name for exportation. +# Only intended to be used with the function (non-OO) interface. +#### +'save_parameters' => <<'END_OF_FUNC', +sub save_parameters { + my $fh = shift; + return save(to_filehandle($fh)); +} +END_OF_FUNC + +#### Method: restore_parameters +# A way to restore CGI parameters from an initializer. +# Only intended to be used with the function (non-OO) interface. +#### +'restore_parameters' => <<'END_OF_FUNC', +sub restore_parameters { + $Q = $CGI::DefaultClass->new(@_); +} +END_OF_FUNC + +#### Method: multipart_init +# Return a Content-Type: style header for server-push +# This has to be NPH on most web servers, and it is advisable to set $| = 1 +# +# Many thanks to Ed Jordan for this +# contribution, updated by Andrew Benham (adsb@bigfoot.com) +#### +'multipart_init' => <<'END_OF_FUNC', +sub multipart_init { + my($self,@p) = self_or_default(@_); + my($boundary,@other) = rearrange_header([BOUNDARY],@p); + $boundary = $boundary || '------- =_aaaaaaaaaa0'; + $self->{'separator'} = "$CRLF--$boundary$CRLF"; + $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; + $type = SERVER_PUSH($boundary); + return $self->header( + -nph => 0, + -type => $type, + (map { split "=", $_, 2 } @other), + ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; +} +END_OF_FUNC + + +#### Method: multipart_start +# Return a Content-Type: style header for server-push, start of section +# +# Many thanks to Ed Jordan for this +# contribution, updated by Andrew Benham (adsb@bigfoot.com) +#### +'multipart_start' => <<'END_OF_FUNC', +sub multipart_start { + my(@header); + my($self,@p) = self_or_default(@_); + my($type,@other) = rearrange([TYPE],@p); + $type = $type || 'text/html'; + push(@header,"Content-Type: $type"); + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + for (@other) { + # Don't use \s because of perl bug 21951 + next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; + ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e; + } + push(@header,@other); + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + return $header; +} +END_OF_FUNC + + +#### Method: multipart_end +# Return a MIME boundary separator for server-push, end of section +# +# Many thanks to Ed Jordan for this +# contribution +#### +'multipart_end' => <<'END_OF_FUNC', +sub multipart_end { + my($self,@p) = self_or_default(@_); + return $self->{'separator'}; +} +END_OF_FUNC + + +#### Method: multipart_final +# Return a MIME boundary separator for server-push, end of all sections +# +# Contributed by Andrew Benham (adsb@bigfoot.com) +#### +'multipart_final' => <<'END_OF_FUNC', +sub multipart_final { + my($self,@p) = self_or_default(@_); + return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF; +} +END_OF_FUNC + + #### Method: header # Return a Content-Type: style header # @@ -920,41 +1459,74 @@ sub header { my($self,@p) = self_or_default(@_); my(@header); - my($type,$status,$cookie,$target,$expires,$nph,@other) = - $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; + + my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = + rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], + 'STATUS',['COOKIE','COOKIES'],'TARGET', + 'EXPIRES','NPH','CHARSET', + 'ATTACHMENT','P3P'],@p); + + $nph ||= $NPH; + + $type ||= 'text/html' unless defined($type); + + if (defined $charset) { + $self->charset($charset); + } else { + $charset = $self->charset if $type =~ /^text\//; + } + $charset ||= ''; # rearrange() was designed for the HTML portion, so we # need to fix it up a little. - foreach (@other) { - next unless my($header,$value) = /([^\s=]+)=(.+)/; - substr($header,1,1000)=~tr/A-Z/a-z/; - ($value)=$value=~/^"(.*)"$/; - $_ = "$header: $value"; + for (@other) { + # Don't use \s because of perl bug 21951 + next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; + ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; } - $type = $type || 'text/html'; + $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'; + push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; + push(@header,"Server: " . &server_software()) if $nph; - push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH; push(@header,"Status: $status") if $status; - push(@header,"Window-target: $target") if $target; + push(@header,"Window-Target: $target") if $target; + if ($p3p) { + $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY'; + push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p")); + } # push all the cookies -- there may be several if ($cookie) { - my(@cookie) = ref($cookie) ? @{$cookie} : $cookie; - foreach (@cookie) { - push(@header,"Set-cookie: $_"); + my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie; + for (@cookie) { + my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; + push(@header,"Set-Cookie: $cs") if $cs ne ''; } } # if the user indicates an expiration time, then we need # both an Expires and a Date header (so that the browser is # uses OUR clock) - push(@header,"Expires: " . &expires($expires)) if $expires; - push(@header,"Date: " . &expires(0)) if $expires; + push(@header,"Expires: " . expires($expires,'http')) + if $expires; + push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; push(@header,"Pragma: no-cache") if $self->cache(); - push(@header,@other); - push(@header,"Content-type: $type"); - - my $header = join($CRLF,@header); - return $header . "${CRLF}${CRLF}"; + push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; + push(@header,map {ucfirst $_} @other); + push(@header,"Content-Type: $type") if $type ne ''; + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + if (($MOD_PERL >= 1) && !$nph) { + $self->r->send_cgi_header($header); + return ''; + } + return $header; } END_OF_FUNC @@ -982,25 +1554,21 @@ END_OF_FUNC 'redirect' => <<'END_OF_FUNC', sub redirect { my($self,@p) = self_or_default(@_); - my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p); - $url = $url || $self->self_url; + my($url,$target,$status,$cookie,$nph,@other) = + rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p); + $status = '302 Found' unless defined $status; + $url ||= $self->self_url; my(@o); - foreach (@other) { push(@o,split("=")); } - if($MOD_PERL or exists $self->{'.req'}) { - my $r = $self->{'.req'} || Apache->request; - $r->header_out(Location => $url); - $r->err_header_out(Location => $url); - $r->status(302); - return; - } - push(@o, - '-Status'=>'302 Found', - '-Location'=>$url, - '-URI'=>$url, - '-nph'=>($nph||$NPH)); - push(@o,'-Target'=>$target) if $target; - push(@o,'-Cookie'=>$cookie) if $cookie; - return $self->header(@o); + for (@other) { tr/\"//d; push(@o,split("=",$_,2)); } + unshift(@o, + '-Status' => $status, + '-Location'=> $url, + '-nph' => $nph); + unshift(@o,'-Target'=>$target) if $target; + unshift(@o,'-Type'=>''); + my @unescaped; + unshift(@unescaped,'-Cookie'=>$cookie) if $cookie; + return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped); } END_OF_FUNC @@ -1018,61 +1586,227 @@ END_OF_FUNC # $script -> (option) Javascript code (-script) # $no_script -> (option) Javascript END ; my($other) = @other ? " @other" : ''; - push(@result,""); + push(@result,"\n\n"); return join("\n",@result); } END_OF_FUNC +### Method: _style +# internal method for generating a CSS style section +#### +'_style' => <<'END_OF_FUNC', +sub _style { + my ($self,$style) = @_; + my (@result); + + my $type = 'text/css'; + my $rel = 'stylesheet'; + + + my $cdata_start = $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,$alternate,$foo,@other) = + rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)], + ('-foo'=>'bar', + ref($s) eq 'ARRAY' ? @$s : %$s)); + 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 + for $src (@$src) + { + push(@result,$XHTML ? qq() + : qq()) if $src; + } + } + else + { # Otherwise, push the single -src, if it exists. + push(@result,$XHTML ? qq() + : qq() + ) if $src; + } + if ($verbatim) { + my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim; + push(@result, "") for @v; + } + my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code; + push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c; + + } else { + my $src = $s; + push(@result,$XHTML ? qq() + : qq()); + } + } + @result; +} +END_OF_FUNC + +'_script' => <<'END_OF_FUNC', +sub _script { + my ($self,$script) = @_; + my (@result); + + my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); + for $script (@scripts) { + my($src,$code,$language); + if (ref($script)) { # script is a hash + ($src,$code,$type) = + rearrange(['SRC','CODE',['LANGUAGE','TYPE']], + '-foo'=>'bar', # a trick to allow the '-' to be omitted + ref($script) eq 'ARRAY' ? @$script : %$script); + $type ||= 'text/javascript'; + unless ($type =~ m!\w+/\w+!) { + $type =~ s/[\d.]+$//; + $type = "text/$type"; + } + } else { + ($src,$code,$type) = ('',$script, 'text/javascript'); + } + + my $comment = '//'; # javascript by default + $comment = '#' if $type=~/perl|tcl/i; + $comment = "'" if $type=~/vbscript/i; + + my ($cdata_start,$cdata_end); + if ($XHTML) { + $cdata_start = "$comment"; + } else { + $cdata_start = "\n\n"; + } + my(@satts); + push(@satts,'src'=>$src) if $src; + push(@satts,'type'=>$type); + $code = $cdata_start . $code . $cdata_end if defined $code; + push(@result,$self->script({@satts},$code || '')); + } + @result; +} +END_OF_FUNC #### Method: end_html # End an HTML document. -# Trivial method for completeness. Just returns "" +# Trivial method for completeness. Just returns "" #### 'end_html' => <<'END_OF_FUNC', sub end_html { - return ""; + return "\n\n"; } END_OF_FUNC @@ -1086,14 +1820,14 @@ END_OF_FUNC # Parameters: # $action -> optional URL of script to run # Returns: -# A string containing a tag +# A string containing a tag 'isindex' => <<'END_OF_FUNC', sub isindex { my($self,@p) = self_or_default(@_); - my($action,@other) = $self->rearrange([ACTION],@p); - $action = qq/ACTION="$action"/ if $action; + my($action,@other) = rearrange([ACTION],@p); + $action = qq/ action="$action"/ if $action; my($other) = @other ? " @other" : ''; - return ""; + return $XHTML ? "" : ""; } END_OF_FUNC @@ -1109,15 +1843,20 @@ sub startform { my($self,@p) = self_or_default(@_); my($method,$action,$enctype,@other) = - $self->rearrange([METHOD,ACTION,ENCTYPE],@p); + rearrange([METHOD,ACTION,ENCTYPE],@p); - $method = $method || 'POST'; - $enctype = $enctype || &URL_ENCODED; - $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ? - 'ACTION="'.$self->script_name.'"' : ''; + $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 || $self->self_url); + } + $action = qq(action="$action"); my($other) = @other ? " @other" : ''; $self->{'.parametersToAdd'}={}; - return qq/
\n/; + return qq/\n/; } END_OF_FUNC @@ -1126,24 +1865,26 @@ END_OF_FUNC # synonym for startform 'start_form' => <<'END_OF_FUNC', sub start_form { - &startform; + $XHTML ? &start_multipart_form : &startform; } END_OF_FUNC +'end_multipart_form' => <<'END_OF_FUNC', +sub end_multipart_form { + &endform; +} +END_OF_FUNC #### Method: start_multipart_form # synonym for startform 'start_multipart_form' => <<'END_OF_FUNC', sub start_multipart_form { my($self,@p) = self_or_default(@_); - if ($self->use_named_parameters || - (defined($param[0]) && substr($param[0],0,1) eq '-')) { - my(%p) = @p; - $p{'-enctype'}=&MULTIPART; - return $self->startform(%p); + if (defined($p[0]) && substr($p[0],0,1) eq '-') { + return $self->startform(-enctype=>&MULTIPART,@p); } else { my($method,$action,@other) = - $self->rearrange([METHOD,ACTION],@p); + rearrange([METHOD,ACTION],@p); return $self->startform($method,$action,&MULTIPART,@other); } } @@ -1154,21 +1895,44 @@ END_OF_FUNC # End a form 'endform' => <<'END_OF_FUNC', sub endform { - my($self,@p) = self_or_default(@_); - return ($self->get_fields,"
"); + my($self,@p) = self_or_default(@_); + if ( $NOSTICKY ) { + return wantarray ? ("") : "\n"; + } else { + if (my @fields = $self->get_fields) { + return wantarray ? ("
",@fields,"
","") + : "
".(join '',@fields)."
\n"; + } else { + return ""; + } + } } END_OF_FUNC -#### Method: end_form -# synonym for endform -'end_form' => <<'END_OF_FUNC', -sub end_form { - &endform; +'_textfield' => <<'END_OF_FUNC', +sub _textfield { + my($self,$tag,@p) = self_or_default(@_); + my($name,$default,$size,$maxlength,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p); + + my $current = $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $current = defined($current) ? $self->escapeHTML($current,1) : ''; + $name = defined($name) ? $self->escapeHTML($name) : ''; + my($s) = defined($size) ? qq/ size="$size"/ : ''; + my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : ''; + my($other) = @other ? " @other" : ''; + # this entered at cristy's request to fix problems with file upload fields + # and WebTV -- not sure it won't break stuff + my($value) = $current ne '' ? qq(value="$current") : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); } END_OF_FUNC - #### Method: textfield # Parameters: # $name -> Name of the text field @@ -1177,23 +1941,12 @@ END_OF_FUNC # $size -> Optional width of field in characaters. # $maxlength -> Optional maximum number of characters. # Returns: -# A string containing a field +# A string containing a field # 'textfield' => <<'END_OF_FUNC', sub textfield { my($self,@p) = self_or_default(@_); - my($name,$default,$size,$maxlength,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); - - my $current = $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $current = defined($current) ? $self->escapeHTML($current) : ''; - $name = defined($name) ? $self->escapeHTML($name) : ''; - my($s) = defined($size) ? qq/ SIZE=$size/ : ''; - my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; - my($other) = @other ? " @other" : ''; - return qq//; + $self->_textfield('text',@p); } END_OF_FUNC @@ -1204,24 +1957,12 @@ END_OF_FUNC # $size -> Optional width of field in characaters. # $maxlength -> Optional maximum number of characters. # Returns: -# A string containing a field +# A string containing a field # 'filefield' => <<'END_OF_FUNC', sub filefield { my($self,@p) = self_or_default(@_); - - my($name,$default,$size,$maxlength,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); - - $current = $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $name = defined($name) ? $self->escapeHTML($name) : ''; - my($s) = defined($size) ? qq/ SIZE=$size/ : ''; - my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; - $current = defined($current) ? $self->escapeHTML($current) : ''; - $other = ' ' . join(" ",@other); - return qq//; + $self->_textfield('file',@p); } END_OF_FUNC @@ -1235,28 +1976,15 @@ END_OF_FUNC # $size -> Optional width of field in characters. # $maxlength -> Optional maximum characters that can be entered. # Returns: -# A string containing a field +# A string containing a field # 'password_field' => <<'END_OF_FUNC', sub password_field { my ($self,@p) = self_or_default(@_); - - my($name,$default,$size,$maxlength,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); - - my($current) = $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $name = defined($name) ? $self->escapeHTML($name) : ''; - $current = defined($current) ? $self->escapeHTML($current) : ''; - my($s) = defined($size) ? qq/ SIZE=$size/ : ''; - my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; - my($other) = @other ? " @other" : ''; - return qq//; + $self->_textfield('password',@p); } END_OF_FUNC - #### Method: textarea # Parameters: # $name -> Name of the text field @@ -1265,24 +1993,24 @@ END_OF_FUNC # $rows -> Optional number of rows in text area # $columns -> Optional number of columns in text area # Returns: -# A string containing a tag +# A string containing a tag # 'textarea' => <<'END_OF_FUNC', sub textarea { my($self,@p) = self_or_default(@_); - - my($name,$default,$rows,$cols,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p); + my($name,$default,$rows,$cols,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p); my($current)= $override ? $default : (defined($self->param($name)) ? $self->param($name) : $default); $name = defined($name) ? $self->escapeHTML($name) : ''; $current = defined($current) ? $self->escapeHTML($current) : ''; - my($r) = $rows ? " ROWS=$rows" : ''; - my($c) = $cols ? " COLS=$cols" : ''; + my($r) = $rows ? qq/ rows="$rows"/ : ''; + my($c) = $cols ? qq/ cols="$cols"/ : ''; my($other) = @other ? " @other" : ''; - return qq{}; + $tabindex = $self->element_tab($tabindex); + return qq{}; } END_OF_FUNC @@ -1295,27 +2023,29 @@ END_OF_FUNC # $onclick -> (optional) Text of the JavaScript to run when the button is # clicked. # Returns: -# A string containing a tag +# A string containing a tag #### 'button' => <<'END_OF_FUNC', sub button { my($self,@p) = self_or_default(@_); - my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL], - [ONCLICK,SCRIPT]],@p); + my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL], + [ONCLICK,SCRIPT],TABINDEX],@p); $label=$self->escapeHTML($label); - $value=$self->escapeHTML($value); + $value=$self->escapeHTML($value,1); $script=$self->escapeHTML($script); my($name) = ''; - $name = qq/ NAME="$label"/ if $label; + $name = qq/ name="$label"/ if $label; $value = $value || $label; my($val) = ''; - $val = qq/ VALUE="$value"/ if $value; - $script = qq/ ONCLICK="$script"/ if $script; + $val = qq/ value="$value"/ if $value; + $script = qq/ onclick="$script"/ if $script; my($other) = @other ? " @other" : ''; - return qq//; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); } END_OF_FUNC @@ -1327,24 +2057,26 @@ END_OF_FUNC # $value -> (optional) Value of the button when selected (also doubles as label). # $label -> (optional) Label printed on the button(also doubles as the value). # Returns: -# A string containing a tag +# A string containing a tag #### 'submit' => <<'END_OF_FUNC', sub submit { my($self,@p) = self_or_default(@_); - my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p); + my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p); $label=$self->escapeHTML($label); - $value=$self->escapeHTML($value); - - my($name) = ' NAME=".submit"'; - $name = qq/ NAME="$label"/ if $label; - $value = $value || $label; - my($val) = ''; - $val = qq/ VALUE="$value"/ if defined($value); - my($other) = @other ? " @other" : ''; - return qq//; + $value=$self->escapeHTML($value,1); + + my $name = $NOSTICKY ? '' : 'name=".submit" '; + $name = qq/name="$label" / if defined($label); + $value = defined($value) ? $value : $label; + my $val = ''; + $val = qq/value="$value" / if defined($value); + $tabindex = $self->element_tab($tabindex); + my($other) = @other ? "@other " : ''; + return $XHTML ? qq() + : qq(); } END_OF_FUNC @@ -1354,16 +2086,23 @@ END_OF_FUNC # Parameters: # $name -> (optional) Name for the button. # Returns: -# A string containing a tag +# A string containing a tag #### 'reset' => <<'END_OF_FUNC', sub reset { my($self,@p) = self_or_default(@_); - my($label,@other) = $self->rearrange([NAME],@p); + my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p); $label=$self->escapeHTML($label); - my($value) = defined($label) ? qq/ VALUE="$label"/ : ''; + $value=$self->escapeHTML($value,1); + my ($name) = ' name=".reset"'; + $name = qq/ name="$label"/ if defined($label); + $value = defined($value) ? $value : $label; + my($val) = ''; + $val = qq/ value="$value"/ if defined($value); my($other) = @other ? " @other" : ''; - return qq//; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); } END_OF_FUNC @@ -1373,7 +2112,7 @@ END_OF_FUNC # Parameters: # $name -> (optional) Name for the button. # Returns: -# A string containing a tag +# A string containing a tag # # Note: this button has a special meaning to the initialization script, # and tells it to ERASE the current query string so that your defaults @@ -1383,17 +2122,29 @@ END_OF_FUNC sub defaults { my($self,@p) = self_or_default(@_); - my($label,@other) = $self->rearrange([[NAME,VALUE]],@p); + my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p); - $label=$self->escapeHTML($label); + $label=$self->escapeHTML($label,1); $label = $label || "Defaults"; - my($value) = qq/ VALUE="$label"/; + my($value) = qq/ value="$label"/; my($other) = @other ? " @other" : ''; - return qq//; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq//; } END_OF_FUNC +#### Method: comment +# Create an HTML +# Parameters: a string +'comment' => <<'END_OF_FUNC', +sub comment { + my($self,@p) = self_or_CGI(@_); + return ""; +} +END_OF_FUNC + #### Method: checkbox # Create a checkbox that is not logically linked to any others. # The field value is "on" when the button is checked. @@ -1404,135 +2155,133 @@ END_OF_FUNC # $label -> (optional) a user-readable label printed next to the box. # Otherwise the checkbox name is used. # Returns: -# A string containing a field +# A string containing a field #### 'checkbox' => <<'END_OF_FUNC', sub checkbox { my($self,@p) = self_or_default(@_); - my($name,$checked,$value,$label,$override,@other) = - $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); - - if (!$override && defined($self->param($name))) { - $value = $self->param($name) unless defined $value; - $checked = $self->param($name) eq $value ? ' CHECKED' : ''; + 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'; + + if (!$override && ($self->{'.fieldnames'}->{$name} || + defined $self->param($name))) { + $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : ''; } else { - $checked = $checked ? ' CHECKED' : ''; - $value = defined $value ? $value : 'on'; + $checked = $self->_checked($checked); } my($the_label) = defined $label ? $label : $name; $name = $self->escapeHTML($name); - $value = $self->escapeHTML($value); + $value = $self->escapeHTML($value,1); $the_label = $self->escapeHTML($the_label); - my($other) = @other ? " @other" : ''; + my($other) = @other ? "@other " : ''; + $tabindex = $self->element_tab($tabindex); $self->register_parameter($name); - return <$the_label -END + return $XHTML ? CGI::label($labelattributes, + qq{$the_label}) + : qq{$the_label}; } END_OF_FUNC -#### Method: checkbox_group -# Create a list of logically-linked checkboxes. -# Parameters: -# $name -> Common name for all the check boxes -# $values -> A pointer to a regular array containing the -# values for each checkbox in the group. -# $defaults -> (optional) -# 1. If a pointer to a regular array of checkbox values, -# then this will be used to decide which -# checkboxes to turn on by default. -# 2. If a scalar, will be assumed to hold the -# value of a single checkbox in the group to turn on. -# $linebreak -> (optional) Set to true to place linebreaks -# between the buttons. -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# An ARRAY containing a series of fields -#### -'checkbox_group' => <<'END_OF_FUNC', -sub checkbox_group { - my($self,@p) = self_or_default(@_); - - my($name,$values,$defaults,$linebreak,$labels,$rows,$columns, - $rowheaders,$colheaders,$override,$nolabels,@other) = - $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - LINEBREAK,LABELS,ROWS,[COLUMNS,COLS], - ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS],@p); - - my($checked,$break,$result,$label); - - my(%checked) = $self->previous_or_default($name,$defaults,$override); - - $break = $linebreak ? "
" : ''; - $name=$self->escapeHTML($name); - - # Create the elements - my(@elements); - my(@values) = $values ? @$values : $self->param($name); - my($other) = @other ? " @other" : ''; - foreach (@values) { - $checked = $checked{$_} ? ' CHECKED' : ''; - $label = ''; - unless (defined($nolabels) && $nolabels) { - $label = $_; - $label = $labels->{$_} if defined($labels) && $labels->{$_}; - $label = $self->escapeHTML($label); - } - $_ = $self->escapeHTML($_); - push(@elements,qq/${label} ${break}/); - } - $self->register_parameter($name); - return wantarray ? @elements : join('',@elements) unless $columns; - return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); -} -END_OF_FUNC - # Escape HTML -- used internally 'escapeHTML' => <<'END_OF_FUNC', sub escapeHTML { - my($self,$toencode) = @_; - return undef unless defined($toencode); - return $toencode if $self->{'dontescape'}; - $toencode=~s/&/&/g; - $toencode=~s/\"/"/g; - $toencode=~s/>/>/g; - $toencode=~s/{'escape'}; + $toencode =~ s{&}{&}gso; + $toencode =~ s{<}{<}gso; + $toencode =~ s{>}{>}gso; + if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) { + # $quot; was accidentally omitted from the HTML 3.2 DTD -- see + # / + # . + $toencode =~ s{"}{"}gso; + } + else { + $toencode =~ s{"}{"}gso; + } + # 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; + if (defined $newlinestoo && $newlinestoo) { + $toencode =~ s{\012}{ }gso; + $toencode =~ s{\015}{ }gso; + } + } + return $toencode; } END_OF_FUNC +# unescape HTML -- used internally +'unescapeHTML' => <<'END_OF_FUNC', +sub unescapeHTML { + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$string) = CGI::self_or_default(@_); + return undef unless defined($string); + my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i + : 1; + # thanks to Randal Schwartz for the correct solution to this one + $string=~ s[&(.*?);]{ + local $_ = $1; + /^amp$/i ? "&" : + /^quot$/i ? '"' : + /^gt$/i ? ">" : + /^lt$/i ? "<" : + /^#(\d+)$/ && $latin ? chr($1) : + /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) : + $_ + }gex; + return $string; +} +END_OF_FUNC # Internal procedure - don't use '_tableize' => <<'END_OF_FUNC', sub _tableize { my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; + my @rowheaders = $rowheaders ? @$rowheaders : (); + my @colheaders = $colheaders ? @$colheaders : (); my($result); - $rows = int(0.99 + @elements/$columns) unless $rows; + if (defined($columns)) { + $rows = int(0.99 + @elements/$columns) unless defined($rows); + } + if (defined($rows)) { + $columns = int(0.99 + @elements/$rows) unless defined($columns); + } + # rearrange into a pretty table - $result = ""; + $result = "
"; my($row,$column); - unshift(@$colheaders,'') if @$colheaders && @$rowheaders; - $result .= "" if @{$colheaders}; - foreach (@{$colheaders}) { - $result .= ""; + unshift(@colheaders,'') if @colheaders && @rowheaders; + $result .= "" if @colheaders; + for (@colheaders) { + $result .= ""; } for ($row=0;$row<$rows;$row++) { - $result .= ""; - $result .= "" if @$rowheaders; + $result .= ""; + $result .= "" if @rowheaders; for ($column=0;$column<$columns;$column++) { - $result .= ""; + $result .= "" + if defined($elements[$column*$rows + $row]); } - $result .= ""; + $result .= ""; } - $result .= "
$_
$_
$rowheaders->[$row]
$rowheaders[$row]" . $elements[$column*$rows + $row] . "" . $elements[$column*$rows + $row] . "
"; + $result .= ""; return $result; } END_OF_FUNC @@ -1549,64 +2298,143 @@ END_OF_FUNC # $linebreak -> (optional) Set to true to place linebreaks # between the buttons. # $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox +# A pointer to a hash of labels to print next to each checkbox # in the form $label{'value'}="Long explanatory label". # Otherwise the provided values are used as the labels. # Returns: -# An ARRAY containing a series of fields +# An ARRAY containing a series of fields #### 'radio_group' => <<'END_OF_FUNC', sub radio_group { my($self,@p) = self_or_default(@_); - - my($name,$values,$default,$linebreak,$labels, - $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) = - $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS, - ROWS,[COLUMNS,COLS], - ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS],@p); - my($result,$checked); - - if (!$override && defined($self->param($name))) { - $checked = $self->param($name); - } else { - $checked = $default; - } - # If no check array is specified, check the first by default - $checked = $values->[0] unless $checked; - $name=$self->escapeHTML($name); - - my(@elements); - my(@values) = $values ? @$values : $self->param($name); - my($other) = @other ? " @other" : ''; - foreach (@values) { - my($checkit) = $checked eq $_ ? ' CHECKED' : ''; - my($break) = $linebreak ? '
' : ''; - my($label)=''; - unless (defined($nolabels) && $nolabels) { - $label = $_; - $label = $labels->{$_} if defined($labels) && $labels->{$_}; - $label = $self->escapeHTML($label); - } - $_=$self->escapeHTML($_); - push(@elements,qq/${label} ${break}/); - } - $self->register_parameter($name); - return wantarray ? @elements : join('',@elements) unless $columns; - return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); + $self->_box_group('radio',@p); } END_OF_FUNC - -#### Method: popup_menu -# Create a popup menu. +#### Method: checkbox_group +# Create a list of logically-linked checkboxes. # Parameters: -# $name -> Name for all the menu +# $name -> Common name for all the check boxes # $values -> A pointer to a regular array containing the -# text of each menu item. -# $default -> (optional) Default item to display +# values for each checkbox in the group. +# $defaults -> (optional) +# 1. If a pointer to a regular array of checkbox values, +# then this will be used to decide which +# checkboxes to turn on by default. +# 2. If a scalar, will be assumed to hold the +# value of a single checkbox in the group to turn on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. # $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of fields +#### + +'checkbox_group' => <<'END_OF_FUNC', +sub checkbox_group { + my($self,@p) = self_or_default(@_); + $self->_box_group('checkbox',@p); +} +END_OF_FUNC + +'_box_group' => <<'END_OF_FUNC', +sub _box_group { + my $self = shift; + my $box_type = shift; + + 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); + + @values = $self->_set_values_and_labels($values,\$labels,$name); + my %checked = $self->previous_or_default($name,$defaults,$override); + + # If no check array is specified, check the first by default + $checked{$values[0]}++ if $box_type eq 'radio' && !%checked; + + $name=$self->escapeHTML($name); + + my %tabs = (); + if ($TABINDEX && $tabindex) { + if (!ref $tabindex) { + $self->element_tab($tabindex); + } elsif (ref $tabindex eq 'ARRAY') { + %tabs = map {$_=>$self->element_tab} @$tabindex; + } elsif (ref $tabindex eq 'HASH') { + %tabs = %$tabindex; + } + } + %tabs = map {$_=>$self->element_tab} @values unless %tabs; + my $other = @other ? "@other " : ''; + my $radio_checked; + + # for disabling groups of radio/checkbox buttons + my %disabled; + for (@{$disabled}) { + $disabled{$_}=1; + } + + for (@values) { + my $disable=""; + if ($disabled{$_}) { + $disable="disabled='1'"; + } + + my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++) + : $checked{$_}); + my($break); + if ($linebreak) { + $break = $XHTML ? "
" : "
"; + } + else { + $break = ''; + } + my($label)=''; + unless (defined($nolabels) && $nolabels) { + $label = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + $label = $self->escapeHTML($label,1); + $label = "$label" if $disabled{$_}; + } + my $attribs = $self->_set_attributes($_, $attributes); + my $tab = $tabs{$_}; + $_=$self->escapeHTML($_); + + if ($XHTML) { + push @elements, + CGI::label($labelattributes, + qq($label)).${break}; + } else { + push(@elements,qq/${label}${break}/); + } + } + $self->register_parameter($name); + return wantarray ? @elements : "@elements" + unless defined($columns) || defined($rows); + return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); +} +END_OF_FUNC + + +#### Method: popup_menu +# Create a popup menu. +# Parameters: +# $name -> Name for all the menu +# $values -> A pointer to a regular array containing the +# text of each menu item. +# $default -> (optional) Default item to display +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox # in the form $label{'value'}="Long explanatory label". # Otherwise the provided values are used as the labels. # Returns: @@ -1616,30 +2444,107 @@ END_OF_FUNC sub popup_menu { my($self,@p) = self_or_default(@_); - my($name,$values,$default,$labels,$override,@other) = - $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p); - my($result,$selected); + my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) = + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, + ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); + my($result,%selected); if (!$override && defined($self->param($name))) { - $selected = $self->param($name); - } else { - $selected = $default; + $selected{$self->param($name)}++; + } elsif ($default) { + %selected = map {$_=>1} ref($default) eq 'ARRAY' + ? @$default + : $default; } $name=$self->escapeHTML($name); my($other) = @other ? " @other" : ''; - my(@values) = $values ? @$values : $self->param($name); - $result = qq/\n/; + for (@values) { + if (/_set_attributes($_, $attributes); + my($selectit) = $self->_selected($selected{$_}); + my($label) = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + my($value) = $self->escapeHTML($_); + $label = $self->escapeHTML($label,1); + $result .= "$label\n"; + } } - $result .= "\n"; + $result .= ""; + return $result; +} +END_OF_FUNC + + +#### Method: optgroup +# Create a optgroup. +# Parameters: +# $name -> Label for the group +# $values -> A pointer to a regular array containing the +# values for each option line in the group. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each item +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# $labeled -> (optional) +# A true value indicates the value should be used as the label attribute +# in the option elements. +# The label attribute specifies the option label presented to the user. +# This defaults to the content of the \n/; + for (@values) { + if (/_set_attributes($_, $attributes); + my($label) = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + $label=$self->escapeHTML($label); + my($value)=$self->escapeHTML($_,1); + $result .= $labeled ? $novals ? "$label\n" + : "$label\n" + : $novals ? "$label\n" + : "$label\n"; + } + } + $result .= ""; return $result; } END_OF_FUNC @@ -1659,7 +2564,7 @@ END_OF_FUNC # $size -> (optional) Size of the list. # $multiple -> (optional) If set, allow multiple selections. # $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox +# A pointer to a hash of labels to print next to each checkbox # in the form $label{'value'}="Long explanatory label". # Otherwise the provided values are used as the labels. # Returns: @@ -1668,30 +2573,34 @@ END_OF_FUNC 'scrolling_list' => <<'END_OF_FUNC', sub scrolling_list { my($self,@p) = self_or_default(@_); - my($name,$values,$defaults,$size,$multiple,$labels,$override,@other) - = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p); + my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other) + = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], + SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); + + my($result,@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); - my($result); - my(@values) = $values ? @$values : $self->param($name); $size = $size || scalar(@values); my(%selected) = $self->previous_or_default($name,$defaults,$override); - my($is_multiple) = $multiple ? ' MULTIPLE' : ''; - my($has_size) = $size ? " SIZE=$size" : ''; + + my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : ''; + my($has_size) = $size ? qq/ size="$size"/: ''; my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); - $result = qq/\n/; + for (@values) { + my($selectit) = $self->_selected($selected{$_}); my($label) = $_; - $label = $labels->{$_} if defined($labels) && $labels->{$_}; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label=$self->escapeHTML($label); - my($value)=$self->escapeHTML($_); - $result .= "\n"; } - $result .= "\n"; + $result .= ""; $self->register_parameter($name); return $result; } @@ -1705,7 +2614,7 @@ END_OF_FUNC # or # $default->[initial values of field] # Returns: -# A string containing a +# A string containing a #### 'hidden' => <<'END_OF_FUNC', sub hidden { @@ -1715,14 +2624,14 @@ sub hidden { # calling scheme, so we have to special-case (darn) my(@result,@value); my($name,$default,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); + rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); my $do_override = 0; - if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) { + if ( ref($p[0]) || substr($p[0],0,1) eq '-') { @value = ref($default) ? @{$default} : $default; $do_override = $override; } else { - foreach ($default,$override,@other) { + for ($default,$override,@other) { push(@value,$_) if defined($_); } } @@ -1732,9 +2641,10 @@ sub hidden { @value = @prev if !$do_override && @prev; $name=$self->escapeHTML($name); - foreach (@value) { - $_=$self->escapeHTML($_); - push(@result,qq//); + for (@value) { + $_ = defined($_) ? $self->escapeHTML($_,1) : ''; + push @result,$XHTML ? qq() + : qq(); } return wantarray ? @result : join('',@result); } @@ -1747,19 +2657,20 @@ END_OF_FUNC # $src -> URL of the image source # $align -> Alignment style (TOP, BOTTOM or MIDDLE) # Returns: -# A string containing a +# A string containing a #### 'image_button' => <<'END_OF_FUNC', sub image_button { my($self,@p) = self_or_default(@_); my($name,$src,$alignment,@other) = - $self->rearrange([NAME,SRC,ALIGN],@p); + 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 qq//; + return $XHTML ? qq() + : qq//; } END_OF_FUNC @@ -1772,16 +2683,8 @@ END_OF_FUNC #### 'self_url' => <<'END_OF_FUNC', sub self_url { - my($self) = self_or_default(@_); - my($query_string) = $self->query_string; - my $protocol = $self->protocol(); - my $name = "$protocol://" . $self->server_name; - $name .= ":" . $self->server_port - unless $self->server_port == 80; - $name .= $self->script_name; - $name .= $self->path_info if $self->path_info; - return $name unless $query_string; - return "$name?$query_string"; + my($self,@p) = self_or_default(@_); + return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); } END_OF_FUNC @@ -1801,13 +2704,53 @@ END_OF_FUNC #### 'url' => <<'END_OF_FUNC', sub url { - my($self) = self_or_default(@_); - my $protocol = $self->protocol(); - my $name = "$protocol://" . $self->server_name; - $name .= ":" . $self->server_port - unless $self->server_port == 80; - $name .= $self->script_name; - return $name; + my($self,@p) = self_or_default(@_); + my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) = + rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p); + my $url = ''; + $full++ if $base || !($relative || $absolute); + $rewrite++ unless defined $rewrite; + + my $path = $self->path_info; + my $script_name = $self->script_name; + my $request_uri = unescape($self->request_uri) || ''; + my $query_str = $self->query_string; + + 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/\?.*$//s; # remove query string + $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO}; +# $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') || ''; + $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); + return $url if $base; + $url .= $uri; + } elsif ($relative) { + ($url) = $uri =~ m!([^/]+)$!; + } elsif ($absolute) { + $url = $uri; + } + + $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; } END_OF_FUNC @@ -1822,106 +2765,68 @@ END_OF_FUNC # -path -> paths for which this cookie is valid (optional) # -domain -> internet domain in which this cookie is valid (optional) # -secure -> if true, cookie only passed through secure channel (optional) -# -expires -> expiry date in format Wdy, DD-Mon-YY HH:MM:SS GMT (optional) +# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) #### 'cookie' => <<'END_OF_FUNC', -# temporary, for debugging. sub cookie { my($self,@p) = self_or_default(@_); - my($name,$value,$path,$domain,$secure,$expires) = - $self->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; # if no value is supplied, then we retrieve the # value of the cookie, if any. For efficiency, we cache the parsed - # cookie in our state variables. - unless (defined($value)) { - unless ($self->{'.cookies'}) { - my(@pairs) = split("; ",$self->raw_cookie); - foreach (@pairs) { - my($key,$value) = split("="); - my(@values) = map unescape($_),split('&',$value); - $self->{'.cookies'}->{unescape($key)} = [@values]; - } - } + # cookies in our state variables. + unless ( defined($value) ) { + $self->{'.cookies'} = CGI::Cookie->fetch + unless $self->{'.cookies'}; # If no name is supplied, then retrieve the names of all our cookies. return () unless $self->{'.cookies'}; - return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0] - if defined($name) && $name ne ''; - return keys %{$self->{'.cookies'}}; + return keys %{$self->{'.cookies'}} unless $name; + return () unless $self->{'.cookies'}->{$name}; + return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; } - my(@values); - # Pull out our parameters. - if (ref($value)) { - if (ref($value) eq 'ARRAY') { - @values = @$value; - } elsif (ref($value) eq 'HASH') { - @values = %$value; - } - } else { - @values = ($value); - } - @values = map escape($_),@values; - - # I.E. requires the path to be present. - ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path; - - my(@constant_values); - push(@constant_values,"domain=$domain") if $domain; - push(@constant_values,"path=$path") if $path; - push(@constant_values,"expires=".&expires($expires)) if $expires; - push(@constant_values,'secure') if $secure; - - my($key) = &escape($name); - my($cookie) = join("=",$key,join("&",@values)); - return join("; ",$cookie,@constant_values); -} -END_OF_FUNC - - -# This internal routine creates an expires string exactly some number of -# hours from the current time in GMT. This is the format -# required by Netscape cookies, and I think it works for the HTTP -# Expires: header as well. -'expires' => <<'END_OF_FUNC', -sub expires { - my($time) = @_; - my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; - my(@WDAY) = qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/; - my(%mult) = ('s'=>1, - 'm'=>60, - 'h'=>60*60, - 'd'=>60*60*24, - 'M'=>60*60*24*30, - 'y'=>60*60*24*365); - # format for time can be in any of the forms... - # "now" -- expire immediately - # "+180s" -- in 180 seconds - # "+2m" -- in 2 minutes - # "+12h" -- in 12 hours - # "+1d" -- in 1 day - # "+3M" -- in 3 months - # "+2y" -- in 2 years - # "-3m" -- 3 minutes ago(!) - # If you don't supply one of these forms, we assume you are - # specifying the date yourself - my($offset); - if (!$time || ($time eq 'now')) { - $offset = 0; - } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) { - $offset = ($mult{$2} || 1)*$1; - } else { - return $time; - } - my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime(time+$offset); - $year += 1900 unless $year < 100; - return sprintf("%s, %02d-%s-%02d %02d:%02d:%02d GMT", - $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); + # If we get here, we're creating a new cookie + return undef unless defined($name) && $name ne ''; # this is an error + + my @param; + push(@param,'-name'=>$name); + push(@param,'-value'=>$value); + push(@param,'-domain'=>$domain) if $domain; + 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); +} +END_OF_FUNC + +'parse_keywordlist' => <<'END_OF_FUNC', +sub parse_keywordlist { + my($self,$tosplit) = @_; + $tosplit = unescape($tosplit); # unescape the keywords + $tosplit=~tr/+/ /; # pluses to spaces + my(@keywords) = split(/\s+/,$tosplit); + return @keywords; } END_OF_FUNC +'param_fetch' => <<'END_OF_FUNC', +sub param_fetch { + my($self,@p) = self_or_default(@_); + my($name) = rearrange([NAME],@p); + unless (exists($self->{param}{$name})) { + $self->add_parameter($name); + $self->{param}{$name} = []; + } + + return $self->{param}{$name}; +} +END_OF_FUNC ############################################### # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT @@ -1933,7 +2838,70 @@ END_OF_FUNC #### 'path_info' => <<'END_OF_FUNC', sub path_info { - return $ENV{'PATH_INFO'}; + my ($self,$info) = self_or_default(@_); + if (defined($info)) { + $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; + $self->{'.path_info'} = $info; + } elsif (! defined($self->{'.path_info'}) ) { + my (undef,$path_info) = $self->_name_and_path_from_env; + $self->{'.path_info'} = $path_info || ''; + } + return $self->{'.path_info'}; +} +END_OF_FUNC + +# This function returns a potentially modified version of SCRIPT_NAME +# and PATH_INFO. Some HTTP servers do sanitise the paths in those +# variables. It is the case of at least Apache 2. If for instance the +# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set: +# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y +# SCRIPT_NAME=/path/to/env.cgi +# PATH_INFO=/x/y/x +# +# This is all fine except that some bogus CGI scripts expect +# PATH_INFO=/http://foo when the user requests +# http://xxx/script.cgi/http://foo +# +# Old versions of this module used to accomodate with those scripts, so +# this is why we do this here to keep those scripts backward compatible. +# Basically, we accomodate with those scripts but within limits, that is +# we only try to preserve the number of / that were provided by the user +# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number +# of consecutive /. +# +# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a +# script_name of /x//y/script.cgi and a path_info of /a//b, but in: +# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions +# possibly sanitised by the HTTP server, so in the case of Apache 2: +# script_name == /foo/x/z/script.cgi and path_info == /b/c. +# +# Future versions of this module may no longer do that, so one should +# avoid relying on the browser, proxy, server, and CGI.pm preserving the +# number of consecutive slashes as no guarantee can be made there. +'_name_and_path_from_env' => <<'END_OF_FUNC', +sub _name_and_path_from_env { + my $self = shift; + my $script_name = $ENV{SCRIPT_NAME} || ''; + my $path_info = $ENV{PATH_INFO} || ''; + my $uri = $self->request_uri || ''; + + $uri =~ s/\?.*//s; + $uri = unescape($uri); + + if ($uri ne "$script_name$path_info") { + my $script_name_pattern = quotemeta($script_name); + my $path_info_pattern = quotemeta($path_info); + $script_name_pattern =~ s{(?:\\/)+}{/+}g; + $path_info_pattern =~ s{(?:\\/)+}{/+}g; + + if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) { + # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the + # numer of consecutive slashes, so we can extract the info from + # REQUEST_URI: + ($script_name, $path_info) = ($1, $2); + } + } + return ($script_name,$path_info); } END_OF_FUNC @@ -1947,6 +2915,15 @@ sub request_method { } END_OF_FUNC +#### Method: content_type +# Returns the content_type string +#### +'content_type' => <<'END_OF_FUNC', +sub content_type { + return $ENV{'CONTENT_TYPE'}; +} +END_OF_FUNC + #### Method: path_translated # Return the physical path information provided # by the URL (if any) @@ -1958,6 +2935,16 @@ sub path_translated { END_OF_FUNC +#### Method: request_uri +# Return the literal request URI +#### +'request_uri' => <<'END_OF_FUNC', +sub request_uri { + return $ENV{'REQUEST_URI'}; +} +END_OF_FUNC + + #### Method: query_string # Synthesize a query string from our current # parameters @@ -1966,14 +2953,18 @@ END_OF_FUNC sub query_string { my($self) = self_or_default(@_); my($param,$value,@pairs); - foreach $param ($self->param) { - my($eparam) = &escape($param); - foreach $value ($self->param($param)) { - $value = &escape($value); + for $param ($self->param) { + my($eparam) = escape($param); + for $value ($self->param($param)) { + $value = escape($value); + next unless defined $value; push(@pairs,"$eparam=$value"); } } - return join("&",@pairs); + for (keys %{$self->{'.fieldnames'}}) { + push(@pairs,".cgifields=".escape("$_")); + } + return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); } END_OF_FUNC @@ -1989,14 +2980,16 @@ END_OF_FUNC # declares a quantitative score for it. # This handles MIME type globs correctly. #### -'accept' => <<'END_OF_FUNC', -sub accept { +'Accept' => <<'END_OF_FUNC', +sub Accept { my($self,$search) = self_or_CGI(@_); my(%prefs,$type,$pref,$pat); - my(@accept) = split(',',$self->http('accept')); + my(@accept) = defined $self->http('accept') + ? split(',',$self->http('accept')) + : (); - foreach (@accept) { + for (@accept) { ($pref) = /q=(\d\.\d+|\d+)/; ($type) = m#(\S+/[^;]+)#; next unless $type; @@ -2015,7 +3008,7 @@ sub accept { return $prefs{$search} if $prefs{$search}; # Didn't get it, so try pattern matching. - foreach (keys %prefs) { + for (keys %prefs) { next unless /\*/; # not a pattern match ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters $pat =~ s/\*/.*/g; # turn it into a pattern @@ -2039,14 +3032,28 @@ sub user_agent { END_OF_FUNC -#### Method: cookie -# Returns the magic cookie for the session. -# To set the magic cookie for new transations, -# try print $q->header('-Set-cookie'=>'my cookie') +#### Method: raw_cookie +# Returns the magic cookies for the session. +# The cookies are not parsed or altered in any way, i.e. +# cookies are returned exactly as given in the HTTP +# headers. If a cookie name is given, only that cookie's +# value is returned, otherwise the entire raw cookie +# is returned. #### 'raw_cookie' => <<'END_OF_FUNC', sub raw_cookie { - my($self) = self_or_CGI(@_); + my($self,$key) = self_or_CGI(@_); + + require CGI::Cookie; + + if (defined($key)) { + $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch + unless $self->{'.raw_cookies'}; + + return () unless $self->{'.raw_cookies'}; + return () unless $self->{'.raw_cookies'}->{$key}; + return $self->{'.raw_cookies'}->{$key}; + } return $self->http('cookie') || $ENV{'COOKIE'} || ''; } END_OF_FUNC @@ -2057,7 +3064,9 @@ END_OF_FUNC ###### 'virtual_host' => <<'END_OF_FUNC', sub virtual_host { - return http('host') || server_name(); + my $vh = http('x_forwarded_host') || http('host') || server_name(); + $vh =~ s/:\d+$//; # get rid of port number + return $vh; } END_OF_FUNC @@ -2093,10 +3102,14 @@ END_OF_FUNC #### 'script_name' => <<'END_OF_FUNC', sub script_name { - return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'}; - # These are for debugging - return "/$0" unless $0=~/^\//; - return $0; + my ($self,@p) = self_or_default(@_); + if (@p) { + $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; + } + return $self->{'.script_name'}; } END_OF_FUNC @@ -2131,6 +3144,22 @@ sub server_software { } END_OF_FUNC +#### Method: virtual_port +# Return the server port, taking virtual hosts into account +#### +'virtual_port' => <<'END_OF_FUNC', +sub virtual_port { + my($self) = self_or_default(@_); + my $vh = $self->http('x_forwarded_host') || $self->http('host'); + my $protocol = $self->protocol; + if ($vh) { + return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80); + } else { + return $self->server_port(); + } +} +END_OF_FUNC + #### Method: server_port # Return the tcp/ip port the server is running on #### @@ -2157,9 +3186,10 @@ END_OF_FUNC sub http { my ($self,$parameter) = self_or_CGI(@_); return $ENV{$parameter} if $parameter=~/^HTTP/; + $parameter =~ tr/-/_/; return $ENV{"HTTP_\U$parameter\E"} if $parameter; my(@p); - foreach (keys %ENV) { + for (keys %ENV) { push(@p,$_) if /^HTTP/; } return @p; @@ -2175,9 +3205,10 @@ sub https { my ($self,$parameter) = self_or_CGI(@_); return $ENV{HTTPS} unless $parameter; return $ENV{$parameter} if $parameter=~/^HTTPS/; + $parameter =~ tr/-/_/; return $ENV{"HTTPS_\U$parameter\E"} if $parameter; my(@p); - foreach (keys %ENV) { + for (keys %ENV) { push(@p,$_) if /^HTTPS/; } return @p; @@ -2191,7 +3222,7 @@ END_OF_FUNC sub protocol { local($^W)=0; my $self = shift; - return 'https' if $self->https() eq 'ON'; + return 'https' if uc($self->https()) eq 'ON'; return 'https' if $self->server_port == 443; my $prot = $self->server_protocol; my($protocol,$version) = split('/',$prot); @@ -2242,14 +3273,62 @@ sub user_name { } END_OF_FUNC +#### Method: nosticky +# Set or return the NOSTICKY global flag +#### +'nosticky' => <<'END_OF_FUNC', +sub nosticky { + my ($self,$param) = self_or_CGI(@_); + $CGI::NOSTICKY = $param if defined($param); + return $CGI::NOSTICKY; +} +END_OF_FUNC + #### Method: nph # Set or return the NPH global flag #### 'nph' => <<'END_OF_FUNC', sub nph { my ($self,$param) = self_or_CGI(@_); - $CGI::nph = $param if defined($param); - return $CGI::nph; + $CGI::NPH = $param if defined($param); + return $CGI::NPH; +} +END_OF_FUNC + +#### Method: private_tempfiles +# Set or return the private_tempfiles global flag +#### +'private_tempfiles' => <<'END_OF_FUNC', +sub private_tempfiles { + my ($self,$param) = self_or_CGI(@_); + $CGI::PRIVATE_TEMPFILES = $param if defined($param); + return $CGI::PRIVATE_TEMPFILES; +} +END_OF_FUNC +#### Method: close_upload_files +# Set or return the close_upload_files global flag +#### +'close_upload_files' => <<'END_OF_FUNC', +sub close_upload_files { + my ($self,$param) = self_or_CGI(@_); + $CGI::CLOSE_UPLOAD_FILES = $param if defined($param); + return $CGI::CLOSE_UPLOAD_FILES; +} +END_OF_FUNC + + +#### Method: default_dtd +# Set or return the default_dtd global +#### +'default_dtd' => <<'END_OF_FUNC', +sub default_dtd { + my ($self,$param,$param2) = self_or_CGI(@_); + if (defined $param2 && defined $param) { + $CGI::DEFAULT_DTD = [ $param, $param2 ]; + } elsif (defined $param) { + $CGI::DEFAULT_DTD = $param; + } + return $CGI::DEFAULT_DTD; } END_OF_FUNC @@ -2261,10 +3340,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); } @@ -2283,36 +3362,42 @@ END_OF_FUNC 'get_fields' => <<'END_OF_FUNC', sub get_fields { my($self) = @_; - return $self->hidden('-name'=>'.cgifields', - '-values'=>[keys %{$self->{'.parametersToAdd'}}], - '-override'=>1); + return $self->CGI::hidden('-name'=>'.cgifields', + '-values'=>[keys %{$self->{'.parametersToAdd'}}], + '-override'=>1); } END_OF_FUNC 'read_from_cmdline' => <<'END_OF_FUNC', sub read_from_cmdline { - require "shellwords.pl"; my($input,@words); my($query_string); - if (@ARGV) { - $input = join(" ",@ARGV); - } else { - print STDERR "(offline mode: enter name=value pairs on standard input)\n"; - chomp(@lines = <>); # remove newlines + my($subpath); + if ($DEBUG && @ARGV) { + @words = @ARGV; + } elsif ($DEBUG > 1) { + require "shellwords.pl"; + print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; + chomp(@lines = ); # remove newlines $input = join(" ",@lines); + @words = &shellwords($input); + } + for (@words) { + s/\\=/%3D/g; + s/\\&/%26/g; } - # minimal handling of escape characters - $input=~s/\\=/%3D/g; - $input=~s/\\&/%26/g; - - @words = &shellwords($input); if ("@words"=~/=/) { $query_string = join('&',@words); } else { $query_string = join('+',@words); } - return $query_string; + if ($query_string =~ /^(.*?)\?(.*)$/) + { + $query_string = $2; + $subpath = $1; + } + return { 'query_string' => $query_string, 'subpath' => $subpath }; } END_OF_FUNC @@ -2330,91 +3415,288 @@ sub read_multipart { my($buffer) = $self->new_MultipartBuffer($boundary,$length); return unless $buffer; my(%header,$body); + my $filenumber = 0; while (!$buffer->eof) { %header = $buffer->readHeader; - die "Malformed multipart POST\n" unless %header; - # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition" - # Sheesh. - my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition'; - my($param)= $header{$key}=~/ name="([^\"]*)"/; + unless (%header) { + $self->cgi_error("400 Bad request (malformed multipart POST)"); + return; + } + + $header{'Content-Disposition'} ||= ''; # quench uninit variable warning - # possible bug: our regular expression expects the filename= part to fall - # at the end of the line. Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{$key}=~/ filename="(.*)"$/; + my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/; + $param .= $TAINTED; + + # 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 ||= ''; # quench uninit variable warning + + $filename =~ s/^"([^"]*)"$/$1/; + # Test for Opera's multiple upload feature + my($multipart) = ( defined( $header{'Content-Type'} ) && + $header{'Content-Type'} =~ /multipart\/mixed/ ) ? + 1 : 0; # add this parameter to our list $self->add_parameter($param); # If no filename specified, then just read the data and assign it # to our parameter list. - unless ($filename) { + if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) { my($value) = $buffer->readBody; - push(@{$self->{$param}},$value); + $value .= $TAINTED; + push(@{$self->{param}{$param}},$value); next; } - # 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. - my($tmpfile) = new TempFile; - my $tmp = $tmpfile->as_string; - - open (OUT,">$tmp") || die "CGI open of $tmpfile: $!\n"; - $CGI::DefaultClass->binmode(OUT) if $CGI::needs_binmode; - chmod 0666,$tmp; # make sure anyone can delete it. - my $data; - while ($data = $buffer->read) { - print OUT $data; - } - close OUT; - - # Now create a new filehandle in the caller's namespace. - # The name of this filehandle just happens to be identical - # to the original filename (NOT the name of the temporary - # file, which is hidden!) - my($filehandle); - if ($filename=~/^[a-zA-Z_]/) { - my($frame,$cp)=(1); - do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()"); - $filehandle = "$cp\:\:$filename"; - } else { - $filehandle = "\:\:$filename"; + 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; + } + + # set the filename to some recognizable value + if ( ( !defined($filename) || $filename eq '' ) && $multipart ) { + $filename = "multipart/mixed"; + } + + # 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($filename,$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); + + # if this is an multipart/mixed attachment, save the header + # together with the body for later parsing with an external + # MIME parser module + if ( $multipart ) { + for ( keys %header ) { + print $filehandle "$_: $header{$_}${CRLF}"; + } + print $filehandle "${CRLF}"; + } + + my ($data); + local($\) = ''; + 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 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}{$param}},$filehandle); + } + } +} +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; } - open($filehandle,$tmp) || die "CGI open of $tmp: $!\n"; - $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; - - push(@{$self->{$param}},$filename); - - # Under Unix, it would be safe to let the temporary file - # be deleted immediately. However, I fear that other operating - # systems are not so forgiving. Therefore we save a reference - # to the temporary file in the CGI object so that the file - # isn't unlinked until the CGI object itself goes out of - # scope. This is a bit hacky, but it has the interesting side - # effect that one can access the name of the tmpfile by - # asking for $query->{$query->param('foo')}, where 'foo' - # is the name of the file upload field. - $self->{'.tmpfiles'}->{$filename}= { - name=>$tmpfile, - info=>{%header} + 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}{$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); + return unless @param; + return wantarray ? @param : $param[0]; } END_OF_FUNC 'tmpFileName' => <<'END_OF_FUNC', sub tmpFileName { my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{$filename}->{name}->as_string; + return $self->{'.tmpfiles'}->{$$filename}->{name} ? + $self->{'.tmpfiles'}->{$$filename}->{name}->as_string + : ''; } END_OF_FUNC -'uploadInfo' => <<'END_OF_FUNC' +'uploadInfo' => <<'END_OF_FUNC', sub uploadInfo { my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{$filename}->{info}; + return $self->{'.tmpfiles'}->{$$filename}->{info}; +} +END_OF_FUNC + +# internal routine, don't use +'_set_values_and_labels' => <<'END_OF_FUNC', +sub _set_values_and_labels { + my $self = shift; + my ($v,$l,$n) = @_; + $$l = $v if ref($v) eq 'HASH' && !ref($$l); + return $self->param($n) if !defined($v); + return $v if !ref($v); + return ref($v) eq 'HASH' ? keys %$v : @$v; +} +END_OF_FUNC + +# internal routine, don't use +'_set_attributes' => <<'END_OF_FUNC', +sub _set_attributes { + my $self = shift; + my($element, $attributes) = @_; + return '' unless defined($attributes->{$element}); + $attribs = ' '; + for my $attrib (keys %{$attributes->{$element}}) { + (my $clean_attrib = $attrib) =~ s/^-//; + $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" "; + } + $attribs =~ s/ $//; + return $attribs; +} +END_OF_FUNC + +'_compile_all' => <<'END_OF_FUNC', +sub _compile_all { + for (@_) { + next if defined(&$_); + $AUTOLOAD = "CGI::$_"; + _compile(); + } } END_OF_FUNC @@ -2422,19 +3704,102 @@ END_OF_FUNC END_OF_AUTOLOAD ; -# Globals and stubs for other packages that we use +######################################################### +# Globals and stubs for other packages that we use. +######################################################### + +################### Fh -- lightweight filehandle ############### +package Fh; + +use overload + '""' => \&asString, + 'cmp' => \&compare, + 'fallback'=>1; + +$FH='fh00000'; + +*Fh::AUTOLOAD = \&CGI::AUTOLOAD; + +sub DESTROY { + my $self = shift; + close $self; +} + +$AUTOLOADED_ROUTINES = ''; # prevent -w error +$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; +%SUBS = ( +'asString' => <<'END_OF_FUNC', +sub asString { + my $self = shift; + # get rid of package name + (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//; + $i =~ s/%(..)/ chr(hex($1)) /eg; + return $i.$CGI::TAINTED; +# BEGIN DEAD CODE +# This was an extremely clever patch that allowed "use strict refs". +# Unfortunately it relied on another bug that caused leaky file descriptors. +# The underlying bug has been fixed, so this no longer works. However +# "strict refs" still works for some reason. +# my $self = shift; +# return ${*{$self}{SCALAR}}; +# END DEAD CODE +} +END_OF_FUNC + +'compare' => <<'END_OF_FUNC', +sub compare { + my $self = shift; + my $value = shift; + return "$self" cmp $value; +} +END_OF_FUNC + +'new' => <<'END_OF_FUNC', +sub new { + my($pack,$name,$file,$delete) = @_; + _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; + require Fcntl unless defined &Fcntl::O_RDWR; + (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg; + my $fv = ++$FH . $safename; + my $ref = \*{"Fh::$fv"}; + $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; + CORE::delete $Fh::{$fv}; + return bless $ref,$pack; +} +END_OF_FUNC + +'handle' => <<'END_OF_FUNC', +sub handle { + my $self = shift; + eval "require IO::Handle" unless IO::Handle->can('new_from_fd'); + return IO::Handle->new_from_fd(fileno $self,"<"); +} +END_OF_FUNC + +); +END_OF_AUTOLOAD + +######################## MultipartBuffer #################### package MultipartBuffer; +use constant DEBUG => 0; + # how many bytes to read at a time. We use -# a 5K buffer by default. -$FILLUNIT = 1024 * 5; -$TIMEOUT = 10*60; # 10 minute timeout -$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers +# a 4K buffer by default. +$INITIAL_FILLUNIT = 1024 * 4; +$TIMEOUT = 240*60; # 4 hour timeout for big files +$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers $CRLF=$CGI::CRLF; #reuse the autoload function *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD; +# avoid autoloader warnings +sub DESTROY {} + ############################################################################### ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### ############################################################################### @@ -2444,17 +3809,10 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'new' => <<'END_OF_FUNC', sub new { - my($package,$interface,$boundary,$length,$filehandle) = @_; - my $IN; - if ($filehandle) { - my($package) = caller; - # force into caller's package if necessary - $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; - } - $IN = "main::STDIN" unless $IN; + my($package,$interface,$boundary,$length) = @_; + $FILLUNIT = $INITIAL_FILLUNIT; + $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always - $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode; - # If the user types garbage into the file upload field, # then Netscape passes NOTHING to the server (not good). # We may hang on this read in that case. So we implement @@ -2463,26 +3821,29 @@ sub new { # Netscape seems to be a little bit unreliable # about providing boundary strings. + my $boundary_read = 0; if ($boundary) { # Under the MIME spec, the boundary consists of the # characters "--" PLUS the Boundary string - $boundary = "--$boundary"; - # Read the topmost (boundary) line plus the CRLF - my($null) = ''; - $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0); + + # BUG: IE 3.01 on the Macintosh uses just the boundary -- not + # the two extra hyphens. We do a special case here on the user-agent!!!! + $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport'); + } else { # otherwise we find it ourselves my($old); ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line - $boundary = <$IN>; # BUG: This won't work correctly under mod_perl + $boundary = ; # BUG: This won't work correctly under mod_perl $length -= length($boundary); chomp($boundary); # remove the CRLF $/ = $old; # restore old line separator + $boundary_read++; } my $self = {LENGTH=>$length, + CHUNKED=>!$length, BOUNDARY=>$boundary, - IN=>$IN, INTERFACE=>$interface, BUFFER=>'', }; @@ -2490,7 +3851,15 @@ sub new { $FILLUNIT = length($boundary) if length($boundary) > $FILLUNIT; - return bless $self,ref $package || $package; + my $retval = bless $self,ref $package || $package; + + # Read the preamble and the topmost (boundary) line plus the CRLF. + unless ($boundary_read) { + while ($self->read(0)) { } + } + die "Malformed multipart POST: data truncated\n" if $self->eof; + + return $retval; } END_OF_FUNC @@ -2500,20 +3869,42 @@ sub readHeader { my($end); my($ok) = 0; my($bad) = 0; + + local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; + do { $self->fillBuffer($FILLUNIT); $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; $ok++ if $self->{BUFFER} eq ''; $bad++ if !$ok && $self->{LENGTH} <= 0; - $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; + # this was a bad idea + # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; } until $ok || $bad; return () if $bad; + #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines! + my($header) = substr($self->{BUFFER},0,$end+2); substr($self->{BUFFER},0,$end+4) = ''; my %return; - while ($header=~/^([\w-]+): (.*)$CRLF/mog) { - $return{$1}=$2; + + if ($CGI::EBCDIC) { + warn "untranslated header=$header\n" if DEBUG; + $header = CGI::Util::ascii2ebcdic($header); + warn "translated header=$header\n" if DEBUG; + } + + # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 + # (Folding Long Header Fields), 3.4.3 (Comments) + # and 3.4.5 (Quoted-Strings). + + my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; + $header=~s/$CRLF\s+/ /og; # merge continuation lines + + while ($header=~/($token+):\s+([^$CRLF]*)/mgox) { + my ($field_name,$field_value) = ($1,$2); + $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize + $return{$field_name}=$field_value; } return %return; } @@ -2525,9 +3916,18 @@ sub readBody { my($self) = @_; my($data); my($returnval)=''; + + #EBCDIC NOTE: want to translate returnval into EBCDIC HERE + while (defined($data = $self->read)) { $returnval .= $data; } + + if ($CGI::EBCDIC) { + warn "untranslated body=$returnval\n" if DEBUG; + $returnval = CGI::Util::ascii2ebcdic($returnval); + warn "translated body=$returnval\n" if DEBUG; + } return $returnval; } END_OF_FUNC @@ -2540,49 +3940,58 @@ sub read { my($self,$bytes) = @_; # default number of bytes to read - $bytes = $bytes || $FILLUNIT; + $bytes = $bytes || $FILLUNIT; # Fill up our internal buffer in such a way that the boundary # is never split between reads. $self->fillBuffer($bytes); + my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY}; + my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--'; + # Find the boundary in the buffer (it may not be there). - my $start = index($self->{BUFFER},$self->{BOUNDARY}); + my $start = index($self->{BUFFER},$boundary_start); + + warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG; + # protect against malformed multipart POST operations - die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0); + die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0); + + #EBCDIC NOTE: want to translate boundary search into ASCII here. # If the boundary begins the data, then skip past it - # and return undef. The +2 here is a fiendish plot to - # remove the CR/LF pair at the end of the boundary. + # and return undef. if ($start == 0) { # clear us out completely if we've hit the last boundary. - if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) { + if (index($self->{BUFFER},$boundary_end)==0) { $self->{BUFFER}=''; $self->{LENGTH}=0; return undef; } # just remove the boundary. - substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)=''; + substr($self->{BUFFER},0,length($boundary_start))=''; + $self->{BUFFER} =~ s/^\012\015?//; return undef; } - my $bytesToReturn; + my $bytesToReturn; if ($start > 0) { # read up to the boundary - $bytesToReturn = $start > $bytes ? $bytes : $start; + $bytesToReturn = $start-2 > $bytes ? $bytes : $start; } else { # read the requested number of bytes # leave enough bytes in the buffer to allow us to read # the boundary. Thanks to Kevin Hendrick for finding # this one. - $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1); + $bytesToReturn = $bytes - (length($boundary_start)+1); } my $returnval=substr($self->{BUFFER},0,$bytesToReturn); substr($self->{BUFFER},0,$bytesToReturn)=''; # If we hit the boundary, remove the CRLF from the end. - return ($start > 0) ? substr($returnval,0,-2) : $returnval; + return ($bytesToReturn==$start) + ? substr($returnval,0,-2) : $returnval; } END_OF_FUNC @@ -2592,32 +4001,33 @@ END_OF_FUNC 'fillBuffer' => <<'END_OF_FUNC', sub fillBuffer { my($self,$bytes) = @_; - return unless $self->{LENGTH}; + return unless $self->{CHUNKED} || $self->{LENGTH}; my($boundaryLength) = length($self->{BOUNDARY}); my($bufferLength) = length($self->{BUFFER}); my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; - $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead; + $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead; - # Try to read some data. We may hang here if the browser is screwed up. - my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN}, - \$self->{BUFFER}, + # Try to read some data. We may hang here if the browser is screwed up. + my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER}, $bytesToRead, $bufferLength); + warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG; + $self->{BUFFER} = '' unless defined $self->{BUFFER}; # An apparent bug in the Apache server causes the read() # to return zero bytes repeatedly without blocking if the # remote user aborts during a file transfer. I don't know how # they manage this, but the workaround is to abort if we get # more than SPIN_LOOP_MAX consecutive zero reads. - if ($bytesRead == 0) { + if ($bytesRead <= 0) { die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); } else { $self->{ZERO_LOOP_COUNTER}=0; } - $self->{LENGTH} -= $bytesRead; + $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead; } END_OF_FUNC @@ -2638,22 +4048,58 @@ END_OF_AUTOLOAD #################################################################################### ################################## TEMPORARY FILES ################################# #################################################################################### -package TempFile; +package CGITempFile; + +sub find_tempdir { + $SL = $CGI::SL; + $MAC = $CGI::OS eq 'MACINTOSH'; + my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; + unless (defined $TMPDIRECTORY) { + @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", + "C:${SL}temp","${SL}tmp","${SL}temp", + "${vol}${SL}Temporary Items", + "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", + "C:${SL}system${SL}temp"); + + if( $CGI::OS eq 'WINDOWS' ){ + unshift @TEMP, + $ENV{TEMP}, + $ENV{TMP}, + $ENV{WINDIR} . $SL . 'TEMP'; + } -$SL = $CGI::SL; -unless ($TMPDIRECTORY) { - @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items"); - foreach (@TEMP) { - do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; + unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'}; + + # this feature was supposed to provide per-user tmpfiles, but + # it is problematic. + # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX'; + # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this + # : can generate a 'getpwuid() not implemented' exception, even though + # : it's never called. Found under DOS/Win with the DJGPP perl port. + # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX. + # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0; + + for (@TEMP) { + do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; } + } + $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; } -$TMPDIRECTORY = "." unless $TMPDIRECTORY; -$SEQUENCE="CGItemp${$}0000"; +find_tempdir(); + +$MAXTRIES = 5000; # cute feature, but overload implementation broke it # %OVERLOAD = ('""'=>'as_string'); -*TempFile::AUTOLOAD = \&CGI::AUTOLOAD; +*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD; + +sub DESTROY { + my($self) = @_; + $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\~-]+)$! || return; + my $safe = $1; # untaint operation + unlink $safe; # get rid of the file +} ############################################################################### ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### @@ -2664,17 +4110,17 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'new' => <<'END_OF_FUNC', sub new { - my($package) = @_; - $SEQUENCE++; - my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}"; - return bless \$directory; -} -END_OF_FUNC - -'DESTROY' => <<'END_OF_FUNC', -sub DESTROY { - my($self) = @_; - unlink $$self; # get rid of the file + my($package,$sequence) = @_; + my $filename; + find_tempdir() unless -w $TMPDIRECTORY; + for (my $i = 0; $i < $MAXTRIES; $i++) { + 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_\+ \'\":/.\$\\~-]+)$!; + # this used to untaint, now it doesn't + # $filename = $1; + return bless \$filename; } END_OF_FUNC @@ -2700,104 +4146,238 @@ if ($^W) { $MultipartBuffer::SPIN_LOOP_MAX; $MultipartBuffer::CRLF; $MultipartBuffer::TIMEOUT; - $MultipartBuffer::FILLUNIT; - $TempFile::SEQUENCE; + $MultipartBuffer::INITIAL_FILLUNIT; EOF ; } -$revision; +1; __END__ =head1 NAME -CGI - Simple Common Gateway Interface Class +CGI - Handle Common Gateway Interface requests and responses =head1 SYNOPSIS - use CGI; - # the rest is too complicated for a synopsis; keep reading + use CGI; -=head1 ABSTRACT + my $q = CGI->new; -This perl library uses perl5 objects to make it easy to create -Web fill-out forms and parse their contents. This package -defines CGI objects, entities that contain the values of the -current query string and other state variables. -Using a CGI object's methods, you can examine keywords and parameters -passed to your script, and create forms whose initial values -are taken from the current query (thereby preserving state -information). + # Process an HTTP request + @values = $q->param('form_field'); -The current version of CGI.pm is available at + $fh = $q->upload('file_field'); - http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html - ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ + $riddle = $query->cookie('riddle_name'); + %answers = $query->cookie('answers'); -=head1 INSTALLATION + # Prepare various HTTP responses + print $q->header(); + print $q->header('application/json'); -CGI is a part of the base Perl installation. However, you may need -to install a newer version someday. Therefore: + $cookie1 = $q->cookie(-name=>'riddle_name', -value=>"The Sphynx's Question"); + $cookie2 = $q->cookie(-name=>'answers', -value=>\%answers); + print $q->header( + -type => 'image/gif', + -expires => '+3d', + -cookie => [$cookie1,$cookie2] + ); -To install this package, just change to the directory in which this -file is found and type the following: + print $q->redirect('http://somewhere.else/in/movie/land'); - perl Makefile.PL - make - make install +=head1 DESCRIPTION -This will copy CGI.pm to your perl library directory for use by all -perl scripts. You probably must be root to do this. Now you can -load the CGI routines in your Perl scripts with the line: +CGI.pm is a stable, complete and mature solution for processing and preparing +HTTP requests and responses. Major features including processing form +submissions, file uploads, reading and writing cookies, query string generation +and manipulation, and processing and preparing HTTP headers. Some HTML +generation utilities are included as well. + +CGI.pm performs very well in in a vanilla CGI.pm environment and also comes +with built-in support for mod_perl and mod_perl2 as well as FastCGI. + +It has the benefit of having developed and refined over 10 years with input +from dozens of contributors and being deployed on thousands of websites. +CGI.pm has been included in the Perl distribution since Perl 5.4, and has +become a de-facto standard. + +=head2 PROGRAMMING STYLE + +There are two styles of programming with CGI.pm, an object-oriented +style and a function-oriented style. In the object-oriented style you +create one or more CGI objects and then use object methods to create +the various elements of the page. Each CGI object starts out with the +list of named parameters that were passed to your CGI script by the +server. You can modify the objects, save them to a file or database +and recreate them. Because each object corresponds to the "state" of +the CGI script, and because each object's parameter list is +independent of the others, this allows you to save the state of the +script and restore it later. + +For example, using the object oriented style, here is how you create +a simple "Hello World" HTML page: + + #!/usr/local/bin/perl -w + use CGI; # load CGI routines + $q = new CGI; # create new CGI object + print $q->header, # create the HTTP header + $q->start_html('hello world'), # start the HTML + $q->h1('hello world'), # level 1 header + $q->end_html; # end the HTML + +In the function-oriented style, there is one default CGI object that +you rarely deal with directly. Instead you just call functions to +retrieve CGI parameters, create HTML tags, manage cookies, and so +on. This provides you with a cleaner programming interface, but +limits you to using one CGI object at a time. The following example +prints the same page, but uses the function-oriented interface. +The main differences are that we now need to import a set of functions +into our name space (usually the "standard" functions), and we don't +need to create the CGI object. + + #!/usr/local/bin/perl + use CGI qw/:standard/; # load standard CGI routines + print header, # create the HTTP header + start_html('hello world'), # start the HTML + h1('hello world'), # level 1 header + end_html; # end the HTML + +The examples in this document mainly use the object-oriented style. +See HOW TO IMPORT FUNCTIONS for important information on +function-oriented programming in CGI.pm + +=head2 CALLING CGI.PM ROUTINES + +Most CGI.pm routines accept several arguments, sometimes as many as 20 +optional ones! To simplify this interface, all routines use a named +argument calling style that looks like this: + + print $q->header(-type=>'image/gif',-expires=>'+3d'); + +Each argument name is preceded by a dash. Neither case nor order +matters in the argument list. -type, -Type, and -TYPE are all +acceptable. In fact, only the first argument needs to begin with a +dash. If a dash is present in the first argument, CGI.pm assumes +dashes for the subsequent ones. + +Several routines are commonly called with just one argument. In the +case of these routines you can provide the single argument without an +argument name. header() happens to be one of these routines. In this +case, the single argument is the document type. + + print $q->header('text/html'); + +Other such routines are documented below. + +Sometimes named arguments expect a scalar, sometimes a reference to an +array, and sometimes a reference to a hash. Often, you can pass any +type of argument and the routine will do whatever is most appropriate. +For example, the param() routine is used to set a CGI parameter to a +single or a multi-valued value. The two cases are shown below: + + $q->param(-name=>'veggie',-value=>'tomato'); + $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']); + +A large number of routines in CGI.pm actually aren't specifically +defined in the module, but are generated automatically as needed. +These are the "HTML shortcuts," routines that generate HTML tags for +use in dynamically-generated pages. HTML tags have both attributes +(the attribute="value" pairs within the tag itself) and contents (the +part between the opening and closing pairs.) To distinguish between +attributes and contents, CGI.pm uses the convention of passing HTML +attributes as a hash reference as the first argument, and the +contents, if any, as any subsequent arguments. It works out like +this: + + Code Generated HTML + ---- -------------- + h1()

+ h1('some','contents');

some contents

+ h1({-align=>left});

+ h1({-align=>left},'contents');

contents

+ +HTML tags are described in more detail later. + +Many newcomers to CGI.pm are puzzled by the difference between the +calling conventions for the HTML shortcuts, which require curly braces +around the HTML tag attributes, and the calling conventions for other +routines, which manage to generate attributes without the curly +brackets. Don't be confused. As a convenience the curly braces are +optional in all but the HTML shortcuts. If you like, you can use +curly braces when calling any routine that takes named arguments. For +example: + + print $q->header( {-type=>'image/gif',-expires=>'+3d'} ); + +If you use the B<-w> switch, you will be warned that some CGI.pm argument +names conflict with built-in Perl functions. The most frequent of +these is the -values argument, used to create multi-valued menus, +radio button clusters and the like. To get around this warning, you +have several choices: - use CGI; +=over 4 -If you don't have sufficient privileges to install CGI.pm in the Perl -library directory, you can put CGI.pm into some convenient spot, such -as your home directory, or in cgi-bin itself and prefix all Perl -scripts that call it with something along the lines of the following -preamble: +=item 1. - use lib '/home/davis/lib'; - use CGI; +Use another name for the argument, if one is available. +For example, -value is an alias for -values. -If you are using a version of perl earlier than 5.002 (such as NT perl), use -this instead: +=item 2. - BEGIN { - unshift(@INC,'/home/davis/lib'); - } - use CGI; +Change the capitalization, e.g. -Values + +=item 3. -The CGI distribution also comes with a cute module called L. -It redefines the die(), warn(), confess() and croak() error routines -so that they write nicely formatted error messages into the server's -error log (or to the output stream of your choice). This avoids long -hours of groping through the error and access logs, trying to figure -out which CGI script is generating error messages. If you choose, -you can even have fatal error messages echoed to the browser to avoid -the annoying and uninformative "Server Error" message. +Put quotes around the argument name, e.g. '-values' -=head1 DESCRIPTION +=back + +Many routines will do something useful with a named argument that it +doesn't recognize. For example, you can produce non-standard HTTP +header fields by providing them as named arguments: + + print $q->header(-type => 'text/html', + -cost => 'Three smackers', + -annoyance_level => 'high', + -complaints_to => 'bit bucket'); + +This will produce the following nonstandard HTTP header: + + HTTP/1.0 200 OK + Cost: Three smackers + Annoyance-level: high + Complaints-to: bit bucket + Content-type: text/html -=head2 CREATING A NEW QUERY OBJECT: +Notice the way that underscores are translated automatically into +hyphens. HTML-generating routines perform a different type of +translation. + +This feature allows you to keep up with the rapidly changing HTTP and +HTML "standards". + +=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE): $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 $query = new CGI(INPUTFILE); -If you provide a file handle to the new() method, it -will read parameters from the file (or STDIN, or whatever). The -file can be in any of the forms describing below under debugging -(i.e. a series of newline delimited TAG=VALUE pairs will work). -Conveniently, this type of file is created by the save() method -(see below). Multiple records can be saved and restored. +If you provide a file handle to the new() method, it will read +parameters from the file (or STDIN, or whatever). The file can be in +any of the forms describing below under debugging (i.e. a series of +newline delimited TAG=VALUE pairs will work). Conveniently, this type +of file is created by the save() method (see below). Multiple records +can be saved and restored. Perl purists will be pleased to know that this syntax accepts references to file handles, or even references to filehandle globs, @@ -2805,7 +4385,19 @@ which is the "official" way to pass a filehandle: $query = new CGI(\*STDIN); -You can also initialize the query object from an associative array +You can also initialize the CGI object with a FileHandle or IO::File +object. + +If you are using the function-oriented interface and want to +initialize CGI state from a file handle, the way to do this is with +B. This will (re)initialize the +default CGI object from the indicated file handle. + + open (IN,"test.in") || die; + restore_parameters(IN); + close IN; + +You can also initialize the query object from a hash reference: $query = new CGI( {'dinosaur'=>'barney', @@ -2817,11 +4409,20 @@ or from a properly formatted, URL-escaped query string: $query = new CGI('dinosaur=barney&color=purple'); +or from a previously existing CGI object (currently this clones the +parameter list, but none of the other object-specific fields, such as +autoescaping): + + $old_query = new CGI; + $new_query = new CGI($old_query); + To create an empty query, initialize it from an empty string or hash: - $empty_query = new CGI(""); - -or- - $empty_query = new CGI({}); + $empty_query = new CGI(""); + + -or- + + $empty_query = new CGI({}); =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY: @@ -2835,10 +4436,11 @@ parsed keywords can be obtained as an array using the keywords() method. @names = $query->param If the script was invoked with a parameter list -(e.g. "name1=value1&name2=value2&name3=value3"), the param() -method will return the parameter names as a list. If the -script was invoked as an script, there will be a -single parameter named 'keywords'. +(e.g. "name1=value1&name2=value2&name3=value3"), the param() method +will return the parameter names as a list. If the script was invoked +as an script and contains a string without ampersands +(e.g. "value1+value2+value3") , there will be a single parameter named +"keywords" containing the "+"-delimited keywords. NOTE: As of version 1.5, the array of parameter names returned will be in the same order as they were submitted by the browser. @@ -2859,6 +4461,14 @@ named parameter. If the parameter is multivalued (e.g. from multiple selections in a scrolling list), you can ask to receive an array. Otherwise the method will return a single value. +If a value is not given in the query string, as in the queries +"name1=&name2=", it will be returned as an empty string. + + +If the parameter does not exist at all, then param() will return undef +in a scalar context, and the empty list in a list context. + + =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER: $query->param('foo','an','array','of','values'); @@ -2880,7 +4490,7 @@ in more detail later: =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER: - $query->append(-name=>;'foo',-values=>['yet','more','values']); + $query->append(-name=>'foo',-values=>['yet','more','values']); This adds a value or list of values to the named parameter. The values are appended to the end of the parameter if it already exists. @@ -2897,28 +4507,100 @@ If no namespace is given, this method will assume 'Q'. WARNING: don't import anything into 'main'; this is a major security risk!!!! -In older versions, this method was called B. As of version 2.20, +NOTE 1: Variable names are transformed as necessary into legal Perl +variable names. All non-legal characters are transformed into +underscores. If you need to keep the original names, you should use +the param() method instead to access CGI variables by name. + +NOTE 2: In older versions, this method was called B. As of version 2.20, this name has been removed completely to avoid conflict with the built-in Perl module B operator. =head2 DELETING A PARAMETER COMPLETELY: - $query->delete('foo'); + $query->delete('foo','bar','baz'); -This completely clears a parameter. It sometimes useful for -resetting parameters that you don't want passed down between -script invocations. +This completely clears a list of parameters. It sometimes useful for +resetting parameters that you don't want passed down between script +invocations. + +If you are using the function call interface, use "Delete()" instead +to avoid conflicts with Perl's built-in delete operator. =head2 DELETING ALL PARAMETERS: -$query->delete_all(); + $query->delete_all(); This clears the CGI object completely. It might be useful to ensure that all the defaults are taken when you create a fill-out form. -=head2 SAVING THE STATE OF THE FORM TO A FILE: +Use Delete_all() instead if you are using the function call interface. + +=head2 HANDLING NON-URLENCODED ARGUMENTS + + +If POSTed data is not of type application/x-www-form-urlencoded or +multipart/form-data, then the POSTed data will not be processed, but +instead be returned as-is in a parameter named POSTDATA. To retrieve +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.) + + +=head2 DIRECT ACCESS TO THE PARAMETER LIST: + + $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; + unshift @{$q->param_fetch(-name=>'address')},'George Munster'; + +If you need access to the parameter list in a way that isn't covered +by the methods above, you can obtain a direct reference to it by +calling the B method with the name of the . This +will return an array reference to the named parameters, which you then +can manipulate in any way you like. + +You can also use a named argument style using the B<-name> argument. + +=head2 FETCHING THE PARAMETER LIST AS A HASH: + + $params = $q->Vars; + print $params->{'address'}; + @foo = split("\0",$params->{'foo'}); + %params = $q->Vars; + + use CGI ':cgi-lib'; + $params = Vars; + +Many people want to fetch the entire parameter list as a hash in which +the keys are the names of the CGI parameters, and the values are the +parameters' values. The Vars() method does this. Called in a scalar +context, it returns the parameter list as a tied hash reference. +Changing a key changes the value of the parameter in the underlying +CGI parameter list. Called in a list context, it returns the +parameter list as an ordinary hash. This allows you to read the +contents of the parameter list, but not to change it. + +When using this, the thing you must watch out for are multivalued CGI +parameters. Because a hash cannot distinguish between scalar and +list context, multivalued parameters will be returned as a packed +string, separated by the "\0" (null) character. You must split this +packed string in order to get at the individual values. This is the +convention introduced long ago by Steve Brenner in his cgi-lib.pl +module for Perl version 4. + +If you wish to use Vars() as a function, import the I<:cgi-lib> set of +function calls (also see the section on CGI-LIB compatibility). - $query->save(FILEHANDLE) +=head2 SAVING THE STATE OF THE SCRIPT TO A FILE: + + $query->save(\*FILEHANDLE) This will write the current state of the form to the provided filehandle. You can read it back in by providing a filehandle @@ -2945,360 +4627,1097 @@ a short example of creating multiple session records: open (OUT,">>test.out") || die; $records = 5; - foreach (0..$records) { + for (0..$records) { my $q = new CGI; $q->param(-name=>'counter',-value=>$_); - $q->save(OUT); + $q->save(\*OUT); } close OUT; # reopen for reading open (IN,"test.out") || die; while (!eof(IN)) { - my $q = new CGI(IN); + my $q = new CGI(\*IN); print $q->param('counter'),"\n"; } -The file format used for save/restore is identical to that used by the -Whitehead Genome Center's data exchange format "Boulderio", and can be -manipulated and even databased using Boulderio utilities. See - - http://www.genome.wi.mit.edu/genome_software/other/boulder.html +The file format used for save/restore is identical to that used by the +Whitehead Genome Center's data exchange format "Boulderio", and can be +manipulated and even databased using Boulderio utilities. See + + http://stein.cshl.org/boulder/ + +for further details. + +If you wish to use this method from the function-oriented (non-OO) +interface, the exported name for this method is B. + +=head2 RETRIEVING CGI ERRORS + +Errors can occur while processing user input, particularly when +processing uploaded files. When these errors occur, CGI will stop +processing and return an empty parameter list. You can test for +the existence and nature of errors using the I function. +The error messages are formatted as HTTP status codes. You can either +incorporate the error text into an HTML page, or use it as the value +of the HTTP status: + + my $error = $q->cgi_error; + if ($error) { + print $q->header(-status=>$error), + $q->start_html('Problems'), + $q->h2('Request not processed'), + $q->strong($error); + exit 0; + } + +When using the function-oriented interface (see the next section), +errors may only occur the first time you call I. Be ready +for this! + +=head2 USING THE FUNCTION-ORIENTED INTERFACE + +To use the function-oriented interface, you must specify which CGI.pm +routines or sets of routines to import into your script's namespace. +There is a small overhead associated with this importation, but it +isn't much. + + use CGI ; + +The listed methods will be imported into the current package; you can +call them directly without creating a CGI object first. This example +shows how to import the B and B +methods, and then use them directly: + + use CGI 'param','header'; + print header('text/plain'); + $zipcode = param('zipcode'); + +More frequently, you'll import common sets of functions by referring +to the groups by name. All function sets are preceded with a ":" +character as in ":html3" (for tags defined in the HTML 3 standard). + +Here is a list of the function sets you can import: + +=over 4 + +=item B<:cgi> + +Import all CGI-handling methods, such as B, B +and the like. + +=item B<:form> + +Import all fill-out form generating methods, such as B. + +=item B<:html2> + +Import all methods that generate HTML 2.0 standard elements. + +=item B<:html3> + +Import all methods that generate HTML 3.0 elements (such as +, and ). + +=item B<:html4> + +Import all methods that generate HTML 4 elements (such as +, and ). + +=item B<:netscape> + +Import all methods that generate Netscape-specific HTML extensions. + +=item B<:html> + +Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' + +'netscape')... + +=item B<:standard> + +Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'. + +=item B<:all> + +Import all the available methods. For the full list, see the CGI.pm +code, where the variable %EXPORT_TAGS is defined. + +=back + +If you import a function name that is not part of CGI.pm, the module +will treat it as a new HTML tag and generate the appropriate +subroutine. You can then use it like any other HTML tag. This is to +provide for the rapidly-evolving HTML "standard." For example, say +Microsoft comes out with a new tag called (which causes the +user's desktop to be flooded with a rotating gradient fill until his +machine reboots). You don't need to wait for a new version of CGI.pm +to start using it immediately: + + use CGI qw/:standard :html3 gradient/; + print gradient({-start=>'red',-end=>'blue'}); + +Note that in the interests of execution speed CGI.pm does B use +the standard L syntax for specifying load symbols. This may +change in the future. + +If you import any of the state-maintaining CGI or form-generating +methods, a default CGI object will be created and initialized +automatically the first time you use any of the methods that require +one to be present. This includes B, B, +B and the like. (If you need direct access to the CGI +object, you can find it in the global variable B<$CGI::Q>). By +importing CGI.pm methods, you can create visually elegant scripts: + + use CGI qw/:standard/; + print + header, + start_html('Simple Script'), + h1('Simple Script'), + start_form, + "What's your name? ",textfield('name'),p, + "What's the combination?", + checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','moe']),p, + "What's your favorite color?", + popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']),p, + submit, + end_form, + hr,"\n"; + + if (param) { + print + "Your name is ",em(param('name')),p, + "The keywords are: ",em(join(", ",param('words'))),p, + "Your favorite color is ",em(param('color')),".\n"; + } + print end_html; + +=head2 PRAGMAS + +In addition to the function sets, there are a number of pragmas that +you can import. Pragmas, which are always preceded by a hyphen, +change the way that CGI.pm functions in various ways. Pragmas, +function sets, and individual functions can all be imported in the +same use() line. For example, the following use statement imports the +standard set of functions and enables debugging mode (pragma +-debug): + + use CGI qw/:standard -debug/; + +The current list of pragmas is as follows: + +=over 4 + +=item -any + +When you I, then any method that the query object +doesn't recognize will be interpreted as a new HTML tag. This allows +you to support the next I Netscape or Microsoft HTML +extension. This lets you go wild with new and unsupported tags: + + use CGI qw(-any); + $q=new CGI; + print $q->gradient({speed=>'fast',start=>'red',end=>'blue'}); + +Since using any causes any mistyped method name +to be interpreted as an HTML tag, use it with care or not at +all. + +=item -compile + +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 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); + +or even + + use CGI qw(-compile :all); + +Note that using the -compile pragma in this way will always have +the effect of importing the compiled functions into the current +namespace. If you want to compile without importing use the +compile() method instead: + + use CGI(); + CGI->compile(); + +This is particularly useful in a mod_perl environment, in which you +might want to precompile all CGI routines in a startup script, and +then import the functions individually in each mod_perl script. + +=item -nosticky + +By default the CGI module implements a state-preserving behavior +called "sticky" fields. The way this works is that if you are +regenerating a form, the methods that generate the form field values +will interrogate param() to see if similarly-named parameters are +present in the query string. If they find a like-named parameter, they +will use it to set their default values. + +Sometimes this isn't what you want. The B<-nosticky> pragma prevents +this behavior. You can also selectively change the sticky behavior in +each element that you generate. + +=item -tabindex + +Automatically add tab index attributes to each form field. With this +option turned off, you can still add tab indexes manually by passing a +-tabindex option to each field-generating method. + +=item -no_undef_params + +This keeps CGI.pm from including undef params in the parameter list. + +=item -no_xhtml + +By default, CGI.pm versions 2.69 and higher emit XHTML +(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this +feature. Thanks to Michalis Kabrianis for this +feature. + +If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD, +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 +parsed header) script. You may need to do other things as well +to tell the server that the script is NPH. See the discussion +of NPH scripts below. + +=item -newstyle_urls + +Separate the name=value pairs in CGI parameter query strings with +semicolons rather than ampersands. For example: + + ?name=fred;age=24;favorite_color=3 + +Semicolon-delimited query strings are always accepted, but will not be +emitted by self_url() and query_string() unless the -newstyle_urls +pragma is specified. + +This became the default in version 2.64. + +=item -oldstyle_urls + +Separate the name=value pairs in CGI parameter query strings with +ampersands rather than semicolons. This is no longer the default. + +=item -autoload + +This overrides the autoloader so that any function in your program +that is not recognized is referred to CGI.pm for possible evaluation. +This allows you to use all the CGI.pm functions without adding them to +your symbol table, which is of concern for mod_perl users who are +worried about memory consumption. I when +I<-autoload> is in effect, you cannot use "poetry mode" +(functions without the parenthesis). Use I rather +than I
, or add something like I +to the top of your script. + +=item -no_debug + +This turns off the command-line processing features. If you want to +run a CGI.pm script from the command line to produce HTML, and you +don't want it to read CGI parameters from the command line or STDIN, +then use this pragma: + + use CGI qw(-no_debug :standard); + +=item -debug + +This turns on full debugging. In addition to reading CGI arguments +from the command-line processing, CGI.pm will pause and try to read +arguments from STDIN, producing the message "(offline mode: enter +name=value pairs on standard input)" features. + +See the section on debugging for more details. + +=item -private_tempfiles + +CGI.pm can process uploaded file. Ordinarily it spools the uploaded +file to a temporary directory, then deletes the file when done. +However, this opens the risk of eavesdropping as described in the file +upload section. Another CGI script author could peek at this data +during the upload, even if it is confidential information. On Unix +systems, the -private_tempfiles pragma will cause the temporary file +to be unlinked as soon as it is opened and before any data is written +into it, reducing, but not eliminating the risk of eavesdropping +(there is still a potential race condition). To make life harder for +the attacker, the program chooses tempfile names by calculating a 32 +bit checksum of the incoming HTTP headers. + +To ensure that the temporary file cannot be read by other CGI scripts, +use suEXEC or a CGI wrapper program to run your script. The temporary +file is created with mode 0600 (neither world nor group readable). + +The temporary directory is selected using the following algorithm: + + 1. if the current user (e.g. "nobody") has a directory named + "tmp" in its home directory, use that (Unix systems only). + + 2. if the environment variable TMPDIR exists, use the location + indicated. + + 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp, + /tmp, /temp, ::Temporary Items, and \WWW_ROOT. + +Each of these locations is checked that it is a directory and is +writable. If not, the algorithm tries the next choice. + +=back + +=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS + +Many of the methods generate HTML tags. As described below, tag +functions automatically generate both the opening and closing tags. +For example: + + print h1('Level 1 Header'); + +produces + +

Level 1 Header

+ +There will be some times when you want to produce the start and end +tags yourself. In this case, you can use the form start_I +and end_I, as in: + + print start_h1,'Level 1 Header',end_h1; + +With a few exceptions (described below), start_I and +end_I functions are not generated automatically when you +I. However, you can specify the tags you want to generate +I functions for by putting an asterisk in front of their +name, or, alternatively, requesting either "start_I" or +"end_I" in the import list. + +Example: + + use CGI qw/:standard *table start_ul/; + +In this example, the following functions are generated in addition to +the standard ones: + +=over 4 + +=item 1. start_table() (generates a
tag) + +=item 2. end_table() (generates a
tag) + +=item 3. start_ul() (generates a
    tag) + +=item 4. end_ul() (generates a
tag) + +=back + +=head1 GENERATING DYNAMIC DOCUMENTS + +Most of CGI.pm's functions deal with creating documents on the fly. +Generally you will produce the HTTP header first, followed by the +document itself. CGI.pm provides functions for generating HTTP +headers of various types as well as for generating HTML. For creating +GIF images, see the GD.pm module. + +Each of these functions produces a fragment of HTML or HTTP which you +can print out directly so that it displays in the browser window, +append to a string, or save to a file for later use. + +=head2 CREATING A STANDARD HTTP HEADER: + +Normally the first thing you will do in any CGI script is print out an +HTTP header. This tells the browser what type of document to expect, +and gives other optional information, such as the language, expiration +date, and whether to cache the document. The header can also be +manipulated for special purposes, such as server push and pay per view +pages. + + print header; + + -or- + + print header('image/gif'); + + -or- + + print header('text/html','204 No response'); + + -or- + + print header(-type=>'image/gif', + -nph=>1, + -status=>'402 Payment required', + -expires=>'+3d', + -cookie=>$cookie, + -charset=>'utf-7', + -attachment=>'foo.gif', + -Cost=>'$2.00'); + +header() returns the Content-type: header. You can provide your own +MIME type if you choose, otherwise it defaults to text/html. An +optional second parameter specifies the status code and a human-readable +message. For example, you can specify 204, "No response" to create a +script that tells the browser to do nothing at all. + +The last example shows the named argument style for passing arguments +to the CGI methods using named parameters. Recognized parameters are +B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named +parameters will be stripped of their initial hyphens and turned into +header fields, allowing you to specify any HTTP header you desire. +Internal underscores will be turned into hyphens: + + print header(-Content_length=>3002); + +Most browsers will not cache the output from CGI scripts. Every time +the browser reloads the page, the script is invoked anew. You can +change this behavior with the B<-expires> parameter. When you specify +an absolute or relative expiration interval with this parameter, some +browsers and proxy servers will cache the script's output until the +indicated expiration date. The following forms are all valid for the +-expires field: + + +30s 30 seconds from now + +10m ten minutes from now + +1h one hour from now + -1d yesterday (i.e. "ASAP!") + now immediately + +3M in three months + +10y in ten years time + Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date + +The B<-cookie> parameter generates a header that tells the browser to provide +a "magic cookie" during all subsequent transactions with your script. +Netscape cookies have a special format that includes interesting attributes +such as expiration time. Use the cookie() method to create and retrieve +session cookies. + +The B<-nph> parameter, if set to a true value, will issue the correct +headers to work with a NPH (no-parse-header) script. This is important +to use with certain servers that expect all their scripts to be NPH. + +The B<-charset> parameter can be used to control the character set +sent to the browser. If not provided, defaults to ISO-8859-1. As a +side effect, this sets the charset() method as well. + +The B<-attachment> parameter can be used to turn the page into an +attachment. Instead of displaying the page, some browsers will prompt +the user to save it to disk. The value of the argument is the +suggested name for the saved file. In order for this to work, you may +have to set the B<-type> to "application/octet-stream". + +The B<-p3p> parameter will add a P3P tag to the outgoing header. The +parameter can be an arrayref or a space-delimited string of P3P tags. +For example: + + print header(-p3p=>[qw(CAO DSP LAW CURa)]); + print header(-p3p=>'CAO DSP LAW CURa'); + +In either case, the outgoing header will be formatted as: + + P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa" + +=head2 GENERATING A REDIRECTION HEADER + + print redirect('http://somewhere.else/in/movie/land'); + +Sometimes you don't want to produce a document yourself, but simply +redirect the browser elsewhere, perhaps choosing a URL based on the +time of day or the identity of the user. + +The redirect() function redirects the browser to a different URL. If +you use redirection like this, you should B print out a header as +well. + +You should always use full URLs (including the http: or ftp: part) in +redirection requests. Relative URLs will not work correctly. + +You can also use named arguments: + + print redirect(-uri=>'http://somewhere.else/in/movie/land', + -nph=>1, + -status=>301); + +The B<-nph> parameter, if set to a true value, will issue the correct +headers to work with a NPH (no-parse-header) script. This is important +to use with certain servers, such as Microsoft IIS, which +expect all their scripts to be NPH. + +The B<-status> parameter will set the status of the redirect. HTTP +defines three different possible redirection status codes: + + 301 Moved Permanently + 302 Found + 303 See Other + +The default if not specified is 302, which means "moved temporarily." +You may change the status to another status code if you wish. Be +advised that changing the status to anything other than 301, 302 or +303 will probably break redirection. + +=head2 CREATING THE HTML DOCUMENT HEADER + + print start_html(-title=>'Secrets of the Pyramids', + -author=>'fred@capricorn.org', + -base=>'true', + -target=>'_blank', + -meta=>{'keywords'=>'pharaoh secret mummy', + 'copyright'=>'copyright 1996 King Tut'}, + -style=>{'src'=>'/styles/style1.css'}, + -BGCOLOR=>'blue'); + +After creating the HTTP header, most CGI scripts will start writing +out an HTML document. The start_html() routine creates the top of the +page, along with a lot of optional information that controls the +page's appearance and behavior. + +This method returns a canned HTML header and the opening tag. +All parameters are optional. In the named parameter form, recognized +parameters are -title, -author, -base, -xbase, -dtd, -lang and -target +(see below for the explanation). Any additional parameters you +provide, such as the Netscape unofficial BGCOLOR attribute, are added +to the tag. Additional parameters must be proceeded by a +hyphen. + +The argument B<-xbase> allows you to provide an HREF for the tag +different from the current location, as in + + -xbase=>"http://home.mcom.com/" + +All relative links will be interpreted relative to this tag. + +The argument B<-target> allows you to provide a default target frame +for all the links and fill-out forms on the page. B +See the Netscape documentation on frames for details of how to +manipulate this. + + -target=>"answer_window" + +All relative links will be interpreted relative to this tag. +You add arbitrary meta information to the header with the B<-meta> +argument. This argument expects a reference to a hash +containing name/value pairs of meta information. These will be turned +into a series of header tags that look something like this: + + + + +To create an HTTP-EQUIV type of tag, use B<-head>, described +below. + +The B<-style> argument is used to incorporate cascading stylesheets +into your code. See the section on CASCADING STYLESHEETS for more +information. + +The B<-lang> argument is used to incorporate a language attribute into +the tag. For example: + + print $q->start_html(-lang=>'fr-CA'); + +The default if not specified is "en-US" for US English, unless the +-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the +lang attribute is left off. You can force the lang attribute to left +off in other cases by passing an empty string (-lang=>''). + +The B<-encoding> argument can be used to specify the character set for +XHTML. It defaults to iso-8859-1 if not specified. + +The B<-declare_xml> argument, when used in conjunction with XHTML, +will put a declaration at the top of the HTML header. The sole +purpose of this declaration is to declare the character set +encoding. In the absence of -declare_xml, the output HTML will contain +a tag that specifies the encoding, allowing the HTML to pass +most validators. The default for -declare_xml is false. + +You can place other arbitrary HTML elements to the section with the +B<-head> tag. For example, to place the rarely-used element in the +head section, use this: + + print start_html(-head=>Link({-rel=>'next', + -href=>'http://www.capricorn.com/s2.html'})); + +To incorporate multiple HTML elements into the section, just pass an +array reference: + + print start_html(-head=>[ + Link({-rel=>'next', + -href=>'http://www.capricorn.com/s2.html'}), + Link({-rel=>'previous', + -href=>'http://www.capricorn.com/s1.html'}) + ] + ); + +And here's how to create an HTTP-EQUIV tag: + + print start_html(-head=>meta({-http_equiv => 'Content-Type', + -content => 'text/html'})) + + +JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, +B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used +to add Netscape JavaScript calls to your pages. B<-script> should +point to a block of text containing JavaScript function definitions. +This block will be placed within a