X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=21d74c0eed46261a206fad763706bdc25ba3bffa;hb=23f6cb285656c85849665669b0a13828f0d8b395;hp=c0cb5fd518a75113f1dae6241becdbf216b0dcac;hpb=475342a6d5f74335e2bdfa64bd71f39289320205;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CGI.pm b/lib/CGI.pm index c0cb5fd..21d74c0 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -1,5 +1,6 @@ package CGI; require 5.004; +use Carp 'croak'; # See the bottom of this file for the POD documentation. Search for the # string '=head'. @@ -17,46 +18,83 @@ require 5.004; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.18 1999/06/09 14:52:45 lstein Exp $'; -$CGI::VERSION='2.53'; +$CGI::revision = '$Id: CGI.pm,v 1.260 2008/09/08 14:13:23 lstein Exp $'; +$CGI::VERSION='3.42'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. -# $TempFile::TMPDIRECTORY = '/usr/tmp'; +# $CGITempFile::TMPDIRECTORY = '/usr/tmp'; +use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); + +#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN', +# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd']; + +use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', + 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd']; + +{ + 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 = '-//IETF//DTD HTML//EN'; + $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) + # 2) CGI::nph(1) # 3) print header(-nph=>1) $NPH = 0; - # Set this to 1 to disable debugging from the - # command line - $NO_DEBUG = 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); + # 2) CGI::private_tempfiles(1); $PRIVATE_TEMPFILES = 0; - # Set this to a positive value to limit the size of a POSTing - # to a certain number of bytes: - $POST_MAX = -1; + # Set this to 1 to generate automatic tab indexes + $TABINDEX = 0; - # Change this to 1 to disable uploads entirely: - $DISABLE_UPLOADS = 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; @@ -65,13 +103,24 @@ sub initialize_globals { $HEADERS_ONCE = 0; # separate the name=value pairs by semicolons rather than ampersands - $USE_PARAM_SEMICOLONS = 0; + $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; @@ -79,6 +128,8 @@ sub initialize_globals { # ------------------ START OF THE LIBRARY ------------ +*end_form = \&endform; + # make mod_perlhappy initialize_globals(); @@ -91,22 +142,26 @@ unless ($OS) { $OS = $Config::Config{'osname'}; } } -if ($OS=~/Win/i) { +if ($OS =~ /^MSWin/i) { $OS = 'WINDOWS'; -} elsif ($OS=~/vms/i) { +} elsif ($OS =~ /^VMS/i) { $OS = 'VMS'; -} elsif ($OS=~/dos/i) { +} elsif ($OS =~ /^dos/i) { $OS = 'DOS'; -} elsif ($OS=~/^MacOS$/i) { +} 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|DOS|OS2|MSWin)/; +$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; @@ -117,7 +172,8 @@ $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; # The path separator is a slash, backslash or semicolon, depending # on the paltform. $SL = { - UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' + UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', + WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/' }->{$OS}; # This no longer seems to be necessary @@ -126,13 +182,22 @@ $SL = { $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; # Turn on special checking for Doug MacEachern's modperl -if (exists $ENV{'GATEWAY_INTERFACE'} - && - ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//)) -{ - $| = 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; + } } + # Turn on special checking for ActiveState's PerlEx $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; @@ -151,68 +216,77 @@ if ($OS eq 'VMS') { $CRLF = "\015\012"; } -if ($EBCDIC) { -@A2E = ( - 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, - 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, -240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, -124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, -215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, -121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, -151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, - 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, - 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, - 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, -144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, -100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, -172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, - 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, -140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 - ); -} - 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); } %EXPORT_TAGS = ( ':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/], - ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param - embed basefont style span layer ilayer font frameset frame script small big/], + 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 url self_url script_name cookie Dump + ':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_host remote_ident auth_type http use_named_parameters + 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/], - ':imagemap' => [qw/Area Map/], ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], - ':html' => [qw/:html2 :html3 :netscape/], - ':standard' => [qw/:html2 :html3 :form :cgi/], - ':push' => [qw/multipart_init multipart_start multipart_end/], - ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/] + ':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; + # This causes modules to clash. + undef %EXPORT_OK; + undef %EXPORT; $self->_setup_symbols(@_); my ($callpack, $callfile, $callline) = caller; @@ -254,21 +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; - if ($MOD_PERL) { - Apache->request->register_cleanup(\&CGI::_reset_globals); - undef $NPH; + 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') { + foreach my $href (values %{$self->{'.tmpfiles'}}) { + $href->{hndl}->DESTROY if defined $href->{hndl}; + $href->{name}->DESTROY if defined $href->{name}; } - $self->_reset_globals if $PERLEX; - $self->init($initializer); - return $self; + } +} + +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. @@ -289,10 +427,10 @@ 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) { @@ -300,16 +438,24 @@ sub param { } } # 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}; + + 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 { @@ -320,7 +466,7 @@ sub self_or_default { $Q = $CGI::DefaultClass->new unless defined($Q); unshift(@_,$Q); } - return @_; + return wantarray ? @_ : $Q; } sub self_or_CGI { @@ -348,18 +494,35 @@ sub self_or_CGI { # parameter list with the single parameter 'keywords'. sub init { - my($self,$initializer) = @_; - my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); - local($/) = "\n"; + 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 (@QUERY_PARAM && !defined($initializer)) { - foreach (@QUERY_PARAM) { - $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); - } - return; + if (defined(@QUERY_PARAM) && !defined($initializer)) { + 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'}); @@ -367,12 +530,16 @@ sub init { $fh = to_filehandle($initializer) if $initializer; + # set charset to the safe ISO-8859-1 + $self->charset('ISO-8859-1'); + METHOD: { # avoid unreasonably large postings if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { - $self->cgi_error("413 Request entity too large"); - last METHOD; + #discard the post, unread + $self->cgi_error("413 Request entity too large"); + last METHOD; } # Process multipart postings, but only if the initializer is @@ -387,9 +554,50 @@ sub init { last METHOD; } + # Process XForms postings. We know that we have XForms in the + # following cases: + # method eq 'POST' && content-type eq 'application/xml' + # method eq 'POST' && content-type =~ /multipart\/related.+start=/ + # There are more cases, actually, but for now, we don't support other + # methods for XForm posts. + # In a XForm POST, the QUERY_STRING is parsed normally. + # If the content-type is 'application/xml', we just set the param + # XForms:Model (referring to the xml syntax) param containing the + # unparsed XML data. + # In the case of multipart/related we set XForms:Model as above, but + # the other parts are available as uploads with the Content-ID as the + # the key. + # See the URL below for XForms specs on this issue. + # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options + if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) { + if ($ENV{'CONTENT_TYPE'} eq 'application/xml') { + my($param) = 'XForms:Model'; + my($value) = ''; + $self->add_parameter($param); + $self->read_from_client(\$value,$content_length,0) + if $content_length > 0; + push (@{$self->{param}{$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 (defined($initializer)) { + if (!$is_xforms && defined($initializer)) { if (UNIVERSAL::isa($initializer,'CGI')) { $query_string = $initializer->query_string; last METHOD; @@ -400,21 +608,21 @@ sub init { } last METHOD; } - - if (defined($fh) && ($fh ne '')) { - while (<$fh>) { - chomp; - last if /^=/; - push(@lines,$_); - } - # massage back into standard format - if ("@lines" =~ /=/) { - $query_string=join("&",@lines); - } else { - $query_string=join("+",@lines); - } - last METHOD; - } + + if (defined($fh) && ($fh ne '')) { + while (<$fh>) { + 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'; @@ -425,17 +633,18 @@ sub init { # If method is GET or HEAD, fetch the query from # the environment. - if ($meth=~/^(GET|HEAD)$/) { + if ($is_xforms || $meth=~/^(GET|HEAD)$/) { if ($MOD_PERL) { - $query_string = Apache->request->args; + $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'}; } last METHOD; } - if ($meth eq 'POST') { - $self->read_from_client(\*STDIN,\$query_string,$content_length,0) + 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 @@ -448,24 +657,44 @@ sub init { # 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() unless $NO_DEBUG; + 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 ne '') { - 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 @@ -477,7 +706,8 @@ sub init { # 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: @@ -516,30 +746,6 @@ sub cgi_error { return $self->{'.cgi_error'}; } -# unescape URL-encoded data -sub unescape { - shift() if ref($_[0]) || $_[0] eq $DefaultClass; - my $todecode = shift; - return undef unless defined($todecode); - $todecode =~ tr/+/ /; # pluses become spaces - if ($EBCDIC) { - $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge; - } else { - $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; - } - return $todecode; -} - -# URL-encode data -sub escape { - shift() if ref($_[0]) || $_[0] eq $DefaultClass; - my $toencode = shift; - return undef unless defined($toencode); - $toencode=~s/ /+/g; - $toencode=~s/([^a-zA-Z0-9_.+-])/uc sprintf("%%%02x",ord($1))/eg; - return $toencode; -} - sub save_request { my($self) = @_; # We're going to play with the package globals now so that if we get called @@ -547,8 +753,12 @@ sub save_request { # us to have several of these objects. @QUERY_PARAM = $self->param; # save list of parameters foreach (@QUERY_PARAM) { - $QUERY_PARAM{$_}=$self->{$_}; + next unless defined $_; + $QUERY_PARAM{$_}=$self->{param}{$_}; } + $QUERY_CHARSET = $self->charset; + %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; + %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} }; } sub parse_params { @@ -557,17 +767,21 @@ sub parse_params { my($param,$value); foreach (@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 { @@ -579,34 +793,33 @@ sub all_parameters { # 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 { - shift if \$_[0] && -# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || - (ref(\$_[0]) && - (substr(ref(\$_[0]),0,3) eq 'CGI' || - UNIVERSAL::isa(\$_[0],'CGI'))); - - my(\$attr) = ''; - if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') { - my(\@attr) = make_attributes( '',shift() ); - \$attr = " \@attr" if \@attr; - } + 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 "<\U$1\E\$attr>";} !; + $func .= qq! return "<\L$1\E\$attr>";} !; } elsif ($tagname=~/end_(\w+)/i) { - $func .= qq! return "<\U/$1\E>"; } !; + $func .= qq! return "<\L/$1\E>"; } !; } else { $func .= qq# - my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U\E"); - return \$tag unless \@_; - my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; + 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"; }#; } @@ -619,47 +832,6 @@ sub AUTOLOAD { goto &$func; } -# 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; - - if (ref($param[0]) eq 'HASH') { - @param = %{$param[0]}; - } else { - return @param - unless (defined($param[0]) && substr($param[0],0,1) eq '-') - || $self->use_named_parameters; - } - - # map parameters into positional indices - my ($i,%pos); - $i = 0; - foreach (@$order) { - foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; } - $i++; - } - - my (@result,%leftover); - $#result = $#$order; # preextend - while (@param) { - my $key = uc(shift(@param)); - $key =~ s/^\-//; - if (exists $pos{$key}) { - $result[$pos{$key}] = shift(@param); - } else { - $leftover{$key} = shift(@param); - } - } - - push (@result,$self->make_attributes(\%leftover)) if %leftover; - @result; -} - sub _compile { my($func) = $AUTOLOAD; my($pack,$func_name); @@ -674,8 +846,9 @@ sub _compile { my($sub) = \%{"$pack\:\:SUBS"}; unless (%$sub) { my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; + local ($@,$!); eval "package $pack; $$auto"; - die $@ if $@; + croak("$AUTOLOAD: $@") if $@; $$auto = ''; # Free the unneeded storage (but don't undef it!!!) } my($code) = $sub->{$func_name}; @@ -691,30 +864,58 @@ sub _compile { $code = $CGI::DefaultClass->_make_tag_func($func_name); } } - die "Undefined subroutine $AUTOLOAD\n" unless $code; + croak("Undefined subroutine $AUTOLOAD\n") unless $code; + local ($@,$!); eval "package $pack; $code"; if ($@) { $@ =~ s/ at .*\n//; - die $@; + croak("$AUTOLOAD: $@"); } } CORE::delete($sub->{$func_name}); #free storage return "$pack\:\:$func_name"; } +sub _selected { + my $self = shift; + my $value = shift; + return '' unless $value; + return $XHTML ? qq(selected="selected" ) : qq(selected ); +} + +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; + foreach (@_) { $HEADERS_ONCE++, next if /^[:-]unique_headers$/; $NPH++, next if /^[:-]nph$/; - $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/; + $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$/) { @@ -733,6 +934,28 @@ sub _setup_symbols { } } _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" ); } ############################################################################### @@ -752,39 +975,25 @@ sub MULTIPART { 'multipart/form-data'; } END_OF_FUNC 'SERVER_PUSH' => <<'END_OF_FUNC', -sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; } -END_OF_FUNC - -'use_named_parameters' => <<'END_OF_FUNC', -#### 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; -} +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,$filehandle) = @_; - return MultipartBuffer->new($self,$boundary,$length,$filehandle); + my($self,$boundary,$length) = @_; + return MultipartBuffer->new($self,$boundary,$length); } END_OF_FUNC 'read_from_client' => <<'END_OF_FUNC', # Read data from a file handle sub read_from_client { - my($self, $fh, $buff, $len, $offset) = @_; + my($self, $buff, $len, $offset) = @_; local $^W=0; # prevent a warning - return undef unless defined($fh); - return read($fh, $$buff, $len, $offset); + return $MOD_PERL + ? $self->r->read($$buff, $len, $offset) + : read(\*STDIN, $$buff, $len, $offset); } END_OF_FUNC @@ -793,11 +1002,18 @@ END_OF_FUNC # Deletes the named parameter entirely. #### sub delete { - my($self,$name) = self_or_default(@_); - CORE::delete $self->{$name}; - CORE::delete $self->{'.fieldnames'}->{$name}; - @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); - return wantarray ? () : undef; + 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; + foreach my $name (@to_delete) + { + CORE::delete $self->{param}{$name}; + CORE::delete $self->{'.fieldnames'}->{$name}; + $to_delete{$name}++; + } + @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); + return; } END_OF_FUNC @@ -841,8 +1057,8 @@ 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) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : (); + $self->{param}{'keywords'}=[@values] if @values; + my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : (); @result; } END_OF_FUNC @@ -851,8 +1067,9 @@ END_OF_FUNC # with Steve Brenner's cgi-lib.pl routines 'Vars' => <<'END_OF_FUNC', sub Vars { + my $q = shift; my %in; - tie(%in,CGI); + tie(%in,CGI,$q); return %in if wantarray; return \%in; } @@ -916,14 +1133,23 @@ sub MethPost { END_OF_FUNC 'TIEHASH' => <<'END_OF_FUNC', -sub TIEHASH { - return $Q || 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 @@ -950,7 +1176,7 @@ END_OF_FUNC 'EXISTS' => <<'END_OF_FUNC', sub EXISTS { - exists $_[0]->{$_[1]}; + exists $_[0]->{param}{$_[1]}; } END_OF_FUNC @@ -972,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); } @@ -989,7 +1215,8 @@ EOF 'delete_all' => <<'EOF', sub delete_all { my($self) = self_or_default(@_); - undef %{$self}; + my @param = $self->param(); + $self->delete(@param); } EOF @@ -1013,7 +1240,9 @@ EOF 'autoEscape' => <<'END_OF_FUNC', sub autoEscape { my($self,$escape) = self_or_default(@_); - $self->{'dontescape'}=!$escape; + my $d = $self->{'escape'}; + $self->{'escape'} = $escape; + $d; } END_OF_FUNC @@ -1027,21 +1256,6 @@ 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, use dashes - push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/); - } - return @att; -} -END_OF_FUNC - #### Method: url_param # Return a parameter in the QUERY_STRING, regardless of # whether this was a POST or a GET @@ -1073,29 +1287,29 @@ sub url_param { } 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 @@ -1106,7 +1320,7 @@ END_OF_FUNC #### 'as_string' => <<'END_OF_FUNC', sub as_string { - &dump(@_); + &Dump(@_); } END_OF_FUNC @@ -1128,6 +1342,9 @@ sub save { print $filehandle "$escaped_param=",escape("$value"),"\n"; } } + foreach (keys %{$self->{'.fieldnames'}}) { + print $filehandle ".cgifields=",escape("$_"),"\n"; + } print $filehandle "=\n"; # end of record } END_OF_FUNC @@ -1156,23 +1373,24 @@ END_OF_FUNC #### Method: multipart_init # Return a Content-Type: style header for server-push -# This has to be NPH, and it is advisable to set $| = 1 +# This has to be NPH on most web servers, and it is advisable to set $| = 1 # # Many thanks to Ed Jordan for this -# contribution +# 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) = $self->rearrange([BOUNDARY],@p); + my($boundary,@other) = rearrange_header([BOUNDARY],@p); $boundary = $boundary || '------- =_aaaaaaaaaa0'; - $self->{'separator'} = "\n--$boundary\n"; + $self->{'separator'} = "$CRLF--$boundary$CRLF"; + $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; $type = SERVER_PUSH($boundary); return $self->header( - -nph => 1, + -nph => 0, -type => $type, (map { split "=", $_, 2 } @other), - ) . $self->multipart_end; + ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; } END_OF_FUNC @@ -1181,23 +1399,32 @@ END_OF_FUNC # Return a Content-Type: style header for server-push, start of section # # Many thanks to Ed Jordan for this -# contribution +# 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) = $self->rearrange([TYPE],@p); + my($type,@other) = rearrange([TYPE],@p); $type = $type || 'text/html'; - return $self->header( - -type => $type, - (map { split "=", $_, 2 } @other), - ); + push(@header,"Content-Type: $type"); + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + foreach (@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 Content-Type: style header for server-push, end of section +# Return a MIME boundary separator for server-push, end of section # # Many thanks to Ed Jordan for this # contribution @@ -1210,6 +1437,19 @@ sub multipart_end { 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 # @@ -1219,28 +1459,50 @@ sub header { my($self,@p) = self_or_default(@_); my(@header); - return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; + 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); - my($type,$status,$cookie,$target,$expires,$nph,@other) = - $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], - STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + $nph ||= $NPH; + + $type ||= 'text/html' unless defined($type); + + if (defined $charset) { + $self->charset($charset); + } else { + $charset = $self->charset if $type =~ /^text\//; + } + $charset ||= ''; - $nph ||= $NPH; # rearrange() was designed for the HTML portion, so we # need to fix it up a little. foreach (@other) { - next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/; - ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e; + # 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 ||= 'text/html' unless defined($type); + $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,"Status: $status") if $status; 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) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie; @@ -1254,16 +1516,15 @@ sub header { # uses OUR clock) push(@header,"Expires: " . expires($expires,'http')) if $expires; - push(@header,"Date: " . expires(0,'http')) if $expires || $cookie; + push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; push(@header,"Pragma: no-cache") if $self->cache(); - push(@header,@other); + 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 and not $nph) { - my $r = Apache->request; - $r->send_cgi_header($header); - return ''; + if (($MOD_PERL >= 1) && !$nph) { + $self->r->send_cgi_header($header); + return ''; } return $header; } @@ -1293,18 +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([[LOCATION,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) { tr/\"//d; push(@o,split("=",$_,2)); } unshift(@o, - '-Status'=>'302 Moved', - '-Location'=>$url, - '-nph'=>$nph); + '-Status' => $status, + '-Location'=> $url, + '-nph' => $nph); unshift(@o,'-Target'=>$target) if $target; - unshift(@o,'-Cookie'=>$cookie) if $cookie; unshift(@o,'-Type'=>''); - return $self->header(@o); + my @unescaped; + unshift(@unescaped,'-Cookie'=>$cookie) if $cookie; + return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped); } END_OF_FUNC @@ -1322,53 +1586,112 @@ 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 @@ -1380,47 +1703,98 @@ END_OF_FUNC sub _style { my ($self,$style) = @_; my (@result); + my $type = 'text/css'; - if (ref($style)) { - my($src,$code,$stype,@other) = - $self->rearrange([SRC,CODE,TYPE], - '-foo'=>'bar', # a trick to allow the '-' to be omitted - ref($style) eq 'ARRAY' ? @$style : %$style); - $type = $stype if $stype; - push(@result,qq//) if $src; - push(@result,style({'type'=>$type},"")) if $code; - } else { - push(@result,style({'type'=>$type},"")); + 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 + foreach $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, "") foreach @v; + } + my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code; + push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @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); foreach $script (@scripts) { my($src,$code,$language); if (ref($script)) { # script is a hash - ($src,$code,$language) = - $self->rearrange([SRC,CODE,LANGUAGE], + ($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,$language) = ('',$script,'JavaScript'); + ($src,$code,$type) = ('',$script, 'text/javascript'); } - my(@satts); - push(@satts,'src'=>$src) if $src; - push(@satts,'language'=>$language || 'JavaScript'); - $code = "" - if $code && $language=~/javascript/i; - $code = "" - if $code && $language=~/perl/i; - push(@result,script({@satts},$code || '')); + + 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; } @@ -1428,11 +1802,11 @@ 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 @@ -1446,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 @@ -1469,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 @@ -1486,7 +1865,7 @@ END_OF_FUNC # synonym for startform 'start_form' => <<'END_OF_FUNC', sub start_form { - &startform; + $XHTML ? &start_multipart_form : &startform; } END_OF_FUNC @@ -1501,14 +1880,11 @@ END_OF_FUNC '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); } } @@ -1519,17 +1895,17 @@ END_OF_FUNC # End a form 'endform' => <<'END_OF_FUNC', sub endform { - my($self,@p) = self_or_default(@_); - return ($self->get_fields,"
"); -} -END_OF_FUNC - - -#### Method: end_form -# synonym for endform -'end_form' => <<'END_OF_FUNC', -sub end_form { - &endform; + 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 @@ -1537,21 +1913,23 @@ END_OF_FUNC '_textfield' => <<'END_OF_FUNC', sub _textfield { my($self,$tag,@p) = self_or_default(@_); - my($name,$default,$size,$maxlength,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); + 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) : ''; + $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($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") : ''; - return qq//; + my($value) = $current ne '' ? qq(value="$current") : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); } END_OF_FUNC @@ -1563,7 +1941,7 @@ 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 { @@ -1579,7 +1957,7 @@ 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 { @@ -1598,7 +1976,7 @@ 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 { @@ -1615,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 @@ -1645,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 @@ -1677,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); + $value=$self->escapeHTML($value,1); - my($name) = ' NAME=".submit"'; - $name = qq/ NAME="$label"/ if defined($label); + 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); - my($other) = @other ? " @other" : ''; - return qq//; + 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 @@ -1704,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 @@ -1723,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 @@ -1733,13 +2122,15 @@ 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 @@ -1764,117 +2155,85 @@ 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); - + 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)) ? ' CHECKED' : ''; + $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : ''; } else { - $checked = $checked ? ' CHECKED' : ''; + $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 qq{$the_label}; + 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,@values); - - @values = $self->_set_values_and_labels($values,\$labels,$name); - - my($other) = @other ? " @other" : ''; - foreach (@values) { - $checked = $checked{$_} ? ' CHECKED' : ''; - $label = ''; - unless (defined($nolabels) && $nolabels) { - $label = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - $label = $self->escapeHTML($label); - } - $_ = $self->escapeHTML($_); - push(@elements,qq/${label}${break}/); - } - $self->register_parameter($name); - return wantarray ? @elements : join(' ',@elements) - unless defined($columns) || defined($rows); - return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); -} -END_OF_FUNC # Escape HTML -- used internally 'escapeHTML' => <<'END_OF_FUNC', sub escapeHTML { - my ($self,$toencode) = self_or_default(@_); - return undef unless defined($toencode); - return $toencode if ref($self) && $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 { - my $string = ref($_[0]) ? $_[1] : $_[0]; + # 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; @@ -1882,8 +2241,8 @@ sub unescapeHTML { /^quot$/i ? '"' : /^gt$/i ? ">" : /^lt$/i ? "<" : - /^#(\d+)$/ ? chr($1) : - /^#x([0-9a-f]+)$/i ? chr(hex($1)) : + /^#(\d+)$/ && $latin ? chr($1) : + /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) : $_ }gex; return $string; @@ -1894,6 +2253,8 @@ END_OF_FUNC '_tableize' => <<'END_OF_FUNC', sub _tableize { my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; + my @rowheaders = $rowheaders ? @$rowheaders : (); + my @colheaders = $colheaders ? @$colheaders : (); my($result); if (defined($columns)) { @@ -1902,25 +2263,25 @@ sub _tableize { 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; + foreach (@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 @@ -1941,47 +2302,124 @@ END_OF_FUNC # 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(@_); + $self->_box_group('radio',@p); +} +END_OF_FUNC - 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); +#### 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(@_); + $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); - if (!$override && defined($self->param($name))) { - $checked = $self->param($name); - } else { - $checked = $default; - } - my(@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] unless defined($checked) && $checked ne ''; + $checked{$values[0]}++ if $box_type eq 'radio' && !%checked; + $name=$self->escapeHTML($name); - my($other) = @other ? " @other" : ''; + 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; + foreach (@{$disabled}) { + $disabled{$_}=1; + } + foreach (@values) { - my($checkit) = $checked eq $_ ? ' CHECKED' : ''; - my($break) = $linebreak ? '
' : ''; + 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); + $label = $self->escapeHTML($label,1); + $label = "$label" if $disabled{$_}; } + my $attribs = $self->_set_attributes($_, $attributes); + my $tab = $tabs{$_}; $_=$self->escapeHTML($_); - push(@elements,qq/${label}${break}/); + + if ($XHTML) { + push @elements, + CGI::label($labelattributes, + qq($label)).${break}; + } else { + push(@elements,qq/${label}${break}/); + } } $self->register_parameter($name); - return wantarray ? @elements : join(' ',@elements) + return wantarray ? @elements : "@elements" unless defined($columns) || defined($rows); return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); } @@ -2006,32 +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 = $self->_set_values_and_labels($values,\$labels,$name); - - $result = qq/\n/; foreach (@values) { - my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : ''; - my($label) = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - my($value) = $self->escapeHTML($_); - $label=$self->escapeHTML($label); - $result .= "_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 an associative array 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/; + foreach (@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 @@ -2060,9 +2573,9 @@ 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); @@ -2070,21 +2583,24 @@ sub scrolling_list { $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/; foreach (@values) { - my($selectit) = $selected{$_} ? 'SELECTED' : ''; + my($selectit) = $self->_selected($selected{$_}); my($label) = $_; $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; } @@ -2098,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 { @@ -2108,10 +2624,10 @@ 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 ( ref($p[0]) || 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 { @@ -2126,8 +2642,9 @@ sub hidden { $name=$self->escapeHTML($name); foreach (@value) { - $_=$self->escapeHTML($_); - push(@result,qq//); + $_ = defined($_) ? $self->escapeHTML($_,1) : ''; + push @result,$XHTML ? qq() + : qq(); } return wantarray ? @result : join('',@result); } @@ -2140,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 @@ -2187,45 +2705,51 @@ END_OF_FUNC 'url' => <<'END_OF_FUNC', sub url { my($self,@p) = self_or_default(@_); - my ($relative,$absolute,$full,$path_info,$query) = - $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p); - my $url; - $full++ if !($relative || $absolute); - - my $path = $self->path_info; - my $script_name; - if (exists($ENV{REQUEST_URI})) { - my $index; - $script_name = $ENV{REQUEST_URI}; - # strip query string - substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0; - # and path - substr($script_name,$index) = '' if $path and ($index = rindex($script_name,$path)) >= 0; - } else { - $script_name = $self->script_name; - } + 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('host'); + my $vh = http('x_forwarded_host') || http('host') || ''; + $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it. if ($vh) { $url .= $vh; } else { $url .= server_name(); - my $port = $self->server_port; - $url .= ":" . $port - unless (lc($protocol) eq 'http' && $port == 80) - || (lc($protocol) eq 'https' && $port == 443); } - $url .= $script_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) = $script_name =~ m!([^/]+)$!; + ($url) = $uri =~ m!([^/]+)$!; } elsif ($absolute) { - $url = $script_name; + $url = $uri; } - $url .= $path if $path_info and defined $path; - $url .= "?" . $self->query_string if $query and $self->query_string; + + $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; } @@ -2246,8 +2770,8 @@ END_OF_FUNC 'cookie' => <<'END_OF_FUNC', 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; @@ -2266,7 +2790,7 @@ sub cookie { } # If we get here, we're creating a new cookie - return undef unless $name; # this is an error + return undef unless defined($name) && $name ne ''; # this is an error my @param; push(@param,'-name'=>$name); @@ -2275,74 +2799,12 @@ sub cookie { push(@param,'-path'=>$path) if $path; push(@param,'-expires'=>$expires) if $expires; push(@param,'-secure'=>$secure) if $secure; + push(@param,'-httponly'=>$httponly) if $httponly; return new CGI::Cookie(@param); } END_OF_FUNC -# This internal routine creates an expires time exactly some number of -# hours from the current time. It incorporates modifications from -# Mark Fisher. -'expire_calc' => <<'END_OF_FUNC', -sub expire_calc { - my($time) = @_; - 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 || (lc($time) eq 'now')) { - $offset = 0; - } elsif ($time=~/^\d+/) { - return $time; - } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { - $offset = ($mult{$2} || 1)*$1; - } else { - return $time; - } - return (time+$offset); -} -END_OF_FUNC - -# This internal routine creates date strings suitable for use in -# cookies and HTTP headers. (They differ, unfortunately.) -# Thanks to Mark Fisher for this. -'expires' => <<'END_OF_FUNC', -sub expires { - my($time,$format) = @_; - $format ||= 'http'; - - my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; - my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; - - # pass through preformatted dates for the sake of expire_calc() - $time = expire_calc($time); - return $time unless $time =~ /^\d+$/; - - # make HTTP/cookie date string from GMT'ed time - # (cookies use '-' as date separator, HTTP uses ' ') - my($sc) = ' '; - $sc = '-' if $format eq "cookie"; - my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); - $year += 1900; - return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", - $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); -} -END_OF_FUNC - 'parse_keywordlist' => <<'END_OF_FUNC', sub parse_keywordlist { my($self,$tosplit) = @_; @@ -2356,13 +2818,13 @@ END_OF_FUNC 'param_fetch' => <<'END_OF_FUNC', sub param_fetch { my($self,@p) = self_or_default(@_); - my($name) = $self->rearrange([NAME],@p); - unless (exists($self->{$name})) { + my($name) = rearrange([NAME],@p); + unless (exists($self->{param}{$name})) { $self->add_parameter($name); - $self->{$name} = []; + $self->{param}{$name} = []; } - return $self->{$name}; + return $self->{param}{$name}; } END_OF_FUNC @@ -2381,17 +2843,68 @@ sub path_info { $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; $self->{'.path_info'} = $info; } elsif (! defined($self->{'.path_info'}) ) { - $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ? - $ENV{'PATH_INFO'} : ''; - - # hack to fix broken path info in IIS - $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS; - + 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 + #### Method: request_method # Returns 'POST', 'GET', 'PUT' or 'HEAD' @@ -2422,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 @@ -2438,6 +2961,9 @@ sub query_string { push(@pairs,"$eparam=$value"); } } + foreach (keys %{$self->{'.fieldnames'}}) { + push(@pairs,".cgifields=".escape("$_")); + } return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); } END_OF_FUNC @@ -2459,7 +2985,9 @@ 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) { ($pref) = /q=(\d\.\d+|\d+)/; @@ -2536,7 +3064,7 @@ END_OF_FUNC ###### 'virtual_host' => <<'END_OF_FUNC', sub virtual_host { - my $vh = http('host') || server_name(); + my $vh = http('x_forwarded_host') || http('host') || server_name(); $vh =~ s/:\d+$//; # get rid of port number return $vh; } @@ -2574,10 +3102,14 @@ END_OF_FUNC #### 'script_name' => <<'END_OF_FUNC', sub script_name { - return $ENV{'SCRIPT_NAME'} if defined($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 @@ -2612,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 #### @@ -2725,6 +3273,17 @@ 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 #### @@ -2746,14 +3305,29 @@ sub private_tempfiles { 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) = self_or_CGI(@_); - $CGI::DEFAULT_DTD = $param if defined($param); + 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 @@ -2766,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); } @@ -2798,11 +3372,12 @@ END_OF_FUNC sub read_from_cmdline { my($input,@words); my($query_string); - if (@ARGV) { + my($subpath); + if ($DEBUG && @ARGV) { @words = @ARGV; - } else { + } elsif ($DEBUG > 1) { require "shellwords.pl"; - print STDERR "(offline mode: enter name=value pairs on standard input)\n"; + 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); @@ -2817,7 +3392,12 @@ sub read_from_cmdline { } 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 @@ -2831,8 +3411,8 @@ END_OF_FUNC ##### 'read_multipart' => <<'END_OF_FUNC', sub read_multipart { - my($self,$boundary,$length,$filehandle) = @_; - my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle); + my($self,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); return unless $buffer; my(%header,$body); my $filenumber = 0; @@ -2844,19 +3424,34 @@ sub read_multipart { return; } - my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/; + $header{'Content-Disposition'} ||= ''; # quench uninit variable warning + + 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 - # Bug: Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/; + $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; } @@ -2872,54 +3467,190 @@ sub read_multipart { 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,values %ENV)); + my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV)); for (my $cnt=10;$cnt>0;$cnt--) { - next unless $tmpfile = new TempFile($seqno); + next unless $tmpfile = new CGITempFile($seqno); $tmp = $tmpfile->as_string; - last if $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES); + last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES)); $seqno += int rand(100); } - die "CGI open of tmpfile: $!\n" unless $filehandle; - $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + 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 ) { + foreach ( keys %header ) { + print $filehandle "$_: $header{$_}${CRLF}"; + } + print $filehandle "${CRLF}"; + } my ($data); local($\) = ''; - while (defined($data = $buffer->read)) { - print $filehandle $data; + 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; + } + + 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. - $self->{'.tmpfiles'}->{$filename}= { + # Use the typeglob as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle}= { + hndl => $filehandle, name => $tmpfile, info => {%header}, }; - push(@{$self->{$param}},$filehandle); + 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 = $self->param($param_name); - return unless $param; - return unless ref($param) && fileno($param); - return $param; + 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} ? - $self->{'.tmpfiles'}->{$filename}->{name}->as_string + return $self->{'.tmpfiles'}->{$$filename}->{name} ? + $self->{'.tmpfiles'}->{$$filename}->{name}->as_string : ''; } END_OF_FUNC @@ -2927,7 +3658,7 @@ 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 @@ -2943,6 +3674,22 @@ sub _set_values_and_labels { } 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 = ' '; + foreach 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 { foreach (@_) { @@ -2963,6 +3710,7 @@ END_OF_AUTOLOAD ################### Fh -- lightweight filehandle ############### package Fh; + use overload '""' => \&asString, 'cmp' => \&compare, @@ -2972,6 +3720,11 @@ $FH='fh00000'; *Fh::AUTOLOAD = \&CGI::AUTOLOAD; +sub DESTROY { + my $self = shift; + close $self; +} + $AUTOLOADED_ROUTINES = ''; # prevent -w error $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; %SUBS = ( @@ -2979,9 +3732,9 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; sub asString { my $self = shift; # get rid of package name - (my $i = $$self) =~ s/^\*(\w+::)+//; - $i =~ s/\\(.)/$1/g; - return $i; + (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. @@ -3004,20 +3757,25 @@ 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; - ++$FH; - my $ref = \*{'Fh::' . quotemeta($name)}; - sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; - unlink($file) if $delete; - CORE::delete $Fh::{$FH}; + (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 -'DESTROY' => <<'END_OF_FUNC', -sub DESTROY { - my $self = shift; - close $self; +'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 @@ -3027,6 +3785,8 @@ END_OF_AUTOLOAD ######################## MultipartBuffer #################### package MultipartBuffer; +use constant DEBUG => 0; + # how many bytes to read at a time. We use # a 4K buffer by default. $INITIAL_FILLUNIT = 1024 * 4; @@ -3049,18 +3809,10 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'new' => <<'END_OF_FUNC', sub new { - my($package,$interface,$boundary,$length,$filehandle) = @_; + my($package,$interface,$boundary,$length) = @_; $FILLUNIT = $INITIAL_FILLUNIT; - my $IN; - if ($filehandle) { - my($package) = caller; - # force into caller's package if necessary - $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; - } - $IN = "main::STDIN" unless $IN; + $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 @@ -3069,6 +3821,7 @@ 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 @@ -3076,20 +3829,21 @@ sub new { # 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'); + $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=>'', }; @@ -3100,8 +3854,10 @@ sub new { my $retval = bless $self,ref $package || $package; # Read the preamble and the topmost (boundary) line plus the CRLF. - while ($self->read(0)) { } - die "Malformed multipart POST\n" if $self->eof; + unless ($boundary_read) { + while ($self->read(0)) { } + } + die "Malformed multipart POST: data truncated\n" if $self->eof; return $retval; } @@ -3114,9 +3870,7 @@ sub readHeader { my($ok) = 0; my($bad) = 0; - if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert! - local($CRLF) = "\015\012"; - } + local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; do { $self->fillBuffer($FILLUNIT); @@ -3128,19 +3882,27 @@ sub readHeader { } 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; - + 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); # avoid taintedness + my ($field_name,$field_value) = ($1,$2); $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize $return{$field_name}=$field_value; } @@ -3154,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 @@ -3169,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 @@ -3221,18 +4001,18 @@ 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() @@ -3240,14 +4020,14 @@ sub fillBuffer { # 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 @@ -3268,37 +4048,58 @@ END_OF_AUTOLOAD #################################################################################### ################################## TEMPORARY FILES ################################# #################################################################################### -package TempFile; +package CGITempFile; -$SL = $CGI::SL; -$MAC = $CGI::OS eq 'MACINTOSH'; -my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; -unless ($TMPDIRECTORY) { +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"); - unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'}; + "${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'; + } - # + 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'; + # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0; foreach (@TEMP) { - do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; + do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; } + } + $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; } -$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; +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 #################### @@ -3311,23 +4112,18 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; sub new { my($package,$sequence) = @_; my $filename; + find_tempdir() unless -w $TMPDIRECTORY; for (my $i = 0; $i < $MAXTRIES; $i++) { - last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++)); + last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++)); } - # untaint the darn thing - return unless $filename =~ m!^([a-zA-Z0-9_ '":/\\]+)$!; - $filename = $1; + # 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 -'DESTROY' => <<'END_OF_FUNC', -sub DESTROY { - my($self) = @_; - unlink $$self; # get rid of the file -} -END_OF_FUNC - 'as_string' => <<'END_OF_FUNC' sub as_string { my($self) = @_; @@ -3386,12 +4182,17 @@ CGI - Simple Common Gateway Interface Class hr; 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')), + my $name = param('name'); + my $keywords = join ', ',param('words'); + my $color = param('color'); + print "Your name is",em(escapeHTML($name)),p, + "The keywords are: ",em(escapeHTML($keywords)),p, + "Your favorite color is ",em(escapeHTML($color)), hr; } + print end_html; + =head1 ABSTRACT This perl library uses perl5 objects to make it easy to create Web @@ -3475,17 +4276,6 @@ 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. -You don't have to use the hyphen at all if you don't want to. After -creating a CGI object, call the B method with -a nonzero value. This will tell CGI.pm that you intend to use named -parameters exclusively: - - $query = new CGI; - $query->use_named_parameters(1); - $field = $query->radio_group('name'=>'OS', - 'values'=>['Unix','Windows','Macintosh'], - 'default'=>'Unix'); - 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 @@ -3502,7 +4292,7 @@ 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']); + $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. @@ -3517,12 +4307,12 @@ this: Code Generated HTML ---- -------------- - h1()

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

