CGI
view release on metacpan or search on metacpan
# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
# and sometimes CR). The most popular VMS web server
# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
# use ASCII, so \015\012 means something different. I find this all
# really annoying.
$EBCDIC = "\t" ne "\011";
if ($OS eq 'VMS') {
$CRLF = "\n";
} elsif ($EBCDIC) {
$CRLF= "\r\n";
} else {
$CRLF = "\015\012";
}
_set_binmode() if ($needs_binmode);
sub _set_binmode {
# rt #57524 - don't set binmode on filehandles if there are
# already none default layers set on them
my %default_layers = (
unix => 1,
perlio => 1,
stdio => 1,
crlf => 1,
);
foreach my $fh (
\*main::STDOUT,
\*main::STDIN,
\*main::STDERR,
) {
my @modes = grep { ! $default_layers{$_} }
PerlIO::get_layers( $fh );
if ( ! @modes ) {
$CGI::DefaultClass->binmode( $fh );
}
}
}
%EXPORT_TAGS = (
':html2' => [ 'h1' .. 'h6', qw/
p br hr ol ul li dl dt dd menu code var strong em
tt u i b blockquote pre img a address cite samp dfn html head
base body Link nextid title meta kbd start_html end_html
input Select option comment charset escapeHTML
/ ],
':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
thead tbody tfoot
/ ],
':form' => [ qw/
textfield textarea filefield password_field hidden checkbox checkbox_group
submit reset defaults radio_group popup_menu button autoEscape
scrolling_list image_button start_form end_form
start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART
/ ],
':cgi' => [ qw/
param multi_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 save_parameters restore_parameters param_fetch
remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error env_query_string
/ ],
':netscape' => [qw/blink fontsize center/],
':ssl' => [qw/https/],
':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
# bulk export/import
':html' => [qw/:html2 :html3 :html4 :netscape/],
':standard' => [qw/:html2 :html3 :html4 :form :cgi :ssl/],
':all' => [qw/:html2 :html3 :html4 :netscape :form :cgi :ssl :push/]
);
# to import symbols into caller
sub import {
my $self = shift;
# This causes modules to clash.
undef %EXPORT_OK;
undef %EXPORT;
$self->_setup_symbols(@_);
my ($callpack, $callfile, $callline) = caller;
if ( $callpack eq 'CGI::Fast' ) {
# fixes GH #11 (and GH #12 in CGI::Fast since
# sub import was added to CGI::Fast in 9537f90
# so we need to move up a level to export the
# routines to the namespace of whatever is using
# CGI::Fast
($callpack, $callfile, $callline) = caller(1);
}
# To allow overriding, search through the packages
# Till we find one in which the correct subroutine is defined.
my @packages = ($self,@{"$self\:\:ISA"});
for $sym (sort keys %EXPORT) {
my $pck;
my $def = $DefaultClass;
for $pck (@packages) {
if (defined(&{"$pck\:\:$sym"})) {
$def = $pck;
last;
}
}
*{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
}
}
sub expand_tags {
my($tag) = @_;
return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
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.
( run in 1.368 second using v1.01-cache-2.11-cpan-364913b4093 )