# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.145 2003/12/10 15:16:08 lstein Exp $';
-$CGI::VERSION=3.01;
+$CGI::revision = '$Id: CGI.pm,v 1.165 2004/04/12 20:37:26 lstein Exp $';
+$CGI::VERSION=3.05;
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
$TAINTED = substr("$0$^X",0,0);
}
-my @SAVED_SYMBOLS;
-
$MOD_PERL = 0; # no mod_perl by default
+@SAVED_SYMBOLS = ();
# >>>>> Here are some globals that you might want to adjust <<<<<<
sub initialize_globals {
# Other globals that you shouldn't worry about.
undef $Q;
$BEEN_THERE = 0;
+ $DTD_PUBLIC_IDENTIFIER = "";
undef @QUERY_PARAM;
undef %EXPORT;
undef $QUERY_CHARSET;
# ------------------ START OF THE LIBRARY ------------
+*end_form = \&endform;
+
# make mod_perlhappy
initialize_globals();
if (defined $mod_perl::VERSION) {
if ($mod_perl::VERSION >= 1.99) {
$MOD_PERL = 2;
+ require Apache::Response;
require Apache::RequestRec;
require Apache::RequestUtil;
require APR::Pool;
)) {
$self->r(shift @initializer);
}
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'CODE'))) {
+ $self->upload_hook(shift @initializer, shift @initializer);
+ }
if ($MOD_PERL) {
$self->r(Apache->request) unless $self->r;
my $r = $self->r;
# Special case. Erase everything if there is a field named
# .defaults.
if ($self->param('.defaults')) {
- undef %{$self};
+ $self->delete_all();
}
# Associative array containing our defined fieldnames
$XHTML=0, next if /^[:-]no_?xhtml$/;
$USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
$PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
- $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
+ $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
$EXPORT{$_}++, next if /^[:-]any$/;
$compile++, next if /^[:-]compile$/;
$NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
$to_delete{$name}++;
}
@{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
- return wantarray ? () : undef;
+ return;
}
END_OF_FUNC
$self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
$type = SERVER_PUSH($boundary);
return $self->header(
- -nph => 1,
+ -nph => 0,
-type => $type,
(map { split "=", $_, 2 } @other),
) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
'redirect' => <<'END_OF_FUNC',
sub redirect {
my($self,@p) = self_or_default(@_);
- my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,['COOKIE','COOKIES'],NPH],@p);
+ my($url,$target,$status,$cookie,$nph,@other) =
+ rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
+ $status = '302 Moved' unless defined $status;
$url ||= $self->self_url;
my(@o);
foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
- '-Status' => '302 Moved',
+ '-Status' => $status,
'-Location'=> $url,
'-nph' => $nph);
unshift(@o,'-Target'=>$target) if $target;
$encoding = 'iso-8859-1' unless defined $encoding;
- # 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);
- $lang = 'en-US' unless defined $lang;
+ # Need to sort out the DTD before it's okay to call escapeHTML().
my(@result,$xml_dtd);
if ($dtd) {
if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
if (ref($dtd) && ref($dtd) eq 'ARRAY') {
push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
} else {
push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd;
+ }
+
+ # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
+ # call escapeHTML(). 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);
+
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
+ $lang = "" unless defined $lang;
+ $XHTML = 0;
+ }
+ else {
+ $lang = 'en-US' unless defined $lang;
}
+
push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang" xml:lang="$lang"><head><title>$title</title>)
: ($lang ? qq(<html lang="$lang">) : "<html>")
. "<head><title>$title</title>");
push(@result,ref($head) ? @$head : $head) if $head;
# handle the infrequently-used -style and -script parameters
- push(@result,$self->_style($style)) if defined $style;
+ push(@result,$self->_style($style)) if defined $style;
push(@result,$self->_script($script)) if defined $script;
# handle -noscript parameter
my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
- if (ref($style)) {
- my($src,$code,$verbatim,$stype,$foo,@other) =
- rearrange([SRC,CODE,VERBATIM,TYPE],
- '-foo'=>'bar', # trick to allow dash to be omitted
- ref($style) eq 'ARRAY' ? @$style : %$style);
- $type = $stype if $stype;
- my $other = @other ? join ' ',@other : '';
-
- if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
- { # If it is, push a LINK tag for each one
- foreach $src (@$src)
- {
- push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+ my @s = ref($style) eq 'ARRAY' ? @$style : $style;
+
+ for my $s (@s) {
+ if (ref($s)) {
+ my($src,$code,$verbatim,$stype,$foo,@other) =
+ rearrange([qw(SRC CODE VERBATIM TYPE FOO)],
+ ('-foo'=>'bar',
+ ref($s) eq 'ARRAY' ? @$s : %$s));
+ $type = $stype if $stype;
+ my $other = @other ? join ' ',@other : '';
+
+ if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
+ { # If it is, push a LINK tag for each one
+ foreach $src (@$src)
+ {
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
: qq(<link rel="stylesheet" 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>)
- ) if $src;
- }
- if ($verbatim) {
- push(@result, "<style type=\"text/css\">\n$verbatim\n</style>");
- }
- push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
- } else {
- my $src = $style;
+ 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>));
+ : qq(<link rel="stylesheet" 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;
+ }
+ my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
+ push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c;
+
+ } else {
+ my $src = $s;
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+ : qq(<link rel="stylesheet" type="$type" href="$src"$other>));
+ }
}
@result;
}
my($method,$action,$enctype,@other) =
rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = lc($method) || 'post';
- $enctype = $enctype || &URL_ENCODED;
- unless (defined $action) {
-
+ $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 (length($ENV{QUERY_STRING})>0) {
+ if (exists $ENV{QUERY_STRING} && length($ENV{QUERY_STRING})>0) {
$action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1);
}
}
END_OF_FUNC
-#### Method: end_form
-# synonym for endform
-'end_form' => <<'END_OF_FUNC',
-sub end_form {
- &endform;
-}
-END_OF_FUNC
-
-
'_textfield' => <<'END_OF_FUNC',
sub _textfield {
my($self,$tag,@p) = self_or_default(@_);
$label=$self->escapeHTML($label);
$value=$self->escapeHTML($value,1);
- my($name) = ' name=".submit"' unless $NOSTICKY;
+ my $name = $NOSTICKY ? '' : ' name=".submit"';
$name = qq/ name="$label"/ if defined($label);
$value = defined($value) ? $value : $label;
my $val = '';
: qq/<input type="checkbox" name="$name" value="$_"$checked$other$attribs>${label}${break}/);
}
$self->register_parameter($name);
- return wantarray ? @elements : join(' ',@elements)
+ return wantarray ? @elements : join(' ',@elements)
unless defined($columns) || defined($rows);
$rows = 1 if $rows && $rows < 1;
$cols = 1 if $cols && $cols < 1;
$toencode =~ s{&}{&}gso;
$toencode =~ s{<}{<}gso;
$toencode =~ s{>}{>}gso;
- $toencode =~ s{"}{"}gso;
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
+ # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
+ # <http://validator.w3.org/docs/errors.html#bad-entity> /
+ # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
+ $toencode =~ s{"}{"}gso;
+ }
+ else {
+ $toencode =~ s{"}{"}gso;
+ }
my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
uc $self->{'.charset'} eq 'WINDOWS-1252';
if ($latin) { # bug in some browsers
# unescape HTML -- used internally
'unescapeHTML' => <<'END_OF_FUNC',
sub unescapeHTML {
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
my ($self,$string) = CGI::self_or_default(@_);
return undef unless defined($string);
my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
$name=$self->escapeHTML($name);
foreach (@value) {
$_ = defined($_) ? $self->escapeHTML($_,1) : '';
- push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" />)
- : qq(<input type="hidden" name="$name" value="$_">);
+ push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
+ : qq(<input type="hidden" name="$name" value="$_" @other>);
}
return wantarray ? @result : join('',@result);
}
if (exists($ENV{REQUEST_URI})) {
my $index;
$script_name = unescape($ENV{REQUEST_URI});
- $script_name =~ s/\?.+$//; # strip query string
+ $script_name =~ s/\?.+$//s; # strip query string
# and path
if (exists($ENV{PATH_INFO})) {
- my $encoded_path = quotemeta($ENV{PATH_INFO});
- $script_name =~ s/$encoded_path$//i;
+ my $encoded_path = unescape($ENV{PATH_INFO});
+ $script_name =~ s/\Q$encoded_path\E$//i;
}
}
if ($full) {
my $protocol = $self->protocol();
$url = "$protocol://";
- my $vh = http('host');
+ my $vh = http('x_forwarded_host') || http('host');
if ($vh) {
$url .= $vh;
} else {
######
'virtual_host' => <<'END_OF_FUNC',
sub virtual_host {
- my $vh = http('host') || server_name();
+ my $vh = http('x_forwarded_host') || http('host') || server_name();
$vh =~ s/:\d+$//; # get rid of port number
return $vh;
}
'virtual_port' => <<'END_OF_FUNC',
sub virtual_port {
my($self) = self_or_default(@_);
- my $vh = $self->http('host');
+ my $vh = $self->http('x_forwarded_host') || $self->http('host');
if ($vh) {
return ($vh =~ /:(\d+)$/)[0] || '80';
} else {
return;
}
- my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
+ my($param)= $header{'Content-Disposition'}=~/ name="([^;]*)"/;
$param .= $TAINTED;
# Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
+ my($filename) = $header{'Content-Disposition'}=~/ filename="([^;]*)"/;
# Test for Opera's multiple upload feature
my($multipart) = ( defined( $header{'Content-Type'} ) &&
$header{'Content-Type'} =~ /multipart\/mixed/ ) ?
return '' unless defined($attributes->{$element});
$attribs = ' ';
foreach my $attrib (keys %{$attributes->{$element}}) {
- $attrib =~ s/^-//;
- $attribs .= "@{[lc($attrib)]}=\"$attributes->{$element}{$attrib}\" ";
+ (my $clean_attrib = $attrib) =~ s/^-//;
+ $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
}
$attribs =~ s/ $//;
return $attribs;
feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
feature.
+If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD,
+XHTML will automatically be disabled without needing to use this
+pragma.
+
=item -nph
This makes CGI.pm produce a header appropriate for an NPH (no
You can also use named arguments:
print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
- -nph=>1);
+ -nph=>1,
+ -status=>301);
The B<-nph> parameter, if set to a true value, will issue the correct
headers to work with a NPH (no-parse-header) script. This is important
to use with certain servers, such as Microsoft IIS, which
expect all their scripts to be NPH.
+The B<-status> parameter will set the status of the redirect. HTTP
+defines three different possible redirection status codes:
+
+ 301 Moved Permanently
+ 302 Found
+ 303 See Other
+
+The default if not specified is 302, which means "moved temporarily."
+You may change the status to another status code if you wish. Be
+advised that changing the status to anything other than 301, 302 or
+303 will probably break redirection.
+
=head2 CREATING THE HTML DOCUMENT HEADER
print $query->start_html(-title=>'Secrets of the Pyramids',
information.
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 <html> tag. For example:
print $q->start_html(-lang=>'fr-CA');
-To leave off the lang attribute, as you must do if you want to generate
-legal HTML 3.2 or earlier, pass the empty string (-lang=>'').
+The default if not specified is "en-US" for US English, unless the
+-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
+lang attribute is left off. You can force the lang attribute to left
+off in other cases by passing an empty string (-lang=>'').
The B<-encoding> argument can be used to specify the character set for
XHTML. It defaults to iso-8859-1 if not specified.
$query = new CGI;
$query->autoEscape(undef);
+I<A Lurking Trap!> Some of the form-element generating methods return
+multiple tags. In a scalar context, the tags will be concatenated
+together with spaces, or whatever is the current value of the $"
+global. In a list context, the methods will return a list of
+elements, allowing you to modify them if you wish. Usually you will
+not notice this behavior, but beware of this:
+
+ printf("%s\n",$query->end_form())
+
+end_form() produces several tags, and only the first of them will be
+printed because the format only expects one value.
+
+<p>
+
+
=head2 CREATING AN ISINDEX TAG
print $query->isindex(-action=>$action);
print;
}
-In an array context, upload() will return an array of filehandles.
+In an 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.
The first argument (-name) is optional. You can give the button a
name if you have several submission buttons in your form and you want
-to distinguish between them. The name will also be used as the
-user-visible label. Be aware that a few older browsers don't deal with this correctly and
-B<never> send back a value from a button.
+to distinguish between them.
=item 2.
The second argument (-value) is also optional. This gives the button
-a value that will be passed to your script in the query string.
+a value that will be passed to your script in the query string. The
+name will also be used as the user-visible label.
+
+=item 3.
+
+You can use -label as an alias for -value. I always get confused
+about which of -name and -value changes the user-visible label on the
+button.
=back
);
print end_html;
-Pass an array reference to B<-style> in order to incorporate multiple
-stylesheets into your document.
+Pass an array reference to B<-code> or B<-src> in order to incorporate
+multiple stylesheets into your document.
Should you wish to incorporate a verbatim stylesheet that includes
arbitrary formatting in the header, you may pass a -verbatim tag to
NEW VERSION
use CGI;
- CGI::ReadParse
+ CGI::ReadParse;
print "The value of the antique is $in{antique}.\n";
CGI.pm's ReadParse() routine creates a tied variable named %in,
https://perl5.git.perl.org / perl5.git / blobdiff