some contents

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

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

contents

+ h1()

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

some contents

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

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

contents

-HTML tags are described in more detail later. +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 @@ -3543,12 +4333,18 @@ have several choices: =over 4 -=item 1. Use another name for the argument, if one is available. For -example, -value is an alias for -values. +=item 1. + +Use another name for the argument, if one is available. +For example, -value is an alias for -values. + +=item 2. + +Change the capitalization, e.g. -Values -=item 2. Change the capitalization, e.g. -Values +=item 3. -=item 3. Put quotes around the argument name, e.g. '-values' +Put quotes around the argument name, e.g. '-values' =back @@ -3581,7 +4377,10 @@ HTML "standards". $query = new CGI; This will parse the input (from both POST and GET methods) and store -it into a perl5 object called $query. +it into a perl5 object called $query. + +Any filehandles from file uploads will have their position reset to +the beginning of the file. =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE @@ -3651,10 +4450,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. @@ -3675,6 +4475,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'); @@ -3713,17 +4521,22 @@ 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. @@ -3737,6 +4550,25 @@ that all the defaults are taken when you create a fill-out form. 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'; @@ -3765,13 +4597,13 @@ 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 an array context, it returns the +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 -array context, multivalued parameters will be returned as a packed +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 @@ -3782,7 +4614,7 @@ function calls (also see the section on CGI-LIB compatibility). =head2 SAVING THE STATE OF THE SCRIPT TO A FILE: - $query->save(FILEHANDLE) + $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 @@ -3812,21 +4644,21 @@ a short example of creating multiple session records: foreach (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://stein.cshl.org/boulder/ for further details. @@ -3898,9 +4730,14 @@ Import all methods that generate HTML 2.0 standard elements. =item B<:html3> -Import all methods that generate HTML 3.0 proposed elements (such as +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. @@ -3912,7 +4749,7 @@ Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' + =item B<:standard> -Import "standard" features, 'html2', 'html3', 'form' and 'cgi'. +Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'. =item B<:all> @@ -3925,7 +4762,7 @@ 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 +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: @@ -3978,10 +4815,10 @@ 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 disables debugging mode (pragma --no_debug): +standard set of functions and enables debugging mode (pragma +-debug): - use CGI qw/:standard -no_debug/; + use CGI qw/:standard -debug/; The current list of pragmas is as follows: @@ -4007,7 +4844,7 @@ all. This causes the indicated autoloaded methods to be compiled up front, rather than deferred to later. This is useful for scripts that run for an extended period of time under FastCGI or mod_perl, and for -those destined to be crunched by Malcom Beattie's Perl compiler. Use +those destined to be crunched by Malcolm Beattie's Perl compiler. Use it in conjunction with the methods or method families you plan to use. use CGI qw(-compile :standard :html3); @@ -4019,7 +4856,58 @@ or even 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 (see below). +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 @@ -4039,6 +4927,13 @@ 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 @@ -4055,17 +4950,18 @@ to the top of your script. 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 pausing to request CGI parameters from standard input or -the command line, then use this pragma: +don't want it to read CGI parameters from the command line or STDIN, +then use this pragma: use CGI qw(-no_debug :standard); -If you'd like to process the command-line parameters but not standard -input, this should work: +=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. - use CGI qw(-no_debug :standard); - restore_parameters(join('&',@ARGV)); - See the section on debugging for more details. =item -private_tempfiles @@ -4112,7 +5008,7 @@ For example: produces -

Level 1 Header

+

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 @@ -4136,13 +5032,13 @@ the standard ones: =over 4 -=item 1. start_table() (generates a
tag) +=item 1. start_table() (generates a
tag) -=item 2. end_table() (generates a
tag) +=item 2. end_table() (generates a tag) -=item 3. start_ul() (generates a
    tag) +=item 3. start_ul() (generates a
      tag) -=item 4. end_ul() (generates a
    tag) +=item 4. end_ul() (generates a
tag) =back @@ -4167,23 +5063,25 @@ 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 $query->header; + print header; -or- - print $query->header('image/gif'); + print header('image/gif'); -or- - print $query->header('text/html','204 No response'); + print header('text/html','204 No response'); -or- - print $query->header(-type=>'image/gif', + 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 @@ -4199,7 +5097,7 @@ 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 $query->header(-Content_length=>3002); + 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 @@ -4224,14 +5122,34 @@ 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, such as Microsoft Internet Explorer, which -expect all their scripts to be NPH. +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 $query->redirect('http://somewhere.else/in/movie/land'); + 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 @@ -4239,29 +5157,37 @@ 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. As of version 2.0, we produce both the unofficial Location: -header and the official URI: header. This should satisfy most servers -and browsers. +well. -One hint I can offer is that relative links may not work correctly -when you generate a redirection to another document on your site. -This is due to a well-intentioned optimization that some servers use. -The solution to this is to use the full URL (including the http: part) -of the document you are redirecting to. +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 $query->redirect(-uri=>'http://somewhere.else/in/movie/land', - -nph=>1); + 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 Internet Explorer, which +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 $query->start_html(-title=>'Secrets of the Pyramids', + print start_html(-title=>'Secrets of the Pyramids', -author=>'fred@capricorn.org', -base=>'true', -target=>'_blank', @@ -4275,14 +5201,15 @@ 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. +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 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. +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 +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/" @@ -4290,8 +5217,10 @@ different from the current location, as in 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. See the Netscape -documentation on frames for details of how to manipulate this. +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" @@ -4299,29 +5228,46 @@ 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 an associative array containing name/value pairs of meta information. These will be turned -into a series of header tags that look something like this: +into a series of header tags that look something like this: - - + + -There is no support for the HTTP-EQUIV type of tag. This is -because you can modify the HTTP header directly with the B -method. For example, if you want to send the Refresh: header, do it -in the header() method: +To create an HTTP-EQUIV type of tag, use B<-head>, described +below. - print $q->header(-Refresh=>'10; URL=http://www.capricorn.com'); +The B<-style> argument is used to incorporate cascading stylesheets +into your code. See the section on CASCADING STYLESHEETS for more +information. -The B<-style> tag 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: -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 + 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'})); + -href=>'http://www.capricorn.com/s2.html'})); -To incorporate multiple HTML elements into the section, just pass an +To incorporate multiple HTML elements into the section, just pass an array reference: print start_html(-head=>[ @@ -4332,11 +5278,17 @@ array reference: ] ); +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