package CGI;
require 5.004;
+use Carp 'croak';
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
# listing the modifications you have made.
# The most recent version and complete docs are available at:
-# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
-# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.32 1998/05/28 21:55:43 lstein Exp lstein $';
-$CGI::VERSION='2.42';
+$CGI::revision = '$Id: CGI.pm,v 1.49 2001/02/04 23:08:39 lstein Exp $';
+$CGI::VERSION='2.753';
# 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);
+
+use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
+ 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
# >>>>> Here are some globals that you might want to adjust <<<<<<
sub initialize_globals {
# Set this to 1 to enable copious autoloader debugging messages
$AUTOLOAD_DEBUG = 0;
+
+ # Set this to 1 to generate XTML-compatible output
+ $XHTML = 1;
# Change this to the preferred DTD to print in start_html()
# or use default_dtd('text of DTD to use');
- $DEFAULT_DTD = '-//IETF//DTD HTML//EN';
+ $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
+ 'http://www.w3.org/TR/html4/loose.dtd' ] ;
+
+ # Set this to 1 to enable NOSTICKY scripts
+ # or:
+ # 1) use CGI qw(-nosticky)
+ # 2) $CGI::nosticky(1)
+ $NOSTICKY = 0;
# Set this to 1 to enable NPH scripts
# or:
# 1) use CGI qw(-nph)
- # 2) $CGI::nph(1)
+ # 2) CGI::nph(1)
# 3) print header(-nph=>1)
$NPH = 0;
- # Set this to 1 to disable debugging from the
- # command line
- $NO_DEBUG = 0;
+ # Set this to 1 to enable debugging from @ARGV
+ # Set to 2 to enable debugging from STDIN
+ $DEBUG = 1;
# Set this to 1 to make the temporary files created
# during file uploads safe from prying eyes
# or do...
# 1) use CGI qw(:private_tempfiles)
- # 2) $CGI::private_tempfiles(1);
+ # 2) CGI::private_tempfiles(1);
$PRIVATE_TEMPFILES = 0;
# Set this to a positive value to limit the size of a POSTing
# Change this to 1 to disable uploads entirely:
$DISABLE_UPLOADS = 0;
+ # Automatically determined -- don't change
+ $EBCDIC = 0;
+
+ # Change this to 1 to suppress redundant HTTP headers
+ $HEADERS_ONCE = 0;
+
+ # separate the name=value pairs by semicolons rather than ampersands
+ $USE_PARAM_SEMICOLONS = 1;
+
+ # Do not include undefined params parsed from query string
+ # use CGI qw(-no_undef_params);
+ $NO_UNDEF_PARAMS = 0;
+
# 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;
$OS = $Config::Config{'osname'};
}
}
-if ($OS=~/Win/i) {
- $OS = 'WINDOWS';
-} elsif ($OS=~/vms/i) {
- $OS = 'VMS';
-} elsif ($OS=~/^MacOS$/i) {
+if ($OS =~ /^MSWin/i) {
+ $OS = 'WINDOWS';
+} elsif ($OS =~ /^VMS/i) {
+ $OS = 'VMS';
+} elsif ($OS =~ /^dos/i) {
+ $OS = 'DOS';
+} elsif ($OS =~ /^MacOS/i) {
$OS = 'MACINTOSH';
-} elsif ($OS=~/os2/i) {
+} elsif ($OS =~ /^os2/i) {
$OS = 'OS2';
+} elsif ($OS =~ /^epoc/i) {
+ $OS = 'EPOC';
} else {
$OS = 'UNIX';
}
# Some OS logic. Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
+$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
# This is the default class for the CGI object to use when all else fails.
$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
# The path separator is a slash, backslash or semicolon, depending
# on the paltform.
$SL = {
- UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', MACINTOSH=>':', VMS=>'/'
+ UNIX=>'/', OS2=>'\\', EPOC=>'/',
+ WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
}->{$OS};
# This no longer seems to be necessary
$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
# Turn on special checking for Doug MacEachern's modperl
-if (defined($ENV{'GATEWAY_INTERFACE'}) &&
- ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
+if (exists $ENV{'GATEWAY_INTERFACE'}
+ &&
+ ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
{
$| = 1;
require Apache;
# really annoying.
$EBCDIC = "\t" ne "\011";
if ($OS eq 'VMS') {
- $CRLF = "\n";
+ $CRLF = "\n";
} elsif ($EBCDIC) {
- $CRLF= "\r\n";
+ $CRLF= "\r\n";
} else {
- $CRLF = "\015\012";
+ $CRLF = "\015\012";
}
if ($needs_binmode) {
':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
tt u i b blockquote pre img a address cite samp dfn html head
base body Link nextid title meta kbd start_html end_html
- input Select option comment/],
- ':html3'=>[qw/div table caption th td TR Tr sup sub strike applet Param
+ 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/],
':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 isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
- ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
- raw_cookie request_method query_string accept user_agent remote_host
+ 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
+ raw_cookie request_method query_string Accept user_agent remote_host content_type
remote_addr referer server_name server_software server_port server_protocol
- virtual_host remote_ident auth_type http use_named_parameters
+ virtual_host remote_ident auth_type http
save_parameters restore_parameters param_fetch
- remote_user user_name header redirect import_names put Delete Delete_all url_param/],
+ remote_user user_name header redirect import_names put
+ Delete Delete_all url_param cgi_error/],
':ssl' => [qw/https/],
- ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
+ ':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/],
+ ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
);
sub expand_tags {
my($tag) = @_;
+ return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
my(@r);
return ($tag) unless $EXPORT_TAGS{$tag};
foreach (@{$EXPORT_TAGS{$tag}}) {
my($class,$initializer) = @_;
my $self = {};
bless $self,ref $class || $class || $DefaultClass;
- if ($MOD_PERL) {
- Apache->request->register_cleanup(\&CGI::_reset_globals);
- undef $NPH;
+ if ($MOD_PERL && defined Apache->request) {
+ Apache->request->register_cleanup(\&CGI::_reset_globals);
+ undef $NPH;
}
$self->_reset_globals if $PERLEX;
$self->init($initializer);
# For compatibility between old calling style and use_named_parameters() style,
# we have to special case for a single parameter present.
if (@p > 1) {
- ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
+ ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
my(@values);
- if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
+ if (substr($p[0],0,1) eq '-') {
@values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
} else {
foreach ($value,@other) {
$name = $p[0];
}
- return () unless defined($name) && $self->{$name};
+ return unless defined($name) && $self->{$name};
return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
}
$Q = $CGI::DefaultClass->new unless defined($Q);
unshift(@_,$Q);
}
- return @_;
+ return wantarray ? @_ : $Q;
}
sub self_or_CGI {
sub init {
my($self,$initializer) = @_;
my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+ local($/) = "\n";
# if we get called more than once, we want to initialize
# ourselves from the original query (which may be gone
foreach (@QUERY_PARAM) {
$self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
}
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
return;
}
$meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
$content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
- die "Client attempted to POST $content_length bytes, but POSTs are limited to $POST_MAX"
- if ($POST_MAX > 0) && ($content_length > $POST_MAX);
+
$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;
+ }
+
# Process multipart postings, but only if the initializer is
# not defined.
if ($meth eq 'POST'
&& $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
&& !defined($initializer)
) {
- my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";]+)\"?/;
+ my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
$self->read_multipart($boundary,$content_length);
last METHOD;
}
# If method is GET or HEAD, fetch the query from
# the environment.
if ($meth=~/^(GET|HEAD)$/) {
- $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ if ($MOD_PERL) {
+ $query_string = Apache->request->args;
+ } else {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
+ }
last METHOD;
}
# Check the command line and then the standard input for data.
# We use the shellwords package in order to behave the way that
# UN*X programmers expect.
- $query_string = read_from_cmdline() unless $NO_DEBUG;
+ $query_string = read_from_cmdline() if $DEBUG;
}
# We now have the query string in hand. We do slightly
# different things for keyword lists and parameter lists.
- if ($query_string ne '') {
- if ($query_string =~ /=/) {
+ if (defined $query_string && length $query_string) {
+ if ($query_string =~ /[&=;]/) {
$self->parse_params($query_string);
} else {
$self->add_parameter('keywords');
# Clear out our default submission button flag if present
$self->delete('.submit');
$self->delete('.cgifields');
+
$self->save_request unless $initializer;
}
CORE::print(@_);
}
-# unescape URL-encoded data
-sub unescape {
- shift() if ref($_[0]);
- my $todecode = shift;
- return undef unless defined($todecode);
- $todecode =~ tr/+/ /; # pluses become spaces
- $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
- return $todecode;
-}
-
-# URL-encode data
-sub escape {
- shift() if ref($_[0]) || $_[0] eq $DefaultClass;
- my $toencode = shift;
- return undef unless defined($toencode);
- $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
- return $toencode;
+# get/set last cgi_error
+sub cgi_error {
+ my ($self,$err) = self_or_default(@_);
+ $self->{'.cgi_error'} = $err if defined $err;
+ return $self->{'.cgi_error'};
}
sub save_request {
# us to have several of these objects.
@QUERY_PARAM = $self->param; # save list of parameters
foreach (@QUERY_PARAM) {
- $QUERY_PARAM{$_}=$self->{$_};
+ next unless defined $_;
+ $QUERY_PARAM{$_}=$self->{$_};
}
+ $QUERY_CHARSET = $self->charset;
+ %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
}
sub parse_params {
my($self,$tosplit) = @_;
- my(@pairs) = split('&',$tosplit);
+ my(@pairs) = split(/[&;]/,$tosplit);
my($param,$value);
foreach (@pairs) {
($param,$value) = split('=',$_,2);
+ next if $NO_UNDEF_PARAMS and not $value;
+ $value = '' unless defined $value;
$param = unescape($param);
$value = unescape($value);
$self->add_parameter($param);
sub add_parameter {
my($self,$param)=@_;
+ return unless defined $param;
push (@{$self->{'.parameters'}},$param)
unless defined($self->{$param});
}
}
sub _make_tag_func {
- my $tagname = shift;
- return qq{
- sub $tagname {
- # handle various cases in which we're called
- # most of this bizarre stuff is to avoid -w errors
- shift if \$_[0] &&
- (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
- (ref(\$_[0]) &&
- (substr(ref(\$_[0]),0,3) eq 'CGI' ||
- UNIVERSAL::isa(\$_[0],'CGI')));
-
+ 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() );
+ my(\@attr) = make_attributes(shift()||undef,1);
\$attr = " \@attr" if \@attr;
}
- my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
- return \$tag unless \@_;
- my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
+ );
+ if ($tagname=~/start_(\w+)/i) {
+ $func .= qq! return "<\L$1\E\$attr>";} !;
+ } elsif ($tagname=~/end_(\w+)/i) {
+ $func .= qq! return "<\L/$1\E>"; } !;
+ } else {
+ $func .= qq#
+ return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@_;
+ my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
+ my \@result = map { "\$tag\$_\$untag" }
+ (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
return "\@result";
- }
-}
+ }#;
+ }
+return $func;
}
sub AUTOLOAD {
goto &$func;
}
-# PRIVATE SUBROUTINE
-# Smart rearrangement of parameters to allow named parameter
-# calling. We do the rearangement if:
-# 1. The first parameter begins with a -
-# 2. The use_named_parameters() method returns true
-sub rearrange {
- my($self,$order,@param) = @_;
- return () unless @param;
-
- if (ref($param[0]) eq 'HASH') {
- @param = %{$param[0]};
- } else {
- return @param
- unless (defined($param[0]) && substr($param[0],0,1) eq '-')
- || $self->use_named_parameters;
- }
-
- # map parameters into positional indices
- my ($i,%pos);
- $i = 0;
- foreach (@$order) {
- foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
- $i++;
- }
-
- my (@result,%leftover);
- $#result = $#$order; # preextend
- while (@param) {
- my $key = uc(shift(@param));
- $key =~ s/^\-//;
- if (exists $pos{$key}) {
- $result[$pos{$key}] = shift(@param);
- } else {
- $leftover{$key} = shift(@param);
- }
- }
-
- push (@result,$self->make_attributes(\%leftover)) if %leftover;
- @result;
-}
-
sub _compile {
my($func) = $AUTOLOAD;
my($pack,$func_name);
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};
$code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
if (!$code) {
+ (my $base = $func_name) =~ s/^(start_|end_)//i;
if ($EXPORT{':any'} ||
$EXPORT{'-any'} ||
- $EXPORT{$func_name} ||
+ $EXPORT{$base} ||
(%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
- && $EXPORT_OK{$func_name}) {
- $code = _make_tag_func($func_name);
+ && $EXPORT_OK{$base}) {
+ $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: $@");
}
}
- delete($sub->{$func_name}); #free storage
+ CORE::delete($sub->{$func_name}); #free storage
return "$pack\:\:$func_name";
}
my $self = shift;
my $compile = 0;
foreach (@_) {
- $NPH++, next if /^[:-]nph$/;
- $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
- $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
- $EXPORT{$_}++, next if /^[:-]any$/;
- $compile++, next if /^[:-]compile$/;
+ $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
+ $NPH++, next if /^[:-]nph$/;
+ $NOSTICKY++, next if /^[:-]nosticky$/;
+ $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
+ $DEBUG=2, next if /^[:-][Dd]ebug$/;
+ $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+ $XHTML++, next if /^[:-]xhtml$/;
+ $XHTML=0, next if /^[:-]no_?xhtml$/;
+ $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
+ $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
+ $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.
+ # This is probably extremely evil code -- to be deleted some day.
if (/^[-]autoload$/) {
my($pkg) = caller(1);
*{"${pkg}::AUTOLOAD"} = sub {
_compile_all(keys %EXPORT) if $compile;
}
+sub charset {
+ my ($self,$charset) = self_or_default(@_);
+ $self->{'.charset'} = $charset if defined $charset;
+ $self->{'.charset'};
+}
+
###############################################################################
################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
###############################################################################
END_OF_FUNC
'SERVER_PUSH' => <<'END_OF_FUNC',
-sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
-END_OF_FUNC
-
-'use_named_parameters' => <<'END_OF_FUNC',
-#### Method: use_named_parameters
-# Force CGI.pm to use named parameter-style method calls
-# rather than positional parameters. The same effect
-# will happen automatically if the first parameter
-# begins with a -.
-sub use_named_parameters {
- my($self,$use_named) = self_or_default(@_);
- return $self->{'.named'} unless defined ($use_named);
-
- # stupidity to avoid annoying warnings
- return $self->{'.named'}=$use_named;
-}
+sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
END_OF_FUNC
'new_MultipartBuffer' => <<'END_OF_FUNC',
# Deletes the named parameter entirely.
####
sub delete {
- my($self,$name) = self_or_default(@_);
- delete $self->{$name};
- delete $self->{'.fieldnames'}->{$name};
+ my($self,@p) = self_or_default(@_);
+ my($name) = rearrange([NAME],@p);
+ CORE::delete $self->{$name};
+ CORE::delete $self->{'.fieldnames'}->{$name};
@{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
return wantarray ? () : undef;
}
my($self,$namespace,$delete) = self_or_default(@_);
$namespace = 'Q' unless defined($namespace);
die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
- if ($delete || $MOD_PERL) {
+ if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
# can anyone find an easier way to do this?
foreach (keys %{"${namespace}::"}) {
local *symbol = "${namespace}::${_}";
sub keywords {
my($self,@values) = self_or_default(@_);
# If values is provided, then we set it.
- $self->{'keywords'}=[@values] if defined(@values);
+ $self->{'keywords'}=[@values] if @values;
my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
@result;
}
# These are some tie() interfaces for compatibility
# with Steve Brenner's cgi-lib.pl routines
+'Vars' => <<'END_OF_FUNC',
+sub Vars {
+ my $q = shift;
+ my %in;
+ tie(%in,CGI,$q);
+ return %in if wantarray;
+ return \%in;
+}
+END_OF_FUNC
+
+# These are some tie() interfaces for compatibility
+# with Steve Brenner's cgi-lib.pl routines
'ReadParse' => <<'END_OF_FUNC',
sub ReadParse {
local(*in);
'TIEHASH' => <<'END_OF_FUNC',
sub TIEHASH {
- return $Q || new CGI;
+ return $_[1] if defined $_[1];
+ return $Q ||= new shift;
}
END_OF_FUNC
'STORE' => <<'END_OF_FUNC',
sub STORE {
- $_[0]->param($_[1],split("\0",$_[2]));
+ my $self = shift;
+ my $tag = shift;
+ my $vals = shift;
+ my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
+ $self->param(-name=>$tag,-value=>\@vals);
}
END_OF_FUNC
'append' => <<'EOF',
sub append {
my($self,@p) = @_;
- my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
+ my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
if (@values) {
$self->add_parameter($name);
}
END_OF_FUNC
-'make_attributes' => <<'END_OF_FUNC',
-sub make_attributes {
- my($self,$attr) = @_;
- return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
- my(@att);
- foreach (keys %{$attr}) {
- my($key) = $_;
- $key=~s/^\-//; # get rid of initial - if present
- $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
- push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
- }
- return @att;
-}
-END_OF_FUNC
-
#### Method: url_param
# Return a parameter in the QUERY_STRING, regardless of
# whether this was a POST or a GET
unless (exists($self->{'.url_param'})) {
$self->{'.url_param'}={}; # empty hash
if ($ENV{QUERY_STRING} =~ /=/) {
- my(@pairs) = split('&',$ENV{QUERY_STRING});
+ my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
my($param,$value);
foreach (@pairs) {
($param,$value) = split('=',$_,2);
}
END_OF_FUNC
-#### Method: dump
+#### Method: Dump
# Returns a string in which all the known parameter/value
# pairs are represented as nested lists, mainly for the purposes
# of debugging.
####
-'dump' => <<'END_OF_FUNC',
-sub dump {
+'Dump' => <<'END_OF_FUNC',
+sub Dump {
my($self) = self_or_default(@_);
my($param,$value,@result);
return '<UL></UL>' unless $self->param;
push(@result,"<UL>");
foreach $value ($self->param($param)) {
$value = $self->escapeHTML($value);
+ $value =~ s/\n/<BR>\n/g;
push(@result,"<LI>$value");
}
push(@result,"</UL>");
####
'as_string' => <<'END_OF_FUNC',
sub as_string {
- &dump(@_);
+ &Dump(@_);
}
END_OF_FUNC
$filehandle = to_filehandle($filehandle);
my($param);
local($,) = ''; # set print field separator back to a sane value
+ local($\) = ''; # set output line separator to a sane value
foreach $param ($self->param) {
my($escaped_param) = escape($param);
my($value);
foreach $value ($self->param($param)) {
- print $filehandle "$escaped_param=",escape($value),"\n";
+ 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
#### 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 <ed@fidalgo.net> for this
-# contribution
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
####
'multipart_init' => <<'END_OF_FUNC',
sub multipart_init {
my($self,@p) = self_or_default(@_);
- my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
+ my($boundary,@other) = rearrange([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
# Return a Content-Type: style header for server-push, start of section
#
# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
####
'multipart_start' => <<'END_OF_FUNC',
sub multipart_start {
+ my(@header);
my($self,@p) = self_or_default(@_);
- my($type,@other) = $self->rearrange([TYPE],@p);
+ my($type,@other) = rearrange([TYPE],@p);
$type = $type || 'text/html';
- return $self->header(
- -type => $type,
- (map { split "=", $_, 2 } @other),
- );
+ push(@header,"Content-Type: $type");
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ foreach (@other) {
+ next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
+ ($_ = $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 <ed@fidalgo.net> for this
# contribution
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
#
my($self,@p) = self_or_default(@_);
my(@header);
- my($type,$status,$cookie,$target,$expires,$nph,@other) =
- $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+ return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
+
+ my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,@other) =
+ rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
+ 'STATUS',['COOKIE','COOKIES'],'TARGET',
+ 'EXPIRES','NPH','CHARSET',
+ 'ATTACHMENT'],@p);
+
+ $nph ||= $NPH;
+ if (defined $charset) {
+ $self->charset($charset);
+ } else {
+ $charset = $self->charset;
+ }
- $nph ||= $NPH;
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
foreach (@other) {
- next unless my($header,$value) = /([^\s=]+)=\"?([^\"]+)\"?/;
- ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
+ next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
}
- $type = $type || 'text/html';
+ $type ||= 'text/html' unless defined($type);
+ $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/;
# 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 ($cookie) {
my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
foreach (@cookie) {
- push(@header,"Set-Cookie: " . (UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_));
+ my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
+ push(@header,"Set-Cookie: $cs") if $cs ne '';
}
}
# if the user indicates an expiration time, then we need
# 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,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
push(@header,@other);
- push(@header,"Content-Type: $type");
+ push(@header,"Content-Type: $type") if $type ne '';
my $header = join($CRLF,@header)."${CRLF}${CRLF}";
if ($MOD_PERL and not $nph) {
'redirect' => <<'END_OF_FUNC',
sub redirect {
my($self,@p) = self_or_default(@_);
- my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
- $url = $url || $self->self_url;
+ my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
+ $url ||= $self->self_url;
my(@o);
foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
'-nph'=>$nph);
unshift(@o,'-Target'=>$target) if $target;
unshift(@o,'-Cookie'=>$cookie) if $cookie;
+ unshift(@o,'-Type'=>'');
return $self->header(@o);
}
END_OF_FUNC
'start_html' => <<'END_OF_FUNC',
sub start_html {
my($self,@p) = &self_or_default(@_);
- my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) =
- $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
+ my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,$lang,@other) =
+ rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG],@p);
# strangely enough, the title needs to be escaped as HTML
# while the author needs to be escaped as a URL
$title = $self->escapeHTML($title || 'Untitled Document');
$author = $self->escape($author);
- my(@result);
- $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|;
- push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)) if $dtd;
- push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
- push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author;
+ $lang ||= 'en-US';
+ my(@result,$xml_dtd);
+ if ($dtd) {
+ if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
+ $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
+ } else {
+ $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
+ }
+ } else {
+ $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
+ }
+
+ $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
+ $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
+ push @result,q(<?xml version="1.0" encoding="utf-8"?>) if $xml_dtd;
+
+ if (ref($dtd) && ref($dtd) eq 'ARRAY') {
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t"$dtd->[1]">));
+ } else {
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
+ }
+ push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang"><head><title>$title</title>)
+ : qq(<html lang="$lang"><head><title>$title</title>));
+ if (defined $author) {
+ push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
+ : "<link rev=\"made\" href=\"mailto:$author\">");
+ }
if ($base || $xbase || $target) {
my $href = $xbase || $self->url('-path'=>1);
- my $t = $target ? qq/ TARGET="$target"/ : '';
- push(@result,qq/<BASE HREF="$href"$t>/);
+ my $t = $target ? qq/ target="$target"/ : '';
+ push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
}
if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
- foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
+ foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
+ : qq(<meta name="$_" content="$meta->{$_}">)); }
}
push(@result,ref($head) ? @$head : $head) if $head;
# handle -noscript parameter
push(@result,<<END) if $noscript;
-<NOSCRIPT>
+<noscript>
$noscript
-</NOSCRIPT>
+</noscript>
END
;
my($other) = @other ? " @other" : '';
- push(@result,"</HEAD><BODY$other>");
+ push(@result,"</head><body$other>");
return join("\n",@result);
}
END_OF_FUNC
my ($self,$style) = @_;
my (@result);
my $type = 'text/css';
+
+ my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
+ my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
+
if (ref($style)) {
- my($src,$code,$stype,@other) =
- $self->rearrange([SRC,CODE,TYPE],
- '-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($style) eq 'ARRAY' ? @$style : %$style);
- $type = $stype if $stype;
- push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src;
- push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
+ 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;
+ if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
+ { # If it is, push a LINK tag for each one.
+ foreach $src (@$src)
+ {
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
+ : qq(<link rel="stylesheet" type="$type" href="$src">/)) if $src;
+ }
+ }
+ else
+ { # Otherwise, push the single -src, if it exists.
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
+ : qq(<link rel="stylesheet" type="$type" href="$src">)
+ ) if $src;
+ }
+ push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
} else {
- push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
+ push(@result,style({'type'=>$type},"$cdata_start\n$style\n$cdata_end"));
}
@result;
}
END_OF_FUNC
-
'_script' => <<'END_OF_FUNC',
sub _script {
my ($self,$script) = @_;
my (@result);
+
my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
foreach $script (@scripts) {
my($src,$code,$language);
if (ref($script)) { # script is a hash
- ($src,$code,$language) =
- $self->rearrange([SRC,CODE,LANGUAGE],
+ ($src,$code,$language, $type) =
+ rearrange([SRC,CODE,LANGUAGE,TYPE],
'-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($style) eq 'ARRAY' ? @$script : %$script);
-
+ ref($script) eq 'ARRAY' ? @$script : %$script);
+ # User may not have specified language
+ $language ||= 'JavaScript';
+ unless (defined $type) {
+ $type = lc $language;
+ # strip '1.2' from 'javascript1.2'
+ $type =~ s/^(\D+).*$/text\/$1/;
+ }
} else {
- ($src,$code,$language) = ('',$script,'JavaScript');
+ ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
}
+
+ my $comment = '//'; # javascript by default
+ $comment = '#' if $type=~/perl|tcl/i;
+ $comment = "'" if $type=~/vbscript/i;
+
+ my $cdata_start = "\n<!-- Hide script\n";
+ $cdata_start .= "$comment<![CDATA[\n" if $XHTML;
+ my $cdata_end = $XHTML ? "\n$comment]]>" : $comment;
+ $cdata_end .= " End script hiding -->\n";
+
my(@satts);
push(@satts,'src'=>$src) if $src;
- push(@satts,'language'=>$language || 'JavaScript');
- $code = "<!-- Hide script\n$code\n// End script hiding -->"
- if $code && $language=~/javascript/i;
- $code = "<!-- Hide script\n$code\n\# End script hiding -->"
- if $code && $language=~/perl/i;
- push(@result,script({@satts},$code));
+ push(@satts,'language'=>$language);
+ push(@satts,'type'=>$type);
+ $code = "$cdata_start$code$cdata_end" if defined $code;
+ push(@result,script({@satts},$code || ''));
}
@result;
}
####
'end_html' => <<'END_OF_FUNC',
sub end_html {
- return "</BODY></HTML>";
+ return "</body></html>";
}
END_OF_FUNC
'isindex' => <<'END_OF_FUNC',
sub isindex {
my($self,@p) = self_or_default(@_);
- my($action,@other) = $self->rearrange([ACTION],@p);
- $action = qq/ACTION="$action"/ if $action;
+ my($action,@other) = rearrange([ACTION],@p);
+ $action = qq/action="$action"/ if $action;
my($other) = @other ? " @other" : '';
- return "<ISINDEX $action$other>";
+ return $XHTML ? "<isindex $action$other />" : "<isindex $action$other>";
}
END_OF_FUNC
my($self,@p) = self_or_default(@_);
my($method,$action,$enctype,@other) =
- $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
+ rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = $method || 'POST';
+ $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->url(-absolute=>1,-path=>1);
+ $action .= "?$ENV{QUERY_STRING}" if $ENV{QUERY_STRING};
+ }
+ $action = qq(action="$action");
my($other) = @other ? " @other" : '';
$self->{'.parametersToAdd'}={};
- return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
+ return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
}
END_OF_FUNC
}
END_OF_FUNC
+'end_multipart_form' => <<'END_OF_FUNC',
+sub end_multipart_form {
+ &endform;
+}
+END_OF_FUNC
#### Method: start_multipart_form
# synonym for startform
'start_multipart_form' => <<'END_OF_FUNC',
sub start_multipart_form {
my($self,@p) = self_or_default(@_);
- if ($self->use_named_parameters ||
- (defined($param[0]) && substr($param[0],0,1) eq '-')) {
+ if (defined($param[0]) && substr($param[0],0,1) eq '-') {
my(%p) = @p;
$p{'-enctype'}=&MULTIPART;
return $self->startform(%p);
} else {
my($method,$action,@other) =
- $self->rearrange([METHOD,ACTION],@p);
+ rearrange([METHOD,ACTION],@p);
return $self->startform($method,$action,&MULTIPART,@other);
}
}
'endform' => <<'END_OF_FUNC',
sub endform {
my($self,@p) = self_or_default(@_);
- return ($self->get_fields,"</FORM>");
+ if ( $NOSTICKY ) {
+ return wantarray ? ("</form>") : "\n</form>";
+ } else {
+ return wantarray ? ($self->get_fields,"</form>") :
+ $self->get_fields ."\n</form>";
+ }
}
END_OF_FUNC
sub _textfield {
my($self,$tag,@p) = self_or_default(@_);
my($name,$default,$size,$maxlength,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+ rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
my $current = $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
- $current = defined($current) ? $self->escapeHTML($current) : '';
+ $current = defined($current) ? $self->escapeHTML($current,1) : '';
$name = defined($name) ? $self->escapeHTML($name) : '';
- my($s) = defined($size) ? qq/ SIZE=$size/ : '';
- my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
- my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="$tag" NAME="$name" VALUE="$current"$s$m$other>/;
+ 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 $XHTML ? qq(<input type="$tag" name="$name" $value$s$m$other />)
+ : qq/<input type="$tag" name="$name" $value$s$m$other>/;
}
END_OF_FUNC
my($self,@p) = self_or_default(@_);
my($name,$default,$rows,$cols,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
+ rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
my($current)= $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
$name = defined($name) ? $self->escapeHTML($name) : '';
$current = defined($current) ? $self->escapeHTML($current) : '';
- my($r) = $rows ? " ROWS=$rows" : '';
- my($c) = $cols ? " COLS=$cols" : '';
+ my($r) = $rows ? " rows=$rows" : '';
+ my($c) = $cols ? " cols=$cols" : '';
my($other) = @other ? " @other" : '';
- return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
+ return qq{<textarea name="$name"$r$c$other>$current</textarea>};
}
END_OF_FUNC
sub button {
my($self,@p) = self_or_default(@_);
- my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
+ my($label,$value,$script,@other) = rearrange([NAME,[VALUE,LABEL],
[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/<INPUT TYPE="button"$name$val$script$other>/;
+ return $XHTML ? qq(<input type="button"$name$val$script$other />)
+ : qq/<input type="button"$name$val$script$other>/;
}
END_OF_FUNC
sub submit {
my($self,@p) = self_or_default(@_);
- my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
+ 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"';
- $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);
+ $val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="submit"$name$val$other>/;
+ return $XHTML ? qq(<input type="submit"$name$val$other />)
+ : qq/<input type="submit"$name$val$other>/;
}
END_OF_FUNC
'reset' => <<'END_OF_FUNC',
sub reset {
my($self,@p) = self_or_default(@_);
- my($label,@other) = $self->rearrange([NAME],@p);
+ my($label,@other) = rearrange([NAME],@p);
$label=$self->escapeHTML($label);
- my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
+ my($value) = defined($label) ? qq/ value="$label"/ : '';
my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="reset"$value$other>/;
+ return $XHTML ? qq(<input type="reset"$value$other />)
+ : qq/<input type="reset"$value$other>/;
}
END_OF_FUNC
sub defaults {
my($self,@p) = self_or_default(@_);
- my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
+ 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/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
+ return $XHTML ? qq(<input type="submit" name=".defaults"$value$other />)
+ : qq/<input type="submit" NAME=".defaults"$value$other>/;
}
END_OF_FUNC
my($self,@p) = self_or_default(@_);
my($name,$checked,$value,$label,$override,@other) =
- $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
+ rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@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)) ? ' checked' : '';
} else {
- $checked = $checked ? ' CHECKED' : '';
+ $checked = $checked ? qq/ 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 <<END;
-<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
-END
+ return $XHTML ? qq{<input type="checkbox" name="$name" value="$value"$checked$other />$the_label}
+ : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
}
END_OF_FUNC
my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
$rowheaders,$colheaders,$override,$nolabels,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
ROWHEADERS,COLHEADERS,
[OVERRIDE,FORCE],NOLABELS],@p);
my(%checked) = $self->previous_or_default($name,$defaults,$override);
- $break = $linebreak ? "<BR>" : '';
+ if ($linebreak) {
+ $break = $XHTML ? "<br />" : "<br>";
+ }
+ else {
+ $break = '';
+ }
$name=$self->escapeHTML($name);
# Create the elements
my($other) = @other ? " @other" : '';
foreach (@values) {
- $checked = $checked{$_} ? ' CHECKED' : '';
+ $checked = $checked{$_} ? qq/ checked/ : '';
$label = '';
unless (defined($nolabels) && $nolabels) {
$label = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->escapeHTML($label);
}
- $_ = $self->escapeHTML($_);
- push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label}${break}/);
+ $_ = $self->escapeHTML($_,1);
+ push(@elements,$XHTML ? qq(<input type="checkbox" name="$name" value="$_"$checked$other />${label}${break})
+ : qq/<input type="checkbox" name="$name" value="$_"$checked$other>${label}${break}/);
}
$self->register_parameter($name);
return wantarray ? @elements : join(' ',@elements)
# Escape HTML -- used internally
'escapeHTML' => <<'END_OF_FUNC',
sub escapeHTML {
- my($self,$toencode) = @_;
- $toencode = $self unless ref($self);
- return undef unless defined($toencode);
- return $toencode if ref($self) && $self->{'dontescape'};
-
- $toencode=~s/&/&/g;
- $toencode=~s/\"/"/g;
- $toencode=~s/>/>/g;
- $toencode=~s/</</g;
- return $toencode;
+ my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
+ return undef unless defined($toencode);
+ return $toencode if ref($self) && $self->{'dontescape'};
+ $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);
- $string=~s/&/&/ig;
- $string=~s/"/\"/ig;
- $string=~s/>/>/ig;
- $string=~s/</</ig;
- $string=~s/&#(\d+);/chr($1)/eg;
- $string=~s/&#[xX]([0-9a-fA-F]);/chr(hex($1))/eg;
+ my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
+ : 1;
+ # thanks to Randal Schwartz for the correct solution to this one
+ $string=~ s[&(.*?);]{
+ local $_ = $1;
+ /^amp$/i ? "&" :
+ /^quot$/i ? '"' :
+ /^gt$/i ? ">" :
+ /^lt$/i ? "<" :
+ /^#(\d+)$/ && $latin ? chr($1) :
+ /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
+ $_
+ }gex;
return $string;
}
END_OF_FUNC
'_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)) {
}
# rearrange into a pretty table
- $result = "<TABLE>";
+ $result = "<table>";
my($row,$column);
- unshift(@$colheaders,'') if defined(@$colheaders) && defined(@$rowheaders);
- $result .= "<TR>" if defined(@{$colheaders});
+ unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
+ $result .= "<tr>" if @{$colheaders};
foreach (@{$colheaders}) {
- $result .= "<TH>$_</TH>";
+ $result .= "<th>$_</th>";
}
for ($row=0;$row<$rows;$row++) {
- $result .= "<TR>";
- $result .= "<TH>$rowheaders->[$row]</TH>" if defined(@$rowheaders);
+ $result .= "<tr>";
+ $result .= "<th>$rowheaders->[$row]</th>" if @$rowheaders;
for ($column=0;$column<$columns;$column++) {
- $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
+ $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
if defined($elements[$column*$rows + $row]);
}
- $result .= "</TR>";
+ $result .= "</tr>";
}
- $result .= "</TABLE>";
+ $result .= "</table>";
return $result;
}
END_OF_FUNC
my($name,$values,$default,$linebreak,$labels,
$rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
+ rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
ROWS,[COLUMNS,COLS],
ROWHEADERS,COLHEADERS,
[OVERRIDE,FORCE],NOLABELS],@p);
} else {
$checked = $default;
}
- # If no check array is specified, check the first by default
- $checked = $values->[0] unless defined($checked) && $checked ne '';
- $name=$self->escapeHTML($name);
-
my(@elements,@values);
-
@values = $self->_set_values_and_labels($values,\$labels,$name);
+ # If no check array is specified, check the first by default
+ $checked = $values[0] unless defined($checked) && $checked ne '';
+ $name=$self->escapeHTML($name);
+
my($other) = @other ? " @other" : '';
foreach (@values) {
- my($checkit) = $checked eq $_ ? ' CHECKED' : '';
- my($break) = $linebreak ? '<BR>' : '';
+ my($checkit) = $checked eq $_ ? qq/ checked/ : '';
+ my($break);
+ if ($linebreak) {
+ $break = $XHTML ? "<br />" : "<br>";
+ }
+ 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);
}
$_=$self->escapeHTML($_);
- push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/);
+ push(@elements,$XHTML ? qq(<input type="radio" name="$name" value="$_"$checkit$other />${label}${break})
+ : qq/<input type="radio" name="$name" value="$_"$checkit$other>${label}${break}/);
}
$self->register_parameter($name);
return wantarray ? @elements : join(' ',@elements)
my($self,@p) = self_or_default(@_);
my($name,$values,$default,$labels,$override,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
my($result,$selected);
if (!$override && defined($self->param($name))) {
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
- $result = qq/<SELECT NAME="$name"$other>\n/;
+ $result = qq/<select name="$name"$other>\n/;
foreach (@values) {
- my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
+ my($selectit) = defined($selected) ? ($selected eq $_ ? qq/selected/ : '' ) : '';
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
my($value) = $self->escapeHTML($_);
- $label=$self->escapeHTML($label);
- $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
+ $label=$self->escapeHTML($label,1);
+ $result .= "<option $selectit value=\"$value\">$label</option>\n";
}
- $result .= "</SELECT>\n";
+ $result .= "</select>\n";
return $result;
}
END_OF_FUNC
sub scrolling_list {
my($self,@p) = self_or_default(@_);
my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
- = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
my($result,@values);
$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/ : '';
+ my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
- $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
+ $result = qq/<select name="$name"$has_size$is_multiple$other>\n/;
foreach (@values) {
- my($selectit) = $selected{$_} ? 'SELECTED' : '';
+ my($selectit) = $selected{$_} ? qq/selected/ : '';
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label=$self->escapeHTML($label);
- my($value)=$self->escapeHTML($_);
- $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
+ my($value)=$self->escapeHTML($_,1);
+ $result .= "<option $selectit value=\"$value\">$label</option>\n";
}
- $result .= "</SELECT>\n";
+ $result .= "</select>\n";
$self->register_parameter($name);
return $result;
}
# calling scheme, so we have to special-case (darn)
my(@result,@value);
my($name,$default,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
+ rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
my $do_override = 0;
- if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
+ if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
@value = ref($default) ? @{$default} : $default;
$do_override = $override;
} else {
$name=$self->escapeHTML($name);
foreach (@value) {
- $_=$self->escapeHTML($_);
- push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
+ $_ = defined($_) ? $self->escapeHTML($_,1) : '';
+ push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" />)
+ : qq(<input type="hidden" name="$name" value="$_">);
}
return wantarray ? @result : join('',@result);
}
my($self,@p) = self_or_default(@_);
my($name,$src,$alignment,@other) =
- $self->rearrange([NAME,SRC,ALIGN],@p);
+ rearrange([NAME,SRC,ALIGN],@p);
- my($align) = $alignment ? " ALIGN=\U$alignment" : '';
+ my($align) = $alignment ? " align=\U$alignment" : '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
- return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
+ return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
+ : qq/<input type="image" name="$name" src="$src"$align$other>/;
}
END_OF_FUNC
'url' => <<'END_OF_FUNC',
sub url {
my($self,@p) = self_or_default(@_);
- my ($relative,$absolute,$full,$path_info,$query) =
- $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
+ my ($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 = $self->script_name;
+
+# If anybody knows why I ever wrote this please tell me!
+# 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 $encoded_path = $ENV{PATH_INFO}) =~ s!([^a-zA-Z0-9_./-])!uc sprintf("%%%02x",ord($1))!eg;;
+# substr($script_name,$index) = '' if ($index = rindex($script_name,$encoded_path)) >= 0;
+# }
+# } else {
+# $script_name = $self->script_name;
+# }
if ($full) {
my $protocol = $self->protocol();
unless (lc($protocol) eq 'http' && $port == 80)
|| (lc($protocol) eq 'https' && $port == 443);
}
- $url .= $self->script_name;
+ return $url if $base;
+ $url .= $script_name;
} elsif ($relative) {
- ($url) = $self->script_name =~ m!([^/]+)$!;
+ ($url) = $script_name =~ m!([^/]+)$!;
} elsif ($absolute) {
- $url = $self->script_name;
+ $url = $script_name;
}
- $url .= $self->path_info if $path_info and $self->path_info;
+
+ $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;
return $url;
}
sub cookie {
my($self,@p) = self_or_default(@_);
my($name,$value,$path,$domain,$secure,$expires) =
- $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
require CGI::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);
}
END_OF_FUNC
-# This internal routine creates an expires time exactly some number of
-# hours from the current time. It incorporates modifications from
-# Mark Fisher.
-'expire_calc' => <<'END_OF_FUNC',
-sub expire_calc {
- my($time) = @_;
- my(%mult) = ('s'=>1,
- 'm'=>60,
- 'h'=>60*60,
- 'd'=>60*60*24,
- 'M'=>60*60*24*30,
- 'y'=>60*60*24*365);
- # format for time can be in any of the forms...
- # "now" -- expire immediately
- # "+180s" -- in 180 seconds
- # "+2m" -- in 2 minutes
- # "+12h" -- in 12 hours
- # "+1d" -- in 1 day
- # "+3M" -- in 3 months
- # "+2y" -- in 2 years
- # "-3m" -- 3 minutes ago(!)
- # If you don't supply one of these forms, we assume you are
- # specifying the date yourself
- my($offset);
- if (!$time || (lc($time) eq 'now')) {
- $offset = 0;
- } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
- $offset = ($mult{$2} || 1)*$1;
- } else {
- return $time;
- }
- return (time+$offset);
-}
-END_OF_FUNC
-
-# This internal routine creates date strings suitable for use in
-# cookies and HTTP headers. (They differ, unfortunately.)
-# Thanks to Fisher Mark for this.
-'expires' => <<'END_OF_FUNC',
-sub expires {
- my($time,$format) = @_;
- $format ||= 'http';
-
- my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
- my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
-
- # pass through preformatted dates for the sake of expire_calc()
- $time = expire_calc($time);
- return $time unless $time =~ /^\d+$/;
-
- # make HTTP/cookie date string from GMT'ed time
- # (cookies use '-' as date separator, HTTP uses ' ')
- my($sc) = ' ';
- $sc = '-' if $format eq "cookie";
- my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
- $year += 1900;
- return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
- $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
-}
-END_OF_FUNC
-
'parse_keywordlist' => <<'END_OF_FUNC',
sub parse_keywordlist {
my($self,$tosplit) = @_;
'param_fetch' => <<'END_OF_FUNC',
sub param_fetch {
my($self,@p) = self_or_default(@_);
- my($name) = $self->rearrange([NAME],@p);
+ my($name) = rearrange([NAME],@p);
unless (exists($self->{$name})) {
$self->add_parameter($name);
$self->{$name} = [];
}
END_OF_FUNC
+#### Method: content_type
+# Returns the content_type string
+####
+'content_type' => <<'END_OF_FUNC',
+sub content_type {
+ return $ENV{'CONTENT_TYPE'};
+}
+END_OF_FUNC
+
#### Method: path_translated
# Return the physical path information provided
# by the URL (if any)
my($eparam) = escape($param);
foreach $value ($self->param($param)) {
$value = escape($value);
+ next unless defined $value;
push(@pairs,"$eparam=$value");
}
}
- return join("&",@pairs);
+ foreach (keys %{$self->{'.fieldnames'}}) {
+ push(@pairs,".cgifields=".escape("$_"));
+ }
+ return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
}
END_OF_FUNC
# declares a quantitative score for it.
# This handles MIME type globs correctly.
####
-'accept' => <<'END_OF_FUNC',
-sub accept {
+'Accept' => <<'END_OF_FUNC',
+sub Accept {
my($self,$search) = self_or_CGI(@_);
my(%prefs,$type,$pref,$pat);
sub http {
my ($self,$parameter) = self_or_CGI(@_);
return $ENV{$parameter} if $parameter=~/^HTTP/;
+ $parameter =~ tr/-/_/;
return $ENV{"HTTP_\U$parameter\E"} if $parameter;
my(@p);
foreach (keys %ENV) {
my ($self,$parameter) = self_or_CGI(@_);
return $ENV{HTTPS} unless $parameter;
return $ENV{$parameter} if $parameter=~/^HTTPS/;
+ $parameter =~ tr/-/_/;
return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
my(@p);
foreach (keys %ENV) {
}
END_OF_FUNC
+#### Method: nosticky
+# Set or return the NOSTICKY global flag
+####
+'nosticky' => <<'END_OF_FUNC',
+sub nosticky {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::NOSTICKY = $param if defined($param);
+ return $CGI::NOSTICKY;
+}
+END_OF_FUNC
+
#### Method: nph
# Set or return the NPH global flag
####
####
'default_dtd' => <<'END_OF_FUNC',
sub default_dtd {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::DEFAULT_DTD = $param if defined($param);
+ my ($self,$param,$param2) = self_or_CGI(@_);
+ if (defined $param2 && defined $param) {
+ $CGI::DEFAULT_DTD = [ $param, $param2 ];
+ } elsif (defined $param) {
+ $CGI::DEFAULT_DTD = $param;
+ }
return $CGI::DEFAULT_DTD;
}
END_OF_FUNC
sub read_from_cmdline {
my($input,@words);
my($query_string);
- if (@ARGV) {
+ if ($DEBUG && @ARGV) {
@words = @ARGV;
- } else {
+ } elsif ($DEBUG > 1) {
require "shellwords.pl";
print STDERR "(offline mode: enter name=value pairs on standard input)\n";
chomp(@lines = <STDIN>); # remove newlines
my $filenumber = 0;
while (!$buffer->eof) {
%header = $buffer->readHeader;
- die "Malformed multipart POST\n" unless %header;
+
+ unless (%header) {
+ $self->cgi_error("400 Bad request (malformed multipart POST)");
+ return;
+ }
my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
# Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
+ my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
# add this parameter to our list
$self->add_parameter($param);
# If no filename specified, then just read the data and assign it
# to our parameter list.
- unless ($filename) {
+ if ( !defined($filename) || $filename eq '' ) {
my($value) = $buffer->readBody;
push(@{$self->{$param}},$value);
next;
last UPLOADS;
}
- $tmpfile = new TempFile;
- $tmp = $tmpfile->as_string;
-
- $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES);
-
+ # 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);
+ $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;
- chmod 0600,$tmp; # only the owner can tamper with it
my ($data);
+ local($\) = '';
while (defined($data = $buffer->read)) {
print $filehandle $data;
}
# Save some information about the uploaded file where we can get
# at it later.
- $self->{'.tmpfiles'}->{$filename}= {
+ $self->{'.tmpfiles'}->{fileno($filehandle)}= {
name => $tmpfile,
info => {%header},
};
}
END_OF_FUNC
+'upload' =><<'END_OF_FUNC',
+sub upload {
+ my($self,$param_name) = self_or_default(@_);
+ my @param = grep(ref && fileno($_), $self->param($param_name));
+ return unless @param;
+ return wantarray ? @param : $param[0];
+}
+END_OF_FUNC
+
'tmpFileName' => <<'END_OF_FUNC',
sub tmpFileName {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$filename}->{name} ?
- $self->{'.tmpfiles'}->{$filename}->{name}->as_string
+ return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
+ $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
: '';
}
END_OF_FUNC
'uploadInfo' => <<'END_OF_FUNC',
sub uploadInfo {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$filename}->{info};
+ return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
}
END_OF_FUNC
'asString' => <<'END_OF_FUNC',
sub asString {
my $self = shift;
- my $i = $$self;
- $i=~ s/^\*(\w+::)+//; # get rid of package name
- $i =~ s/\\(.)/$1/g;
+ # get rid of package name
+ (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
+ $i =~ s/%(..)/ chr(hex($1)) /eg;
return $i;
+# BEGIN DEAD CODE
+# This was an extremely clever patch that allowed "use strict refs".
+# Unfortunately it relied on another bug that caused leaky file descriptors.
+# The underlying bug has been fixed, so this no longer works. However
+# "strict refs" still works for some reason.
+# my $self = shift;
+# return ${*{$self}{SCALAR}};
+# END DEAD CODE
}
END_OF_FUNC
sub new {
my($pack,$name,$file,$delete) = @_;
require Fcntl unless defined &Fcntl::O_RDWR;
- ++$FH;
- *{$FH} = quotemeta($name);
- sysopen($FH,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL())
- || die "CGI open of $file: $!\n";
+ (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
+ my $fv = ++$FH . $safename;
+ my $ref = \*{"Fh::$fv"};
+ sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
unlink($file) if $delete;
- return bless \*{$FH},$pack;
+ CORE::delete $Fh::{$fv};
+ return bless $ref,$pack;
}
END_OF_FUNC
package MultipartBuffer;
# how many bytes to read at a time. We use
-# a 5K buffer by default.
-$INITIAL_FILLUNIT = 1024 * 5;
-$TIMEOUT = 10*60; # 10 minute timeout
-$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers
+# a 4K buffer by default.
+$INITIAL_FILLUNIT = 1024 * 4;
+$TIMEOUT = 240*60; # 4 hour timeout for big files
+$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
$CRLF=$CGI::CRLF;
#reuse the autoload function
# Netscape seems to be a little bit unreliable
# about providing boundary strings.
+ my $boundary_read = 0;
if ($boundary) {
# Under the MIME spec, the boundary consists of the
# characters "--" PLUS the Boundary string
# BUG: IE 3.01 on the Macintosh uses just the boundary -- not
- # the two extra spaces. We do a special case here on the user-agent!!!!
- $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; Mac');
+ # 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');
} else { # otherwise we find it ourselves
my($old);
$length -= length($boundary);
chomp($boundary); # remove the CRLF
$/ = $old; # restore old line separator
+ $boundary_read++;
}
my $self = {LENGTH=>$length,
my $retval = bless $self,ref $package || $package;
# Read the preamble and the topmost (boundary) line plus the CRLF.
- while ($self->read(0)) { }
+ unless ($boundary_read) {
+ while ($self->read(0)) { }
+ }
die "Malformed multipart POST\n" if $self->eof;
return $retval;
my($ok) = 0;
my($bad) = 0;
- if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert!
- local($CRLF) = "\015\012";
- }
+ local($CRLF) = "\015\012" if $CGI::OS eq 'VMS';
do {
$self->fillBuffer($FILLUNIT);
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.
}
# 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;
}
\$self->{BUFFER},
$bytesToRead,
$bufferLength);
+ $self->{BUFFER} = '' unless defined $self->{BUFFER};
# An apparent bug in the Apache server causes the read()
# to return zero bytes repeatedly without blocking if the
my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
unless ($TMPDIRECTORY) {
@TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
- "${SL}tmp","${SL}temp","${vol}${SL}Temporary Items",
- "${SL}WWW_ROOT");
+ "C:${SL}temp","${SL}tmp","${SL}temp",
+ "${vol}${SL}Temporary Items",
+ "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
+ "C:${SL}system${SL}temp");
+ unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
+
+ # this feature was supposed to provide per-user tmpfiles, but
+ # it is problematic.
+ # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
+ # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
+ # : can generate a 'getpwuid() not implemented' exception, even though
+ # : it's never called. Found under DOS/Win with the DJGPP perl port.
+ # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
+ # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
+
foreach (@TEMP) {
do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
}
}
$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
-$SEQUENCE=0;
$MAXTRIES = 5000;
# cute feature, but overload implementation broke it
'new' => <<'END_OF_FUNC',
sub new {
- my($package) = @_;
- my $directory;
- my $i;
- for ($i = 0; $i < $MAXTRIES; $i++) {
- $directory = sprintf("${TMPDIRECTORY}${SL}CGItemp%d%04d",${$},++$SEQUENCE);
- last if ! -f $directory;
+ my($package,$sequence) = @_;
+ my $filename;
+ for (my $i = 0; $i < $MAXTRIES; $i++) {
+ last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
}
- return bless \$directory;
+ # untaint the darn thing
+ return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\-]+)$!;
+ $filename = $1;
+ return bless \$filename;
}
END_OF_FUNC
$MultipartBuffer::CRLF;
$MultipartBuffer::TIMEOUT;
$MultipartBuffer::INITIAL_FILLUNIT;
- $TempFile::SEQUENCE;
EOF
;
}
into our name space (usually the "standard" functions), and we don't
need to create the CGI object.
- #!/usr/local/bin/pelr
+ #!/usr/local/bin/perl
use CGI qw/:standard/; # load standard CGI routines
print header, # create the HTTP header
start_html('hello world'), # start the HTML
dash. If a dash is present in the first argument, CGI.pm assumes
dashes for the subsequent ones.
-You don't have to use the hyphen at all if you don't want to. After
-creating a CGI object, call the B<use_named_parameters()> method with
-a nonzero value. This will tell CGI.pm that you intend to use named
-parameters exclusively:
-
- $query = new CGI;
- $query->use_named_parameters(1);
- $field = $query->radio_group('name'=>'OS',
- 'values'=>['Unix','Windows','Macintosh'],
- 'default'=>'Unix');
-
Several routines are commonly called with just one argument. In the
case of these routines you can provide the single argument without an
argument name. header() happens to be one of these routines. In this
single or a multi-valued value. The two cases are shown below:
$q->param(-name=>'veggie',-value=>'tomato');
- $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']);
+ $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
A large number of routines in CGI.pm actually aren't specifically
defined in the module, but are generated automatically as needed.
=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. Put quotes around the argument name, e.g. '-values'
+=item 3.
+
+Put quotes around the argument name, e.g. '-values'
=back
@names = $query->param
If the script was invoked with a parameter list
-(e.g. "name1=value1&name2=value2&name3=value3"), the param()
-method will return the parameter names as a list. If the
-script was invoked as an <ISINDEX> script, there will be a
-single parameter named 'keywords'.
+(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
+will return the parameter names as a list. If the script was invoked
+as an <ISINDEX> script and contains a string without ampersands
+(e.g. "value1+value2+value3") , there will be a single parameter named
+"keywords" containing the "+"-delimited keywords.
NOTE: As of version 1.5, the array of parameter names returned will
be in the same order as they were submitted by the browser.
selections in a scrolling list), you can ask to receive an array. Otherwise
the method will return a single value.
+If a value is not given in the query string, as in the queries
+"name1=&name2=" or "name1&name2", it will be returned as an empty
+string. This feature is new in 2.63.
+
=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
$query->param('foo','an','array','of','values');
You can also use a named argument style using the B<-name> argument.
+=head2 FETCHING THE PARAMETER LIST AS A HASH:
+
+ $params = $q->Vars;
+ print $params->{'address'};
+ @foo = split("\0",$params->{'foo'});
+ %params = $q->Vars;
+
+ use CGI ':cgi-lib';
+ $params = Vars;
+
+Many people want to fetch the entire parameter list as a hash in which
+the keys are the names of the CGI parameters, and the values are the
+parameters' values. The Vars() method does this. Called in a scalar
+context, it returns the parameter list as a tied hash reference.
+Changing a key changes the value of the parameter in the underlying
+CGI parameter list. Called in a list context, it returns the
+parameter list as an ordinary hash. This allows you to read the
+contents of the parameter list, but not to change it.
+
+When using this, the thing you must watch out for are multivalued CGI
+parameters. Because a hash cannot distinguish between scalar and
+list context, multivalued parameters will be returned as a packed
+string, separated by the "\0" (null) character. You must split this
+packed string in order to get at the individual values. This is the
+convention introduced long ago by Steve Brenner in his cgi-lib.pl
+module for Perl version 4.
+
+If you wish to use Vars() as a function, import the I<:cgi-lib> set of
+function calls (also see the section on CGI-LIB compatibility).
+
=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
$query->save(FILEHANDLE)
The file format used for save/restore is identical to that used by the
Whitehead Genome Center's data exchange format "Boulderio", and can be
manipulated and even databased using Boulderio utilities. See
-
- http://www.genome.wi.mit.edu/genome_software/other/boulder.html
+
+ http://stein.cshl.org/boulder/
for further details.
If you wish to use this method from the function-oriented (non-OO)
interface, the exported name for this method is B<save_parameters()>.
+=head2 RETRIEVING CGI ERRORS
+
+Errors can occur while processing user input, particularly when
+processing uploaded files. When these errors occur, CGI will stop
+processing and return an empty parameter list. You can test for
+the existence and nature of errors using the I<cgi_error()> function.
+The error messages are formatted as HTTP status codes. You can either
+incorporate the error text into an HTML page, or use it as the value
+of the HTTP status:
+
+ my $error = $q->cgi_error;
+ if ($error) {
+ print $q->header(-status=>$error),
+ $q->start_html('Problems'),
+ $q->h2('Request not processed'),
+ $q->strong($error);
+ exit 0;
+ }
+
+When using the function-oriented interface (see the next section),
+errors may only occur the first time you call I<param()>. Be ready
+for this!
+
=head2 USING THE FUNCTION-ORIENTED INTERFACE
To use the function-oriented interface, you must specify which CGI.pm
=item B<:all>
Import all the available methods. For the full list, see the CGI.pm
-code, where the variable %TAGS is defined.
+code, where the variable %EXPORT_TAGS is defined.
=back
change the way that CGI.pm functions in various ways. Pragmas,
function sets, and individual functions can all be imported in the
same use() line. For example, the following use statement imports the
-standard set of functions and disables debugging mode (pragma
--no_debug):
+standard set of functions and enables debugging mode (pragma
+-debug):
- use CGI qw/:standard -no_debug/;
+ use CGI qw/:standard -debug/;
The current list of pragmas is as follows:
namespace. If you want to compile without importing use the
compile() method instead (see below).
+=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.
+
+=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 <kabrianis@hellug.gr> for this
+feature.
+
=item -nph
This makes CGI.pm produce a header appropriate for an NPH (no
to tell the server that the script is NPH. See the discussion
of NPH scripts below.
+=item -newstyle_urls
+
+Separate the name=value pairs in CGI parameter query strings with
+semicolons rather than ampersands. For example:
+
+ ?name=fred;age=24;favorite_color=3
+
+Semicolon-delimited query strings are always accepted, but will not be
+emitted by self_url() and query_string() unless the -newstyle_urls
+pragma is specified.
+
+This became the default in version 2.64.
+
+=item -oldstyle_urls
+
+Separate the name=value pairs in CGI parameter query strings with
+ampersands rather than semicolons. This is no longer the default.
+
=item -autoload
This overrides the autoloader so that any function in your program
This turns off the command-line processing features. If you want to
run a CGI.pm script from the command line to produce HTML, and you
-don't want it pausing to request CGI parameters from standard input or
-the command line, then use this pragma:
+don't want it to read CGI parameters from the command line or STDIN,
+then use this pragma:
use CGI qw(-no_debug :standard);
-If you'd like to process the command-line parameters but not standard
-input, this should work:
+=item -debug
+
+This turns on full debugging. In addition to reading CGI arguments
+from the command-line processing, CGI.pm will pause and try to read
+arguments from STDIN, producing the message "(offline mode: enter
+name=value pairs on standard input)" features.
- use CGI qw(-no_debug :standard);
- restore_parameters(join('&',@ARGV));
-
See the section on debugging for more details.
=item -private_tempfiles
-CGI.pm can process uploaded file. Ordinarily it spools the
-uploaded file to a temporary directory, then deletes the file
-when done. However, this opens the risk of eavesdropping as
-described in the file upload section.
-Another CGI script author could peek at this data during the
-upload, even if it is confidential information. On Unix systems,
-the -private_tempfiles pragma will cause the temporary file to be unlinked as soon
-as it is opened and before any data is written into it,
-eliminating the risk of eavesdropping.
-n
+CGI.pm can process uploaded file. Ordinarily it spools the uploaded
+file to a temporary directory, then deletes the file when done.
+However, this opens the risk of eavesdropping as described in the file
+upload section. Another CGI script author could peek at this data
+during the upload, even if it is confidential information. On Unix
+systems, the -private_tempfiles pragma will cause the temporary file
+to be unlinked as soon as it is opened and before any data is written
+into it, reducing, but not eliminating the risk of eavesdropping
+(there is still a potential race condition). To make life harder for
+the attacker, the program chooses tempfile names by calculating a 32
+bit checksum of the incoming HTTP headers.
+
+To ensure that the temporary file cannot be read by other CGI scripts,
+use suEXEC or a CGI wrapper program to run your script. The temporary
+file is created with mode 0600 (neither world nor group readable).
+
+The temporary directory is selected using the following algorithm:
+
+ 1. if the current user (e.g. "nobody") has a directory named
+ "tmp" in its home directory, use that (Unix systems only).
+
+ 2. if the environment variable TMPDIR exists, use the location
+ indicated.
+
+ 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
+ /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
+
+Each of these locations is checked that it is a directory and is
+writable. If not, the algorithm tries the next choice.
+
+=back
+
+=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
+
+Many of the methods generate HTML tags. As described below, tag
+functions automatically generate both the opening and closing tags.
+For example:
+
+ print h1('Level 1 Header');
+
+produces
+
+ <H1>Level 1 Header</H1>
+
+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<tag_name>
+and end_I<tag_name>, as in:
+
+ print start_h1,'Level 1 Header',end_h1;
+
+With a few exceptions (described below), start_I<tag_name> and
+end_I<tag_name> functions are not generated automatically when you
+I<use CGI>. However, you can specify the tags you want to generate
+I<start/end> functions for by putting an asterisk in front of their
+name, or, alternatively, requesting either "start_I<tag_name>" or
+"end_I<tag_name>" in the import list.
+
+Example:
+
+ use CGI qw/:standard *table start_ul/;
+
+In this example, the following functions are generated in addition to
+the standard ones:
+
+=over 4
+
+=item 1. start_table() (generates a <TABLE> tag)
+
+=item 2. end_table() (generates a </TABLE> tag)
+
+=item 3. start_ul() (generates a <UL> tag)
+
+=item 4. end_ul() (generates a </UL> tag)
+
=back
=head1 GENERATING DYNAMIC DOCUMENTS
-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
The B<-nph> parameter, if set to a true value, will issue the correct
headers to work with a NPH (no-parse-header) script. This is important
-to use with certain servers, such as Microsoft Internet Explorer, which
-expect all their scripts to be NPH.
+to use with certain servers that expect all their scripts to be NPH.
+
+The B<-charset> parameter can be used to control the character set
+sent to the browser. If not provided, defaults to ISO-8859-1. As a
+side effect, this sets the charset() method as well.
+
+The B<-attachment> parameter can be used to turn the page into an
+attachment. Instead of displaying the page, some browsers will prompt
+the user to save it to disk. The value of the argument is the
+suggested name for the saved file. In order for this to work, you may
+have to set the B<-type> to "application/octet-stream".
=head2 GENERATING A REDIRECTION HEADER
The redirect() function redirects the browser to a different URL. If
you use redirection like this, you should B<not> 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 method returns a canned HTML header and the opening <BODY> 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 <BODY>
-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 <BODY> tag. Additional parameters must be proceeded by a
+hyphen.
The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
different from the current location, as in
All relative links will be interpreted relative to this tag.
The argument B<-target> allows you to provide a default target frame
-for all the links and fill-out forms on the page. See the Netscape
-documentation on frames for details of how to manipulate this.
+for all the links and fill-out forms on the page. B<This is a
+non-standard HTTP feature which only works with Netscape browsers!>
+See the Netscape documentation on frames for details of how to
+manipulate this.
-target=>"answer_window"
<META NAME="keywords" CONTENT="pharaoh secret mummy">
<META NAME="description" CONTENT="copyright 1996 King Tut">
-There is no support for the HTTP-EQUIV type of <META> tag. This is
-because you can modify the HTTP header directly with the B<header()>
-method. For example, if you want to send the Refresh: header, do it
-in the header() method:
+To create an HTTP-EQUIV type of <META> 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.
- print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
+The B<-lang> argument is used to incorporate a language attribute into
+the <HTML> tag. The default if not specified is "en-US" for US
+English. For example:
-The B<-style> tag is used to incorporate cascading stylesheets into
-your code. See the section on CASCADING STYLESHEETS for more information.
+ print $q->start_html(-lang=>'fr-CA');
You can place other arbitrary HTML elements to the <HEAD> section with the
B<-head> tag. For example, to place the rarely-used <LINK> element in the
head section, use this:
- print $q->start_html(-head=>Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}));
+ print start_html(-head=>Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}));
To incorporate multiple HTML elements into the <HEAD> section, just pass an
array reference:
- print $q->start_html(-head=>[
- Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}),
- Link({-rel=>'previous',
- -href=>'http://www.capricorn.com/s1.html'})
+ print start_html(-head=>[
+ Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}),
+ Link({-rel=>'previous',
+ -href=>'http://www.capricorn.com/s1.html'})
]
);
+And here's how to create an HTTP-EQUIV <META> 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
);
print $q->(-title=>'The Riddle of the Sphinx',
- -script=>{-language=>'PERLSCRIPT'},
- -code=>'print "hello world!\n;"'
+ -script=>{-language=>'PERLSCRIPT',
+ -code=>'print "hello world!\n;"'}
);
=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
$myself = $query->self_url;
- print "<A HREF=$myself>I'm talking to myself.</A>";
+ print q(<A HREF="$myself">I'm talking to myself.</A>);
self_url() will return a URL, that, when selected, will reinvoke
this script with all its state information intact. This is most
$absolute_url = $query->url(-absolute=>1);
$url_with_path = $query->url(-path_info=>1);
$url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
+ $netloc = $query->url(-base => 1);
B<url()> returns the script's URL in a variety of formats. Called
without any arguments, it returns the full form of the URL, including
B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
as a synonym.
+=item B<-base>
+
+Generate just the protocol and net location, as in http://www.foo.com:8000
+
=back
+=head2 MIXING POST AND URL PARAMETERS
+
+ $color = $query->url_param('color');
+
+It is possible for a script to receive CGI parameters in the URL as
+well as in the fill-out form by creating a form that POSTs to a URL
+containing a query string (a "?" mark followed by arguments). The
+B<param()> method will always return the contents of the POSTed
+fill-out form, ignoring the URL's query string. To retrieve URL
+parameters, call the B<url_param()> method. Use it in the same way as
+B<param()>. The main difference is that it allows you to read the
+parameters, but not set them.
+
+
+Under no circumstances will the contents of the URL query string
+interfere with similarly-named CGI parameters in POSTed forms. If you
+try to mix a URL query string with a form submitted with the GET
+method, the results will not be what you expect.
+
=head1 CREATING STANDARD HTML ELEMENTS:
CGI.pm defines general HTML shortcut methods for most, if not all of
"Open a new frame");
<A HREF="fred.html",TARGET="_new">Open a new frame</A>
-
+
You may dispense with the dashes in front of the attribute names if
you prefer:
attribute argument was the same as providing undef. However, this has
changed in order to accommodate those who want to create tags of the form
<IMG ALT="">. The difference is shown in these two pieces of code:
-
+
CODE RESULT
img({alt=>undef}) <IMG ALT>
img({alt=>''}) <IMT ALT="">
list:
print ul(
- li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']);
+ li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
);
This example will result in HTML output that looks like this:
Tr
Link
Delete
+ Accept
+ Sub
In addition, start_html(), end_html(), start_form(), end_form(),
start_multipart_form() and all the fill-out form tags are special.
See their respective sections.
+=head2 AUTOESCAPING HTML
+
+By default, all HTML that is emitted by the form-generating functions
+is passed through a function called escapeHTML():
+
+=over 4
+
+=item $escaped_string = escapeHTML("unescaped string");
+
+Escape HTML formatting characters in a string.
+
+=back
+
+Provided that you have specified a character set of ISO-8859-1 (the
+default), the standard HTML escaping rules will be used. The "<"
+character becomes "<", ">" becomes ">", "&" becomes "&", and
+the quote character becomes """. In addition, the hexadecimal
+0x8b and 0x9b characters, which many windows-based browsers interpret
+as the left and right angle-bracket characters, are replaced by their
+numeric HTML entities ("‹" and "›"). If you manually change
+the charset, either by calling the charset() method explicitly or by
+passing a -charset argument to header(), then B<all> characters will
+be replaced by their numeric entities, since CGI.pm has no lookup
+table for all the possible encodings.
+
+The automatic escaping does not apply to other shortcuts, such as
+h1(). You should call escapeHTML() yourself on untrusted data in
+order to protect your pages against nasty tricks that people may enter
+into guestbooks, etc.. To change the character set, use charset().
+To turn autoescaping off completely, use autoescape():
+
+=over 4
+
+=item $charset = charset([$charset]);
+
+Get or set the current character set.
+
+=item $flag = autoEscape([$flag]);
+
+Get or set the value of the autoescape flag.
+
+=back
+
+=head2 PRETTY-PRINTING HTML
+
+By default, all the HTML produced by these functions comes out as one
+long line without carriage returns or indentation. This is yuck, but
+it does reduce the size of the documents by 10-20%. To get
+pretty-printed output, please use L<CGI::Pretty>, a subclass
+contributed by Brian Paulsen.
+
=head1 CREATING FILL-OUT FORMS:
I<General note> The various form-creating methods all return strings
$query = new CGI;
$query->autoEscape(undef);
-
=head2 CREATING AN ISINDEX TAG
=head2 STARTING AND ENDING A FORM
- print $query->startform(-method=>$method,
+ print $query->start_form(-method=>$method,
-action=>$action,
- -encoding=>$encoding);
+ -enctype=>$encoding);
<... various form stuff ...>
print $query->endform;
-or-
- print $query->startform($method,$action,$encoding);
+ print $query->start_form($method,$action,$encoding);
<... various form stuff ...>
print $query->endform;
-startform() will return a <FORM> tag with the optional method,
+start_form() will return a <FORM> tag with the optional method,
action and form encoding that you specify. The defaults are:
-
+
method: POST
action: this script
- encoding: application/x-www-form-urlencoded
+ enctype: application/x-www-form-urlencoded
endform() returns the closing </FORM> tag.
-Startform()'s encoding method tells the browser how to package the various
+Start_form()'s enctype argument tells the browser how to package the various
fields of the form before sending the form to the server. Two
values are possible:
+B<Note:> This method was previously named startform(), and startform()
+is still recognized as an alias.
+
=over 4
=item B<application/x-www-form-urlencoded>
Netscape 2.0. It is compatible with many CGI scripts and is
suitable for short fields containing text data. For your
convenience, CGI.pm stores the name of this encoding
-type in B<$CGI::URL_ENCODED>.
+type in B<&CGI::URL_ENCODED>.
=item B<multipart/form-data>
=back
-For compatibility, the startform() method uses the older form of
+For compatibility, the start_form() method uses the older form of
encoding by default. If you want to use the newer form of encoding
by default, you can call B<start_multipart_form()> instead of
-B<startform()>.
+B<start_form()>.
JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
for use with JavaScript. The -name parameter gives the
filefield() will return a file upload field for Netscape 2.0 browsers.
In order to take full advantage of this I<you must use the new
multipart encoding scheme> for the form. You can do this either
-by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
+by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
or by calling the new method B<start_multipart_form()> instead of
-vanilla B<startform()>.
+vanilla B<start_form()>.
=over 4
The optional second parameter is the starting value for the field contents
to be used as the default file name (-default).
-The beta2 version of Netscape 2.0 currently doesn't pay any attention
-to this field, and so the starting value will always be blank. Worse,
-the field loses its "sticky" behavior and forgets its previous
-contents. The starting value field is called for in the HTML
-specification, however, and possibly later versions of Netscape will
-honor it.
+For security reasons, browsers don't pay any attention to this field,
+and so the starting value will always be blank. Worse, the field
+loses its "sticky" behavior and forgets its previous contents. The
+starting value field is called for in the HTML specification, however,
+and possibly some browser will eventually provide support for it.
=item 3.
=back
When the form is processed, you can retrieve the entered filename
-by calling param().
+by calling param():
$filename = $query->param('uploaded_file');
-In Netscape Navigator 2.0, the filename that gets returned is the full
-local filename on the B<remote user's> machine. If the remote user is
-on a Unix machine, the filename will follow Unix conventions:
-
- /path/to/the/file
-
-On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
-
- C:\PATH\TO\THE\FILE.MSW
-
-On a Macintosh machine, the filename will follow Mac conventions:
-
- HD 40:Desktop Folder:Sort Through:Reminders
+Different browsers will return slightly different things for the
+name. Some browsers return the filename only. Others return the full
+path to the file, using the path conventions of the user's machine.
+Regardless, the name returned is always the name of the file on the
+I<user's> machine, and is unrelated to the name of the temporary file
+that CGI.pm creates during upload spooling (see below).
The filename returned is also a file handle. You can read the contents
of the file using standard Perl file reading calls:
print OUTFILE $buffer;
}
+However, there are problems with the dual nature of the upload fields.
+If you C<use strict>, then Perl will complain when you try to use a
+string as a filehandle. You can get around this by placing the file
+reading code in a block containing the C<no strict> pragma. More
+seriously, it is possible for the remote user to type garbage into the
+upload field, in which case what you get from param() is not a
+filehandle at all, but a string.
+
+To be safe, use the I<upload()> function (new in version 2.47). When
+called with the name of an upload field, I<upload()> returns a
+filehandle, or undef if the parameter is not a valid filehandle.
+
+ $fh = $query->upload('uploaded_file');
+ while (<$fh>) {
+ print;
+ }
+
+In an array context, upload() will return an array of filehandles.
+This makes it possible to create forms that use the same name for
+multiple upload fields.
+
+This is the recommended idiom.
+
When a file is uploaded the browser usually sends along some
information along with it in the format of headers. The information
usually includes the MIME content type. Future browsers may send
If you are using a machine that recognizes "text" and "binary" data
modes, be sure to understand when and how to use them (see the Camel book).
-Otherwise you may find that binary files are corrupted during file uploads.
+Otherwise you may find that binary files are corrupted during file
+uploads.
+
+There are occasionally problems involving parsing the uploaded file.
+This usually happens when the user presses "Stop" before the upload is
+finished. In this case, CGI.pm will return undef for the name of the
+uploaded file and set I<cgi_error()> to the string "400 Bad request
+(malformed multipart POST)". This error message is designed so that
+you can incorporate it into a status code to be sent to the browser.
+Example:
+
+ $file = $query->upload('uploaded_file');
+ if (!$file && $query->cgi_error) {
+ print $query->header(-status=>$query->cgi_error);
+ exit 0;
+ }
+
+You are free to create a custom HTML page to complain about the error,
+if you wish.
+
+If you are using CGI.pm on a Windows platform and find that binary
+files get slightly larger when uploaded but that text files remain the
+same, then you have forgotten to activate binary mode on the output
+filehandle. Be sure to call binmode() on any handle that you create
+to write the uploaded file to disk.
JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
print $query->checkbox_group(-name=>'group_name',
-values=>['eenie','meenie','minie','moe'],
-rows=2,-columns=>2);
-
+
checkbox_group() creates a list of checkboxes that are related
by the same name.
form to its value from the last time the script was called,
NOT necessarily to the defaults.
+Note that this conflicts with the Perl reset() built-in. Use
+CORE::reset() to get the original reset function.
+
=head2 CREATING A DEFAULT BUTTON
print $query->defaults('button_label')
The second argument (-src) is also required and specifies the URL
=item 3.
+
The third option (-align, optional) is an alignment type, and may be
TOP, BOTTOM or MIDDLE
non-Netscape browsers this form element will probably not even
display.
-=head1 NETSCAPE COOKIES
+=head1 HTTP COOKIES
-Netscape browsers versions 1.1 and higher support a so-called
-"cookie" designed to help maintain state within a browser session.
-CGI.pm has several methods that support cookies.
+Netscape browsers versions 1.1 and higher, and all versions of
+Internet Explorer, support a so-called "cookie" designed to help
+maintain state within a browser session. CGI.pm has several methods
+that support cookies.
A cookie is a name=value pair much like the named parameters in a CGI
query string. CGI scripts create one or more cookies and send
This is a time/date string (in a special GMT format) that indicates
when a cookie expires. The cookie will be saved and returned to your
script until this expiration date is reached if the user exits
-Netscape and restarts it. If an expiration date isn't specified, the cookie
-will remain active until the user quits Netscape.
+the browser and restarts it. If an expiration date isn't specified, the cookie
+will remain active until the user quits the browser.
=item 2. a domain
This is a partial or complete domain name for which the cookie is
valid. The browser will return the cookie to any host that matches
the partial domain name. For example, if you specify a domain name
-of ".capricorn.com", then Netscape will return the cookie to
+of ".capricorn.com", then the browser will return the cookie to
Web servers running on any of the machines "www.capricorn.com",
"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
must contain at least two periods to prevent attempts to match
=back
-The interface to Netscape cookies is the B<cookie()> method:
+The interface to HTTP cookies is the B<cookie()> method:
$cookie = $query->cookie(-name=>'sessionID',
-value=>'xyzzy',
=item B<-name>
The name of the cookie (required). This can be any string at all.
-Although Netscape limits its cookie names to non-whitespace
+Although browsers limit their cookie names to non-whitespace
alphanumeric characters, CGI.pm removes this restriction by escaping
and unescaping cookies behind the scenes.
-value=>\%answers);
print $query->header(-cookie=>[$cookie1,$cookie2]);
-To retrieve a cookie, request it by name by calling cookie()
-method without the B<-value> parameter:
+To retrieve a cookie, request it by name by calling cookie() method
+without the B<-value> parameter:
use CGI;
$query = new CGI;
- %answers = $query->cookie(-name=>'answers');
- # $query->cookie('answers') will work too!
+ $riddle = $query->cookie('riddle_name');
+ %answers = $query->cookie('answers');
+
+Cookies created with a single scalar value, such as the "riddle_name"
+cookie, will be returned in that form. Cookies with array and hash
+values can also be retrieved.
The cookie and CGI namespaces are separate. If you have a parameter
named 'answers' and a cookie named 'answers', the values retrieved by
See the B<cookie.cgi> example script for some ideas on how to use
cookies effectively.
-B<NOTE:> There appear to be some (undocumented) restrictions on
-Netscape cookies. In Netscape 2.01, at least, I haven't been able to
-set more than three cookies at a time. There may also be limits on
-the length of cookies. If you need to store a lot of information,
-it's probably better to create a unique session ID, store it in a
-cookie, and use the session ID to locate an external file/database
-saved on the server's side of the connection.
+=head1 WORKING WITH FRAMES
-=head1 WORKING WITH NETSCAPE FRAMES
-
-It's possible for CGI.pm scripts to write into several browser
-panels and windows using Netscape's frame mechanism.
-There are three techniques for defining new frames programmatically:
+It's possible for CGI.pm scripts to write into several browser panels
+and windows using the HTML 4 frame mechanism. There are three
+techniques for defining new frames programmatically:
=over 4
=item 2. Specify the destination for the document in the HTTP header
You may provide a B<-target> parameter to the header() method:
-
+
print $q->header(-target=>'ResultsWindow');
-This will tell Netscape to load the output of your script into the
-frame named "ResultsWindow". If a frame of that name doesn't
-already exist, Netscape will pop up a new window and load your
-script's document into that. There are a number of magic names
-that you can use for targets. See the frame documents on Netscape's
-home pages for details.
+This will tell the browser to load the output of your script into the
+frame named "ResultsWindow". If a frame of that name doesn't already
+exist, the browser will pop up a new window and load your script's
+document into that. There are a number of magic names that you can
+use for targets. See the frame documents on Netscape's home pages for
+details.
=item 3. Specify the destination for the document in the <FORM> tag
You can specify the frame to load in the FORM tag itself. With
CGI.pm it looks like this:
- print $q->startform(-target=>'ResultsWindow');
+ print $q->start_form(-target=>'ResultsWindow');
When your script is reinvoked by the form, its output will be loaded
into the frame named "ResultsWindow". If one doesn't already exist
);
print end_html;
+Pass an array reference to B<-style> in order to incorporate multiple
+stylesheets into your document.
+
=head1 DEBUGGING
-If you are running the script
-from the command line or in the perl debugger, you can pass the script
-a list of keywords or parameter=value pairs on the command line or
-from standard input (you don't have to worry about tricking your
-script into reading from environment variables).
-You can pass keywords like this:
+If you are running the script from the command line or in the perl
+debugger, you can pass the script a list of keywords or
+parameter=value pairs on the command line or from standard input (you
+don't have to worry about tricking your script into reading from
+environment variables). You can pass keywords like this:
your_script.pl keyword1 keyword2 keyword3
your_script.pl name1=value1&name2=value2
-or even as newline-delimited parameters on standard input.
+To turn off this feature, use the -no_debug pragma.
+
+To test the POST method, you may enable full debugging with the -debug
+pragma. This will allow you to feed newline-delimited name=value
+pairs to the script on standard input.
When debugging, you can use quotes and backslashes to escape
characters in the familiar shell manner, letting you place
=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
-The dump() method produces a string consisting of all the query's
+The Dump() method produces a string consisting of all the query's
name/value pairs formatted nicely as a nested list. This is useful
for debugging purposes:
- print $query->dump
-
+ print $query->Dump
+
Produces something that looks like:
</UL>
</UL>
-You can pass a value of 'true' to dump() in order to get it to
-print the results out as plain text, suitable for incorporating
-into a <PRE> section.
-
-As a shortcut, as of version 1.56 you can interpolate the entire CGI
-object into a string and it will be replaced with the a nice HTML dump
-shown above:
+As a shortcut, you can interpolate the entire CGI object into a string
+and it will be replaced with the a nice HTML dump shown above:
$query=new CGI;
print "<H2>Current Values</H2> $query\n";
=over 4
-=item B<accept()>
+=item B<Accept()>
-Return a list of MIME types that the remote browser
-accepts. If you give this method a single argument
-corresponding to a MIME type, as in
-$query->accept('text/html'), it will return a
-floating point value corresponding to the browser's
-preference for this type from 0.0 (don't want) to 1.0.
-Glob types (e.g. text/*) in the browser's accept list
-are handled correctly.
+Return a list of MIME types that the remote browser accepts. If you
+give this method a single argument corresponding to a MIME type, as in
+$query->Accept('text/html'), it will return a floating point value
+corresponding to the browser's preference for this type from 0.0
+(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
+list are handled correctly.
+
+Note that the capitalization changed between version 2.43 and 2.44 in
+order to avoid conflict with Perl's accept() function.
=item B<raw_cookie()>
Returns the HTTP_COOKIE variable, an HTTP extension implemented by
-Netscape browsers version 1.1 and higher. Cookies have a special
-format, and this method call just returns the raw form (?cookie
-dough). See cookie() for ways of setting and retrieving cooked
-cookies.
+Netscape browsers version 1.1 and higher, and all versions of Internet
+Explorer. Cookies have a special format, and this method call just
+returns the raw form (?cookie dough). See cookie() for ways of
+setting and retrieving cooked cookies.
Called with no parameters, raw_cookie() returns the packed cookie
structure. You can separate it into individual cookies by splitting
=item B<path_info()>
Returns additional path information from the script URL.
-E.G. fetching /cgi-bin/your_script/additional/stuff will
-result in $query->path_info() returning
-"additional/stuff".
+E.G. fetching /cgi-bin/your_script/additional/stuff will result in
+$query->path_info() returning "/additional/stuff".
NOTE: The Microsoft Internet Information Server
is broken with respect to additional path information. If
if the former is unavailable.
=item B<script_name()>
+
Return the script name as a partial URL, for self-refering
scripts.
When using virtual hosts, returns the name of the host that
the browser attempted to contact
+=item B<server_port ()>
+
+Return the port that the server is listening on.
+
=item B<server_software ()>
Returns the server software and version number.
=item B<user_name ()>
-Attempt to obtain the remote user's name, using a variety
-of different techniques. This only works with older browsers
-such as Mosaic. Netscape does not reliably report the user
-name!
+Attempt to obtain the remote user's name, using a variety of different
+techniques. This only works with older browsers such as Mosaic.
+Newer browsers do not report the user name for privacy reasons!
=item B<request_method()>
Returns the method used to access your script, usually
one of 'POST', 'GET' or 'HEAD'.
+=item B<content_type()>
+
+Returns the content_type of data submitted in a POST, generally
+multipart/form-data or application/x-www-form-urlencoded
+
+=item B<http()>
+
+Called with no arguments returns the list of HTTP environment
+variables, including such things as HTTP_USER_AGENT,
+HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
+like-named HTTP header fields in the request. Called with the name of
+an HTTP header field, returns its value. Capitalization and the use
+of hyphens versus underscores are not significant.
+
+For example, all three of these examples are equivalent:
+
+ $requested_language = $q->http('Accept-language');
+ $requested_language = $q->http('Accept_language');
+ $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE');
+
+=item B<https()>
+
+The same as I<http()>, but operates on the HTTPS environment variables
+present when the SSL protocol is in effect. Can be used to determine
+whether SSL is turned on.
+
=back
=head1 USING NPH SCRIPTS
CGI->nph(1)
-=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements:
+=item By using B<-nph> parameters
+
+in the B<header()> and B<redirect()> statements:
print $q->header(-nph=>1);
=head1 Server Push
-CGI.pm provides three simple functions for producing multipart
+CGI.pm provides four simple functions for producing multipart
documents of the type needed to implement server push. These
functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
import these into your namespace, you must import the ":push" set.
#!/usr/local/bin/perl
use CGI qw/:push -nph/;
$| = 1;
- print multipart_init(-boundary=>'----------------here we go!');
- while (1) {
+ print multipart_init(-boundary=>'----here we go!');
+ foreach (0 .. 4) {
print multipart_start(-type=>'text/plain'),
- "The current time is ",scalar(localtime),"\n",
- multipart_end;
+ "The current time is ",scalar(localtime),"\n";
+ if ($_ < 4) {
+ print multipart_end;
+ } else {
+ print multipart_final;
+ }
sleep 1;
}
This script initializes server push by calling B<multipart_init()>.
-It then enters an infinite loop in which it begins a new multipart
-section by calling B<multipart_start()>, prints the current local time,
+It then enters a loop in which it begins a new multipart section by
+calling B<multipart_start()>, prints the current local time,
and ends a multipart section with B<multipart_end()>. It then sleeps
-a second, and begins again.
+a second, and begins again. On the final iteration, it ends the
+multipart section with B<multipart_final()> rather than with
+B<multipart_end()>.
=over 4
=item multipart_init()
-
+
multipart_init(-boundary=>$boundary);
Initialize the multipart system. The -boundary argument specifies
multipart_end()
End a part. You must remember to call multipart_end() once for each
-multipart_start().
+multipart_start(), except at the end of the last part of the multipart
+document when multipart_final() should be called instead of multipart_end().
+
+=item multipart_final()
+
+ multipart_final()
+
+End all parts. You should call multipart_final() rather than
+multipart_end() at the end of the last part of the multipart document.
=back
Users interested in server push applications should also have a look
at the CGI::Push module.
+Only Netscape Navigator supports server push. Internet Explorer
+browsers do not.
+
=head1 Avoiding Denial of Service Attacks
A potential problem with CGI.pm is that, by default, it attempts to
=back
-Since an attempt to send a POST larger than $POST_MAX bytes
-will cause a fatal error, you might want to use CGI::Carp to echo the
-fatal error message to the browser window as shown in the example
-above. Otherwise the remote user will see only a generic "Internal
-Server" error message. See the L<CGI::Carp> manual page for more
-details.
+An attempt to send a POST larger than $POST_MAX bytes will cause
+I<param()> to return an empty CGI parameter list. You can test for
+this event by checking I<cgi_error()>, either after you create the CGI
+object or, if you are using the function-oriented interface, call
+<param()> for the first time. If the POST was intercepted, then
+cgi_error() will return the message "413 POST too large".
+
+This error message is actually defined by the HTTP protocol, and is
+designed to be returned to the browser as the CGI script's status
+ code. For example:
+
+ $uploaded_file = param('upload');
+ if (!$uploaded_file && cgi_error()) {
+ print header(-status=>cgi_error());
+ exit 0;
+ }
+
+However it isn't clear that any browser currently knows what to do
+with this status code. It might be better just to create an
+HTML page that warns the user of the problem.
=head1 COMPATIBILITY WITH CGI-LIB.PL
-To make it easier to port existing programs that use cgi-lib.pl
-the compatibility routine "ReadParse" is provided. Porting is
-simple:
+To make it easier to port existing programs that use cgi-lib.pl the
+compatibility routine "ReadParse" is provided. Porting is simple:
OLD VERSION
require "cgi-lib.pl";
=head1 AUTHOR INFORMATION
-Copyright 1995-1997, Lincoln D. Stein. All rights reserved. It may
-be used and modified freely, but I do request that this copyright
-notice remain attached to the file. You may modify this module as you
-wish, but if you redistribute a modified version, please attach a note
-listing the modifications you have made.
+Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-Address bug reports and comments to:
-lstein@genome.wi.mit.edu
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org. When sending
+bug reports, please provide the version of CGI.pm, the version of
+Perl, the name and version of your Web server, and the name and
+version of the operating system you are using. If the problem is even
+remotely browser dependent, please provide information about the
+affected browers as well.
=head1 CREDITS
=item Joergen Haegg (jh@axis.se)
-=item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
+=item Laurent Delfosse (delfosse@delfosse.com)
=item Richard Resnick (applepi1@aol.com)
#!/usr/local/bin/perl
-
+
use CGI;
-
+
$query = new CGI;
print $query->header;
&do_work($query);
&print_tail;
print $query->end_html;
-
+
sub print_prompt {
my($query) = @_;
-
- print $query->startform;
+
+ print $query->start_form;
print "<EM>What's your name?</EM><BR>";
print $query->textfield('name');
print $query->checkbox('Not my real name');
-
+
print "<P><EM>Where can you find English Sparrows?</EM><BR>";
print $query->checkbox_group(
-name=>'Sparrow locations',
-values=>[England,France,Spain,Asia,Hoboken],
-linebreak=>'yes',
-defaults=>[England,Asia]);
-
+
print "<P><EM>How far can they fly?</EM><BR>",
$query->radio_group(
-name=>'how far',
-values=>['10 ft','1 mile','10 miles','real far'],
-default=>'1 mile');
-
+
print "<P><EM>What's your favorite color?</EM> ";
print $query->popup_menu(-name=>'Color',
-values=>['black','brown','red','yellow'],
-default=>'red');
-
+
print $query->hidden('Reference','Monty Python and the Holy Grail');
-
+
print "<P><EM>What have you got there?</EM><BR>";
print $query->scrolling_list(
-name=>'possessions',
'A Sword','A Ticket'],
-size=>5,
-multiple=>'true');
-
+
print "<P><EM>Any parting comments?</EM><BR>";
print $query->textarea(-name=>'Comments',
-rows=>10,
-columns=>50);
-
+
print "<P>",$query->reset;
print $query->submit('Action','Shout');
print $query->submit('Action','Scream');
print $query->endform;
print "<HR>\n";
}
-
+
sub do_work {
my($query) = @_;
my(@values,$key);
print join(", ",@values),"<BR>\n";
}
}
-
+
sub print_tail {
print <<END;
<HR>
=head1 SEE ALSO
L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
-L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
-L<CGI::Push>, L<CGI::Fast>
+L<CGI::Base>, L<CGI::Form>, L<CGI::Push>, L<CGI::Fast>,
+L<CGI::Pretty>
=cut
https://perl5.git.perl.org / perl5.git / blobdiff