# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.181 2005/05/13 21:45:26 lstein Exp $';
-$CGI::VERSION='3.10_01';
+$CGI::revision = '$Id: CGI.pm,v 1.263 2009/02/11 16:56:37 lstein Exp $';
+$CGI::VERSION='3.43';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
-use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
+use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
$TAINTED = substr("$0$^X",0,0);
}
-$MOD_PERL = 0; # no mod_perl by default
+$MOD_PERL = 0; # no mod_perl by default
+
+#global settings
+$POST_MAX = -1; # no limit to uploaded files
+$DISABLE_UPLOADS = 0;
+
@SAVED_SYMBOLS = ();
+
# >>>>> Here are some globals that you might want to adjust <<<<<<
sub initialize_globals {
# Set this to 1 to enable copious autoloader debugging messages
# 2) CGI::private_tempfiles(1);
$PRIVATE_TEMPFILES = 0;
+ # Set this to 1 to generate automatic tab indexes
+ $TABINDEX = 0;
+
# Set this to 1 to cause files uploaded in multipart documents
# to be closed, instead of caching the file handle
# or:
# it can just be renamed, instead of read and written.
$CLOSE_UPLOAD_FILES = 0;
- # Set this to a positive value to limit the size of a POSTing
- # to a certain number of bytes:
- $POST_MAX = -1;
-
- # Change this to 1 to disable uploads entirely:
- $DISABLE_UPLOADS = 0;
-
# Automatically determined -- don't change
$EBCDIC = 0;
# use CGI qw(-no_undef_params);
$NO_UNDEF_PARAMS = 0;
+ # return everything as utf-8
+ $PARAM_UTF8 = 0;
+
# Other globals that you shouldn't worry about.
undef $Q;
$BEEN_THERE = 0;
undef %EXPORT;
undef $QUERY_CHARSET;
undef %QUERY_FIELDNAMES;
+ undef %QUERY_TMPFILES;
# prevent complaints by mod_perl
1;
tt u i b blockquote pre img a address cite samp dfn html head
base body Link nextid title meta kbd start_html end_html
input Select option comment charset escapeHTML/],
- ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
+ ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param nobr
embed basefont style span layer ilayer font frameset frame script small big Area Map/],
':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
ins label legend noframes noscript object optgroup Q
submit reset defaults radio_group popup_menu button autoEscape
scrolling_list image_button start_form end_form startform endform
start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
- ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
+ ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
+ cookie Dump
raw_cookie request_method query_string Accept user_agent remote_host content_type
remote_addr referer server_name server_software server_port server_protocol virtual_port
virtual_host remote_ident auth_type http append
# To allow overriding, search through the packages
# Till we find one in which the correct subroutine is defined.
my @packages = ($self,@{"$self\:\:ISA"});
- foreach $sym (keys %EXPORT) {
+ for $sym (keys %EXPORT) {
my $pck;
my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
- foreach $pck (@packages) {
+ for $pck (@packages) {
if (defined(&{"$pck\:\:$sym"})) {
$def = $pck;
last;
return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
my(@r);
return ($tag) unless $EXPORT_TAGS{$tag};
- foreach (@{$EXPORT_TAGS{$tag}}) {
+ for (@{$EXPORT_TAGS{$tag}}) {
push(@r,&expand_tags($_));
}
return @r;
my $self = {};
bless $self,ref $class || $class || $DefaultClass;
+
+ # always use a tempfile
+ $self->{'use_tempfile'} = 1;
+
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'Apache')
||
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'CODE'))) {
$self->upload_hook(shift @initializer, shift @initializer);
+ $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
}
if ($MOD_PERL) {
if ($MOD_PERL == 1) {
$self->r(Apache->request) unless $self->r;
my $r = $self->r;
$r->register_cleanup(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
}
else {
# XXX: once we have the new API
my $r = $self->r;
$r->subprocess_env unless exists $ENV{REQUEST_METHOD};
$r->pool->cleanup_register(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
}
undef $NPH;
}
# user is still holding any reference to them as well.
sub DESTROY {
my $self = shift;
- foreach my $href (values %{$self->{'.tmpfiles'}}) {
- $href->{hndl}->DESTROY if defined $href->{hndl};
- $href->{name}->DESTROY if defined $href->{name};
+ if ($OS eq 'WINDOWS') {
+ for my $href (values %{$self->{'.tmpfiles'}}) {
+ $href->{hndl}->DESTROY if defined $href->{hndl};
+ $href->{name}->DESTROY if defined $href->{name};
+ }
}
}
}
sub upload_hook {
- my ($self,$hook,$data) = self_or_default(@_);
+ my $self;
+ if (ref $_[0] eq 'CODE') {
+ $CGI::Q = $self = $CGI::DefaultClass->new(@_);
+ } else {
+ $self = shift;
+ }
+ my ($hook,$data,$use_tempfile) = @_;
$self->{'.upload_hook'} = $hook;
$self->{'.upload_data'} = $data;
+ $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
}
#### Method: param
if (substr($p[0],0,1) eq '-') {
@values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
} else {
- foreach ($value,@other) {
+ for ($value,@other) {
push(@values,$_) if defined($_);
}
}
# If values is provided, then we set it.
- if (@values) {
+ if (@values or defined $value) {
$self->add_parameter($name);
- $self->{$name}=[@values];
+ $self->{param}{$name}=[@values];
}
} else {
$name = $p[0];
}
- return unless defined($name) && $self->{$name};
- return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
+ return unless defined($name) && $self->{param}{$name};
+
+ my @result = @{$self->{param}{$name}};
+
+ if ($PARAM_UTF8) {
+ eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
+ @result = map {ref $_ ? $_ : Encode::decode(utf8=>$_) } @result;
+ }
+
+ return wantarray ? @result : $result[0];
}
sub self_or_default {
# Initialize the query object from the environment.
# If a parameter list is found, this object will be set
-# to an associative array in which parameter names are keys
+# to a hash in which parameter names are keys
# and the values are stored as lists
# If a keyword list is found, this method creates a bogus
# parameter list with the single parameter 'keywords'.
my $self = shift;
my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+ my $is_xforms;
+
my $initializer = shift; # for backward compatibility
local($/) = "\n";
# ourselves from the original query (which may be gone
# if it was read from STDIN originally.)
if (defined(@QUERY_PARAM) && !defined($initializer)) {
- foreach (@QUERY_PARAM) {
- $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
- }
- $self->charset($QUERY_CHARSET);
- $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
- return;
+ for my $name (@QUERY_PARAM) {
+ my $val = $QUERY_PARAM{$name}; # always an arrayref;
+ $self->param('-name'=>$name,'-value'=> $val);
+ if (defined $val and ref $val eq 'ARRAY') {
+ for my $fh (grep {defined(fileno($_))} @$val) {
+ seek($fh,0,0); # reset the filehandle.
+ }
+
+ }
+ }
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
+ $self->{'.tmpfiles'} = {%QUERY_TMPFILES};
+ return;
}
$meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
# avoid unreasonably large postings
if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
- # quietly read and discard the post
- my $buffer;
- my $max = $content_length;
- while ($max > 0 &&
- (my $bytes = $MOD_PERL
- ? $self->r->read($buffer,$max < 10000 ? $max : 10000)
- : read(STDIN,$buffer,$max < 10000 ? $max : 10000)
- )) {
- $self->cgi_error("413 Request entity too large");
- last METHOD;
- }
- }
+ #discard the post, unread
+ $self->cgi_error("413 Request entity too large");
+ last METHOD;
+ }
# Process multipart postings, but only if the initializer is
# not defined.
last METHOD;
}
+ # Process XForms postings. We know that we have XForms in the
+ # following cases:
+ # method eq 'POST' && content-type eq 'application/xml'
+ # method eq 'POST' && content-type =~ /multipart\/related.+start=/
+ # There are more cases, actually, but for now, we don't support other
+ # methods for XForm posts.
+ # In a XForm POST, the QUERY_STRING is parsed normally.
+ # If the content-type is 'application/xml', we just set the param
+ # XForms:Model (referring to the xml syntax) param containing the
+ # unparsed XML data.
+ # In the case of multipart/related we set XForms:Model as above, but
+ # the other parts are available as uploads with the Content-ID as the
+ # the key.
+ # See the URL below for XForms specs on this issue.
+ # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
+ if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
+ if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
+ my($param) = 'XForms:Model';
+ my($value) = '';
+ $self->add_parameter($param);
+ $self->read_from_client(\$value,$content_length,0)
+ if $content_length > 0;
+ push (@{$self->{param}{$param}},$value);
+ $is_xforms = 1;
+ } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
+ my($boundary,$start) = ($1,$2);
+ my($param) = 'XForms:Model';
+ $self->add_parameter($param);
+ my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
+ push (@{$self->{param}{$param}},$value);
+ if ($MOD_PERL) {
+ $query_string = $self->r->args;
+ } else {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
+ }
+ $is_xforms = 1;
+ }
+ }
+
+
# If initializer is defined, then read parameters
# from it.
- if (defined($initializer)) {
+ if (!$is_xforms && defined($initializer)) {
if (UNIVERSAL::isa($initializer,'CGI')) {
$query_string = $initializer->query_string;
last METHOD;
}
if (ref($initializer) && ref($initializer) eq 'HASH') {
- foreach (keys %$initializer) {
+ for (keys %$initializer) {
$self->param('-name'=>$_,'-value'=>$initializer->{$_});
}
last METHOD;
}
-
- if (defined($fh) && ($fh ne '')) {
- while (<$fh>) {
- chomp;
- last if /^=/;
- push(@lines,$_);
- }
- # massage back into standard format
- if ("@lines" =~ /=/) {
- $query_string=join("&",@lines);
- } else {
- $query_string=join("+",@lines);
- }
- last METHOD;
- }
if (defined($fh) && ($fh ne '')) {
while (<$fh>) {
# If method is GET or HEAD, fetch the query from
# the environment.
- if ($meth=~/^(GET|HEAD)$/) {
+ if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
if ($MOD_PERL) {
$query_string = $self->r->args;
} else {
last METHOD;
}
- if ($meth eq 'POST') {
+ if ($meth eq 'POST' || $meth eq 'PUT') {
$self->read_from_client(\$query_string,$content_length,0)
if $content_length > 0;
# Some people want to have their cake and eat it too!
}
# YL: Begin Change for XML handler 10/19/2001
- if ($meth eq 'POST'
+ if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT')
&& defined($ENV{'CONTENT_TYPE'})
&& $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
&& $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
- my($param) = 'POSTDATA' ;
+ my($param) = $meth . 'DATA' ;
$self->add_parameter($param) ;
- push (@{$self->{$param}},$query_string);
+ push (@{$self->{param}{$param}},$query_string);
undef $query_string ;
}
# YL: End Change for XML handler 10/19/2001
$self->parse_params($query_string);
} else {
$self->add_parameter('keywords');
- $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
+ $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)];
}
}
$self->delete_all();
}
- # Associative array containing our defined fieldnames
+ # hash containing our defined fieldnames
$self->{'.fieldnames'} = {};
- foreach ($self->param('.cgifields')) {
+ for ($self->param('.cgifields')) {
$self->{'.fieldnames'}->{$_}++;
}
# again, we initialize ourselves in exactly the same way. This allows
# us to have several of these objects.
@QUERY_PARAM = $self->param; # save list of parameters
- foreach (@QUERY_PARAM) {
+ for (@QUERY_PARAM) {
next unless defined $_;
- $QUERY_PARAM{$_}=$self->{$_};
+ $QUERY_PARAM{$_}=$self->{param}{$_};
}
$QUERY_CHARSET = $self->charset;
%QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
+ %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
}
sub parse_params {
my($self,$tosplit) = @_;
my(@pairs) = split(/[&;]/,$tosplit);
my($param,$value);
- foreach (@pairs) {
+ for (@pairs) {
($param,$value) = split('=',$_,2);
next unless defined $param;
next if $NO_UNDEF_PARAMS and not defined $value;
$param = unescape($param);
$value = unescape($value);
$self->add_parameter($param);
- push (@{$self->{$param}},$value);
+ push (@{$self->{param}{$param}},$value);
}
}
my($self,$param)=@_;
return unless defined $param;
push (@{$self->{'.parameters'}},$param)
- unless defined($self->{$param});
+ unless defined($self->{param}{$param});
}
sub all_parameters {
my $self = shift;
my $value = shift;
return '' unless $value;
- return $XHTML ? qq( selected="selected") : qq( selected);
+ return $XHTML ? qq(selected="selected" ) : qq(selected );
}
sub _checked {
my $self = shift;
my $value = shift;
return '' unless $value;
- return $XHTML ? qq( checked="checked") : qq( checked);
+ return $XHTML ? qq(checked="checked" ) : qq(checked );
}
sub _reset_globals { initialize_globals(); }
# to avoid reexporting unwanted variables
undef %EXPORT;
- foreach (@_) {
+ for (@_) {
$HEADERS_ONCE++, next if /^[:-]unique_headers$/;
$NPH++, next if /^[:-]nph$/;
$NOSTICKY++, next if /^[:-]nosticky$/;
$DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
$DEBUG=2, next if /^[:-][Dd]ebug$/;
$USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+ $PARAM_UTF8++, next if /^[:-]utf8$/;
$XHTML++, next if /^[:-]xhtml$/;
$XHTML=0, next if /^[:-]no_?xhtml$/;
$USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
$PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
+ $TABINDEX++, next if /^[:-]tabindex$/;
$CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
$EXPORT{$_}++, next if /^[:-]any$/;
$compile++, next if /^[:-]compile$/;
next;
}
- foreach (&expand_tags($_)) {
+ for (&expand_tags($_)) {
tr/a-zA-Z0-9_//cd; # don't allow weird function names
$EXPORT{$_}++;
}
my ($self,$new_value) = self_or_default(@_);
$self->{'.etab'} ||= 1;
$self->{'.etab'} = $new_value if defined $new_value;
- $self->{'.etab'}++;
+ my $tab = $self->{'.etab'}++;
+ return '' unless $TABINDEX or defined $new_value;
+ return qq(tabindex="$tab" );
}
###############################################################################
my(@names) = rearrange([NAME],@p);
my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
my %to_delete;
- foreach my $name (@to_delete)
+ for my $name (@to_delete)
{
- CORE::delete $self->{$name};
+ CORE::delete $self->{param}{$name};
CORE::delete $self->{'.fieldnames'}->{$name};
$to_delete{$name}++;
}
die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
# can anyone find an easier way to do this?
- foreach (keys %{"${namespace}::"}) {
+ for (keys %{"${namespace}::"}) {
local *symbol = "${namespace}::${_}";
undef $symbol;
undef @symbol;
}
}
my($param,@value,$var);
- foreach $param ($self->param) {
+ for $param ($self->param) {
# protect against silly names
($var = $param)=~tr/a-zA-Z0-9_/_/c;
$var =~ s/^(?=\d)/_/;
sub keywords {
my($self,@values) = self_or_default(@_);
# If values is provided, then we set it.
- $self->{'keywords'}=[@values] if @values;
- my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
+ $self->{param}{'keywords'}=[@values] if @values;
+ my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
@result;
}
END_OF_FUNC
'EXISTS' => <<'END_OF_FUNC',
sub EXISTS {
- exists $_[0]->{$_[1]};
+ exists $_[0]->{param}{$_[1]};
}
END_OF_FUNC
####
'append' => <<'EOF',
sub append {
- my($self,@p) = @_;
+ my($self,@p) = self_or_default(@_);
my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
if (@values) {
$self->add_parameter($name);
- push(@{$self->{$name}},@values);
+ push(@{$self->{param}{$name}},@values);
}
return $self->param($name);
}
if ($ENV{QUERY_STRING} =~ /=/) {
my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
my($param,$value);
- foreach (@pairs) {
+ for (@pairs) {
($param,$value) = split('=',$_,2);
$param = unescape($param);
$value = unescape($value);
my($param,$value,@result);
return '<ul></ul>' unless $self->param;
push(@result,"<ul>");
- foreach $param ($self->param) {
+ for $param ($self->param) {
my($name)=$self->escapeHTML($param);
push(@result,"<li><strong>$param</strong></li>");
push(@result,"<ul>");
- foreach $value ($self->param($param)) {
+ for $value ($self->param($param)) {
$value = $self->escapeHTML($value);
$value =~ s/\n/<br \/>\n/g;
push(@result,"<li>$value</li>");
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) {
+ for $param ($self->param) {
my($escaped_param) = escape($param);
my($value);
- foreach $value ($self->param($param)) {
+ for $value ($self->param($param)) {
print $filehandle "$escaped_param=",escape("$value"),"\n";
}
}
- foreach (keys %{$self->{'.fieldnames'}}) {
+ for (keys %{$self->{'.fieldnames'}}) {
print $filehandle ".cgifields=",escape("$_"),"\n";
}
print $filehandle "=\n"; # end of record
'multipart_init' => <<'END_OF_FUNC',
sub multipart_init {
my($self,@p) = self_or_default(@_);
- my($boundary,@other) = rearrange([BOUNDARY],@p);
+ my($boundary,@other) = rearrange_header([BOUNDARY],@p);
$boundary = $boundary || '------- =_aaaaaaaaaa0';
$self->{'separator'} = "$CRLF--$boundary$CRLF";
$self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
- foreach (@other) {
+ for (@other) {
# Don't use \s because of perl bug 21951
next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
'ATTACHMENT','P3P'],@p);
$nph ||= $NPH;
+
+ $type ||= 'text/html' unless defined($type);
+
if (defined $charset) {
$self->charset($charset);
} else {
- $charset = $self->charset;
+ $charset = $self->charset if $type =~ /^text\//;
}
+ $charset ||= '';
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
- foreach (@other) {
+ for (@other) {
# Don't use \s because of perl bug 21951
next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
- $type ||= 'text/html' unless defined($type);
- $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne '';
+ $type .= "; charset=$charset"
+ if $type ne ''
+ and $type !~ /\bcharset\b/
+ and defined $charset
+ and $charset ne '';
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
# push all the cookies -- there may be several
if ($cookie) {
my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
- foreach (@cookie) {
+ for (@cookie) {
my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
push(@header,"Set-Cookie: $cs") if $cs ne '';
}
push(@header,map {ucfirst $_} @other);
push(@header,"Content-Type: $type") if $type ne '';
my $header = join($CRLF,@header)."${CRLF}${CRLF}";
- if ($MOD_PERL and not $nph) {
+ if (($MOD_PERL >= 1) && !$nph) {
$self->r->send_cgi_header($header);
return '';
}
my($self,@p) = self_or_default(@_);
my($url,$target,$status,$cookie,$nph,@other) =
rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
- $status = '302 Moved' unless defined $status;
+ $status = '302 Found' unless defined $status;
$url ||= $self->self_url;
my(@o);
- foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
+ for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
'-Status' => $status,
'-Location'=> $url,
$self->element_id(0);
$self->element_tab(0);
- $encoding = 'iso-8859-1' unless defined $encoding;
+ $encoding = lc($self->charset) unless defined $encoding;
# Need to sort out the DTD before it's okay to call escapeHTML().
my(@result,$xml_dtd);
}
if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
- foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
+ for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
: qq(<meta name="$_" content="$meta->{$_}">)); }
}
- push(@result,ref($head) ? @$head : $head) if $head;
+ my $meta_bits_set = 0;
+ if( $head ) {
+ if( ref $head ) {
+ push @result, @$head;
+ $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head;
+ }
+ else {
+ push @result, $head;
+ $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i;
+ }
+ }
# handle the infrequently-used -style and -script parameters
push(@result,$self->_style($style)) if defined $style;
push(@result,$self->_script($script)) if defined $script;
- push(@result,$meta_bits) if defined $meta_bits;
+ push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set;
# handle -noscript parameter
push(@result,<<END) if $noscript;
sub _style {
my ($self,$style) = @_;
my (@result);
+
my $type = 'text/css';
+ my $rel = 'stylesheet';
+
my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
my @s = ref($style) eq 'ARRAY' ? @$style : $style;
+ my $other = '';
for my $s (@s) {
if (ref($s)) {
- my($src,$code,$verbatim,$stype,$foo,@other) =
- rearrange([qw(SRC CODE VERBATIM TYPE FOO)],
+ my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
+ rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
('-foo'=>'bar',
ref($s) eq 'ARRAY' ? @$s : %$s));
- $type = $stype if $stype;
- my $other = @other ? join ' ',@other : '';
+ my $type = defined $stype ? $stype : 'text/css';
+ my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
+ $other = "@other" if @other;
if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
{ # If it is, push a LINK tag for each one
- foreach $src (@$src)
+ for $src (@$src)
{
- push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
- : qq(<link rel="stylesheet" type="$type" href="$src"$other>)) if $src;
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
}
}
else
{ # Otherwise, push the single -src, if it exists.
- push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
- : qq(<link rel="stylesheet" type="$type" href="$src"$other>)
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>)
) if $src;
}
if ($verbatim) {
my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
- push(@result, "<style type=\"text/css\">\n$_\n</style>") foreach @v;
+ push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v;
}
my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
- push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c;
+ push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
} else {
my $src = $s;
- push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
- : qq(<link rel="stylesheet" type="$type" href="$src"$other>));
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>));
}
}
@result;
my (@result);
my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
- foreach $script (@scripts) {
+ for $script (@scripts) {
my($src,$code,$language);
if (ref($script)) { # script is a hash
- ($src,$code,$language, $type) =
- rearrange([SRC,CODE,LANGUAGE,TYPE],
+ ($src,$code,$type) =
+ rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
'-foo'=>'bar', # a trick to allow the '-' to be omitted
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/;
+ $type ||= 'text/javascript';
+ unless ($type =~ m!\w+/\w+!) {
+ $type =~ s/[\d.]+$//;
+ $type = "text/$type";
}
} else {
- ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
+ ($src,$code,$type) = ('',$script, 'text/javascript');
}
my $comment = '//'; # javascript by default
}
my(@satts);
push(@satts,'src'=>$src) if $src;
- push(@satts,'language'=>$language) unless defined $type;
push(@satts,'type'=>$type);
$code = $cdata_start . $code . $cdata_end if defined $code;
push(@result,$self->script({@satts},$code || ''));
my($method,$action,$enctype,@other) =
rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = $self->escapeHTML(lc($method) || 'post');
+ $method = $self->escapeHTML(lc($method || 'post'));
$enctype = $self->escapeHTML($enctype || &URL_ENCODED);
if (defined $action) {
$action = $self->escapeHTML($action);
}
else {
- $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1));
- if (exists $ENV{QUERY_STRING} && length($ENV{QUERY_STRING})>0) {
- $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1);
- }
+ $action = $self->escapeHTML($self->request_uri || $self->self_url);
}
$action = qq(action="$action");
my($other) = @other ? " @other" : '';
'start_multipart_form' => <<'END_OF_FUNC',
sub start_multipart_form {
my($self,@p) = self_or_default(@_);
- if (defined($param[0]) && substr($param[0],0,1) eq '-') {
- my(%p) = @p;
- $p{'-enctype'}=&MULTIPART;
- return $self->startform(%p);
+ if (defined($p[0]) && substr($p[0],0,1) eq '-') {
+ return $self->startform(-enctype=>&MULTIPART,@p);
} else {
my($method,$action,@other) =
rearrange([METHOD,ACTION],@p);
# End a form
'endform' => <<'END_OF_FUNC',
sub endform {
- my($self,@p) = self_or_default(@_);
+ my($self,@p) = self_or_default(@_);
if ( $NOSTICKY ) {
return wantarray ? ("</form>") : "\n</form>";
} else {
- return wantarray ? ("<div>",$self->get_fields,"</div>","</form>") :
- "<div>".$self->get_fields ."</div>\n</form>";
+ if (my @fields = $self->get_fields) {
+ return wantarray ? ("<div>",@fields,"</div>","</form>")
+ : "<div>".(join '',@fields)."</div>\n</form>";
+ } else {
+ return "</form>";
+ }
}
}
END_OF_FUNC
# and WebTV -- not sure it won't break stuff
my($value) = $current ne '' ? qq(value="$current") : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="$tag" name="$name" tabindex="$tabindex" $value$s$m$other />)
+ return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
: qq(<input type="$tag" name="$name" $value$s$m$other>);
}
END_OF_FUNC
my($c) = $cols ? qq/ cols="$cols"/ : '';
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return qq{<textarea name="$name" tabindex="$tabindex"$r$c$other>$current</textarea>};
+ return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
}
END_OF_FUNC
$script = qq/ onclick="$script"/ if $script;
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="button" tabindex="$tabindex"$name$val$script$other />)
+ return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
: qq(<input type="button"$name$val$script$other>);
}
END_OF_FUNC
$label=$self->escapeHTML($label);
$value=$self->escapeHTML($value,1);
- my $name = $NOSTICKY ? '' : ' name=".submit"';
- $name = qq/ name="$label"/ if defined($label);
+ my $name = $NOSTICKY ? '' : 'name=".submit" ';
+ $name = qq/name="$label" / if defined($label);
$value = defined($value) ? $value : $label;
my $val = '';
- $val = qq/ value="$value"/ if defined($value);
+ $val = qq/value="$value" / if defined($value);
$tabindex = $self->element_tab($tabindex);
- my($other) = @other ? " @other" : '';
- return $XHTML ? qq(<input type="submit" tabindex="$tabindex"$name$val$other />)
- : qq(<input type="submit"$name$val$other>);
+ my($other) = @other ? "@other " : '';
+ return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
+ : qq(<input type="submit" $name$val$other>);
}
END_OF_FUNC
$val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="reset" tabindex="$tabindex"$name$val$other />)
+ return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
: qq(<input type="reset"$name$val$other>);
}
END_OF_FUNC
my($value) = qq/ value="$label"/;
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="submit" name=".defaults" tabindex="$tabindex"$value$other />)
+ return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
: qq/<input type="submit" NAME=".defaults"$value$other>/;
}
END_OF_FUNC
sub checkbox {
my($self,@p) = self_or_default(@_);
- my($name,$checked,$value,$label,$override,$tabindex,@other) =
- rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE],TABINDEX],@p);
+ my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) =
+ rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
+ [OVERRIDE,FORCE],TABINDEX],@p);
$value = defined $value ? $value : 'on';
$name = $self->escapeHTML($name);
$value = $self->escapeHTML($value,1);
$the_label = $self->escapeHTML($the_label);
- my($other) = @other ? " @other" : '';
+ my($other) = @other ? "@other " : '';
$tabindex = $self->element_tab($tabindex);
$self->register_parameter($name);
- return $XHTML ? CGI::label(qq{<input type="checkbox" name="$name" value="$value" tabindex="$tabindex"$checked$other />$the_label})
+ return $XHTML ? CGI::label($labelattributes,
+ qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
: qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
}
END_OF_FUNC
else {
$toencode =~ s{"}{"}gso;
}
- my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
- uc $self->{'.charset'} eq 'WINDOWS-1252';
- if ($latin) { # bug in some browsers
+ # Handle bug in some browsers with Latin charsets
+ if ($self->{'.charset'} &&
+ (uc($self->{'.charset'}) eq 'ISO-8859-1' ||
+ uc($self->{'.charset'}) eq 'WINDOWS-1252'))
+ {
$toencode =~ s{'}{'}gso;
$toencode =~ s{\x8b}{‹}gso;
$toencode =~ s{\x9b}{›}gso;
my($row,$column);
unshift(@colheaders,'') if @colheaders && @rowheaders;
$result .= "<tr>" if @colheaders;
- foreach (@colheaders) {
+ for (@colheaders) {
$result .= "<th>$_</th>";
}
for ($row=0;$row<$rows;$row++) {
# $linebreak -> (optional) Set to true to place linebreaks
# between the buttons.
# $labels -> (optional)
-# A pointer to an associative array of labels to print next to each checkbox
+# A pointer to a hash of labels to print next to each checkbox
# in the form $label{'value'}="Long explanatory label".
# Otherwise the provided values are used as the labels.
# Returns:
# $linebreak -> (optional) Set to true to place linebreaks
# between the buttons.
# $labels -> (optional)
-# A pointer to an associative array of labels to print next to each checkbox
+# A pointer to a hash of labels to print next to each checkbox
# in the form $label{'value'}="Long explanatory label".
# Otherwise the provided values are used as the labels.
# Returns:
my $self = shift;
my $box_type = shift;
- my($name,$values,$defaults,$linebreak,$labels,$attributes,
- $rows,$columns,$rowheaders,$colheaders,
- $override,$nolabels,$tabindex,@other) =
- rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES,
- ROWS,[COLUMNS,COLS],ROWHEADERS,COLHEADERS,
- [OVERRIDE,FORCE],NOLABELS,TABINDEX
- ],@_);
- my($result,$checked);
+ my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
+ $attributes,$rows,$columns,$rowheaders,$colheaders,
+ $override,$nolabels,$tabindex,$disabled,@other) =
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
+ ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
+ [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
+ ],@_);
- my(@elements,@values);
+ my($result,$checked,@elements,@values);
+
@values = $self->_set_values_and_labels($values,\$labels,$name);
my %checked = $self->previous_or_default($name,$defaults,$override);
$name=$self->escapeHTML($name);
my %tabs = ();
- if ($tabindex) {
+ if ($TABINDEX && $tabindex) {
if (!ref $tabindex) {
$self->element_tab($tabindex);
} elsif (ref $tabindex eq 'ARRAY') {
}
}
%tabs = map {$_=>$self->element_tab} @values unless %tabs;
-
- my $other = @other ? " @other" : '';
+ my $other = @other ? "@other " : '';
my $radio_checked;
- foreach (@values) {
+
+ # for disabling groups of radio/checkbox buttons
+ my %disabled;
+ for (@{$disabled}) {
+ $disabled{$_}=1;
+ }
+
+ for (@values) {
+ my $disable="";
+ if ($disabled{$_}) {
+ $disable="disabled='1'";
+ }
+
my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
: $checked{$_});
my($break);
$label = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->escapeHTML($label,1);
+ $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
}
my $attribs = $self->_set_attributes($_, $attributes);
- my $tab = qq( tabindex="$tabs{$_}") if exists $tabs{$_};
+ my $tab = $tabs{$_};
$_=$self->escapeHTML($_);
+
if ($XHTML) {
push @elements,
- CGI::label(
- qq(<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs />$label)).${break};
+ CGI::label($labelattributes,
+ qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
} else {
- push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs>${label}${break}/);
+ push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/);
}
}
$self->register_parameter($name);
# text of each menu item.
# $default -> (optional) Default item to display
# $labels -> (optional)
-# A pointer to an associative array of labels to print next to each checkbox
+# A pointer to a hash of labels to print next to each checkbox
# in the form $label{'value'}="Long explanatory label".
# Otherwise the provided values are used as the labels.
# Returns:
my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
- my($result,$selected);
+ my($result,%selected);
if (!$override && defined($self->param($name))) {
- $selected = $self->param($name);
- } else {
- $selected = $default;
+ $selected{$self->param($name)}++;
+ } elsif ($default) {
+ %selected = map {$_=>1} ref($default) eq 'ARRAY'
+ ? @$default
+ : $default;
}
$name=$self->escapeHTML($name);
my($other) = @other ? " @other" : '';
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
$tabindex = $self->element_tab($tabindex);
- $result = qq/<select name="$name" tabindex="$tabindex"$other>\n/;
- foreach (@values) {
+ $result = qq/<select name="$name" $tabindex$other>\n/;
+ for (@values) {
if (/<optgroup/) {
- foreach (split(/\n/)) {
+ for my $v (split(/\n/)) {
my $selectit = $XHTML ? 'selected="selected"' : 'selected';
- s/(value="$selected")/$selectit $1/ if defined $selected;
- $result .= "$_\n";
+ for my $selected (keys %selected) {
+ $v =~ s/(value="$selected")/$selectit $1/;
+ }
+ $result .= "$v\n";
}
}
else {
- my $attribs = $self->_set_attributes($_, $attributes);
- my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- my($value) = $self->escapeHTML($_);
- $label=$self->escapeHTML($label,1);
- $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($selectit) = $self->_selected($selected{$_});
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ my($value) = $self->escapeHTML($_);
+ $label = $self->escapeHTML($label,1);
+ $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
}
}
# $values -> A pointer to a regular array containing the
# values for each option line in the group.
# $labels -> (optional)
-# A pointer to an associative array of labels to print next to each item
+# A pointer to a hash of labels to print next to each item
# in the form $label{'value'}="Long explanatory label".
# Otherwise the provided values are used as the labels.
# $labeled -> (optional)
$name=$self->escapeHTML($name);
$result = qq/<optgroup label="$name"$other>\n/;
- foreach (@values) {
+ for (@values) {
if (/<optgroup/) {
- foreach (split(/\n/)) {
+ for (split(/\n/)) {
my $selectit = $XHTML ? 'selected="selected"' : 'selected';
s/(value="$selected")/$selectit $1/ if defined $selected;
$result .= "$_\n";
# $size -> (optional) Size of the list.
# $multiple -> (optional) If set, allow multiple selections.
# $labels -> (optional)
-# A pointer to an associative array of labels to print next to each checkbox
+# A pointer to a hash of labels to print next to each checkbox
# in the form $label{'value'}="Long explanatory label".
# Otherwise the provided values are used as the labels.
# Returns:
$size = $size || scalar(@values);
my(%selected) = $self->previous_or_default($name,$defaults,$override);
+
my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
$tabindex = $self->element_tab($tabindex);
- $result = qq/<select name="$name" tabindex="$tabindex"$has_size$is_multiple$other>\n/;
- foreach (@values) {
+ $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
+ for (@values) {
my($selectit) = $self->_selected($selected{$_});
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label=$self->escapeHTML($label);
my($value)=$self->escapeHTML($_,1);
my $attribs = $self->_set_attributes($_, $attributes);
- $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
+ $result .= "<option ${selectit}${attribs}value=\"$value\">$label</option>\n";
}
$result .= "</select>";
$self->register_parameter($name);
@value = ref($default) ? @{$default} : $default;
$do_override = $override;
} else {
- foreach ($default,$override,@other) {
+ for ($default,$override,@other) {
push(@value,$_) if defined($_);
}
}
@value = @prev if !$do_override && @prev;
$name=$self->escapeHTML($name);
- foreach (@value) {
+ for (@value) {
$_ = defined($_) ? $self->escapeHTML($_,1) : '';
push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
: qq(<input type="hidden" name="$name" value="$_" @other>);
my($name,$src,$alignment,@other) =
rearrange([NAME,SRC,ALIGN],@p);
- my($align) = $alignment ? " align=\U\"$alignment\"" : '';
+ my($align) = $alignment ? " align=\L\"$alignment\"" : '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
'url' => <<'END_OF_FUNC',
sub url {
my($self,@p) = self_or_default(@_);
- my ($relative,$absolute,$full,$path_info,$query,$base) =
- rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
- my $url;
+ my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
+ rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
+ my $url = '';
$full++ if $base || !($relative || $absolute);
+ $rewrite++ unless defined $rewrite;
- my $path = $self->path_info;
- my $script_name = $self->script_name;
-
- # for compatibility with Apache's MultiViews
- if (exists($ENV{REQUEST_URI})) {
- my $index;
- $script_name = unescape($ENV{REQUEST_URI});
- $script_name =~ s/\?.+$//s; # strip query string
- # and path
- if (exists($ENV{PATH_INFO})) {
- my $encoded_path = unescape($ENV{PATH_INFO});
- $script_name =~ s/\Q$encoded_path\E$//i;
- }
- }
+ my $path = $self->path_info;
+ my $script_name = $self->script_name;
+ my $request_uri = unescape($self->request_uri) || '';
+ my $query_str = $self->query_string;
+
+ my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
+ undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
+
+ my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
+ $uri =~ s/\?.*$//s; # remove query string
+ $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO};
+# $uri =~ s/\Q$path\E$// if defined $path; # remove path
if ($full) {
my $protocol = $self->protocol();
$url = "$protocol://";
- my $vh = http('x_forwarded_host') || http('host');
+ my $vh = http('x_forwarded_host') || http('host') || '';
+ $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
if ($vh) {
$url .= $vh;
} else {
$url .= server_name();
- my $port = $self->server_port;
- $url .= ":" . $port
- unless (lc($protocol) eq 'http' && $port == 80)
- || (lc($protocol) eq 'https' && $port == 443);
}
+ my $port = $self->server_port;
+ $url .= ":" . $port
+ unless (lc($protocol) eq 'http' && $port == 80)
+ || (lc($protocol) eq 'https' && $port == 443);
return $url if $base;
- $url .= $script_name;
+ $url .= $uri;
} elsif ($relative) {
- ($url) = $script_name =~ m!([^/]+)$!;
+ ($url) = $uri =~ m!([^/]+)$!;
} elsif ($absolute) {
- $url = $script_name;
+ $url = $uri;
}
- $url .= $path if $path_info and defined $path;
- $url .= "?" . $self->query_string if $query and $self->query_string;
- $url = '' unless defined $url;
+ $url .= $path if $path_info and defined $path;
+ $url .= "?$query_str" if $query and $query_str ne '';
+ $url ||= '';
$url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
return $url;
}
'cookie' => <<'END_OF_FUNC',
sub cookie {
my($self,@p) = self_or_default(@_);
- my($name,$value,$path,$domain,$secure,$expires) =
- rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
+ my($name,$value,$path,$domain,$secure,$expires,$httponly) =
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
require CGI::Cookie;
push(@param,'-path'=>$path) if $path;
push(@param,'-expires'=>$expires) if $expires;
push(@param,'-secure'=>$secure) if $secure;
+ push(@param,'-httponly'=>$httponly) if $httponly;
return new CGI::Cookie(@param);
}
sub param_fetch {
my($self,@p) = self_or_default(@_);
my($name) = rearrange([NAME],@p);
- unless (exists($self->{$name})) {
+ unless (exists($self->{param}{$name})) {
$self->add_parameter($name);
- $self->{$name} = [];
+ $self->{param}{$name} = [];
}
- return $self->{$name};
+ return $self->{param}{$name};
}
END_OF_FUNC
$info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
$self->{'.path_info'} = $info;
} elsif (! defined($self->{'.path_info'}) ) {
- $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
- $ENV{'PATH_INFO'} : '';
-
- # hack to fix broken path info in IIS
- $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
-
+ my (undef,$path_info) = $self->_name_and_path_from_env;
+ $self->{'.path_info'} = $path_info || '';
}
return $self->{'.path_info'};
}
END_OF_FUNC
+# This function returns a potentially modified version of SCRIPT_NAME
+# and PATH_INFO. Some HTTP servers do sanitise the paths in those
+# variables. It is the case of at least Apache 2. If for instance the
+# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
+# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
+# SCRIPT_NAME=/path/to/env.cgi
+# PATH_INFO=/x/y/x
+#
+# This is all fine except that some bogus CGI scripts expect
+# PATH_INFO=/http://foo when the user requests
+# http://xxx/script.cgi/http://foo
+#
+# Old versions of this module used to accomodate with those scripts, so
+# this is why we do this here to keep those scripts backward compatible.
+# Basically, we accomodate with those scripts but within limits, that is
+# we only try to preserve the number of / that were provided by the user
+# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
+# of consecutive /.
+#
+# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
+# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
+# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
+# possibly sanitised by the HTTP server, so in the case of Apache 2:
+# script_name == /foo/x/z/script.cgi and path_info == /b/c.
+#
+# Future versions of this module may no longer do that, so one should
+# avoid relying on the browser, proxy, server, and CGI.pm preserving the
+# number of consecutive slashes as no guarantee can be made there.
+'_name_and_path_from_env' => <<'END_OF_FUNC',
+sub _name_and_path_from_env {
+ my $self = shift;
+ my $script_name = $ENV{SCRIPT_NAME} || '';
+ my $path_info = $ENV{PATH_INFO} || '';
+ my $uri = $self->request_uri || '';
+
+ $uri =~ s/\?.*//s;
+ $uri = unescape($uri);
+
+ if ($uri ne "$script_name$path_info") {
+ my $script_name_pattern = quotemeta($script_name);
+ my $path_info_pattern = quotemeta($path_info);
+ $script_name_pattern =~ s{(?:\\/)+}{/+}g;
+ $path_info_pattern =~ s{(?:\\/)+}{/+}g;
+
+ if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
+ # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
+ # numer of consecutive slashes, so we can extract the info from
+ # REQUEST_URI:
+ ($script_name, $path_info) = ($1, $2);
+ }
+ }
+ return ($script_name,$path_info);
+}
+END_OF_FUNC
+
#### Method: request_method
# Returns 'POST', 'GET', 'PUT' or 'HEAD'
END_OF_FUNC
+#### Method: request_uri
+# Return the literal request URI
+####
+'request_uri' => <<'END_OF_FUNC',
+sub request_uri {
+ return $ENV{'REQUEST_URI'};
+}
+END_OF_FUNC
+
+
#### Method: query_string
# Synthesize a query string from our current
# parameters
sub query_string {
my($self) = self_or_default(@_);
my($param,$value,@pairs);
- foreach $param ($self->param) {
+ for $param ($self->param) {
my($eparam) = escape($param);
- foreach $value ($self->param($param)) {
+ for $value ($self->param($param)) {
$value = escape($value);
next unless defined $value;
push(@pairs,"$eparam=$value");
}
}
- foreach (keys %{$self->{'.fieldnames'}}) {
+ for (keys %{$self->{'.fieldnames'}}) {
push(@pairs,".cgifields=".escape("$_"));
}
return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
my($self,$search) = self_or_CGI(@_);
my(%prefs,$type,$pref,$pat);
- my(@accept) = split(',',$self->http('accept'));
+ my(@accept) = defined $self->http('accept')
+ ? split(',',$self->http('accept'))
+ : ();
- foreach (@accept) {
+ for (@accept) {
($pref) = /q=(\d\.\d+|\d+)/;
($type) = m#(\S+/[^;]+)#;
next unless $type;
return $prefs{$search} if $prefs{$search};
# Didn't get it, so try pattern matching.
- foreach (keys %prefs) {
+ for (keys %prefs) {
next unless /\*/; # not a pattern match
($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
$pat =~ s/\*/.*/g; # turn it into a pattern
####
'script_name' => <<'END_OF_FUNC',
sub script_name {
- return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
- # These are for debugging
- return "/$0" unless $0=~/^\//;
- return $0;
+ my ($self,@p) = self_or_default(@_);
+ if (@p) {
+ $self->{'.script_name'} = shift @p;
+ } elsif (!exists $self->{'.script_name'}) {
+ my ($script_name,$path_info) = $self->_name_and_path_from_env();
+ $self->{'.script_name'} = $script_name;
+ }
+ return $self->{'.script_name'};
}
END_OF_FUNC
sub virtual_port {
my($self) = self_or_default(@_);
my $vh = $self->http('x_forwarded_host') || $self->http('host');
+ my $protocol = $self->protocol;
if ($vh) {
- return ($vh =~ /:(\d+)$/)[0] || '80';
+ return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
} else {
return $self->server_port();
}
$parameter =~ tr/-/_/;
return $ENV{"HTTP_\U$parameter\E"} if $parameter;
my(@p);
- foreach (keys %ENV) {
+ for (keys %ENV) {
push(@p,$_) if /^HTTP/;
}
return @p;
$parameter =~ tr/-/_/;
return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
my(@p);
- foreach (keys %ENV) {
+ for (keys %ENV) {
push(@p,$_) if /^HTTPS/;
}
return @p;
if (!$override && ($self->{'.fieldnames'}->{$name} ||
defined($self->param($name)) ) ) {
- grep($selected{$_}++,$self->param($name));
+ $selected{$_}++ for $self->param($name);
} elsif (defined($defaults) && ref($defaults) &&
(ref($defaults) eq 'ARRAY')) {
- grep($selected{$_}++,@{$defaults});
+ $selected{$_}++ for @{$defaults};
} else {
$selected{$defaults}++ if defined($defaults);
}
$input = join(" ",@lines);
@words = &shellwords($input);
}
- foreach (@words) {
+ for (@words) {
s/\\=/%3D/g;
s/\\&/%26/g;
}
return;
}
- my($param)= $header{'Content-Disposition'}=~/ name="([^;]*)"/;
+ $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
+
+ my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
$param .= $TAINTED;
- # Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="([^;]*)"/;
+ # See RFC 1867, 2183, 2045
+ # NB: File content will be loaded into memory should
+ # content-disposition parsing fail.
+ my ($filename) = $header{'Content-Disposition'}
+ =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
+
+ $filename ||= ''; # quench uninit variable warning
+
+ $filename =~ s/^"([^"]*)"$/$1/;
# Test for Opera's multiple upload feature
my($multipart) = ( defined( $header{'Content-Type'} ) &&
$header{'Content-Type'} =~ /multipart\/mixed/ ) ?
if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
my($value) = $buffer->readBody;
$value .= $TAINTED;
- push(@{$self->{$param}},$value);
+ push(@{$self->{param}{$param}},$value);
next;
}
# together with the body for later parsing with an external
# MIME parser module
if ( $multipart ) {
- foreach ( keys %header ) {
+ for ( keys %header ) {
print $filehandle "$_: $header{$_}${CRLF}";
}
print $filehandle "${CRLF}";
my ($data);
local($\) = '';
- my $totalbytes;
+ my $totalbytes = 0;
while (defined($data = $buffer->read)) {
if (defined $self->{'.upload_hook'})
{
$totalbytes += length($data);
&{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
}
- print $filehandle $data;
+ print $filehandle $data if ($self->{'use_tempfile'});
}
# back up to beginning of file
# Save some information about the uploaded file where we can get
# at it later.
- $self->{'.tmpfiles'}->{fileno($filehandle)}= {
+ # Use the typeglob as the key, as this is guaranteed to be
+ # unique for each filehandle. Don't use the file descriptor as
+ # this will be re-used for each filehandle if the
+ # close_upload_files feature is used.
+ $self->{'.tmpfiles'}->{$$filehandle}= {
hndl => $filehandle,
name => $tmpfile,
info => {%header},
};
- push(@{$self->{$param}},$filehandle);
+ push(@{$self->{param}{$param}},$filehandle);
}
}
}
END_OF_FUNC
+#####
+# subroutine: read_multipart_related
+#
+# Read multipart/related data and store it into our parameters. The
+# first parameter sets the start of the data. The part identified by
+# this Content-ID will not be stored as a file upload, but will be
+# returned by this method. All other parts will be available as file
+# uploads accessible by their Content-ID
+#####
+'read_multipart_related' => <<'END_OF_FUNC',
+sub read_multipart_related {
+ my($self,$start,$boundary,$length) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
+ return unless $buffer;
+ my(%header,$body);
+ my $filenumber = 0;
+ my $returnvalue;
+ while (!$buffer->eof) {
+ %header = $buffer->readHeader;
+
+ unless (%header) {
+ $self->cgi_error("400 Bad request (malformed multipart POST)");
+ return;
+ }
+
+ my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
+ $param .= $TAINTED;
+
+ # If this is the start part, then just read the data and assign it
+ # to our return variable.
+ if ( $param eq $start ) {
+ $returnvalue = $buffer->readBody;
+ $returnvalue .= $TAINTED;
+ next;
+ }
+
+ # add this parameter to our list
+ $self->add_parameter($param);
+
+ my ($tmpfile,$tmp,$filehandle);
+ UPLOADS: {
+ # If we get here, then we are dealing with a potentially large
+ # uploaded form. Save the data to a temporary file, then open
+ # the file for reading.
+
+ # skip the file if uploads disabled
+ if ($DISABLE_UPLOADS) {
+ while (defined($data = $buffer->read)) { }
+ last UPLOADS;
+ }
+
+ # choose a relatively unpredictable tmpfile sequence number
+ my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
+ for (my $cnt=10;$cnt>0;$cnt--) {
+ next unless $tmpfile = new CGITempFile($seqno);
+ $tmp = $tmpfile->as_string;
+ last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
+ $seqno += int rand(100);
+ }
+ die "CGI open of tmpfile: $!\n" unless defined $filehandle;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
+ && defined fileno($filehandle);
+
+ my ($data);
+ local($\) = '';
+ my $totalbytes;
+ while (defined($data = $buffer->read)) {
+ if (defined $self->{'.upload_hook'})
+ {
+ $totalbytes += length($data);
+ &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
+ }
+ print $filehandle $data if ($self->{'use_tempfile'});
+ }
+
+ # back up to beginning of file
+ seek($filehandle,0,0);
+
+ ## Close the filehandle if requested this allows a multipart MIME
+ ## upload to contain many files, and we won't die due to too many
+ ## open file handles. The user can access the files using the hash
+ ## below.
+ close $filehandle if $CLOSE_UPLOAD_FILES;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+
+ # Save some information about the uploaded file where we can get
+ # at it later.
+ # Use the typeglob as the key, as this is guaranteed to be
+ # unique for each filehandle. Don't use the file descriptor as
+ # this will be re-used for each filehandle if the
+ # close_upload_files feature is used.
+ $self->{'.tmpfiles'}->{$$filehandle}= {
+ hndl => $filehandle,
+ name => $tmpfile,
+ info => {%header},
+ };
+ push(@{$self->{param}{$param}},$filehandle);
+ }
+ }
+ return $returnvalue;
+}
+END_OF_FUNC
+
+
'upload' =><<'END_OF_FUNC',
sub upload {
my($self,$param_name) = self_or_default(@_);
- my @param = grep(ref && fileno($_), $self->param($param_name));
+ my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
return unless @param;
return wantarray ? @param : $param[0];
}
'tmpFileName' => <<'END_OF_FUNC',
sub tmpFileName {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
- $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
+ return $self->{'.tmpfiles'}->{$$filename}->{name} ?
+ $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
: '';
}
END_OF_FUNC
'uploadInfo' => <<'END_OF_FUNC',
sub uploadInfo {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
+ return $self->{'.tmpfiles'}->{$$filename}->{info};
}
END_OF_FUNC
my($element, $attributes) = @_;
return '' unless defined($attributes->{$element});
$attribs = ' ';
- foreach my $attrib (keys %{$attributes->{$element}}) {
+ for my $attrib (keys %{$attributes->{$element}}) {
(my $clean_attrib = $attrib) =~ s/^-//;
$attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
}
'_compile_all' => <<'END_OF_FUNC',
sub _compile_all {
- foreach (@_) {
+ for (@_) {
next if defined(&$_);
$AUTOLOAD = "CGI::$_";
_compile();
################### Fh -- lightweight filehandle ###############
package Fh;
+
use overload
'""' => \&asString,
'cmp' => \&compare,
(my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
my $fv = ++$FH . $safename;
my $ref = \*{"Fh::$fv"};
- $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+ $file =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\~-]+)$! || return;
my $safe = $1;
sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
unlink($safe) if $delete;
}
END_OF_FUNC
+'handle' => <<'END_OF_FUNC',
+sub handle {
+ my $self = shift;
+ eval "require IO::Handle" unless IO::Handle->can('new_from_fd');
+ return IO::Handle->new_from_fd(fileno $self,"<");
+}
+END_OF_FUNC
+
);
END_OF_AUTOLOAD
}
my $self = {LENGTH=>$length,
- CHUNKED=>!defined $length,
+ CHUNKED=>!$length,
BOUNDARY=>$boundary,
INTERFACE=>$interface,
BUFFER=>'',
package CGITempFile;
sub find_tempdir {
- undef $TMPDIRECTORY;
$SL = $CGI::SL;
$MAC = $CGI::OS eq 'MACINTOSH';
my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
- unless ($TMPDIRECTORY) {
+ unless (defined $TMPDIRECTORY) {
@TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
"C:${SL}temp","${SL}tmp","${SL}temp",
"${vol}${SL}Temporary Items",
"${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
"C:${SL}system${SL}temp");
+
+ if( $CGI::OS eq 'WINDOWS' ){
+ unshift @TEMP,
+ $ENV{TEMP},
+ $ENV{TMP},
+ $ENV{WINDIR} . $SL . 'TEMP';
+ }
+
unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
# this feature was supposed to provide per-user tmpfiles, but
# : 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) {
+ for (@TEMP) {
do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
}
}
sub DESTROY {
my($self) = @_;
- $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+ $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\~-]+)$! || return;
my $safe = $1; # untaint operation
unlink $safe; # get rid of the file
}
my $filename;
find_tempdir() unless -w $TMPDIRECTORY;
for (my $i = 0; $i < $MAXTRIES; $i++) {
- last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
+ last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
}
# check that it is a more-or-less valid filename
- return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!;
+ return unless $filename =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\~-]+)$!;
# this used to untaint, now it doesn't
# $filename = $1;
return bless \$filename;
=head1 NAME
-CGI - Simple Common Gateway Interface Class
+CGI - Handle Common Gateway Interface requests and responses
=head1 SYNOPSIS
- # CGI script that creates a fill-out form
- # and echoes back its values.
-
- use CGI qw/:standard/;
- print header,
- start_html('A Simple Example'),
- h1('A Simple Example'),
- start_form,
- "What's your name? ",textfield('name'),p,
- "What's the combination?", p,
- checkbox_group(-name=>'words',
- -values=>['eenie','meenie','minie','moe'],
- -defaults=>['eenie','minie']), p,
- "What's your favorite color? ",
- popup_menu(-name=>'color',
- -values=>['red','green','blue','chartreuse']),p,
- submit,
- end_form,
- hr;
-
- if (param()) {
- print "Your name is",em(param('name')),p,
- "The keywords are: ",em(join(", ",param('words'))),p,
- "Your favorite color is ",em(param('color')),
- hr;
- }
+ use CGI;
-=head1 ABSTRACT
+ my $q = CGI->new;
-This perl library uses perl5 objects to make it easy to create Web
-fill-out forms and parse their contents. This package defines CGI
-objects, entities that contain the values of the current query string
-and other state variables. Using a CGI object's methods, you can
-examine keywords and parameters passed to your script, and create
-forms whose initial values are taken from the current query (thereby
-preserving state information). The module provides shortcut functions
-that produce boilerplate HTML, reducing typing and coding errors. It
-also provides functionality for some of the more advanced features of
-CGI scripting, including support for file uploads, cookies, cascading
-style sheets, server push, and frames.
+ # Process an HTTP request
+ @values = $q->param('form_field');
-CGI.pm also provides a simple function-oriented programming style for
-those who don't need its object-oriented features.
+ $fh = $q->upload('file_field');
-The current version of CGI.pm is available at
+ $riddle = $query->cookie('riddle_name');
+ %answers = $query->cookie('answers');
- http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
- ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+ # Prepare various HTTP responses
+ print $q->header();
+ print $q->header('application/json');
+
+ $cookie1 = $q->cookie(-name=>'riddle_name', -value=>"The Sphynx's Question");
+ $cookie2 = $q->cookie(-name=>'answers', -value=>\%answers);
+ print $q->header(
+ -type => 'image/gif',
+ -expires => '+3d',
+ -cookie => [$cookie1,$cookie2]
+ );
+
+ print $q->redirect('http://somewhere.else/in/movie/land');
=head1 DESCRIPTION
+CGI.pm is a stable, complete and mature solution for processing and preparing
+HTTP requests and responses. Major features including processing form
+submissions, file uploads, reading and writing cookies, query string generation
+and manipulation, and processing and preparing HTTP headers. Some HTML
+generation utilities are included as well.
+
+CGI.pm performs very well in in a vanilla CGI.pm environment and also comes
+with built-in support for mod_perl and mod_perl2 as well as FastCGI.
+
+It has the benefit of having developed and refined over 10 years with input
+from dozens of contributors and being deployed on thousands of websites.
+CGI.pm has been included in the Perl distribution since Perl 5.4, and has
+become a de-facto standard.
+
=head2 PROGRAMMING STYLE
There are two styles of programming with CGI.pm, an object-oriented
$query = new CGI;
This will parse the input (from both POST and GET methods) and store
-it into a perl5 object called $query.
+it into a perl5 object called $query.
+
+Any filehandles from file uploads will have their position reset to
+the beginning of the file.
=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
restore_parameters(IN);
close IN;
-You can also initialize the query object from an associative array
+You can also initialize the query object from a hash
reference:
$query = new CGI( {'dinosaur'=>'barney',
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.
+"name1=&name2=", it will be returned as an empty string.
If the parameter does not exist at all, then param() will return undef
Use Delete_all() instead if you are using the function call interface.
+=head2 HANDLING NON-URLENCODED ARGUMENTS
+
+
+If POSTed data is not of type application/x-www-form-urlencoded or
+multipart/form-data, then the POSTed data will not be processed, but
+instead be returned as-is in a parameter named POSTDATA. To retrieve
+it, use code like this:
+
+ my $data = $query->param('POSTDATA');
+
+Likewise if PUTed data can be retrieved with code like this:
+
+ my $data = $query->param('PUTDATA');
+
+(If you don't know what the preceding means, don't worry about it. It
+only affects people trying to use CGI for XML processing and other
+specialized tasks.)
+
+
=head2 DIRECT ACCESS TO THE PARAMETER LIST:
$q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
open (OUT,">>test.out") || die;
$records = 5;
- foreach (0..$records) {
+ for (0..$records) {
my $q = new CGI;
$q->param(-name=>'counter',-value=>$_);
$q->save(\*OUT);
This causes the indicated autoloaded methods to be compiled up front,
rather than deferred to later. This is useful for scripts that run
for an extended period of time under FastCGI or mod_perl, and for
-those destined to be crunched by Malcom Beattie's Perl compiler. Use
+those destined to be crunched by Malcolm Beattie's Perl compiler. Use
it in conjunction with the methods or method families you plan to use.
use CGI qw(-compile :standard :html3);
this behavior. You can also selectively change the sticky behavior in
each element that you generate.
+=item -tabindex
+
+Automatically add tab index attributes to each form field. With this
+option turned off, you can still add tab indexes manually by passing a
+-tabindex option to each field-generating method.
+
=item -no_undef_params
This keeps CGI.pm from including undef params in the parameter list.
XHTML will automatically be disabled without needing to use this
pragma.
+=item -utf8
+
+This makes CGI.pm treat all parameters as UTF-8 strings. Use this with
+care, as it will interfere with the processing of binary uploads. It
+is better to manually select which fields are expected to return utf-8
+strings and convert them using code like this:
+
+ use Encode;
+ my $arg = decode utf8=>param('foo');
+
=item -nph
This makes CGI.pm produce a header appropriate for an NPH (no
All relative links will be interpreted relative to this tag.
You add arbitrary meta information to the header with the B<-meta>
-argument. This argument expects a reference to an associative array
+argument. This argument expects a reference to a hash
containing name/value pairs of meta information. These will be turned
into a series of header <meta> tags that look something like this:
browsers that do not have JavaScript (or browsers where JavaScript is turned
off).
-Netscape 3.0 recognizes several attributes of the <script> tag,
-including LANGUAGE and SRC. The latter is particularly interesting,
-as it allows you to keep the JavaScript code in a file or CGI script
-rather than cluttering up each page with the source. To use these
-attributes pass a HASH reference in the B<-script> parameter containing
-one or more of -language, -src, or -code:
+The <script> tag, has several attributes including "type" and src.
+The latter is particularly interesting, as it allows you to keep the
+JavaScript code in a file or CGI script rather than cluttering up each
+page with the source. To use these attributes pass a HASH reference
+in the B<-script> parameter containing one or more of -type, -src, or
+-code:
print $q->start_html(-title=>'The Riddle of the Sphinx',
- -script=>{-language=>'JAVASCRIPT',
+ -script=>{-type=>'JAVASCRIPT',
-src=>'/javascript/sphinx.js'}
);
print $q->(-title=>'The Riddle of the Sphinx',
- -script=>{-language=>'PERLSCRIPT',
+ -script=>{-type=>'PERLSCRIPT',
-code=>'print "hello world!\n;"'}
);
A final feature allows you to incorporate multiple <script> sections into the
header. Just pass the list of script sections as an array reference.
this allows you to specify different source files for different dialects
-of JavaScript. Example:
+of JavaScript. Example:
print $q->start_html(-title=>'The Riddle of the Sphinx',
-script=>[
- { -language => 'JavaScript1.0',
+ { -type => 'text/javascript',
-src => '/javascript/utilities10.js'
},
- { -language => 'JavaScript1.1',
+ { -type => 'text/javascript',
-src => '/javascript/utilities11.js'
},
- { -language => 'JavaScript1.2',
+ { -type => 'text/jscript',
-src => '/javascript/utilities12.js'
},
- { -language => 'JavaScript28.2',
+ { -type => 'text/ecmascript',
-src => '/javascript/utilities219.js'
}
]
);
-If this looks a bit extreme, take my advice and stick with straight CGI scripting.
-
-See
-
- http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
-
-for more information about JavaScript.
+The option "-language" is a synonym for -type, and is supported for
+backwad compatibility.
The old-style positional parameters are as follows:
Generate just the protocol and net location, as in http://www.foo.com:8000
+=item B<-rewrite>
+
+If Apache's mod_rewrite is turned on, then the script name and path
+info probably won't match the request that the user sent. Set
+-rewrite=>1 (default) to return URLs that match what the user sent
+(the original request URI). Set -rewrite=>0 to return URLs that match
+the URL after mod_rewrite's rules have run. Because the additional
+path information only makes sense in the context of the rewritten URL,
+-rewrite is set to false when you request path info in the URL.
+
=back
=head2 MIXING POST AND URL PARAMETERS
print h1("Chapter","1"); # <h1>Chapter 1</h1>"
-If the first argument is an associative array reference, then the keys
-and values of the associative array become the HTML tag's attributes:
+If the first argument is a hash reference, then the keys
+and values of the hash become the HTML tag's attributes:
print a({-href=>'fred.html',-target=>'_new'},
"Open a new frame");
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.
+filehandle-like object, or undef if the parameter is not a valid
+filehandle.
$fh = upload('uploaded_file');
while (<$fh>) {
print;
}
-In an list context, upload() will return an array of filehandles.
+In a list 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.
+The lightweight filehandle returned by CGI.pm is not compatible with
+IO::Handle; for example, it does not have read() or getline()
+functions, but instead must be manipulated using read($fh) or
+<$fh>. To get a compatible IO::Handle object, call the handle's
+handle() method:
+
+ my $real_io_handle = upload('uploaded_file')->handle;
+
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
other information as well (such as modification date and size). To
retrieve this information, call uploadInfo(). It returns a reference to
-an associative array containing all the document headers.
+a hash containing all the document headers.
$filename = param('uploaded_file');
$type = uploadInfo($filename)->{'Content-Type'};
that the first argument to the callback is an Apache::Upload object,
here it's the remote filename.
- $q = CGI->new();
- $q->upload_hook(\&hook,$data);
+ $q = CGI->new(\&hook [,$data [,$use_tempfile]]);
sub hook
{
print "Read $bytes_read bytes of $filename\n";
}
+The $data field is optional; it lets you pass configuration
+information (e.g. a database handle) to your hook callback.
+
+The $use_tempfile field is a flag that lets you turn on and off
+CGI.pm's use of a temporary disk-based file during file upload. If you
+set this to a FALSE value (default true) then param('uploaded_file')
+will no longer work, and the only way to get at the uploaded data is
+via the hook you provide.
+
If using the function-oriented interface, call the CGI::upload_hook()
method before calling param() or any other CGI functions:
- CGI::upload_hook(\&hook,$data);
+ CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
This method is not exported by default. You will have to import it
explicitly if you wish to use it without the CGI:: prefix.
print popup_menu(-name=>'menu_name',
-values=>['eenie','meenie','minie'],
- -default=>'meenie',
+ -default=>['meenie','minie'],
-labels=>\%labels,
-attributes=>\%attributes);
The optional third parameter (-default) is the name of the default
menu choice. If not specified, the first item will be the default.
-The values of the previous choice will be maintained across queries.
+The values of the previous choice will be maintained across
+queries. Pass an array reference to select multiple defaults.
=item 4.
The optional fourth parameter (-labels) is provided for people who
want to use different values for the user-visible label inside the
popup menu and the value returned to your script. It's a pointer to an
-associative array relating menu values to user-visible labels. If you
+hash relating menu values to user-visible labels. If you
leave this parameter blank, the menu values will be displayed by
default. (You can also leave a label undefined if you want to).
The optional fifth parameter (-attributes) is provided to assign
any of the common HTML attributes to an individual menu item. It's
-a pointer to an associative array relating menu values to another
-associative array with the attribute's name as the key and the
+a pointer to a hash relating menu values to another
+hash with the attribute's name as the key and the
attribute's value as the value.
=back
=item 3.
The optional third parameter (B<-labels>) allows you to pass a reference
-to an associative array containing user-visible labels for one or more
+to a hash containing user-visible labels for one or more
of the menu items. You can use this when you want the user to see one
menu string, but have the browser return your program a different one.
If you don't specify this, the value string will be used instead
An optional sixth parameter (-attributes) is provided to assign
any of the common HTML attributes to an individual menu item. It's
-a pointer to an associative array relating menu values to another
-associative array with the attribute's name as the key and the
+a pointer to a hash relating menu values to another
+hash with the attribute's name as the key and the
attribute's value as the value.
=back
=item 5.
-The optional sixth argument is a pointer to an associative array
+The optional sixth argument is a pointer to a hash
containing long user-visible labels for the list items (-labels).
If not provided, the values will be displayed.
The optional sixth parameter (-attributes) is provided to assign
any of the common HTML attributes to an individual menu item. It's
-a pointer to an associative array relating menu values to another
-associative array with the attribute's name as the key and the
+a pointer to a hash relating menu values to another
+hash with the attribute's name as the key and the
attribute's value as the value.
When this form is processed, all selected list items will be returned as
-values=>['eenie','meenie','minie','moe'],
-default=>['eenie','moe'],
-linebreak=>'true',
+ -disabled => ['moe'],
-labels=>\%labels,
-attributes=>\%attributes);
=back
-The optional b<-labels> argument is a pointer to an associative array
+The optional B<-labels> argument is a pointer to a hash
relating the checkbox values to the user-visible labels that will be
printed next to them. If not provided, the values will be used as the
default.
-Modern browsers can take advantage of the optional parameters
-B<-rows>, and B<-columns>. These parameters cause checkbox_group() to
-return an HTML3 compatible table containing the checkbox group
-formatted with the specified number of rows and columns. You can
-provide just the -columns parameter if you wish; checkbox_group will
-calculate the correct number of rows for you.
+The optional parameters B<-rows>, and B<-columns> cause
+checkbox_group() to return an HTML3 compatible table containing the
+checkbox group formatted with the specified number of rows and
+columns. You can provide just the -columns parameter if you wish;
+checkbox_group will calculate the correct number of rows for you.
+The option B<-disabled> takes an array of checkbox values and disables
+them by greying them out (this may not be supported by all browsers).
The optional B<-attributes> argument is provided to assign any of the
common HTML attributes to an individual menu item. It's a pointer to
-an associative array relating menu values to another associative array
+a hash relating menu values to another hash
with the attribute's name as the key and the attribute's value as the
value.
-tabindex => ['moe','minie','eenie','meenie'] # tab in this order
-tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
When the form is processed, all checked boxes will be returned as
a list under the parameter name 'group_name'. The values of the
"on" checkboxes can be retrieved with:
correct number of rows for you.
To include row and column headings in the returned table, you
-can use the B<-rowheader> and B<-colheader> parameters. Both
+can use the B<-rowheaders> and B<-colheaders> parameters. Both
of these accept a pointer to an array of headings to use.
The headings are just decorative. They don't reorganize the
interpretation of the radio buttons -- they're still a single named
The optional B<-attributes> argument is provided to assign any of the
common HTML attributes to an individual menu item. It's a pointer to
-an associative array relating menu values to another associative array
+a hash relating menu values to another hash
with the attribute's name as the key and the attribute's value as the
value.
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
When the form is processed, the selected radio button can
be retrieved using:
button() produces a button that is compatible with Netscape 2.0's
JavaScript. When it's pressed the fragment of JavaScript code
-pointed to by the B<-onClick> parameter will be executed. On
-non-Netscape browsers this form element will probably not even
-display.
+pointed to by the B<-onClick> parameter will be executed.
=head1 HTTP 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.
+Browsers 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
=item B<-value>
The value of the cookie. This can be any scalar value,
-array reference, or even associative array reference. For example,
-you can store an entire associative array into a cookie this way:
+array reference, or even hash reference. For example,
+you can store an entire hash into a cookie this way:
$cookie=cookie(-name=>'family information',
-value=>\%childrens_ages);
The cookie created by cookie() must be incorporated into the HTTP
header within the string returned by the header() method:
+ use CGI ':standard';
print header(-cookie=>$my_cookie);
To create multiple cookies, give header() an array reference:
print header(-cookie=>[$cookie1,$cookie2]);
To retrieve a cookie, request it by name by calling cookie() method
-without the B<-value> parameter:
+without the B<-value> parameter. This example uses the object-oriented
+form:
use CGI;
$query = new CGI;
- $riddle = cookie('riddle_name');
- %answers = cookie('answers');
+ $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
# vice-versa
param(-name=>'answers',-value=>[cookie('answers')]);
+If you call cookie() without any parameters, it will return a list of
+the names of all cookies passed to your script:
+
+ @cookies = cookie();
+
See the B<cookie.cgi> example script for some ideas on how to use
cookies effectively.
in CGI.pm, but the HTML is very simple to write. See the frame
documentation in Netscape's home pages for details
- http://home.netscape.com/assist/net_sites/frames.html
+ http://wp.netscape.com/assist/net_sites/frames.html
=item 2. Specify the destination for the document in the HTTP header
=head1 SUPPORT FOR JAVASCRIPT
-Netscape versions 2.0 and higher incorporate an interpreted language
-called JavaScript. Internet Explorer, 3.0 and higher, supports a
-closely-related dialect called JScript. JavaScript isn't the same as
-Java, and certainly isn't at all the same as Perl, which is a great
-pity. JavaScript allows you to programmatically change the contents of
-fill-out forms, create new windows, and pop up dialog box from within
-Netscape itself. From the point of view of CGI scripting, JavaScript
-is quite useful for validating fill-out forms prior to submitting
-them.
-
-You'll need to know JavaScript in order to use it. There are many good
-sources in bookstores and on the web.
-
The usual way to use JavaScript is to define a set of functions in a
<SCRIPT> block inside the HTML header and then to register event
handlers in the various elements of the page. Events include such
arbitrary formatting in the header, you may pass a -verbatim tag to
the -style hash, as follows:
-print start_html (-STYLE => {-verbatim => '@import
-url("/server-common/css/'.$cssFile.'");',
- -src => '/server-common/css/core.css'});
-</blockquote></pre>
+print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");',
+ -src => '/server-common/css/core.css'});
This will generate an HTML header that contains this:
Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
print start_html({-head=>\@h})
+To create primary and "alternate" stylesheet, use the B<-alternate> option:
+
+ start_html(-style=>{-src=>[
+ {-src=>'/styles/print.css'},
+ {-src=>'/styles/alt.css',-alternate=>1}
+ ]
+ });
+
=head1 DEBUGGING
If you are running the script from the command line or in the perl
=item B<raw_cookie()>
-Returns the HTTP_COOKIE variable, an HTTP extension implemented by
-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.
+Returns the HTTP_COOKIE variable. 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
Returns the HTTP_USER_AGENT variable. If you give
this method a single argument, it will attempt to
pattern match on it, allowing you to do something
-like user_agent(netscape);
+like user_agent(Mozilla);
=item B<path_info()>
do this manually, although it won't hurt anything if you do. However,
note that if you have applied Service Pack 6, much of the
functionality of NPH scripts, including the ability to redirect while
-setting a cookie, b<do not work at all> on IIS without a special patch
+setting a cookie, B<do not work at all> on IIS without a special patch
from Microsoft. See
http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
Non-Parsed Headers Stripped From CGI Applications That Have nph-
use CGI qw/:push -nph/;
$| = 1;
print multipart_init(-boundary=>'----here we go!');
- foreach (0 .. 4) {
+ for (0 .. 4) {
print multipart_start(-type=>'text/plain'),
"The current time is ",scalar(localtime),"\n";
if ($_ < 4) {
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
compatibility routine "ReadParse" is provided. Porting is simple:
OLD VERSION
-
require "cgi-lib.pl";
&ReadParse;
print "The value of the antique is $in{antique}.\n";
NEW VERSION
-
use CGI;
CGI::ReadParse();
print "The value of the antique is $in{antique}.\n";
=head1 AUTHOR INFORMATION
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+The GD.pm interface is copyright 1995-2007, Lincoln D. Stein. It is
+distributed under GPL and the Artistic License 2.0.
Address bug reports and comments to: lstein@cshl.org. When sending
bug reports, please provide the version of CGI.pm, the version of
print "<h2>Here are the current settings in this form</h2>";
- foreach $key (param) {
+ for $key (param) {
print "<strong>$key</strong> -> ";
@values = param($key);
print join(", ",@values),"<br>\n";
projects / p5sagit/p5-mst-13.2.git / blobdiff