CGI
view release on metacpan or search on metacpan
package CGI;
require 5.008001;
use Carp 'croak';
use URI;
my $appease_cpants_kwalitee = q/
use strict;
use warnings;
#/;
$CGI::VERSION='4.72';
use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
$_XHTML_DTD = ['-//W3C//DTD XHTML 1.0 Transitional//EN',
'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
{
local $^W = 0;
$TAINTED = substr("$0$^X",0,0);
}
$MOD_PERL = 0; # no mod_perl by default
#global settings
$POST_MAX = -1; # no limit to uploaded files
$DISABLE_UPLOADS = 0;
$UNLINK_TMP_FILES = 1;
$LIST_CONTEXT_WARN = 1;
$ENCODE_ENTITIES = q{&<>"'};
$ALLOW_DELETE_CONTENT = 0;
$COOKIE_CACHE = 0; # backcompat: cache was broken for years
@SAVED_SYMBOLS = ();
# >>>>> Here are some globals that you might want to adjust <<<<<<
sub initialize_globals {
# Set this to 1 to generate XTML-compatible output
$XHTML = 1;
# Change this to the preferred DTD to print in start_html()
# or use default_dtd('text of DTD to use');
$DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
'http://www.w3.org/TR/html4/loose.dtd' ] ;
# Set this to 1 to enable NOSTICKY scripts
# or:
# 1) use CGI '-nosticky';
# 2) $CGI::NOSTICKY = 1;
$NOSTICKY = 0;
# Set this to 1 to enable NPH scripts
# or:
# 1) use CGI qw(-nph)
# 2) CGI::nph(1)
# 3) print header(-nph=>1)
$NPH = 0;
# Set this to 1 to enable debugging from @ARGV
# Set to 2 to enable debugging from STDIN
$DEBUG = 1;
# Set this to 1 to generate automatic tab indexes
$TABINDEX = 0;
# Set this to 1 to cause files uploaded in multipart documents
# to be closed, instead of caching the file handle
# or:
# 1) use CGI qw(:close_upload_files)
# 2) $CGI::close_upload_files(1);
# Uploads with many files run out of file handles.
# Also, for performance, since the file is already on disk,
# it can just be renamed, instead of read and written.
$CLOSE_UPLOAD_FILES = 0;
# Automatically determined -- don't change
$EBCDIC = 0;
# Change this to 1 to suppress redundant HTTP headers
$HEADERS_ONCE = 0;
# separate the name=value pairs by semicolons rather than ampersands
$USE_PARAM_SEMICOLONS = 1;
# Do not include undefined params parsed from query string
# use CGI qw(-no_undef_params);
$NO_UNDEF_PARAMS = 0;
# return everything as utf-8
$PARAM_UTF8 = 0;
# make param('PUTDATA') act like file upload
$PUTDATA_UPLOAD = 0;
# Add QUERY_STRING to POST request
$APPEND_QUERY_STRING = 0;
# Other globals that you shouldn't worry about.
undef $Q;
# since this is now the default having removed AUTOLOAD
sub compile { 1; }
sub _all_html_tags {
return qw/
a abbr acronym address applet Area
b base basefont bdo big blink blockquote body br
caption center cite code col colgroup
dd del dfn div dl dt
em embed
fieldset font fontsize frame frameset
h1 h2 h3 h4 h5 h6 head hr html
i iframe ilayer img input ins
kbd
label layer legend li Link
Map menu meta
nextid nobr noframes noscript
object ol option
p Param pre
Q
samp script Select small span
strike strong style Sub sup
table tbody td tfoot th thead title Tr TR tt
u ul
var
/
}
foreach my $tag ( _all_html_tags() ) {
*$tag = sub { return _tag_func($tag,@_); };
# start_html and end_html already exist as custom functions
next if ($tag eq 'html');
foreach my $start_end ( qw/ start end / ) {
my $start_end_function = "${start_end}_${tag}";
*$start_end_function = sub { return _tag_func($start_end_function,@_); };
}
}
sub _tag_func {
my $tagname = shift;
my ($q,$a,@rest) = self_or_default(@_);
my($attr) = '';
if (ref($a) && ref($a) eq 'HASH') {
my(@attr) = make_attributes($a,$q->{'escape'});
$attr = " @attr" if @attr;
} else {
unshift @rest,$a if defined $a;
}
$tagname = lc( $tagname );
if ($tagname=~/start_(\w+)/i) {
return "<$1$attr>";
} elsif ($tagname=~/end_(\w+)/i) {
return "</$1>";
} else {
return $XHTML ? "<$tagname$attr />" : "<$tagname$attr>" unless @rest;
my($tag,$untag) = ("<$tagname$attr>","</$tagname>");
my @result = map { "$tag$_$untag" }
(ref($rest[0]) eq 'ARRAY') ? @{$rest[0]} : "@rest";
return "@result";
}
}
sub _selected {
my $self = shift;
my $value = shift;
return '' unless $value;
return $XHTML ? qq(selected="selected" ) : qq(selected );
}
sub _checked {
my $self = shift;
my $value = shift;
return '' unless $value;
return $XHTML ? qq(checked="checked" ) : qq(checked );
}
sub _reset_globals { initialize_globals(); }
sub _setup_symbols {
my $self = shift;
# to avoid reexporting unwanted variables
undef %EXPORT;
for (@_) {
if ( /^[:-]any$/ ) {
warn "CGI -any pragma has been REMOVED. You should audit your code for any use "
. "of none supported / incorrectly spelled tags and remove them"
;
next;
}
$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$/;
$PUTDATA_UPLOAD++, next if /^[:-](?:putdata_upload|postdata_upload|patchdata_upload)$/;
$PARAM_UTF8++, next if /^[:-]utf8$/;
$XHTML++, next if /^[:-]xhtml$/;
$XHTML=0, next if /^[:-]no_?xhtml$/;
$USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
$TABINDEX++, next if /^[:-]tabindex$/;
$CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
$NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
for (&expand_tags($_)) {
tr/a-zA-Z0-9_//cd; # don't allow weird function names
$EXPORT{$_}++;
}
}
@SAVED_SYMBOLS = @_;
}
sub charset {
my ($self,$charset) = self_or_default(@_);
$self->{'.charset'} = $charset if defined $charset;
$self->{'.charset'};
}
sub element_id {
my ($self,$new_value) = self_or_default(@_);
$self->{'.elid'} = $new_value if defined $new_value;
sprintf('%010d',$self->{'.elid'}++);
}
sub element_tab {
my ($self,$new_value) = self_or_default(@_);
$self->{'.etab'} ||= 1;
$self->{'.etab'} = $new_value if defined $new_value;
my $tab = $self->{'.etab'}++;
return '' unless $TABINDEX or defined $new_value;
return qq(tabindex="$tab" );
####
sub redirect {
my($self,@p) = self_or_default(@_);
my($url,$target,$status,$cookie,$nph,@other) =
rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES','SET-COOKIE'],NPH],@p);
$status = '302 Found' unless defined $status;
$url ||= $self->self_url;
my(@o);
for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
'-Status' => $status,
'-Location'=> $url,
'-nph' => $nph);
unshift(@o,'-Target'=>$target) if $target;
unshift(@o,'-Type'=>'');
my @unescaped;
unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
}
#### Method: start_html
# Canned HTML header
#
# Parameters:
# $title -> (optional) The title for this HTML document (-title)
# $author -> (optional) e-mail address of the author (-author)
# $base -> (optional) if set to true, will enter the BASE address of this document
# for resolving relative references (-base)
# $xbase -> (optional) alternative base at some remote location (-xbase)
# $target -> (optional) target window to load all links into (-target)
# $script -> (option) Javascript code (-script)
# $no_script -> (option) Javascript <noscript> tag (-noscript)
# $meta -> (optional) Meta information tags
# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
# (a scalar or array ref)
# $style -> (optional) reference to an external style sheet
# @other -> (optional) any other named parameters you'd like to incorporate into
# the <body> tag.
####
sub start_html {
my($self,@p) = &self_or_default(@_);
my($title,$author,$base,$xbase,$script,$noscript,
$target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
$self->element_id(0);
$self->element_tab(0);
$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 ($dtd) {
if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
$dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
} else {
$dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
}
} else {
$dtd = $XHTML ? $_XHTML_DTD : $DEFAULT_DTD;
}
$xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
$xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
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->_maybe_escapeHTML($title || 'Untitled Document');
$author = $self->escape($author);
if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2|4\.01?)/i) {
$lang = "" unless defined $lang;
$XHTML = 0;
}
else {
$lang = 'en-US' unless defined $lang;
}
my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
if $XHTML && $encoding && !$declare_xml;
push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
: ($lang ? qq(<html lang="$lang">) : "<html>")
. "<head><title>$title</title>");
if (defined $author) {
push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
: "<link rev=\"made\" href=\"mailto:$author\">");
}
if ($base || $xbase || $target) {
my $href = $xbase || $self->url('-path'=>1);
my $t = $target ? qq/ target="$target"/ : '';
push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
}
if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
for (sort keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
: qq(<meta name="$_" content="$meta->{$_}">)); }
}
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 and !$meta_bits_set;
# handle -noscript parameter
push(@result,<<END) if $noscript;
<noscript>
$noscript
</noscript>
END
;
my($other) = @other ? " @other" : '';
push(@result,"</head>\n<body$other>\n");
return join("\n",@result);
}
### Method: _style
# internal method for generating a CSS style section
####
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,$alternate,$foo,@other) =
rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
('-foo'=>'bar',
ref($s) eq 'ARRAY' ? @$s : %$s));
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
for $src (@$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="$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>") for @v;
}
if ($code) {
my @c = ref($code) eq 'ARRAY' ? @$code : $code;
push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
}
} else {
my $src = $s;
push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
: qq(<link rel="$rel" type="$type" href="$src"$other>));
}
}
@result;
}
sub _script {
my ($self,$script) = @_;
my (@result);
my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
for $script (@scripts) {
my($src,$code,$language,$charset);
if (ref($script)) { # script is a hash
($src,$code,$type,$charset) =
rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'],
'-foo'=>'bar', # a trick to allow the '-' to be omitted
ref($script) eq 'ARRAY' ? @$script : %$script);
$type ||= 'text/javascript';
unless ($type =~ m!\w+/\w+!) {
$type =~ s/[\d.]+$//;
$type = "text/$type";
}
} else {
($src,$code,$type,$charset) = ('',$script, 'text/javascript', '');
}
my $comment = '//'; # javascript by default
$comment = '#' if $type=~/perl|tcl/i;
$comment = "'" if $type=~/vbscript/i;
my ($cdata_start,$cdata_end);
if ($XHTML) {
$cdata_start = "$comment<![CDATA[\n";
$cdata_end .= "\n$comment]]>";
} else {
$cdata_start = "\n<!-- Hide script\n";
$cdata_end = $comment;
$cdata_end .= " End script hiding -->\n";
}
my(@satts);
push(@satts,'src'=>$src) if $src;
push(@satts,'type'=>$type);
push(@satts,'charset'=>$charset) if ($src && $charset);
$code = $cdata_start . $code . $cdata_end if defined $code;
push(@result,$self->script({@satts},$code || ''));
}
@result;
}
#### Method: end_html
# End an HTML document.
# Trivial method for completeness. Just returns "</body>"
####
sub end_html {
return "\n</body>\n</html>";
}
################################
# METHODS USED IN BUILDING FORMS
################################
#### Method: isindex
# Just prints out the isindex tag.
# Parameters:
# $action -> optional URL of script to run
# Returns:
# A string containing a <isindex> tag
sub isindex {
my($self,@p) = self_or_default(@_);
my($action,@other) = rearrange([ACTION],@p);
$action = qq/ action="$action"/ if $action;
my($other) = @other ? " @other" : '';
return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
}
#### Method: start_form
# Start a form
# Parameters:
# $method -> optional submission method to use (GET or POST)
# $action -> optional URL of script to run
# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
sub start_form {
my($self,@p) = self_or_default(@_);
my($method,$action,$enctype,@other) =
rearrange([METHOD,ACTION,ENCTYPE],@p);
$method = $self->_maybe_escapeHTML(lc($method || 'post'));
if( $XHTML ){
$enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART);
}else{
$enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
}
if (defined $action) {
$action = $self->_maybe_escapeHTML($action);
}
else {
$action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
}
$action = qq(action="$action");
my($other) = @other ? " @other" : '';
$self->{'.parametersToAdd'}={};
return qq/<form method="$method" $action enctype="$enctype"$other>/;
}
#### Method: start_multipart_form
sub start_multipart_form {
my($self,@p) = self_or_default(@_);
if (defined($p[0]) && substr($p[0],0,1) eq '-') {
return $self->start_form(-enctype=>&MULTIPART,@p);
} else {
my($method,$action,@other) =
rearrange([METHOD,ACTION],@p);
return $self->start_form($method,$action,&MULTIPART,@other);
}
}
#### Method: end_form
# End a form
# Note: This repeated below under the older name.
sub end_form {
my($self,@p) = self_or_default(@_);
if ( $NOSTICKY ) {
return wantarray ? ("</form>") : "\n</form>";
} else {
if (my @fields = $self->get_fields) {
return wantarray ? ("<div>",@fields,"</div>","</form>")
: "<div>".(join '',@fields)."</div>\n</form>";
} else {
return "</form>";
}
}
}
#### Method: end_multipart_form
# end a multipart form
sub end_multipart_form {
&end_form;
}
sub _textfield {
my($self,$tag,@p) = self_or_default(@_);
my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
my $current = $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
$current = defined($current) ? $self->_maybe_escapeHTML($current,1) : '';
$name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
my($s) = defined($size) ? qq/ size="$size"/ : '';
my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
my($other) = @other ? " @other" : '';
# this entered at cristy's request to fix problems with file upload fields
# and WebTV -- not sure it won't break stuff
my($value) = $current ne '' ? qq(value="$current") : '';
$tabindex = $self->element_tab($tabindex);
return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
: qq(<input type="$tag" name="$name" $value$s$m$other>);
}
#### Method: textfield
# Parameters:
# $name -> Name of the text field
# $default -> Optional default value of the field if not
# already defined.
# $size -> Optional width of field in characaters.
# $maxlength -> Optional maximum number of characters.
# Returns:
# A string containing a <input type="text"> field
#
sub textfield {
my($self,@p) = self_or_default(@_);
$self->_textfield('text',@p);
}
#### Method: filefield
# Parameters:
# $name -> Name of the file upload field
# $size -> Optional width of field in characaters.
# $maxlength -> Optional maximum number of characters.
# Returns:
# A string containing a <input type="file"> field
#
sub filefield {
my($self,@p) = self_or_default(@_);
$self->_textfield('file',@p);
}
#### Method: password
# Create a "secret password" entry field
# Parameters:
# $name -> Name of the field
# $default -> Optional default value of the field if not
# already defined.
# $size -> Optional width of field in characters.
# $maxlength -> Optional maximum characters that can be entered.
# Returns:
# A string containing a <input type="password"> field
#
sub password_field {
my ($self,@p) = self_or_default(@_);
$self->_textfield('password',@p);
}
#### Method: textarea
# Parameters:
# $name -> Name of the text field
# $default -> Optional default value of the field if not
# already defined.
# $rows -> Optional number of rows in text area
# $columns -> Optional number of columns in text area
# Returns:
# A string containing a <textarea></textarea> tag
#
sub textarea {
my($self,@p) = self_or_default(@_);
my($name,$default,$rows,$cols,$override,$tabindex,@other) =
rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
my($current)= $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
$name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
$current = defined($current) ? $self->_maybe_escapeHTML($current) : '';
my($r) = $rows ? qq/ rows="$rows"/ : '';
my($c) = $cols ? qq/ cols="$cols"/ : '';
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
}
#### Method: button
# Create a javascript button.
# Parameters:
# $name -> (optional) Name for the button. (-name)
# $value -> (optional) Value of the button when selected (and visible name) (-value)
# $onclick -> (optional) Text of the JavaScript to run when the button is
# clicked.
# Returns:
# A string containing a <input type="button"> tag
####
sub button {
my($self,@p) = self_or_default(@_);
my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
[ONCLICK,SCRIPT],TABINDEX],@p);
$label=$self->_maybe_escapeHTML($label);
$value=$self->_maybe_escapeHTML($value,1);
$script=$self->_maybe_escapeHTML($script);
$script ||= '';
my($name) = '';
$name = qq/ name="$label"/ if $label;
$value = $value || $label;
my($val) = '';
$val = qq/ value="$value"/ if $value;
$script = qq/ onclick="$script"/ if $script;
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
: qq(<input type="button"$name$val$script$other>);
}
#### Method: submit
# Create a "submit query" button.
# Parameters:
# $name -> (optional) Name for the button.
# $value -> (optional) Value of the button when selected (also doubles as label).
# $label -> (optional) Label printed on the button(also doubles as the value).
# Returns:
# A string containing a <input type="submit"> tag
####
sub submit {
my($self,@p) = self_or_default(@_);
my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
$label=$self->_maybe_escapeHTML($label);
$value=$self->_maybe_escapeHTML($value,1);
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);
$tabindex = $self->element_tab($tabindex);
my($other) = @other ? "@other " : '';
return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
: qq(<input type="submit" $name$val$other>);
}
#### Method: reset
# Create a "reset" button.
# Parameters:
# $name -> (optional) Name for the button.
# Returns:
# A string containing a <input type="reset"> tag
####
sub reset {
my($self,@p) = self_or_default(@_);
my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
$label=$self->_maybe_escapeHTML($label);
$value=$self->_maybe_escapeHTML($value,1);
my ($name) = ' name=".reset"';
$name = qq/ name="$label"/ if defined($label);
$value = defined($value) ? $value : $label;
my($val) = '';
$val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
: qq(<input type="reset"$name$val$other>);
}
#### Method: defaults
# Create a "defaults" button.
# Parameters:
# $name -> (optional) Name for the button.
# Returns:
# A string containing a <input type="submit" name=".defaults"> tag
#
# Note: this button has a special meaning to the initialization script,
# and tells it to ERASE the current query string so that your defaults
# are used again!
####
sub defaults {
my($self,@p) = self_or_default(@_);
my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
$label=$self->_maybe_escapeHTML($label,1);
$label = $label || "Defaults";
my($value) = qq/ value="$label"/;
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
: qq/<input type="submit" NAME=".defaults"$value$other>/;
}
#### Method: comment
# Create an HTML <!-- comment -->
# Parameters: a string
sub comment {
my($self,@p) = self_or_CGI(@_);
return "<!-- @p -->";
}
#### Method: checkbox
# Create a checkbox that is not logically linked to any others.
# The field value is "on" when the button is checked.
# Parameters:
# $name -> Name of the checkbox
# $checked -> (optional) turned on by default if true
# $value -> (optional) value of the checkbox, 'on' by default
# $label -> (optional) a user-readable label printed next to the box.
# Otherwise the checkbox name is used.
# Returns:
# A string containing a <input type="checkbox"> field
####
sub checkbox {
my($self,@p) = self_or_default(@_);
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';
if (!$override && ($self->{'.fieldnames'}->{$name} ||
defined $self->param($name))) {
$checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
} else {
$checked = $self->_checked($checked);
}
my($the_label) = defined $label ? $label : $name;
$name = $self->_maybe_escapeHTML($name);
$value = $self->_maybe_escapeHTML($value,1);
$the_label = $self->_maybe_escapeHTML($the_label);
my($other) = @other ? "@other " : '';
$tabindex = $self->element_tab($tabindex);
$self->register_parameter($name);
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};
}
# Escape HTML
sub escapeHTML {
require HTML::Entities;
# hack to work around earlier hacks
push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
return undef unless defined($toencode);
my $encode_entities = $ENCODE_ENTITIES;
$encode_entities .= "\012\015" if ( $encode_entities && $newlinestoo );
return HTML::Entities::encode_entities($toencode,$encode_entities);
}
# unescape HTML -- used internally
sub unescapeHTML {
require HTML::Entities;
# 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);
return HTML::Entities::decode_entities($string);
}
# Internal procedure - don't use
sub _tableize {
my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
my @rowheaders = $rowheaders ? @$rowheaders : ();
my @colheaders = $colheaders ? @$colheaders : ();
my($result);
if (defined($columns)) {
$rows = int(0.99 + @elements/$columns) unless defined($rows);
}
if (defined($rows)) {
$columns = int(0.99 + @elements/$rows) unless defined($columns);
}
# rearrange into a pretty table
$result = "<table>";
my($row,$column);
unshift(@colheaders,'') if @colheaders && @rowheaders;
$result .= "<tr>" if @colheaders;
for (@colheaders) {
$result .= "<th>$_</th>";
}
for ($row=0;$row<$rows;$row++) {
$result .= "<tr>";
$result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
for ($column=0;$column<$columns;$column++) {
$result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
if defined($elements[$column*$rows + $row]);
}
$result .= "</tr>";
}
$result .= "</table>";
return $result;
}
####
sub checkbox_group {
my($self,@p) = self_or_default(@_);
$self->_box_group('checkbox',@p);
}
sub _box_group {
my $self = shift;
my $box_type = shift;
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($result,$checked,@elements,@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
my %checked = $self->previous_or_default($name,$defaults,$override);
# If no check array is specified, check the first by default
$checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
$name=$self->_maybe_escapeHTML($name);
my %tabs = ();
if ($TABINDEX && $tabindex) {
if (!ref $tabindex) {
$self->element_tab($tabindex);
} elsif (ref $tabindex eq 'ARRAY') {
%tabs = map {$_=>$self->element_tab} @$tabindex;
} elsif (ref $tabindex eq 'HASH') {
%tabs = %$tabindex;
}
}
%tabs = map {$_=>$self->element_tab} @values unless %tabs;
my $other = @other ? "@other " : '';
my $radio_checked;
# 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);
if ($linebreak) {
$break = $XHTML ? "<br />" : "<br>";
}
else {
$break = '';
}
my($label)='';
unless (defined($nolabels) && $nolabels) {
$label = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->_maybe_escapeHTML($label,1);
$label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
}
my $attribs = $self->_set_attributes($_, $attributes);
my $tab = $tabs{$_};
$_=$self->_maybe_escapeHTML($_);
if ($XHTML) {
push @elements,
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$disable>${label}${break}/);
}
}
$self->register_parameter($name);
return wantarray ? @elements : "@elements"
unless defined($columns) || defined($rows);
return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
}
#### Method: popup_menu
# Create a popup menu.
# Parameters:
# $name -> Name for all the menu
# $values -> A pointer to a regular array containing the
# text of each menu item.
# $default -> (optional) Default item to display
# $labels -> (optional)
# 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:
# A string containing the definition of a popup menu.
####
sub popup_menu {
my($self,@p) = self_or_default(@_);
my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
my($result,%selected);
if (!$override && defined($self->param($name))) {
$selected{$self->param($name)}++;
} elsif (defined $default) {
%selected = map {$_=>1} ref($default) eq 'ARRAY'
? @$default
: $default;
}
$name=$self->_maybe_escapeHTML($name);
# RT #30057 - ignore -multiple, if you need this
# then use scrolling_list
@other = grep { $_ !~ /^multiple=/i } @other;
my($other) = @other ? " @other" : '';
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
$tabindex = $self->element_tab($tabindex);
$name = q{} if ! defined $name;
$result = qq/<select name="$name" $tabindex$other>\n/;
for (@values) {
if (/<optgroup/) {
for my $v (split(/\n/)) {
my $selectit = $XHTML ? 'selected="selected"' : 'selected';
for my $selected (sort keys %selected) {
$v =~ s/(value="\Q$selected\E")/$selectit $1/;
}
$result .= "$v\n";
}
}
else {
my $attribs = $self->_set_attributes($_, $attributes);
my($selectit) = $self->_selected($selected{$_});
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
my($value) = $self->_maybe_escapeHTML($_);
$label = $self->_maybe_escapeHTML($label,1);
$result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
}
}
$result .= "</select>";
return $result;
}
#### Method: optgroup
# Create a optgroup.
# Parameters:
# $name -> Label for the group
# $values -> A pointer to a regular array containing the
# values for each option line in the group.
# $labels -> (optional)
# A pointer to 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)
# A true value indicates the value should be used as the label attribute
# in the option elements.
# The label attribute specifies the option label presented to the user.
# This defaults to the content of the <option> element, but the label
# attribute allows authors to more easily use optgroup without sacrificing
# compatibility with browsers that do not support option groups.
# $novals -> (optional)
# A true value indicates to suppress the val attribute in the option elements
# Returns:
# A string containing the definition of an option group.
####
sub optgroup {
my($self,@p) = self_or_default(@_);
my($name,$values,$attributes,$labeled,$noval,$labels,@other)
= rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
my($result,@values);
@values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
my($other) = @other ? " @other" : '';
$name = $self->_maybe_escapeHTML($name) || q{};
$result = qq/<optgroup label="$name"$other>\n/;
for (@values) {
if (/<optgroup/) {
for (split(/\n/)) {
my $selectit = $XHTML ? 'selected="selected"' : 'selected';
s/(value="$selected")/$selectit $1/ if defined $selected;
$result .= "$_\n";
}
}
else {
my $attribs = $self->_set_attributes($_, $attributes);
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label=$self->_maybe_escapeHTML($label);
my($value)=$self->_maybe_escapeHTML($_,1);
$result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
: "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
: $novals ? "<option$attribs>$label</option>\n"
: "<option$attribs value=\"$value\">$label</option>\n";
}
}
$result .= "</optgroup>";
return $result;
}
#### Method: scrolling_list
# Create a scrolling list.
# Parameters:
# $name -> name for the list
# $values -> A pointer to a regular array containing the
# values for each option line in the list.
# $defaults -> (optional)
# 1. If a pointer to a regular array of options,
# then this will be used to decide which
# lines to turn on by default.
# 2. Otherwise holds the value of the single line to turn on.
# $size -> (optional) Size of the list.
# $multiple -> (optional) If set, allow multiple selections.
# $labels -> (optional)
# 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:
# A string containing the definition of a scrolling list.
####
sub scrolling_list {
my($self,@p) = self_or_default(@_);
my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
= rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
my($result,@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
$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->_maybe_escapeHTML($name);
$tabindex = $self->element_tab($tabindex);
$result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
for (@values) {
if (/<optgroup/) {
for my $v (split(/\n/)) {
my $selectit = $XHTML ? 'selected="selected"' : 'selected';
for my $selected (sort keys %selected) {
$v =~ s/(value="$selected")/$selectit $1/;
}
$result .= "$v\n";
}
}
else {
my $attribs = $self->_set_attributes($_, $attributes);
my($selectit) = $self->_selected($selected{$_});
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
my($value) = $self->_maybe_escapeHTML($_);
$label = $self->_maybe_escapeHTML($label,1);
$result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
}
}
$result .= "</select>";
$self->register_parameter($name);
return $result;
}
#### Method: hidden
# Parameters:
# $name -> Name of the hidden field
# @default -> (optional) Initial values of field (may be an array)
# or
# $default->[initial values of field]
# Returns:
# A string containing a <input type="hidden" name="name" value="value">
####
sub hidden {
my($self,@p) = self_or_default(@_);
# this is the one place where we departed from our standard
# calling scheme, so we have to special-case (darn)
my(@result,@value);
my($name,$default,$override,@other) =
rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
my $do_override = 0;
if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
@value = ref($default) ? @{$default} : $default;
$do_override = $override;
} else {
for ($default,$override,@other) {
push(@value,$_) if defined($_);
}
undef @other;
}
# use previous values if override is not set
my @prev = $self->param($name);
@value = @prev if !$do_override && @prev;
$name=$self->_maybe_escapeHTML($name);
for (@value) {
$_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : '';
push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
: qq(<input type="hidden" name="$name" value="$_" @other>);
}
return wantarray ? @result : join('',@result);
}
#### Method: image_button
# Parameters:
# $name -> Name of the button
# $src -> URL of the image source
# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
# Returns:
# A string containing a <input type="image" name="name" src="url" align="alignment">
####
sub image_button {
my($self,@p) = self_or_default(@_);
my($name,$src,$alignment,@other) =
rearrange([NAME,SRC,ALIGN],@p);
my($align) = $alignment ? " align=\L\"$alignment\"" : '';
my($other) = @other ? " @other" : '';
$name=$self->_maybe_escapeHTML($name);
return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
: qq/<input type="image" name="$name" src="$src"$align$other>/;
}
#### Method: self_url
# Returns a URL containing the current script and all its
# param/value pairs arranged as a query. You can use this
# to create a link that, when selected, will reinvoke the
# script with all its state information preserved.
####
sub self_url {
my($self,@p) = self_or_default(@_);
return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
}
# This is provided as a synonym to self_url() for people unfortunate
# enough to have incorporated it into their programs already!
sub state {
&self_url;
}
#### Method: url
# Like self_url, but doesn't return the query string part of
# the URL.
####
sub url {
my($self,@p) = self_or_default(@_);
my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
my $url = '';
$full++ if $base || !($relative || $absolute);
$rewrite++ unless defined $rewrite;
my $path = $self->path_info;
my $script_name = $self->script_name;
my $request_uri = $self->request_uri || '';
my $query_str = $query ? $self->query_string : '';
$script_name =~ s/\?.*$//s; # remove query string
$request_uri =~ s/\?.*$//s; # remove query string
$request_uri = unescape($request_uri);
my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
if ( defined( $ENV{PATH_INFO} ) ) {
# IIS sometimes sets PATH_INFO to the same value as SCRIPT_NAME so only sub it out
# if SCRIPT_NAME isn't defined or isn't the same value as PATH_INFO
$uri =~ s/\Q$ENV{PATH_INFO}\E$//
if ( ! defined( $ENV{SCRIPT_NAME} ) or $ENV{PATH_INFO} ne $ENV{SCRIPT_NAME} );
# if we're not IIS then keep to spec, the relevant info is here:
# https://tools.ietf.org/html/rfc3875#section-4.1.13, namely
# "No PATH_INFO segment (see section 4.1.5) is included in the
# SCRIPT_NAME value." (see GH #126, GH #152, GH #176)
if ( ! $IIS ) {
$uri =~ s/\Q$ENV{PATH_INFO}\E$//;
}
}
if ($full) {
my $protocol = $self->protocol();
( run in 1.477 second using v1.01-cache-2.11-cpan-ba708fea25c )