X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=9f65f7d02b480357c3282439a13cf61ff3b40227;hb=cc83745da206d409d7227df077f422fd9ecbe680;hp=8b7568af8a48f3aff79c5712fc17a8413ae27b5c;hpb=91e74348ab129f737e0d9da75481cd4eb7414ba4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CGI.pm b/lib/CGI.pm index 8b7568a..9f65f7d 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.130 2003/08/01 14:39:17 lstein Exp $ + patches by merlyn'; +$CGI::VERSION='3.00'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. -# $TempFile::TMPDIRECTORY = '/usr/tmp'; +# $CGITempFile::TMPDIRECTORY = '/usr/tmp'; use CGI::Util qw(rearrange make_attributes unescape escape expires); +#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); +} + +my @SAVED_SYMBOLS; + +$MOD_PERL = 0; # no mod_perl by default + # >>>>> 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,16 @@ sub initialize_globals { # 2) CGI::private_tempfiles(1); $PRIVATE_TEMPFILES = 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 +104,17 @@ 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; undef @QUERY_PARAM; undef %EXPORT; + undef $QUERY_CHARSET; + undef %QUERY_FIELDNAMES; # prevent complaints by mod_perl 1; @@ -99,24 +134,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 +164,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 +174,23 @@ $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; - require Apache; +if (exists $ENV{MOD_PERL}) { + eval "require 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 (defined $mod_perl::VERSION) { + if ($mod_perl::VERSION >= 1.99) { + $MOD_PERL = 2; + require Apache::RequestRec; + require Apache::RequestUtil; + 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/; @@ -173,7 +221,10 @@ 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 @@ -187,21 +238,20 @@ if ($needs_binmode) { 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/] ); # 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,22 +293,46 @@ 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; + if (ref($initializer[0]) + && (UNIVERSAL::isa($initializer[0],'Apache') + || + UNIVERSAL::isa($initializer[0],'Apache::RequestRec') + )) { + $self->r(shift @initializer); + } + if ($MOD_PERL) { + $self->r(Apache->request) unless $self->r; + my $r = $self->r; + if ($MOD_PERL == 1) { + $r->register_cleanup(\&CGI::_reset_globals); } - $self->_reset_globals if $PERLEX; - $self->init($initializer); - return $self; + else { + # XXX: once we have the new API + # will do a real PerlOptions -SetupEnv check + $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; + $r->pool->cleanup_register(\&CGI::_reset_globals); + } + undef $NPH; + } + $self->_reset_globals if $PERLEX; + $self->init(@initializer); + return $self; } # We provide a DESTROY method so that the autoloader # doesn't bother trying to find it. sub DESTROY { } +sub r { + my $self = shift; + my $r = $self->{'.r'}; + $self->{'.r'} = shift if @_; + $r; +} + #### Method: param # Returns the value(s)of a named parameter. # If invoked in a list context, returns the @@ -337,17 +411,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,10 +437,19 @@ 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)) { + # quietly read and discard the post + my $buffer; + my $max = $content_length; + while ($max > 0 && (my $bytes = read(STDIN,$buffer,$max < 10000 ? $max : 10000))) { + $max -= $bytes; + } $self->cgi_error("413 Request entity too large"); last METHOD; } @@ -416,7 +506,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'}; @@ -441,9 +531,21 @@ sub init { $query_string = read_from_cmdline() if $DEBUG; } +# 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 { @@ -468,9 +570,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 +619,8 @@ sub save_request { next unless defined $_; $QUERY_PARAM{$_}=$self->{$_}; } + $QUERY_CHARSET = $self->charset; + %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; } sub parse_params { @@ -527,6 +629,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); @@ -558,26 +662,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"; }#; } @@ -605,7 +708,7 @@ sub _compile { unless (%$sub) { my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; 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 +724,40 @@ sub _compile { $code = $CGI::DefaultClass->_make_tag_func($func_name); } } - die "Undefined subroutine $AUTOLOAD\n" unless $code; + croak("Undefined subroutine $AUTOLOAD\n") unless $code; 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 +765,14 @@ 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$/; + $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 +791,7 @@ sub _setup_symbols { } } _compile_all(keys %EXPORT) if $compile; + @SAVED_SYMBOLS = @_; } sub charset { @@ -691,7 +817,7 @@ 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', @@ -717,10 +843,17 @@ 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()); + 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 wantarray ? () : undef; } END_OF_FUNC @@ -841,9 +974,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 +988,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 @@ -918,7 +1056,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 +1081,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 +1137,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 +1183,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 +1214,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, -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 +1240,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 +1278,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 # @@ -1135,10 +1302,11 @@ sub header { return undef 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; if (defined $charset) { @@ -1150,19 +1318,25 @@ sub header { # 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 =~ m!^text/! and $type !~ /\bcharset\b/ 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 +1350,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 +1388,19 @@ 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,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,['COOKIE','COOKIES'],NPH],@p); + $url ||= $self->self_url; my(@o); foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } unshift(@o, - '-Status'=>'302 Moved', - '-Location'=>$url, - '-nph'=>$nph); + '-Status' => '302 Moved', + '-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,48 +1418,63 @@ END_OF_FUNC # $script -> (option) Javascript code (-script) # $no_script -> (option) Javascript END ; my($other) = @other ? " @other" : ''; - push(@result,""); + push(@result,""); return join("\n",@result); } END_OF_FUNC @@ -1315,26 +1504,50 @@ sub _style { my ($self,$style) = @_; my (@result); my $type = 'text/css'; + + my $cdata_start = $XHTML ? "\n\n" : " -->\n"; + 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; + my($src,$code,$verbatim,$stype,$foo,@other) = + rearrange([SRC,CODE,VERBATIM,TYPE], + '-foo'=>'bar', # trick to allow dash to be omitted + ref($style) eq 'ARRAY' ? @$style : %$style); + $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) { + push(@result, ""); + } + push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code; } else { - push(@result,style({'type'=>$type},"")); + my $src = $style; + 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 +1566,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,script({@satts},$code || '')); } @result; } @@ -1373,11 +1593,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 ""; } END_OF_FUNC @@ -1391,14 +1611,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 +1636,18 @@ sub startform { my($method,$action,$enctype,@other) = rearrange([METHOD,ACTION,ENCTYPE],@p); - $method = $method || 'POST'; + $method = lc($method) || 'post'; $enctype = $enctype || &URL_ENCODED; - $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ? - 'ACTION="'.$self->script_name.'"' : ''; + unless (defined $action) { + $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1)); + if (length($ENV{QUERY_STRING})>0) { + $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1); + } + } + $action = qq(action="$action"); my($other) = @other ? " @other" : ''; $self->{'.parametersToAdd'}={}; - return qq/
\n/; + return qq/\n/; } END_OF_FUNC @@ -1465,10 +1690,10 @@ END_OF_FUNC sub endform { my($self,@p) = self_or_default(@_); if ( $NOSTICKY ) { - return wantarray ? ("
") : "\n"; + return wantarray ? ("") : "\n"; } else { - return wantarray ? ($self->get_fields,"") : - $self->get_fields ."\n"; + return wantarray ? ("
",$self->get_fields,"
","") : + "
".$self->get_fields ."
\n"; } } END_OF_FUNC @@ -1487,20 +1712,21 @@ 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); + rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@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") : ''; + return $XHTML ? qq() + : qq(); } END_OF_FUNC @@ -1512,7 +1738,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 +1754,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 +1773,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,7 +1790,7 @@ 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 { @@ -1578,10 +1804,10 @@ sub textarea { $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{}; + return qq{}; } END_OF_FUNC @@ -1594,7 +1820,7 @@ 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 { @@ -1604,17 +1830,18 @@ sub button { [ONCLICK,SCRIPT]],@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//; + return $XHTML ? qq() + : qq(); } END_OF_FUNC @@ -1626,7 +1853,7 @@ 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 { @@ -1635,15 +1862,16 @@ sub submit { my($label,$value,@other) = rearrange([NAME,[VALUE,LABEL]],@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) = ' name=".submit"' unless $NOSTICKY; + $name = qq/ name="$label"/ if defined($label); $value = defined($value) ? $value : $label; - my($val) = ''; - $val = qq/ VALUE="$value"/ if defined($value); + my $val = ''; + $val = qq/ value="$value"/ if defined($value); my($other) = @other ? " @other" : ''; - return qq//; + return $XHTML ? qq() + : qq(); } END_OF_FUNC @@ -1653,16 +1881,22 @@ 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,@other) = rearrange(['NAME',['VALUE','LABEL']],@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//; + return $XHTML ? qq() + : qq(); } END_OF_FUNC @@ -1672,7 +1906,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 @@ -1684,11 +1918,12 @@ sub defaults { my($label,@other) = rearrange([[NAME,VALUE]],@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//; + return $XHTML ? qq() + : qq//; } END_OF_FUNC @@ -1713,7 +1948,7 @@ 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 { @@ -1726,17 +1961,18 @@ sub checkbox { 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" : ''; $self->register_parameter($name); - return qq{$the_label}; + return $XHTML ? qq{$the_label} + : qq{$the_label}; } END_OF_FUNC @@ -1760,16 +1996,16 @@ 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 #### 'checkbox_group' => <<'END_OF_FUNC', sub checkbox_group { my($self,@p) = self_or_default(@_); - my($name,$values,$defaults,$linebreak,$labels,$rows,$columns, + my($name,$values,$defaults,$linebreak,$labels,$attributes,$rows,$columns, $rowheaders,$colheaders,$override,$nolabels,@other) = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - LINEBREAK,LABELS,ROWS,[COLUMNS,COLS], + LINEBREAK,LABELS,ATTRIBUTES,ROWS,[COLUMNS,COLS], ROWHEADERS,COLHEADERS, [OVERRIDE,FORCE],NOLABELS],@p); @@ -1777,7 +2013,12 @@ sub checkbox_group { my(%checked) = $self->previous_or_default($name,$defaults,$override); - $break = $linebreak ? "
" : ''; + if ($linebreak) { + $break = $XHTML ? "
" : "
"; + } + else { + $break = ''; + } $name=$self->escapeHTML($name); # Create the elements @@ -1787,19 +2028,23 @@ sub checkbox_group { my($other) = @other ? " @other" : ''; foreach (@values) { - $checked = $checked{$_} ? ' CHECKED' : ''; + $checked = $self->_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}/); + my $attribs = $self->_set_attributes($_, $attributes); + $_ = $self->escapeHTML($_,1); + push(@elements,$XHTML ? qq(${label}${break}) + : qq/${label}${break}/); } $self->register_parameter($name); return wantarray ? @elements : join(' ',@elements) unless defined($columns) || defined($rows); + $rows = 1 if $rows && $rows < 1; + $cols = 1 if $cols && $cols < 1; return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); } END_OF_FUNC @@ -1807,32 +2052,37 @@ 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; + $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]; + 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 +2090,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 +2102,8 @@ END_OF_FUNC '_tableize' => <<'END_OF_FUNC', sub _tableize { my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; + $rowheaders = [] unless defined $rowheaders; + $colheaders = [] unless defined $colheaders; my($result); if (defined($columns)) { @@ -1862,23 +2114,23 @@ sub _tableize { } # rearrange into a pretty table - $result = ""; + $result = "
"; my($row,$column); unshift(@$colheaders,'') if @$colheaders && @$rowheaders; - $result .= "" if @{$colheaders}; + $result .= "" if @{$colheaders}; foreach (@{$colheaders}) { - $result .= ""; + $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,15 +2151,15 @@ 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(@_); - my($name,$values,$default,$linebreak,$labels, + my($name,$values,$default,$linebreak,$labels,$attributes, $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) = - rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS, + rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,ATTRIBUTES, ROWS,[COLUMNS,COLS], ROWHEADERS,COLHEADERS, [OVERRIDE,FORCE],NOLABELS],@p); @@ -1927,16 +2179,24 @@ sub radio_group { my($other) = @other ? " @other" : ''; foreach (@values) { - my($checkit) = $checked eq $_ ? ' CHECKED' : ''; - my($break) = $linebreak ? '
' : ''; + my($checkit) = $checked eq $_ ? qq/ 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); $_=$self->escapeHTML($_); - push(@elements,qq/${label}${break}/); + push(@elements,$XHTML ? qq(${label}${break}) + : qq/${label}${break}/); } $self->register_parameter($name); return wantarray ? @elements : join(' ',@elements) @@ -1964,8 +2224,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,@other) = + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, + ATTRIBUTES,[OVERRIDE,FORCE]],@p); my($result,$selected); if (!$override && defined($self->param($name))) { @@ -1979,17 +2240,87 @@ 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' : '' ) : ''; + if (/_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); - $result .= "\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 +2349,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,@other) = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p); + SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE]],@p); my($result,@values); @values = $self->_set_values_and_labels($values,\$labels,$name); @@ -2028,21 +2359,22 @@ 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 .= "$label\n"; } - $result .= "\n"; + $result .= ""; $self->register_parameter($name); return $result; } @@ -2056,7 +2388,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 +2416,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 +2431,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 +2440,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,25 +2479,24 @@ 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 ($relative,$absolute,$full,$path_info,$query,$base) = + rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p); my $url; - $full++ if !($relative || $absolute); + $full++ if $base || !($relative || $absolute); my $path = $self->path_info; - my $script_name; + my $script_name = $self->script_name; + + # for compatibility with Apache's MultiViews 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; + $script_name = unescape($ENV{REQUEST_URI}); + $script_name =~ s/\?.+$//; # strip query string # 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; + my $encoded_path = quotemeta($ENV{PATH_INFO}); + $script_name =~ s/$encoded_path$//i; } - } else { - $script_name = $self->script_name; } if ($full) { @@ -2179,16 +2512,18 @@ sub url { unless (lc($protocol) eq 'http' && $port == 80) || (lc($protocol) eq 'https' && $port == 443); } + return $url if $base; $url .= $script_name; } elsif ($relative) { ($url) = $script_name =~ m!([^/]+)$!; } elsif ($absolute) { $url = $script_name; } + $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 =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; return $url; } @@ -2229,7 +2564,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); @@ -2239,7 +2574,7 @@ sub cookie { push(@param,'-expires'=>$expires) if $expires; push(@param,'-secure'=>$secure) if $secure; - return CGI::Cookie->new(@param); + return new CGI::Cookie(@param); } END_OF_FUNC @@ -2338,6 +2673,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 @@ -2657,6 +2995,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 @@ -2760,17 +3109,23 @@ sub read_multipart { } 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,17 +3142,32 @@ 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)); 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; + die "CGI open of tmpfile: $!\n" unless defined $filehandle; $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + # if this is an multipart/mixed attachment, save the header + # together with the body for lateron 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)) { @@ -2806,6 +3176,12 @@ sub read_multipart { # 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 @@ -2823,10 +3199,9 @@ 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 && fileno($_), $self->param($param_name)); + return unless @param; + return wantarray ? @param : $param[0]; } END_OF_FUNC @@ -2858,6 +3233,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}}) { + $attrib =~ s/^-//; + $attribs .= "@{[lc($attrib)]}=\"$attributes->{$element}{$attrib}\" "; + } + $attribs =~ s/ $//; + return $attribs; +} +END_OF_FUNC + '_compile_all' => <<'END_OF_FUNC', sub _compile_all { foreach (@_) { @@ -2895,8 +3286,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,13 +3310,16 @@ 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 @@ -2993,7 +3387,7 @@ 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); @@ -3050,15 +3444,15 @@ sub readHeader { substr($self->{BUFFER},0,$end+4) = ''; my %return; - # 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; } @@ -3099,8 +3493,7 @@ sub read { die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0); # 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. @@ -3111,13 +3504,14 @@ sub read { } # just remove the boundary. - substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)=''; + substr($self->{BUFFER},0,length($self->{BOUNDARY}))=''; + $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 @@ -3129,7 +3523,8 @@ sub read { 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 @@ -3186,17 +3581,20 @@ END_OF_AUTOLOAD #################################################################################### ################################## TEMPORARY FILES ################################# #################################################################################### -package TempFile; - -$SL = $CGI::SL; -$MAC = $CGI::OS eq 'MACINTOSH'; -my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; -unless ($TMPDIRECTORY) { +package CGITempFile; + +sub find_tempdir { + undef $TMPDIRECTORY; + $SL = $CGI::SL; + $MAC = $CGI::OS eq 'MACINTOSH'; + my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; + unless ($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 +3606,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 +3638,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) = @_; @@ -3425,12 +3828,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 +3854,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. -=item 3. Put quotes around the argument name, e.g. '-values' +Change the capitalization, e.g. -Values + +=item 3. + +Put quotes around the argument name, e.g. '-values' =back @@ -3588,6 +3997,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 +4040,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. @@ -3811,9 +4230,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 +4249,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 +4262,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,7 +4356,14 @@ 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 @@ -3942,6 +4373,17 @@ 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. +=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. + =item -nph This makes CGI.pm produce a header appropriate for an NPH (no @@ -4041,7 +4483,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 +4507,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 @@ -4114,6 +4556,7 @@ pages. -expires=>'+3d', -cookie=>$cookie, -charset=>'utf-7', + -attachment=>'foo.gif', -Cost=>'$2.00'); header() returns the Content-type: header. You can provide your own @@ -4162,6 +4605,23 @@ 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'); @@ -4172,9 +4632,7 @@ 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. @@ -4189,7 +4647,7 @@ You can also use named arguments: 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. =head2 CREATING THE HTML DOCUMENT HEADER @@ -4208,14 +4666,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 +4693,38 @@ 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. - - +The B<-lang> argument is used to incorporate a language attribute into +the tag. The default if not specified is "en-US" for US +English. For example: -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: + print $q->start_html(-lang=>'fr-CA'); - print $q->header(-Refresh=>'10; URL=http://www.capricorn.com'); +To leave off the lang attribute, as you must do if you want to generate +legal HTML 3.2 or earlier, pass the empty string (-lang=>''). -The B<-style> tag is used to incorporate cascading stylesheets into -your code. See the section on CASCADING STYLESHEETS for more information. +The B<-encoding> argument can be used to specify the character set for +XHTML. It defaults to iso-8859-1 if not specified. -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 +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 +4735,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