X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=ffb8ce91dcc12e84884269242c37d5dc188975ce;hb=2db40e90730d5fd105e3f74faa4d22f352568b99;hp=8b7568af8a48f3aff79c5712fc17a8413ae27b5c;hpb=91e74348ab129f737e0d9da75481cd4eb7414ba4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CGI.pm b/lib/CGI.pm index 8b7568a..ffb8ce9 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,19 +18,37 @@ 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.30 2000/03/28 21:31:40 lstein Exp $'; -$CGI::VERSION='2.66'; +$CGI::revision = '$Id: CGI.pm,v 1.208 2006/04/23 14:25:14 lstein Exp $'; +$CGI::VERSION='3.22'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. -# $TempFile::TMPDIRECTORY = '/usr/tmp'; -use CGI::Util qw(rearrange make_attributes unescape escape expires); +# $CGITempFile::TMPDIRECTORY = '/usr/tmp'; +use CGI::Util qw(rearrange 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 +@SAVED_SYMBOLS = (); + # >>>>> Here are some globals that you might want to adjust <<<<<< sub initialize_globals { # Set this to 1 to enable copious autoloader debugging messages $AUTOLOAD_DEBUG = 0; + # Set this to 1 to generate XTML-compatible output + $XHTML = 1; + # Change this to the preferred DTD to print in start_html() # or use default_dtd('text of DTD to use'); $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN', @@ -59,6 +78,19 @@ sub initialize_globals { # 2) CGI::private_tempfiles(1); $PRIVATE_TEMPFILES = 0; + # Set this to 1 to generate automatic tab indexes + $TABINDEX = 0; + + # Set this to 1 to cause files uploaded in multipart documents + # to be closed, instead of caching the file handle + # or: + # 1) use CGI qw(:close_upload_files) + # 2) $CGI::close_upload_files(1); + # Uploads with many files run out of file handles. + # Also, for performance, since the file is already on disk, + # it can just be renamed, instead of read and written. + $CLOSE_UPLOAD_FILES = 0; + # Set this to a positive value to limit the size of a POSTing # to a certain number of bytes: $POST_MAX = -1; @@ -75,11 +107,18 @@ sub initialize_globals { # separate the name=value pairs by semicolons rather than ampersands $USE_PARAM_SEMICOLONS = 1; + # Do not include undefined params parsed from query string + # use CGI qw(-no_undef_params); + $NO_UNDEF_PARAMS = 0; + # 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; # prevent complaints by mod_perl 1; @@ -87,6 +126,8 @@ sub initialize_globals { # ------------------ START OF THE LIBRARY ------------ +*end_form = \&endform; + # make mod_perlhappy initialize_globals(); @@ -99,24 +140,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=~/bsdos/i) { - $OS = 'UNIX'; -} 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; @@ -127,7 +170,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 @@ -136,13 +180,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/; @@ -162,9 +215,9 @@ if ($OS eq 'VMS') { } 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 = ( @@ -173,35 +226,65 @@ if ($needs_binmode) { base body Link nextid title meta kbd start_html end_html input Select option comment charset escapeHTML/], ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param - embed basefont style span layer ilayer font frameset frame script small big/], + 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 + 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; @@ -243,21 +326,83 @@ 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 && defined Apache->request) { - 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); + } + 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->_reset_globals if $PERLEX; - $self->init($initializer); - return $self; + 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}; + } + } +} + +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,7 +434,7 @@ sub param { } } # If values is provided, then we set it. - if (@values) { + if (@values or defined $value) { $self->add_parameter($name); $self->{$name}=[@values]; } @@ -298,7 +443,16 @@ sub param { } return unless defined($name) && $self->{$name}; - return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; + + my $charset = $self->charset || ''; + my $utf8 = $charset eq 'utf-8'; + if ($utf8) { + eval "require Encode; 1;" if $utf8 && !Encode->can('decode'); # bring in these functions + return wantarray ? map {Encode::decode(utf8=>$_) } @{$self->{$name}} + : Encode::decode(utf8=>$self->{$name}->[0]); + } else { + return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; + } } sub self_or_default { @@ -337,17 +491,24 @@ 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 $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)) { + if (defined(@QUERY_PARAM) && !defined($initializer)) { foreach (@QUERY_PARAM) { $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); } + $self->charset($QUERY_CHARSET); + $self->{'.fieldnames'} = {%QUERY_FIELDNAMES}; return; } @@ -356,12 +517,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 @@ -405,6 +570,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; + } + # last chance -- treat it as a string $initializer = $$initializer if ref($initializer) eq 'SCALAR'; $query_string = $initializer; @@ -416,7 +596,7 @@ sub init { # the environment. if ($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'}; @@ -425,7 +605,7 @@ sub init { } if ($meth eq 'POST') { - $self->read_from_client(\*STDIN,\$query_string,$content_length,0) + $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 @@ -438,12 +618,32 @@ 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() if $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 ($meth eq 'POST' + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| + && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) { + my($param) = 'POSTDATA' ; + $self->add_parameter($param) ; + push (@{$self->{$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 (defined $query_string && $query_string) { + if (defined $query_string && length $query_string) { if ($query_string =~ /[&=;]/) { $self->parse_params($query_string); } else { @@ -455,7 +655,7 @@ sub init { # 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 @@ -468,9 +668,7 @@ sub init { $self->delete('.submit'); $self->delete('.cgifields'); - # set charset to the safe ISO-8859-1 - $self->charset('ISO-8859-1'); - $self->save_request unless $initializer; + $self->save_request unless defined $initializer; } # FUNCTIONS TO OVERRIDE: @@ -519,6 +717,8 @@ sub save_request { next unless defined $_; $QUERY_PARAM{$_}=$self->{$_}; } + $QUERY_CHARSET = $self->charset; + %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; } sub parse_params { @@ -527,6 +727,8 @@ 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); @@ -551,6 +753,7 @@ sub all_parameters { # put a filehandle into binary mode (DOS) sub binmode { + return unless defined($_[1]) && defined fileno($_[1]); CORE::binmode($_[1]); } @@ -558,26 +761,25 @@ sub _make_tag_func { my ($self,$tagname) = @_; my $func = qq( sub $tagname { - shift if \$_[0] && - (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()||undef,1); - \$attr = " \@attr" if \@attr; - } + 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 \@_; + 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(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; + (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest"; return "\@result"; }#; } @@ -604,8 +806,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}; @@ -621,22 +824,41 @@ 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$/; @@ -644,10 +866,15 @@ sub _setup_symbols { $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; $DEBUG=2, next if /^[:-][Dd]ebug$/; $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $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$/) { @@ -666,6 +893,7 @@ sub _setup_symbols { } } _compile_all(keys %EXPORT) if $compile; + @SAVED_SYMBOLS = @_; } sub charset { @@ -674,6 +902,21 @@ sub 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" ); +} + ############################################################################### ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### ############################################################################### @@ -691,24 +934,25 @@ sub MULTIPART { 'multipart/form-data'; } END_OF_FUNC 'SERVER_PUSH' => <<'END_OF_FUNC', -sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; } +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 @@ -717,11 +961,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->{$name}; + CORE::delete $self->{'.fieldnames'}->{$name}; + $to_delete{$name}++; + } + @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); + return; } END_OF_FUNC @@ -841,9 +1092,13 @@ sub MethPost { END_OF_FUNC 'TIEHASH' => <<'END_OF_FUNC', -sub TIEHASH { - return $_[1] if defined $_[1]; - return $Q ||= new shift; +sub TIEHASH { + my $class = shift; + my $arg = $_[0]; + if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) { + return $arg; + } + return $Q ||= $class->new(@_); } END_OF_FUNC @@ -851,7 +1106,8 @@ END_OF_FUNC sub STORE { my $self = shift; my $tag = shift; - my @vals = split("\0",shift); + my $vals = shift; + my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; $self->param(-name=>$tag,-value=>\@vals); } END_OF_FUNC @@ -901,7 +1157,7 @@ END_OF_FUNC #### 'append' => <<'EOF', sub append { - my($self,@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) { @@ -918,7 +1174,8 @@ EOF 'delete_all' => <<'EOF', sub delete_all { my($self) = self_or_default(@_); - undef %{$self}; + my @param = $self->param(); + $self->delete(@param); } EOF @@ -942,7 +1199,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 @@ -996,20 +1255,20 @@ 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 @@ -1042,6 +1301,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 @@ -1070,23 +1332,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) = rearrange([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 @@ -1095,23 +1358,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) = 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 @@ -1124,6 +1396,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 # @@ -1133,36 +1418,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,@other) = + my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], 'STATUS',['COOKIE','COOKIES'],'TARGET', - 'EXPIRES','NPH','CHARSET'],@p); + 'EXPIRES','NPH','CHARSET', + 'ATTACHMENT','P3P'],@p); $nph ||= $NPH; + + $type ||= 'text/html' unless defined($type); + if (defined $charset) { $self->charset($charset); } else { - $charset = $self->charset; + $charset = $self->charset if $type =~ /^text\//; } + $charset ||= ''; # rearrange() was designed for the HTML portion, so we # need to fix it up a little. 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/; + $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; @@ -1176,16 +1475,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 ''; + $self->r->send_cgi_header($header); + return ''; } return $header; } @@ -1215,18 +1513,21 @@ END_OF_FUNC 'redirect' => <<'END_OF_FUNC', sub redirect { my($self,@p) = self_or_default(@_); - my($url,$target,$cookie,$nph,@other) = 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 @@ -1244,65 +1545,102 @@ 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 @@ -1315,26 +1653,57 @@ sub _style { my ($self,$style) = @_; my (@result); my $type = 'text/css'; - if (ref($style)) { - my($src,$code,$stype,@other) = - 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 $cdata_start = $XHTML ? "\n\n" : " -->\n"; + + my @s = ref($style) eq 'ARRAY' ? @$style : $style; + + for my $s (@s) { + if (ref($s)) { + my($src,$code,$verbatim,$stype,$foo,@other) = + rearrange([qw(SRC CODE VERBATIM TYPE FOO)], + ('-foo'=>'bar', + ref($s) eq 'ARRAY' ? @$s : %$s)); + $type = $stype if $stype; + my $other = @other ? join ' ',@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); @@ -1353,19 +1722,26 @@ sub _script { } else { ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript'); } - my(@satts); - push(@satts,'src'=>$src) if $src; - push(@satts,'language'=>$language); - push(@satts,'type'=>$type); - $code = "" - if $code && $type=~/javascript/i; - $code = "" - if $code && $type=~/perl/i; - $code = "" - if $code && $type=~/tcl/i; - $code = "" - if $code && $type=~/vbscript/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,'language'=>$language) unless defined $type; + push(@satts,'type'=>$type); + $code = $cdata_start . $code . $cdata_end if defined $code; + push(@result,$self->script({@satts},$code || '')); } @result; } @@ -1373,11 +1749,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 @@ -1391,14 +1767,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) = rearrange([ACTION],@p); - $action = qq/ACTION="$action"/ if $action; + $action = qq/ action="$action"/ if $action; my($other) = @other ? " @other" : ''; - return ""; + return $XHTML ? "" : ""; } END_OF_FUNC @@ -1416,13 +1792,18 @@ sub startform { my($method,$action,$enctype,@other) = 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); + } + $action = qq(action="$action"); my($other) = @other ? " @other" : ''; $self->{'.parametersToAdd'}={}; - return qq/
\n/; + return qq/\n/; } END_OF_FUNC @@ -1431,7 +1812,7 @@ END_OF_FUNC # synonym for startform 'start_form' => <<'END_OF_FUNC', sub start_form { - &startform; + $XHTML ? &start_multipart_form : &startform; } END_OF_FUNC @@ -1446,10 +1827,8 @@ END_OF_FUNC 'start_multipart_form' => <<'END_OF_FUNC', sub start_multipart_form { my($self,@p) = self_or_default(@_); - if (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) = rearrange([METHOD,ACTION],@p); @@ -1463,44 +1842,41 @@ END_OF_FUNC # End a form 'endform' => <<'END_OF_FUNC', sub endform { - my($self,@p) = self_or_default(@_); + my($self,@p) = self_or_default(@_); if ( $NOSTICKY ) { - return wantarray ? ("
") : "\n"; + return wantarray ? ("") : "\n"; } else { - return wantarray ? ($self->get_fields,"") : - $self->get_fields ."\n"; + if (my @fields = $self->get_fields) { + return wantarray ? ("
",@fields,"
","") + : "
".(join '',@fields)."
\n"; + } else { + return ""; + } } } END_OF_FUNC -#### Method: end_form -# synonym for endform -'end_form' => <<'END_OF_FUNC', -sub end_form { - &endform; -} -END_OF_FUNC - - '_textfield' => <<'END_OF_FUNC', sub _textfield { my($self,$tag,@p) = self_or_default(@_); - my($name,$default,$size,$maxlength,$override,@other) = - 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 @@ -1512,7 +1888,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 { @@ -1528,7 +1904,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 { @@ -1547,7 +1923,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 { @@ -1564,24 +1940,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) = - 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 @@ -1594,27 +1970,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) = 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 @@ -1626,24 +2004,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) = 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"' unless $NOSTICKY; - $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 @@ -1653,16 +2033,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) = 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 @@ -1672,7 +2059,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 @@ -1682,13 +2069,15 @@ END_OF_FUNC sub defaults { my($self,@p) = self_or_default(@_); - my($label,@other) = 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 @@ -1713,126 +2102,81 @@ 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) = - rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); - + my($name,$checked,$value,$label,$override,$tabindex,@other) = + rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[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(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) = - 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'}; - if (uc $self->{'.charset'} eq 'ISO-8859-1') { - # fix non-compliant bug in IE and Netscape - $toencode =~ s{(.)}{ - if ($1 eq '<') { '<' } - elsif ($1 eq '>') { '>' } - elsif ($1 eq '&') { '&' } - elsif ($1 eq '"') { '"' } - elsif ($1 eq "\x8b") { '‹' } - elsif ($1 eq "\x9b") { '›' } - else { $1 } - }gsex; - } else { - $toencode =~ s/(.)/'&#'.ord($1).';'/gsex; - } - return $toencode; + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); + return undef unless defined($toencode); + return $toencode if ref($self) && !$self->{'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; + } + my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' || + uc $self->{'.charset'} eq 'WINDOWS-1252'; + if ($latin) { # bug in some browsers + $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; @@ -1840,8 +2184,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; @@ -1852,6 +2196,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)) { @@ -1860,25 +2206,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 @@ -1899,47 +2245,111 @@ 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) = - rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS, - ROWS,[COLUMNS,COLS], - ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS],@p); +#### 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,$attributes, + $rows,$columns,$rowheaders,$colheaders, + $override,$nolabels,$tabindex,@other) = + rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES, + ROWS,[COLUMNS,COLS],ROWHEADERS,COLHEADERS, + [OVERRIDE,FORCE],NOLABELS,TABINDEX + ],@_); my($result,$checked); - 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; foreach (@values) { - my($checkit) = $checked eq $_ ? ' CHECKED' : ''; - my($break) = $linebreak ? '
' : ''; + 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); } + my $attribs = $self->_set_attributes($_, $attributes); + my $tab = $tabs{$_}; $_=$self->escapeHTML($_); - push(@elements,qq/${label}${break}/); + if ($XHTML) { + push @elements, + CGI::label( + 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); } @@ -1964,8 +2374,9 @@ END_OF_FUNC sub popup_menu { my($self,@p) = self_or_default(@_); - my($name,$values,$default,$labels,$override,@other) = - rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p); + 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))) { @@ -1978,18 +2389,88 @@ sub popup_menu { 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) = defined($selected) ? $self->_selected($selected eq $_) : ''; + my($label) = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + my($value) = $self->escapeHTML($_); + $label=$self->escapeHTML($label,1); + $result .= "$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 @@ -2018,9 +2499,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) + my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other) = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p); + SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); my($result,@values); @values = $self->_set_values_and_labels($values,\$labels,$name); @@ -2028,21 +2509,23 @@ 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"; + my($value)=$self->escapeHTML($_,1); + my $attribs = $self->_set_attributes($_, $attributes); + $result .= "\n"; } - $result .= "\n"; + $result .= ""; $self->register_parameter($name); return $result; } @@ -2056,7 +2539,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 { @@ -2084,8 +2567,9 @@ sub hidden { $name=$self->escapeHTML($name); foreach (@value) { - $_ = defined($_) ? $self->escapeHTML($_) : ''; - push(@result,qq//); + $_ = defined($_) ? $self->escapeHTML($_,1) : ''; + push @result,$XHTML ? qq() + : qq(); } return wantarray ? @result : join('',@result); } @@ -2098,7 +2582,7 @@ 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 { @@ -2107,10 +2591,11 @@ sub image_button { my($name,$src,$alignment,@other) = rearrange([NAME,SRC,ALIGN],@p); - my($align) = $alignment ? " ALIGN=\U$alignment" : ''; + my($align) = $alignment ? " align=\U\"$alignment\"" : ''; my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); - return qq//; + return $XHTML ? qq() + : qq//; } END_OF_FUNC @@ -2145,50 +2630,48 @@ END_OF_FUNC 'url' => <<'END_OF_FUNC', sub url { my($self,@p) = self_or_default(@_); - my ($relative,$absolute,$full,$path_info,$query) = - 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 - if (exists($ENV{PATH_INFO})) { - my $decoded_path = unescape($ENV{PATH_INFO}); - substr($script_name,$index) = '' if ($index = rindex($script_name,$decoded_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 !~ /^$script_name/; + undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active + + my $uri = $rewrite && $request_uri ? $request_uri : $script_name; + $uri =~ s/\?.*$//; # remove query string + $uri =~ s/\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'); if ($vh) { $url .= $vh; } else { $url .= server_name(); my $port = $self->server_port; $url .= ":" . $port - unless (lc($protocol) eq 'http' && $port == 80) + unless (lc($protocol) eq 'http' && $port == 80) || (lc($protocol) eq 'https' && $port == 443); } - $url .= $script_name; + 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 = '' unless defined $url; - $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/uc sprintf("%%%02x",ord($1))/eg; + + $url .= $path if $path_info and defined $path; + $url .= "?$query_str" if $query and $query_str ne ''; + $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; return $url; } @@ -2209,8 +2692,8 @@ END_OF_FUNC 'cookie' => <<'END_OF_FUNC', sub cookie { my($self,@p) = self_or_default(@_); - my($name,$value,$path,$domain,$secure,$expires) = - rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); + my($name,$value,$path,$domain,$secure,$expires,$httponly) = + rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p); require CGI::Cookie; @@ -2229,7 +2712,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); @@ -2238,8 +2721,9 @@ 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 CGI::Cookie->new(@param); + return new CGI::Cookie(@param); } END_OF_FUNC @@ -2281,17 +2765,40 @@ 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 +# WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54 +'_name_and_path_from_env' => <<'END_OF_FUNC', +sub _name_and_path_from_env { + my $self = shift; + my $raw_script_name = $ENV{SCRIPT_NAME} || ''; + my $raw_path_info = $ENV{PATH_INFO} || ''; + my $uri = unescape($self->request_uri) || ''; + + my $protected = quotemeta($raw_path_info); + $raw_script_name =~ s/$protected$//; + + my @uri_double_slashes = $uri =~ m^(/{2,}?)^g; + my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g; + + my $apache_bug = @uri_double_slashes != @path_double_slashes; + return ($raw_script_name,$raw_path_info) unless $apache_bug; + + my $path_info_search = quotemeta($raw_path_info); + $path_info_search =~ s!/!/+!g; + if ($uri =~ m/^(.+)($path_info_search)/) { + return ($1,$2); + } else { + return ($raw_script_name,$raw_path_info); + } +} +END_OF_FUNC + #### Method: request_method # Returns 'POST', 'GET', 'PUT' or 'HEAD' @@ -2322,6 +2829,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 @@ -2338,6 +2855,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 @@ -2436,7 +2956,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; } @@ -2474,10 +2994,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; + } 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 @@ -2512,6 +3036,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 #### @@ -2657,6 +3197,17 @@ 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 @@ -2713,11 +3264,12 @@ END_OF_FUNC sub read_from_cmdline { my($input,@words); my($query_string); + my($subpath); if ($DEBUG && @ARGV) { @words = @ARGV; } 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); @@ -2732,7 +3284,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 @@ -2746,8 +3303,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; @@ -2759,18 +3316,24 @@ sub read_multipart { return; } - my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/; + my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/; + $param .= $TAINTED; # Bug: Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/; + my($filename) = $header{'Content-Disposition'}=~/ filename="([^"]*)"/; + # 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. - if ( !defined($filename) || $filename eq '' ) { + if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) { my($value) = $buffer->readBody; + $value .= $TAINTED; push(@{$self->{$param}},$value); next; } @@ -2787,30 +3350,63 @@ 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 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; + 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. - $self->{'.tmpfiles'}->{fileno($filehandle)}= { + # 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}, }; @@ -2823,18 +3419,17 @@ 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'}->{fileno($filename)}->{name} ? - $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string + return $self->{'.tmpfiles'}->{$$filename}->{name} ? + $self->{'.tmpfiles'}->{$$filename}->{name}->as_string : ''; } END_OF_FUNC @@ -2842,7 +3437,7 @@ END_OF_FUNC 'uploadInfo' => <<'END_OF_FUNC', sub uploadInfo { my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{fileno($filename)}->{info}; + return $self->{'.tmpfiles'}->{$$filename}->{info}; } END_OF_FUNC @@ -2858,6 +3453,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 (@_) { @@ -2887,6 +3498,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 = ( @@ -2895,8 +3511,8 @@ sub asString { my $self = shift; # get rid of package name (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//; - $i =~ s/\\(.)/$1/g; - return $i; + $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. @@ -2919,30 +3535,28 @@ END_OF_FUNC 'new' => <<'END_OF_FUNC', sub new { my($pack,$name,$file,$delete) = @_; + _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; require Fcntl unless defined &Fcntl::O_RDWR; - my $fv = ('Fh::' . ++$FH . quotemeta($name)); - warn unless *{$fv}; - my $ref = \*{$fv}; - 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; -} -END_OF_FUNC - ); 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; @@ -2965,18 +3579,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 @@ -2993,12 +3599,12 @@ 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 @@ -3006,8 +3612,8 @@ sub new { } my $self = {LENGTH=>$length, + CHUNKED=>!defined $length, BOUNDARY=>$boundary, - IN=>$IN, INTERFACE=>$interface, BUFFER=>'', }; @@ -3021,7 +3627,7 @@ sub new { unless ($boundary_read) { while ($self->read(0)) { } } - die "Malformed multipart POST\n" if $self->eof; + die "Malformed multipart POST: data truncated\n" if $self->eof; return $retval; } @@ -3034,7 +3640,7 @@ sub readHeader { my($ok) = 0; my($bad) = 0; - local($CRLF) = "\015\012" if $CGI::OS eq 'VMS'; + local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; do { $self->fillBuffer($FILLUNIT); @@ -3046,19 +3652,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; } @@ -3072,9 +3686,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 @@ -3087,49 +3710,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 @@ -3139,18 +3771,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() @@ -3158,14 +3790,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 @@ -3186,17 +3818,19 @@ 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", "${SL}SYS\$SCRATCH"); - unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'}; + "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", + "C:${SL}system${SL}temp"); + unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'}; # this feature was supposed to provide per-user tmpfiles, but # it is problematic. @@ -3208,16 +3842,26 @@ unless ($TMPDIRECTORY) { # 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 #################### @@ -3230,23 +3874,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++)); } - # 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) = @_; @@ -3305,9 +3944,12 @@ 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; } @@ -3425,12 +4067,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 @@ -3451,12 +4093,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 @@ -3588,6 +4236,11 @@ If a value is not given in the query string, as in the queries "name1=&name2=" or "name1&name2", it will be returned as an empty string. This feature is new in 2.63. + +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'); @@ -3626,17 +4279,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. @@ -3650,6 +4308,21 @@ 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'); + +(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'; @@ -3695,7 +4368,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 @@ -3725,14 +4398,14 @@ 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"; } @@ -3811,9 +4484,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. @@ -3825,7 +4503,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> @@ -3838,7 +4516,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: @@ -3932,15 +4610,48 @@ 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 -This makes CGI.pm not generating the hidden fields .submit -and .cgifields. It is very useful if you don't want to -have the hidden fields appear in the querystring in a GET method. -For example, a search script generated this way will have -a very nice url with search parameters for bookmarking. +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 -nph @@ -4041,7 +4752,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 @@ -4065,13 +4776,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 @@ -4096,24 +4807,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 @@ -4129,7 +4841,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 @@ -4162,9 +4874,26 @@ 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 @@ -4172,29 +4901,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', @@ -4208,14 +4945,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/" @@ -4234,29 +4972,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: + + + + +To create an HTTP-EQUIV type of tag, use B<-head>, described +below. - - +The B<-style> argument is used to incorporate cascading stylesheets +into your code. See the section on CASCADING STYLESHEETS for more +information. -There is no direct 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: +The B<-lang> argument is used to incorporate a language attribute into +the tag. For example: - print $q->header(-Refresh=>'10; URL=http://www.capricorn.com'); + print $q->start_html(-lang=>'fr-CA'); -The B<-style> tag is used to incorporate cascading stylesheets into -your code. See the section on CASCADING STYLESHEETS for more information. +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=>''). -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 +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=>[ @@ -4267,11 +5022,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