1N/Apackage CGI;
1N/Arequire 5.006;
1N/Ause Carp 'croak';
1N/A
1N/A# See the bottom of this file for the POD documentation. Search for the
1N/A# string '=head'.
1N/A
1N/A# You can run this file through either pod2man or pod2html to produce pretty
1N/A# documentation in manual or html file format (these utilities are part of the
1N/A# Perl 5 distribution).
1N/A
1N/A# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
1N/A# It may be used and modified freely, but I do request that this copyright
1N/A# notice remain attached to the file. You may modify this module as you
1N/A# wish, but if you redistribute a modified version, please attach a note
1N/A# listing the modifications you have made.
1N/A
1N/A# The most recent version and complete docs are available at:
1N/A# http://search.cpan.org/dist/CGI.pm
1N/A
1N/A# The revision is no longer being updated since moving to git.
1N/A$CGI::revision = '$Id: CGI.pm,v 1.266 2009/07/30 16:32:34 lstein Exp $';
1N/A$CGI::VERSION='3.52';
1N/A
1N/A# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
1N/A# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
1N/A# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
1N/Ause CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
1N/A
1N/A#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
1N/A# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
1N/A
1N/Ause constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
1N/A 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
1N/A
1N/A{
1N/A local $^W = 0;
1N/A $TAINTED = substr("$0$^X",0,0);
1N/A}
1N/A
1N/A$MOD_PERL = 0; # no mod_perl by default
1N/A
1N/A#global settings
1N/A$POST_MAX = -1; # no limit to uploaded files
1N/A$DISABLE_UPLOADS = 0;
1N/A
1N/A@SAVED_SYMBOLS = ();
1N/A
1N/A
1N/A# >>>>> Here are some globals that you might want to adjust <<<<<<
1N/Asub initialize_globals {
1N/A # Set this to 1 to enable copious autoloader debugging messages
1N/A $AUTOLOAD_DEBUG = 0;
1N/A
1N/A # Set this to 1 to generate XTML-compatible output
1N/A $XHTML = 1;
1N/A
1N/A # Change this to the preferred DTD to print in start_html()
1N/A # or use default_dtd('text of DTD to use');
1N/A $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
1N/A 'http://www.w3.org/TR/html4/loose.dtd' ] ;
1N/A
1N/A # Set this to 1 to enable NOSTICKY scripts
1N/A # or:
1N/A # 1) use CGI '-nosticky';
1N/A # 2) $CGI::NOSTICKY = 1;
1N/A $NOSTICKY = 0;
1N/A
1N/A # Set this to 1 to enable NPH scripts
1N/A # or:
1N/A # 1) use CGI qw(-nph)
1N/A # 2) CGI::nph(1)
1N/A # 3) print header(-nph=>1)
1N/A $NPH = 0;
1N/A
1N/A # Set this to 1 to enable debugging from @ARGV
1N/A # Set to 2 to enable debugging from STDIN
1N/A $DEBUG = 1;
1N/A
1N/A # Set this to 1 to make the temporary files created
1N/A # during file uploads safe from prying eyes
1N/A # or do...
1N/A # 1) use CGI qw(:private_tempfiles)
1N/A # 2) CGI::private_tempfiles(1);
1N/A $PRIVATE_TEMPFILES = 0;
1N/A
1N/A # Set this to 1 to generate automatic tab indexes
1N/A $TABINDEX = 0;
1N/A
1N/A # Set this to 1 to cause files uploaded in multipart documents
1N/A # to be closed, instead of caching the file handle
1N/A # or:
1N/A # 1) use CGI qw(:close_upload_files)
1N/A # 2) $CGI::close_upload_files(1);
1N/A # Uploads with many files run out of file handles.
1N/A # Also, for performance, since the file is already on disk,
1N/A # it can just be renamed, instead of read and written.
1N/A $CLOSE_UPLOAD_FILES = 0;
1N/A
1N/A # Automatically determined -- don't change
1N/A $EBCDIC = 0;
1N/A
1N/A # Change this to 1 to suppress redundant HTTP headers
1N/A $HEADERS_ONCE = 0;
1N/A
1N/A # separate the name=value pairs by semicolons rather than ampersands
1N/A $USE_PARAM_SEMICOLONS = 1;
1N/A
1N/A # Do not include undefined params parsed from query string
1N/A # use CGI qw(-no_undef_params);
1N/A $NO_UNDEF_PARAMS = 0;
1N/A
1N/A # return everything as utf-8
1N/A $PARAM_UTF8 = 0;
1N/A
1N/A # Other globals that you shouldn't worry about.
1N/A undef $Q;
1N/A $BEEN_THERE = 0;
1N/A $DTD_PUBLIC_IDENTIFIER = "";
1N/A undef @QUERY_PARAM;
1N/A undef %EXPORT;
1N/A undef $QUERY_CHARSET;
1N/A undef %QUERY_FIELDNAMES;
1N/A undef %QUERY_TMPFILES;
1N/A
1N/A # prevent complaints by mod_perl
1N/A 1;
1N/A}
1N/A
1N/A# ------------------ START OF THE LIBRARY ------------
1N/A
1N/A#### Method: endform
1N/A# This method is DEPRECATED
1N/A*endform = \&end_form;
1N/A
1N/A# make mod_perlhappy
1N/Ainitialize_globals();
1N/A
1N/A# FIGURE OUT THE OS WE'RE RUNNING UNDER
1N/A# Some systems support the $^O variable. If not
1N/A# available then require() the Config library
1N/Aunless ($OS) {
1N/A unless ($OS = $^O) {
1N/A require Config;
1N/A $OS = $Config::Config{'osname'};
1N/A }
1N/A}
1N/Aif ($OS =~ /^MSWin/i) {
1N/A $OS = 'WINDOWS';
1N/A} elsif ($OS =~ /^VMS/i) {
1N/A $OS = 'VMS';
1N/A} elsif ($OS =~ /^dos/i) {
1N/A $OS = 'DOS';
1N/A} elsif ($OS =~ /^MacOS/i) {
1N/A $OS = 'MACINTOSH';
1N/A} elsif ($OS =~ /^os2/i) {
1N/A $OS = 'OS2';
1N/A} elsif ($OS =~ /^epoc/i) {
1N/A $OS = 'EPOC';
1N/A} elsif ($OS =~ /^cygwin/i) {
1N/A $OS = 'CYGWIN';
1N/A} elsif ($OS =~ /^NetWare/i) {
1N/A $OS = 'NETWARE';
1N/A} else {
1N/A $OS = 'UNIX';
1N/A}
1N/A
1N/A# Some OS logic. Binary mode enabled on DOS, NT and VMS
1N/A$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN|NETWARE)/;
1N/A
1N/A# This is the default class for the CGI object to use when all else fails.
1N/A$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
1N/A
1N/A# This is where to look for autoloaded routines.
1N/A$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
1N/A
1N/A# The path separator is a slash, backslash or semicolon, depending
1N/A# on the paltform.
1N/A$SL = {
1N/A UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', NETWARE => '/',
1N/A WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
1N/A }->{$OS};
1N/A
1N/A# This no longer seems to be necessary
1N/A# Turn on NPH scripts by default when running under IIS server!
1N/A# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
1N/A$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
1N/A
1N/A# Turn on special checking for ActiveState's PerlEx
1N/A$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
1N/A
1N/A# Turn on special checking for Doug MacEachern's modperl
1N/A# PerlEx::DBI tries to fool DBI by setting MOD_PERL
1N/Aif (exists $ENV{MOD_PERL} && ! $PERLEX) {
1N/A # mod_perl handlers may run system() on scripts using CGI.pm;
1N/A # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
1N/A if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
1N/A $MOD_PERL = 2;
1N/A require Apache2::Response;
1N/A require Apache2::RequestRec;
1N/A require Apache2::RequestUtil;
1N/A require Apache2::RequestIO;
1N/A require APR::Pool;
1N/A } else {
1N/A $MOD_PERL = 1;
1N/A require Apache;
1N/A }
1N/A}
1N/A
1N/A# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
1N/A# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
1N/A# and sometimes CR). The most popular VMS web server
1N/A# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
1N/A# use ASCII, so \015\012 means something different. I find this all
1N/A# really annoying.
1N/A$EBCDIC = "\t" ne "\011";
1N/Aif ($OS eq 'VMS') {
1N/A $CRLF = "\n";
1N/A} elsif ($EBCDIC) {
1N/A $CRLF= "\r\n";
1N/A} else {
1N/A $CRLF = "\015\012";
1N/A}
1N/A
1N/Aif ($needs_binmode) {
1N/A $CGI::DefaultClass->binmode(\*main::STDOUT);
1N/A $CGI::DefaultClass->binmode(\*main::STDIN);
1N/A $CGI::DefaultClass->binmode(\*main::STDERR);
1N/A}
1N/A
1N/A%EXPORT_TAGS = (
1N/A ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
1N/A tt u i b blockquote pre img a address cite samp dfn html head
1N/A base body Link nextid title meta kbd start_html end_html
1N/A input Select option comment charset escapeHTML/],
1N/A ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param nobr
1N/A embed basefont style span layer ilayer font frameset frame script small big Area Map/],
1N/A ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
1N/A ins label legend noframes noscript object optgroup Q
1N/A thead tbody tfoot/],
1N/A ':netscape'=>[qw/blink fontsize center/],
1N/A ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
1N/A submit reset defaults radio_group popup_menu button autoEscape
1N/A scrolling_list image_button start_form end_form startform endform
1N/A start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
1N/A ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
1N/A cookie Dump
1N/A raw_cookie request_method query_string Accept user_agent remote_host content_type
1N/A remote_addr referer server_name server_software server_port server_protocol virtual_port
1N/A virtual_host remote_ident auth_type http append
1N/A save_parameters restore_parameters param_fetch
1N/A remote_user user_name header redirect import_names put
1N/A Delete Delete_all url_param cgi_error/],
1N/A ':ssl' => [qw/https/],
1N/A ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
1N/A ':html' => [qw/:html2 :html3 :html4 :netscape/],
1N/A ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
1N/A ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
1N/A ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
1N/A );
1N/A
1N/A# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
1N/A# Author: Cees Hek <cees@sitesuite.com.au>
1N/A
1N/Asub can {
1N/A my($class, $method) = @_;
1N/A
1N/A # See if UNIVERSAL::can finds it.
1N/A
1N/A if (my $func = $class -> SUPER::can($method) ){
1N/A return $func;
1N/A }
1N/A
1N/A # Try to compile the function.
1N/A
1N/A eval {
1N/A # _compile looks at $AUTOLOAD for the function name.
1N/A
1N/A local $AUTOLOAD = join "::", $class, $method;
1N/A &_compile;
1N/A };
1N/A
1N/A # Now that the function is loaded (if it exists)
1N/A # just use UNIVERSAL::can again to do the work.
1N/A
1N/A return $class -> SUPER::can($method);
1N/A}
1N/A
1N/A# to import symbols into caller
1N/Asub import {
1N/A my $self = shift;
1N/A
1N/A # This causes modules to clash.
1N/A undef %EXPORT_OK;
1N/A undef %EXPORT;
1N/A
1N/A $self->_setup_symbols(@_);
1N/A my ($callpack, $callfile, $callline) = caller;
1N/A
1N/A # To allow overriding, search through the packages
1N/A # Till we find one in which the correct subroutine is defined.
1N/A my @packages = ($self,@{"$self\:\:ISA"});
1N/A for $sym (keys %EXPORT) {
1N/A my $pck;
1N/A my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
1N/A for $pck (@packages) {
1N/A if (defined(&{"$pck\:\:$sym"})) {
1N/A $def = $pck;
1N/A last;
1N/A }
1N/A }
1N/A *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
1N/A }
1N/A}
1N/A
1N/Asub compile {
1N/A my $pack = shift;
1N/A $pack->_setup_symbols('-compile',@_);
1N/A}
1N/A
1N/Asub expand_tags {
1N/A my($tag) = @_;
1N/A return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
1N/A my(@r);
1N/A return ($tag) unless $EXPORT_TAGS{$tag};
1N/A for (@{$EXPORT_TAGS{$tag}}) {
1N/A push(@r,&expand_tags($_));
1N/A }
1N/A return @r;
1N/A}
1N/A
1N/A#### Method: new
1N/A# The new routine. This will check the current environment
1N/A# for an existing query string, and initialize itself, if so.
1N/A####
1N/Asub new {
1N/A my($class,@initializer) = @_;
1N/A my $self = {};
1N/A
1N/A bless $self,ref $class || $class || $DefaultClass;
1N/A
1N/A # always use a tempfile
1N/A $self->{'use_tempfile'} = 1;
1N/A
1N/A if (ref($initializer[0])
1N/A && (UNIVERSAL::isa($initializer[0],'Apache')
1N/A ||
1N/A UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
1N/A )) {
1N/A $self->r(shift @initializer);
1N/A }
1N/A if (ref($initializer[0])
1N/A && (UNIVERSAL::isa($initializer[0],'CODE'))) {
1N/A $self->upload_hook(shift @initializer, shift @initializer);
1N/A $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
1N/A }
1N/A if ($MOD_PERL) {
1N/A if ($MOD_PERL == 1) {
1N/A $self->r(Apache->request) unless $self->r;
1N/A my $r = $self->r;
1N/A $r->register_cleanup(\&CGI::_reset_globals);
1N/A $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
1N/A }
1N/A else {
1N/A # XXX: once we have the new API
1N/A # will do a real PerlOptions -SetupEnv check
1N/A $self->r(Apache2::RequestUtil->request) unless $self->r;
1N/A my $r = $self->r;
1N/A $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
1N/A $r->pool->cleanup_register(\&CGI::_reset_globals);
1N/A $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
1N/A }
1N/A undef $NPH;
1N/A }
1N/A $self->_reset_globals if $PERLEX;
1N/A $self->init(@initializer);
1N/A return $self;
1N/A}
1N/A
1N/A# We provide a DESTROY method so that we can ensure that
1N/A# temporary files are closed (via Fh->DESTROY) before they
1N/A# are unlinked (via CGITempFile->DESTROY) because it is not
1N/A# possible to unlink an open file on Win32. We explicitly
1N/A# call DESTROY on each, rather than just undefing them and
1N/A# letting Perl DESTROY them by garbage collection, in case the
1N/A# user is still holding any reference to them as well.
1N/Asub DESTROY {
1N/A my $self = shift;
1N/A if ($OS eq 'WINDOWS') {
1N/A for my $href (values %{$self->{'.tmpfiles'}}) {
1N/A $href->{hndl}->DESTROY if defined $href->{hndl};
1N/A $href->{name}->DESTROY if defined $href->{name};
1N/A }
1N/A }
1N/A}
1N/A
1N/Asub r {
1N/A my $self = shift;
1N/A my $r = $self->{'.r'};
1N/A $self->{'.r'} = shift if @_;
1N/A $r;
1N/A}
1N/A
1N/Asub upload_hook {
1N/A my $self;
1N/A if (ref $_[0] eq 'CODE') {
1N/A $CGI::Q = $self = $CGI::DefaultClass->new(@_);
1N/A } else {
1N/A $self = shift;
1N/A }
1N/A my ($hook,$data,$use_tempfile) = @_;
1N/A $self->{'.upload_hook'} = $hook;
1N/A $self->{'.upload_data'} = $data;
1N/A $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
1N/A}
1N/A
1N/A#### Method: param
1N/A# Returns the value(s)of a named parameter.
1N/A# If invoked in a list context, returns the
1N/A# entire list. Otherwise returns the first
1N/A# member of the list.
1N/A# If name is not provided, return a list of all
1N/A# the known parameters names available.
1N/A# If more than one argument is provided, the
1N/A# second and subsequent arguments are used to
1N/A# set the value of the parameter.
1N/A####
1N/Asub param {
1N/A my($self,@p) = self_or_default(@_);
1N/A return $self->all_parameters unless @p;
1N/A my($name,$value,@other);
1N/A
1N/A # For compatibility between old calling style and use_named_parameters() style,
1N/A # we have to special case for a single parameter present.
1N/A if (@p > 1) {
1N/A ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
1N/A my(@values);
1N/A
1N/A if (substr($p[0],0,1) eq '-') {
1N/A @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
1N/A } else {
1N/A for ($value,@other) {
1N/A push(@values,$_) if defined($_);
1N/A }
1N/A }
1N/A # If values is provided, then we set it.
1N/A if (@values or defined $value) {
1N/A $self->add_parameter($name);
1N/A $self->{param}{$name}=[@values];
1N/A }
1N/A } else {
1N/A $name = $p[0];
1N/A }
1N/A
1N/A return unless defined($name) && $self->{param}{$name};
1N/A
1N/A my @result = @{$self->{param}{$name}};
1N/A
1N/A if ($PARAM_UTF8) {
1N/A eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
1N/A @result = map {ref $_ ? $_ : $self->_decode_utf8($_) } @result;
1N/A }
1N/A
1N/A return wantarray ? @result : $result[0];
1N/A}
1N/A
1N/Asub _decode_utf8 {
1N/A my ($self, $val) = @_;
1N/A
1N/A if (Encode::is_utf8($val)) {
1N/A return $val;
1N/A }
1N/A else {
1N/A return Encode::decode(utf8 => $val);
1N/A }
1N/A}
1N/A
1N/Asub self_or_default {
1N/A return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
1N/A unless (defined($_[0]) &&
1N/A (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
1N/A ) {
1N/A $Q = $CGI::DefaultClass->new unless defined($Q);
1N/A unshift(@_,$Q);
1N/A }
1N/A return wantarray ? @_ : $Q;
1N/A}
1N/A
1N/Asub self_or_CGI {
1N/A local $^W=0; # prevent a warning
1N/A if (defined($_[0]) &&
1N/A (substr(ref($_[0]),0,3) eq 'CGI'
1N/A || UNIVERSAL::isa($_[0],'CGI'))) {
1N/A return @_;
1N/A } else {
1N/A return ($DefaultClass,@_);
1N/A }
1N/A}
1N/A
1N/A########################################
1N/A# THESE METHODS ARE MORE OR LESS PRIVATE
1N/A# GO TO THE __DATA__ SECTION TO SEE MORE
1N/A# PUBLIC METHODS
1N/A########################################
1N/A
1N/A# Initialize the query object from the environment.
1N/A# If a parameter list is found, this object will be set
1N/A# to a hash in which parameter names are keys
1N/A# and the values are stored as lists
1N/A# If a keyword list is found, this method creates a bogus
1N/A# parameter list with the single parameter 'keywords'.
1N/A
1N/Asub init {
1N/A my $self = shift;
1N/A my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
1N/A
1N/A my $is_xforms;
1N/A
1N/A my $initializer = shift; # for backward compatibility
1N/A local($/) = "\n";
1N/A
1N/A # set autoescaping on by default
1N/A $self->{'escape'} = 1;
1N/A
1N/A # if we get called more than once, we want to initialize
1N/A # ourselves from the original query (which may be gone
1N/A # if it was read from STDIN originally.)
1N/A if (defined(@QUERY_PARAM) && !defined($initializer)) {
1N/A for my $name (@QUERY_PARAM) {
1N/A my $val = $QUERY_PARAM{$name}; # always an arrayref;
1N/A $self->param('-name'=>$name,'-value'=> $val);
1N/A if (defined $val and ref $val eq 'ARRAY') {
1N/A for my $fh (grep {defined(fileno($_))} @$val) {
1N/A seek($fh,0,0); # reset the filehandle.
1N/A }
1N/A
1N/A }
1N/A }
1N/A $self->charset($QUERY_CHARSET);
1N/A $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
1N/A $self->{'.tmpfiles'} = {%QUERY_TMPFILES};
1N/A return;
1N/A }
1N/A
1N/A $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
1N/A $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
1N/A
1N/A $fh = to_filehandle($initializer) if $initializer;
1N/A
1N/A # set charset to the safe ISO-8859-1
1N/A $self->charset('ISO-8859-1');
1N/A
1N/A METHOD: {
1N/A
1N/A # avoid unreasonably large postings
1N/A if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
1N/A #discard the post, unread
1N/A $self->cgi_error("413 Request entity too large");
1N/A last METHOD;
1N/A }
1N/A
1N/A # Process multipart postings, but only if the initializer is
1N/A # not defined.
1N/A if ($meth eq 'POST'
1N/A && defined($ENV{'CONTENT_TYPE'})
1N/A && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
1N/A && !defined($initializer)
1N/A ) {
1N/A my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
1N/A $self->read_multipart($boundary,$content_length);
1N/A last METHOD;
1N/A }
1N/A
1N/A # Process XForms postings. We know that we have XForms in the
1N/A # following cases:
1N/A # method eq 'POST' && content-type eq 'application/xml'
1N/A # method eq 'POST' && content-type =~ /multipart\/related.+start=/
1N/A # There are more cases, actually, but for now, we don't support other
1N/A # methods for XForm posts.
1N/A # In a XForm POST, the QUERY_STRING is parsed normally.
1N/A # If the content-type is 'application/xml', we just set the param
1N/A # XForms:Model (referring to the xml syntax) param containing the
1N/A # unparsed XML data.
1N/A # In the case of multipart/related we set XForms:Model as above, but
1N/A # the other parts are available as uploads with the Content-ID as the
1N/A # the key.
1N/A # See the URL below for XForms specs on this issue.
1N/A # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
1N/A if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
1N/A if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
1N/A my($param) = 'XForms:Model';
1N/A my($value) = '';
1N/A $self->add_parameter($param);
1N/A $self->read_from_client(\$value,$content_length,0)
1N/A if $content_length > 0;
1N/A push (@{$self->{param}{$param}},$value);
1N/A $is_xforms = 1;
1N/A } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
1N/A my($boundary,$start) = ($1,$2);
1N/A my($param) = 'XForms:Model';
1N/A $self->add_parameter($param);
1N/A my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
1N/A push (@{$self->{param}{$param}},$value);
1N/A if ($MOD_PERL) {
1N/A $query_string = $self->r->args;
1N/A } else {
1N/A $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
1N/A $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
1N/A }
1N/A $is_xforms = 1;
1N/A }
1N/A }
1N/A
1N/A
1N/A # If initializer is defined, then read parameters
1N/A # from it.
1N/A if (!$is_xforms && defined($initializer)) {
1N/A if (UNIVERSAL::isa($initializer,'CGI')) {
1N/A $query_string = $initializer->query_string;
1N/A last METHOD;
1N/A }
1N/A if (ref($initializer) && ref($initializer) eq 'HASH') {
1N/A for (keys %$initializer) {
1N/A $self->param('-name'=>$_,'-value'=>$initializer->{$_});
1N/A }
1N/A last METHOD;
1N/A }
1N/A
1N/A if (defined($fh) && ($fh ne '')) {
1N/A while (my $line = <$fh>) {
1N/A chomp $line;
1N/A last if $line =~ /^=$/;
1N/A push(@lines,$line);
1N/A }
1N/A # massage back into standard format
1N/A if ("@lines" =~ /=/) {
1N/A $query_string=join("&",@lines);
1N/A } else {
1N/A $query_string=join("+",@lines);
1N/A }
1N/A last METHOD;
1N/A }
1N/A
1N/A # last chance -- treat it as a string
1N/A $initializer = $$initializer if ref($initializer) eq 'SCALAR';
1N/A $query_string = $initializer;
1N/A
1N/A last METHOD;
1N/A }
1N/A
1N/A # If method is GET or HEAD, fetch the query from
1N/A # the environment.
1N/A if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
1N/A if ($MOD_PERL) {
1N/A $query_string = $self->r->args;
1N/A } else {
1N/A $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
1N/A $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
1N/A }
1N/A last METHOD;
1N/A }
1N/A
1N/A if ($meth eq 'POST' || $meth eq 'PUT') {
1N/A if ( $content_length > 0 ) {
1N/A $self->read_from_client(\$query_string,$content_length,0);
1N/A }
1N/A elsif (not defined $ENV{CONTENT_LENGTH}) {
1N/A $self->read_from_stdin(\$query_string);
1N/A # should this be PUTDATA in case of PUT ?
1N/A my($param) = $meth . 'DATA' ;
1N/A $self->add_parameter($param) ;
1N/A push (@{$self->{param}{$param}},$query_string);
1N/A undef $query_string ;
1N/A }
1N/A # Some people want to have their cake and eat it too!
1N/A # Uncomment this line to have the contents of the query string
1N/A # APPENDED to the POST data.
1N/A # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
1N/A last METHOD;
1N/A }
1N/A
1N/A # If $meth is not of GET, POST, PUT or HEAD, assume we're
1N/A # being debugged offline.
1N/A # Check the command line and then the standard input for data.
1N/A # We use the shellwords package in order to behave the way that
1N/A # UN*X programmers expect.
1N/A if ($DEBUG)
1N/A {
1N/A my $cmdline_ret = read_from_cmdline();
1N/A $query_string = $cmdline_ret->{'query_string'};
1N/A if (defined($cmdline_ret->{'subpath'}))
1N/A {
1N/A $self->path_info($cmdline_ret->{'subpath'});
1N/A }
1N/A }
1N/A }
1N/A
1N/A# YL: Begin Change for XML handler 10/19/2001
1N/A if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT')
1N/A && defined($ENV{'CONTENT_TYPE'})
1N/A && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
1N/A && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
1N/A my($param) = $meth . 'DATA' ;
1N/A $self->add_parameter($param) ;
1N/A push (@{$self->{param}{$param}},$query_string);
1N/A undef $query_string ;
1N/A }
1N/A# YL: End Change for XML handler 10/19/2001
1N/A
1N/A # We now have the query string in hand. We do slightly
1N/A # different things for keyword lists and parameter lists.
1N/A if (defined $query_string && length $query_string) {
1N/A if ($query_string =~ /[&=;]/) {
1N/A $self->parse_params($query_string);
1N/A } else {
1N/A $self->add_parameter('keywords');
1N/A $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)];
1N/A }
1N/A }
1N/A
1N/A # Special case. Erase everything if there is a field named
1N/A # .defaults.
1N/A if ($self->param('.defaults')) {
1N/A $self->delete_all();
1N/A }
1N/A
1N/A # hash containing our defined fieldnames
1N/A $self->{'.fieldnames'} = {};
1N/A for ($self->param('.cgifields')) {
1N/A $self->{'.fieldnames'}->{$_}++;
1N/A }
1N/A
1N/A # Clear out our default submission button flag if present
1N/A $self->delete('.submit');
1N/A $self->delete('.cgifields');
1N/A
1N/A $self->save_request unless defined $initializer;
1N/A}
1N/A
1N/A# FUNCTIONS TO OVERRIDE:
1N/A# Turn a string into a filehandle
1N/Asub to_filehandle {
1N/A my $thingy = shift;
1N/A return undef unless $thingy;
1N/A return $thingy if UNIVERSAL::isa($thingy,'GLOB');
1N/A return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
1N/A if (!ref($thingy)) {
1N/A my $caller = 1;
1N/A while (my $package = caller($caller++)) {
1N/A my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
1N/A return $tmp if defined(fileno($tmp));
1N/A }
1N/A }
1N/A return undef;
1N/A}
1N/A
1N/A# send output to the browser
1N/Asub put {
1N/A my($self,@p) = self_or_default(@_);
1N/A $self->print(@p);
1N/A}
1N/A
1N/A# print to standard output (for overriding in mod_perl)
1N/Asub print {
1N/A shift;
1N/A CORE::print(@_);
1N/A}
1N/A
1N/A# get/set last cgi_error
1N/Asub cgi_error {
1N/A my ($self,$err) = self_or_default(@_);
1N/A $self->{'.cgi_error'} = $err if defined $err;
1N/A return $self->{'.cgi_error'};
1N/A}
1N/A
1N/Asub save_request {
1N/A my($self) = @_;
1N/A # We're going to play with the package globals now so that if we get called
1N/A # again, we initialize ourselves in exactly the same way. This allows
1N/A # us to have several of these objects.
1N/A @QUERY_PARAM = $self->param; # save list of parameters
1N/A for (@QUERY_PARAM) {
1N/A next unless defined $_;
1N/A $QUERY_PARAM{$_}=$self->{param}{$_};
1N/A }
1N/A $QUERY_CHARSET = $self->charset;
1N/A %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
1N/A %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
1N/A}
1N/A
1N/Asub parse_params {
1N/A my($self,$tosplit) = @_;
1N/A my(@pairs) = split(/[&;]/,$tosplit);
1N/A my($param,$value);
1N/A for (@pairs) {
1N/A ($param,$value) = split('=',$_,2);
1N/A next unless defined $param;
1N/A next if $NO_UNDEF_PARAMS and not defined $value;
1N/A $value = '' unless defined $value;
1N/A $param = unescape($param);
1N/A $value = unescape($value);
1N/A $self->add_parameter($param);
1N/A push (@{$self->{param}{$param}},$value);
1N/A }
1N/A}
1N/A
1N/Asub add_parameter {
1N/A my($self,$param)=@_;
1N/A return unless defined $param;
1N/A push (@{$self->{'.parameters'}},$param)
1N/A unless defined($self->{param}{$param});
1N/A}
1N/A
1N/Asub all_parameters {
1N/A my $self = shift;
1N/A return () unless defined($self) && $self->{'.parameters'};
1N/A return () unless @{$self->{'.parameters'}};
1N/A return @{$self->{'.parameters'}};
1N/A}
1N/A
1N/A# put a filehandle into binary mode (DOS)
1N/Asub binmode {
1N/A return unless defined($_[1]) && defined fileno($_[1]);
1N/A CORE::binmode($_[1]);
1N/A}
1N/A
1N/Asub _make_tag_func {
1N/A my ($self,$tagname) = @_;
1N/A my $func = qq(
1N/A sub $tagname {
1N/A my (\$q,\$a,\@rest) = self_or_default(\@_);
1N/A my(\$attr) = '';
1N/A if (ref(\$a) && ref(\$a) eq 'HASH') {
1N/A my(\@attr) = make_attributes(\$a,\$q->{'escape'});
1N/A \$attr = " \@attr" if \@attr;
1N/A } else {
1N/A unshift \@rest,\$a if defined \$a;
1N/A }
1N/A );
1N/A if ($tagname=~/start_(\w+)/i) {
1N/A $func .= qq! return "<\L$1\E\$attr>";} !;
1N/A } elsif ($tagname=~/end_(\w+)/i) {
1N/A $func .= qq! return "<\L/$1\E>"; } !;
1N/A } else {
1N/A $func .= qq#
1N/A return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
1N/A my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
1N/A my \@result = map { "\$tag\$_\$untag" }
1N/A (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
1N/A return "\@result";
1N/A }#;
1N/A }
1N/Areturn $func;
1N/A}
1N/A
1N/Asub AUTOLOAD {
1N/A print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
1N/A my $func = &_compile;
1N/A goto &$func;
1N/A}
1N/A
1N/Asub _compile {
1N/A my($func) = $AUTOLOAD;
1N/A my($pack,$func_name);
1N/A {
1N/A local($1,$2); # this fixes an obscure variable suicide problem.
1N/A $func=~/(.+)::([^:]+)$/;
1N/A ($pack,$func_name) = ($1,$2);
1N/A $pack=~s/::SUPER$//; # fix another obscure problem
1N/A $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
1N/A unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
1N/A
1N/A my($sub) = \%{"$pack\:\:SUBS"};
1N/A unless (%$sub) {
1N/A my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
1N/A local ($@,$!);
1N/A eval "package $pack; $$auto";
1N/A croak("$AUTOLOAD: $@") if $@;
1N/A $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
1N/A }
1N/A my($code) = $sub->{$func_name};
1N/A
1N/A $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
1N/A if (!$code) {
1N/A (my $base = $func_name) =~ s/^(start_|end_)//i;
1N/A if ($EXPORT{':any'} ||
1N/A $EXPORT{'-any'} ||
1N/A $EXPORT{$base} ||
1N/A (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
1N/A && $EXPORT_OK{$base}) {
1N/A $code = $CGI::DefaultClass->_make_tag_func($func_name);
1N/A }
1N/A }
1N/A croak("Undefined subroutine $AUTOLOAD\n") unless $code;
1N/A local ($@,$!);
1N/A eval "package $pack; $code";
1N/A if ($@) {
1N/A $@ =~ s/ at .*\n//;
1N/A croak("$AUTOLOAD: $@");
1N/A }
1N/A }
1N/A CORE::delete($sub->{$func_name}); #free storage
1N/A return "$pack\:\:$func_name";
1N/A}
1N/A
1N/Asub _selected {
1N/A my $self = shift;
1N/A my $value = shift;
1N/A return '' unless $value;
1N/A return $XHTML ? qq(selected="selected" ) : qq(selected );
1N/A}
1N/A
1N/Asub _checked {
1N/A my $self = shift;
1N/A my $value = shift;
1N/A return '' unless $value;
1N/A return $XHTML ? qq(checked="checked" ) : qq(checked );
1N/A}
1N/A
1N/Asub _reset_globals { initialize_globals(); }
1N/A
1N/Asub _setup_symbols {
1N/A my $self = shift;
1N/A my $compile = 0;
1N/A
1N/A # to avoid reexporting unwanted variables
1N/A undef %EXPORT;
1N/A
1N/A for (@_) {
1N/A $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
1N/A $NPH++, next if /^[:-]nph$/;
1N/A $NOSTICKY++, next if /^[:-]nosticky$/;
1N/A $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
1N/A $DEBUG=2, next if /^[:-][Dd]ebug$/;
1N/A $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
1N/A $PARAM_UTF8++, next if /^[:-]utf8$/;
1N/A $XHTML++, next if /^[:-]xhtml$/;
1N/A $XHTML=0, next if /^[:-]no_?xhtml$/;
1N/A $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
1N/A $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
1N/A $TABINDEX++, next if /^[:-]tabindex$/;
1N/A $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
1N/A $EXPORT{$_}++, next if /^[:-]any$/;
1N/A $compile++, next if /^[:-]compile$/;
1N/A $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
1N/A
1N/A # This is probably extremely evil code -- to be deleted some day.
1N/A if (/^[-]autoload$/) {
1N/A my($pkg) = caller(1);
1N/A *{"${pkg}::AUTOLOAD"} = sub {
1N/A my($routine) = $AUTOLOAD;
1N/A $routine =~ s/^.*::/CGI::/;
1N/A &$routine;
1N/A };
1N/A next;
1N/A }
1N/A
1N/A for (&expand_tags($_)) {
1N/A tr/a-zA-Z0-9_//cd; # don't allow weird function names
1N/A $EXPORT{$_}++;
1N/A }
1N/A }
1N/A _compile_all(keys %EXPORT) if $compile;
1N/A @SAVED_SYMBOLS = @_;
1N/A}
1N/A
1N/Asub charset {
1N/A my ($self,$charset) = self_or_default(@_);
1N/A $self->{'.charset'} = $charset if defined $charset;
1N/A $self->{'.charset'};
1N/A}
1N/A
1N/Asub element_id {
1N/A my ($self,$new_value) = self_or_default(@_);
1N/A $self->{'.elid'} = $new_value if defined $new_value;
1N/A sprintf('%010d',$self->{'.elid'}++);
1N/A}
1N/A
1N/Asub element_tab {
1N/A my ($self,$new_value) = self_or_default(@_);
1N/A $self->{'.etab'} ||= 1;
1N/A $self->{'.etab'} = $new_value if defined $new_value;
1N/A my $tab = $self->{'.etab'}++;
1N/A return '' unless $TABINDEX or defined $new_value;
1N/A return qq(tabindex="$tab" );
1N/A}
1N/A
1N/A###############################################################################
1N/A################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
1N/A###############################################################################
1N/A$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
1N/A$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
1N/A
1N/A%SUBS = (
1N/A
1N/A'URL_ENCODED'=> <<'END_OF_FUNC',
1N/Asub URL_ENCODED { 'application/x-www-form-urlencoded'; }
1N/AEND_OF_FUNC
1N/A
1N/A'MULTIPART' => <<'END_OF_FUNC',
1N/Asub MULTIPART { 'multipart/form-data'; }
1N/AEND_OF_FUNC
1N/A
1N/A'SERVER_PUSH' => <<'END_OF_FUNC',
1N/Asub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
1N/AEND_OF_FUNC
1N/A
1N/A'new_MultipartBuffer' => <<'END_OF_FUNC',
1N/A# Create a new multipart buffer
1N/Asub new_MultipartBuffer {
1N/A my($self,$boundary,$length) = @_;
1N/A return MultipartBuffer->new($self,$boundary,$length);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'read_from_client' => <<'END_OF_FUNC',
1N/A# Read data from a file handle
1N/Asub read_from_client {
1N/A my($self, $buff, $len, $offset) = @_;
1N/A local $^W=0; # prevent a warning
1N/A return $MOD_PERL
1N/A ? $self->r->read($$buff, $len, $offset)
1N/A : read(\*STDIN, $$buff, $len, $offset);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'read_from_stdin' => <<'END_OF_FUNC',
1N/A# Read data from stdin until all is read
1N/Asub read_from_stdin {
1N/A my($self, $buff) = @_;
1N/A local $^W=0; # prevent a warning
1N/A
1N/A #
1N/A # TODO: loop over STDIN until all is read
1N/A #
1N/A
1N/A my($eoffound) = 0;
1N/A my($localbuf) = '';
1N/A my($tempbuf) = '';
1N/A my($bufsiz) = 1024;
1N/A my($res);
1N/A while ($eoffound == 0) {
1N/A if ( $MOD_PERL ) {
1N/A $res = $self->r->read($tempbuf, $bufsiz, 0)
1N/A }
1N/A else {
1N/A $res = read(\*STDIN, $tempbuf, $bufsiz);
1N/A }
1N/A
1N/A if ( !defined($res) ) {
1N/A # TODO: how to do error reporting ?
1N/A $eoffound = 1;
1N/A last;
1N/A }
1N/A if ( $res == 0 ) {
1N/A $eoffound = 1;
1N/A last;
1N/A }
1N/A $localbuf .= $tempbuf;
1N/A }
1N/A
1N/A $$buff = $localbuf;
1N/A
1N/A return $res;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'delete' => <<'END_OF_FUNC',
1N/A#### Method: delete
1N/A# Deletes the named parameter entirely.
1N/A####
1N/Asub delete {
1N/A my($self,@p) = self_or_default(@_);
1N/A my(@names) = rearrange([NAME],@p);
1N/A my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
1N/A my %to_delete;
1N/A for my $name (@to_delete)
1N/A {
1N/A CORE::delete $self->{param}{$name};
1N/A CORE::delete $self->{'.fieldnames'}->{$name};
1N/A $to_delete{$name}++;
1N/A }
1N/A @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
1N/A return;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: import_names
1N/A# Import all parameters into the given namespace.
1N/A# Assumes namespace 'Q' if not specified
1N/A####
1N/A'import_names' => <<'END_OF_FUNC',
1N/Asub import_names {
1N/A my($self,$namespace,$delete) = self_or_default(@_);
1N/A $namespace = 'Q' unless defined($namespace);
1N/A die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
1N/A if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
1N/A # can anyone find an easier way to do this?
1N/A for (keys %{"${namespace}::"}) {
1N/A local *symbol = "${namespace}::${_}";
1N/A undef $symbol;
1N/A undef @symbol;
1N/A undef %symbol;
1N/A }
1N/A }
1N/A my($param,@value,$var);
1N/A for $param ($self->param) {
1N/A # protect against silly names
1N/A ($var = $param)=~tr/a-zA-Z0-9_/_/c;
1N/A $var =~ s/^(?=\d)/_/;
1N/A local *symbol = "${namespace}::$var";
1N/A @value = $self->param($param);
1N/A @symbol = @value;
1N/A $symbol = $value[0];
1N/A }
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: keywords
1N/A# Keywords acts a bit differently. Calling it in a list context
1N/A# returns the list of keywords.
1N/A# Calling it in a scalar context gives you the size of the list.
1N/A####
1N/A'keywords' => <<'END_OF_FUNC',
1N/Asub keywords {
1N/A my($self,@values) = self_or_default(@_);
1N/A # If values is provided, then we set it.
1N/A $self->{param}{'keywords'}=[@values] if @values;
1N/A my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
1N/A @result;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# These are some tie() interfaces for compatibility
1N/A# with Steve Brenner's cgi-lib.pl routines
1N/A'Vars' => <<'END_OF_FUNC',
1N/Asub Vars {
1N/A my $q = shift;
1N/A my %in;
1N/A tie(%in,CGI,$q);
1N/A return %in if wantarray;
1N/A return \%in;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# These are some tie() interfaces for compatibility
1N/A# with Steve Brenner's cgi-lib.pl routines
1N/A'ReadParse' => <<'END_OF_FUNC',
1N/Asub ReadParse {
1N/A local(*in);
1N/A if (@_) {
1N/A *in = $_[0];
1N/A } else {
1N/A my $pkg = caller();
1N/A *in=*{"${pkg}::in"};
1N/A }
1N/A tie(%in,CGI);
1N/A return scalar(keys %in);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'PrintHeader' => <<'END_OF_FUNC',
1N/Asub PrintHeader {
1N/A my($self) = self_or_default(@_);
1N/A return $self->header();
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'HtmlTop' => <<'END_OF_FUNC',
1N/Asub HtmlTop {
1N/A my($self,@p) = self_or_default(@_);
1N/A return $self->start_html(@p);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'HtmlBot' => <<'END_OF_FUNC',
1N/Asub HtmlBot {
1N/A my($self,@p) = self_or_default(@_);
1N/A return $self->end_html(@p);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'SplitParam' => <<'END_OF_FUNC',
1N/Asub SplitParam {
1N/A my ($param) = @_;
1N/A my (@params) = split ("\0", $param);
1N/A return (wantarray ? @params : $params[0]);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'MethGet' => <<'END_OF_FUNC',
1N/Asub MethGet {
1N/A return request_method() eq 'GET';
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'MethPost' => <<'END_OF_FUNC',
1N/Asub MethPost {
1N/A return request_method() eq 'POST';
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'MethPut' => <<'END_OF_FUNC',
1N/Asub MethPut {
1N/A return request_method() eq 'PUT';
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'TIEHASH' => <<'END_OF_FUNC',
1N/Asub TIEHASH {
1N/A my $class = shift;
1N/A my $arg = $_[0];
1N/A if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
1N/A return $arg;
1N/A }
1N/A return $Q ||= $class->new(@_);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'STORE' => <<'END_OF_FUNC',
1N/Asub STORE {
1N/A my $self = shift;
1N/A my $tag = shift;
1N/A my $vals = shift;
1N/A my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
1N/A $self->param(-name=>$tag,-value=>\@vals);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'FETCH' => <<'END_OF_FUNC',
1N/Asub FETCH {
1N/A return $_[0] if $_[1] eq 'CGI';
1N/A return undef unless defined $_[0]->param($_[1]);
1N/A return join("\0",$_[0]->param($_[1]));
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'FIRSTKEY' => <<'END_OF_FUNC',
1N/Asub FIRSTKEY {
1N/A $_[0]->{'.iterator'}=0;
1N/A $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'NEXTKEY' => <<'END_OF_FUNC',
1N/Asub NEXTKEY {
1N/A $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'EXISTS' => <<'END_OF_FUNC',
1N/Asub EXISTS {
1N/A exists $_[0]->{param}{$_[1]};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'DELETE' => <<'END_OF_FUNC',
1N/Asub DELETE {
1N/A $_[0]->delete($_[1]);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'CLEAR' => <<'END_OF_FUNC',
1N/Asub CLEAR {
1N/A %{$_[0]}=();
1N/A}
1N/A####
1N/AEND_OF_FUNC
1N/A
1N/A####
1N/A# Append a new value to an existing query
1N/A####
1N/A'append' => <<'EOF',
1N/Asub append {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
1N/A my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
1N/A if (@values) {
1N/A $self->add_parameter($name);
1N/A push(@{$self->{param}{$name}},@values);
1N/A }
1N/A return $self->param($name);
1N/A}
1N/AEOF
1N/A
1N/A#### Method: delete_all
1N/A# Delete all parameters
1N/A####
1N/A'delete_all' => <<'EOF',
1N/Asub delete_all {
1N/A my($self) = self_or_default(@_);
1N/A my @param = $self->param();
1N/A $self->delete(@param);
1N/A}
1N/AEOF
1N/A
1N/A'Delete' => <<'EOF',
1N/Asub Delete {
1N/A my($self,@p) = self_or_default(@_);
1N/A $self->delete(@p);
1N/A}
1N/AEOF
1N/A
1N/A'Delete_all' => <<'EOF',
1N/Asub Delete_all {
1N/A my($self,@p) = self_or_default(@_);
1N/A $self->delete_all(@p);
1N/A}
1N/AEOF
1N/A
1N/A#### Method: autoescape
1N/A# If you want to turn off the autoescaping features,
1N/A# call this method with undef as the argument
1N/A'autoEscape' => <<'END_OF_FUNC',
1N/Asub autoEscape {
1N/A my($self,$escape) = self_or_default(@_);
1N/A my $d = $self->{'escape'};
1N/A $self->{'escape'} = $escape;
1N/A $d;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: version
1N/A# Return the current version
1N/A####
1N/A'version' => <<'END_OF_FUNC',
1N/Asub version {
1N/A return $VERSION;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: url_param
1N/A# Return a parameter in the QUERY_STRING, regardless of
1N/A# whether this was a POST or a GET
1N/A####
1N/A'url_param' => <<'END_OF_FUNC',
1N/Asub url_param {
1N/A my ($self,@p) = self_or_default(@_);
1N/A my $name = shift(@p);
1N/A return undef unless exists($ENV{QUERY_STRING});
1N/A unless (exists($self->{'.url_param'})) {
1N/A $self->{'.url_param'}={}; # empty hash
1N/A if ($ENV{QUERY_STRING} =~ /=/) {
1N/A my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
1N/A my($param,$value);
1N/A for (@pairs) {
1N/A ($param,$value) = split('=',$_,2);
1N/A $param = unescape($param);
1N/A $value = unescape($value);
1N/A push(@{$self->{'.url_param'}->{$param}},$value);
1N/A }
1N/A } else {
1N/A my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING});
1N/A $self->{'.url_param'}{'keywords'} = \@keywords if @keywords;
1N/A }
1N/A }
1N/A return keys %{$self->{'.url_param'}} unless defined($name);
1N/A return () unless $self->{'.url_param'}->{$name};
1N/A return wantarray ? @{$self->{'.url_param'}->{$name}}
1N/A : $self->{'.url_param'}->{$name}->[0];
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: Dump
1N/A# Returns a string in which all the known parameter/value
1N/A# pairs are represented as nested lists, mainly for the purposes
1N/A# of debugging.
1N/A####
1N/A'Dump' => <<'END_OF_FUNC',
1N/Asub Dump {
1N/A my($self) = self_or_default(@_);
1N/A my($param,$value,@result);
1N/A return '<ul></ul>' unless $self->param;
1N/A push(@result,"<ul>");
1N/A for $param ($self->param) {
1N/A my($name)=$self->_maybe_escapeHTML($param);
1N/A push(@result,"<li><strong>$name</strong></li>");
1N/A push(@result,"<ul>");
1N/A for $value ($self->param($param)) {
1N/A $value = $self->_maybe_escapeHTML($value);
1N/A $value =~ s/\n/<br \/>\n/g;
1N/A push(@result,"<li>$value</li>");
1N/A }
1N/A push(@result,"</ul>");
1N/A }
1N/A push(@result,"</ul>");
1N/A return join("\n",@result);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method as_string
1N/A#
1N/A# synonym for "dump"
1N/A####
1N/A'as_string' => <<'END_OF_FUNC',
1N/Asub as_string {
1N/A &Dump(@_);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: save
1N/A# Write values out to a filehandle in such a way that they can
1N/A# be reinitialized by the filehandle form of the new() method
1N/A####
1N/A'save' => <<'END_OF_FUNC',
1N/Asub save {
1N/A my($self,$filehandle) = self_or_default(@_);
1N/A $filehandle = to_filehandle($filehandle);
1N/A my($param);
1N/A local($,) = ''; # set print field separator back to a sane value
1N/A local($\) = ''; # set output line separator to a sane value
1N/A for $param ($self->param) {
1N/A my($escaped_param) = escape($param);
1N/A my($value);
1N/A for $value ($self->param($param)) {
1N/A print $filehandle "$escaped_param=",escape("$value"),"\n"
1N/A if length($escaped_param) or length($value);
1N/A }
1N/A }
1N/A for (keys %{$self->{'.fieldnames'}}) {
1N/A print $filehandle ".cgifields=",escape("$_"),"\n";
1N/A }
1N/A print $filehandle "=\n"; # end of record
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: save_parameters
1N/A# An alias for save() that is a better name for exportation.
1N/A# Only intended to be used with the function (non-OO) interface.
1N/A####
1N/A'save_parameters' => <<'END_OF_FUNC',
1N/Asub save_parameters {
1N/A my $fh = shift;
1N/A return save(to_filehandle($fh));
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: restore_parameters
1N/A# A way to restore CGI parameters from an initializer.
1N/A# Only intended to be used with the function (non-OO) interface.
1N/A####
1N/A'restore_parameters' => <<'END_OF_FUNC',
1N/Asub restore_parameters {
1N/A $Q = $CGI::DefaultClass->new(@_);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: multipart_init
1N/A# Return a Content-Type: style header for server-push
1N/A# This has to be NPH on most web servers, and it is advisable to set $| = 1
1N/A#
1N/A# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1N/A# contribution, updated by Andrew Benham (adsb@bigfoot.com)
1N/A####
1N/A'multipart_init' => <<'END_OF_FUNC',
1N/Asub multipart_init {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($boundary,@other) = rearrange_header([BOUNDARY],@p);
1N/A if (!$boundary) {
1N/A $boundary = '------- =_';
1N/A my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z');
1N/A for (1..17) {
1N/A $boundary .= $chrs[rand(scalar @chrs)];
1N/A }
1N/A }
1N/A
1N/A $self->{'separator'} = "$CRLF--$boundary$CRLF";
1N/A $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
1N/A $type = SERVER_PUSH($boundary);
1N/A return $self->header(
1N/A -nph => 0,
1N/A -type => $type,
1N/A (map { split "=", $_, 2 } @other),
1N/A ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: multipart_start
1N/A# Return a Content-Type: style header for server-push, start of section
1N/A#
1N/A# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1N/A# contribution, updated by Andrew Benham (adsb@bigfoot.com)
1N/A####
1N/A'multipart_start' => <<'END_OF_FUNC',
1N/Asub multipart_start {
1N/A my(@header);
1N/A my($self,@p) = self_or_default(@_);
1N/A my($type,@other) = rearrange([TYPE],@p);
1N/A $type = $type || 'text/html';
1N/A push(@header,"Content-Type: $type");
1N/A
1N/A # rearrange() was designed for the HTML portion, so we
1N/A # need to fix it up a little.
1N/A for (@other) {
1N/A # Don't use \s because of perl bug 21951
1N/A next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1N/A ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
1N/A }
1N/A push(@header,@other);
1N/A my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1N/A return $header;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: multipart_end
1N/A# Return a MIME boundary separator for server-push, end of section
1N/A#
1N/A# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1N/A# contribution
1N/A####
1N/A'multipart_end' => <<'END_OF_FUNC',
1N/Asub multipart_end {
1N/A my($self,@p) = self_or_default(@_);
1N/A return $self->{'separator'};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: multipart_final
1N/A# Return a MIME boundary separator for server-push, end of all sections
1N/A#
1N/A# Contributed by Andrew Benham (adsb@bigfoot.com)
1N/A####
1N/A'multipart_final' => <<'END_OF_FUNC',
1N/Asub multipart_final {
1N/A my($self,@p) = self_or_default(@_);
1N/A return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: header
1N/A# Return a Content-Type: style header
1N/A#
1N/A####
1N/A'header' => <<'END_OF_FUNC',
1N/Asub header {
1N/A my($self,@p) = self_or_default(@_);
1N/A my(@header);
1N/A
1N/A return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1N/A
1N/A my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
1N/A rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1N/A 'STATUS',['COOKIE','COOKIES'],'TARGET',
1N/A 'EXPIRES','NPH','CHARSET',
1N/A 'ATTACHMENT','P3P'],@p);
1N/A
1N/A # CR escaping for values, per RFC 822
1N/A for my $header ($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
1N/A if (defined $header) {
1N/A # From RFC 822:
1N/A # Unfolding is accomplished by regarding CRLF immediately
1N/A # followed by a LWSP-char as equivalent to the LWSP-char.
1N/A $header =~ s/$CRLF(\s)/$1/g;
1N/A
1N/A # All other uses of newlines are invalid input.
1N/A if ($header =~ m/$CRLF|\015|\012/) {
1N/A # shorten very long values in the diagnostic
1N/A $header = substr($header,0,72).'...' if (length $header > 72);
1N/A die "Invalid header value contains a newline not followed by whitespace: $header";
1N/A }
1N/A }
1N/A }
1N/A
1N/A $nph ||= $NPH;
1N/A
1N/A $type ||= 'text/html' unless defined($type);
1N/A
1N/A # sets if $charset is given, gets if not
1N/A $charset = $self->charset( $charset );
1N/A
1N/A # rearrange() was designed for the HTML portion, so we
1N/A # need to fix it up a little.
1N/A for (@other) {
1N/A # Don't use \s because of perl bug 21951
1N/A next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
1N/A ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
1N/A }
1N/A
1N/A $type .= "; charset=$charset"
1N/A if $type ne ''
1N/A and $type !~ /\bcharset\b/
1N/A and defined $charset
1N/A and $charset ne '';
1N/A
1N/A # Maybe future compatibility. Maybe not.
1N/A my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1N/A push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1N/A push(@header,"Server: " . &server_software()) if $nph;
1N/A
1N/A push(@header,"Status: $status") if $status;
1N/A push(@header,"Window-Target: $target") if $target;
1N/A if ($p3p) {
1N/A $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
1N/A push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
1N/A }
1N/A # push all the cookies -- there may be several
1N/A if ($cookie) {
1N/A my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
1N/A for (@cookie) {
1N/A my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1N/A push(@header,"Set-Cookie: $cs") if $cs ne '';
1N/A }
1N/A }
1N/A # if the user indicates an expiration time, then we need
1N/A # both an Expires and a Date header (so that the browser is
1N/A # uses OUR clock)
1N/A push(@header,"Expires: " . expires($expires,'http'))
1N/A if $expires;
1N/A push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
1N/A push(@header,"Pragma: no-cache") if $self->cache();
1N/A push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
1N/A push(@header,map {ucfirst $_} @other);
1N/A push(@header,"Content-Type: $type") if $type ne '';
1N/A my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1N/A if (($MOD_PERL >= 1) && !$nph) {
1N/A $self->r->send_cgi_header($header);
1N/A return '';
1N/A }
1N/A return $header;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: cache
1N/A# Control whether header() will produce the no-cache
1N/A# Pragma directive.
1N/A####
1N/A'cache' => <<'END_OF_FUNC',
1N/Asub cache {
1N/A my($self,$new_value) = self_or_default(@_);
1N/A $new_value = '' unless $new_value;
1N/A if ($new_value ne '') {
1N/A $self->{'cache'} = $new_value;
1N/A }
1N/A return $self->{'cache'};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: redirect
1N/A# Return a Location: style header
1N/A#
1N/A####
1N/A'redirect' => <<'END_OF_FUNC',
1N/Asub redirect {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($url,$target,$status,$cookie,$nph,@other) =
1N/A rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
1N/A $status = '302 Found' unless defined $status;
1N/A $url ||= $self->self_url;
1N/A my(@o);
1N/A for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1N/A unshift(@o,
1N/A '-Status' => $status,
1N/A '-Location'=> $url,
1N/A '-nph' => $nph);
1N/A unshift(@o,'-Target'=>$target) if $target;
1N/A unshift(@o,'-Type'=>'');
1N/A my @unescaped;
1N/A unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
1N/A return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: start_html
1N/A# Canned HTML header
1N/A#
1N/A# Parameters:
1N/A# $title -> (optional) The title for this HTML document (-title)
1N/A# $author -> (optional) e-mail address of the author (-author)
1N/A# $base -> (optional) if set to true, will enter the BASE address of this document
1N/A# for resolving relative references (-base)
1N/A# $xbase -> (optional) alternative base at some remote location (-xbase)
1N/A# $target -> (optional) target window to load all links into (-target)
1N/A# $script -> (option) Javascript code (-script)
1N/A# $no_script -> (option) Javascript <noscript> tag (-noscript)
1N/A# $meta -> (optional) Meta information tags
1N/A# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
1N/A# (a scalar or array ref)
1N/A# $style -> (optional) reference to an external style sheet
1N/A# @other -> (optional) any other named parameters you'd like to incorporate into
1N/A# the <body> tag.
1N/A####
1N/A'start_html' => <<'END_OF_FUNC',
1N/Asub start_html {
1N/A my($self,@p) = &self_or_default(@_);
1N/A my($title,$author,$base,$xbase,$script,$noscript,
1N/A $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
1N/A rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
1N/A META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
1N/A
1N/A $self->element_id(0);
1N/A $self->element_tab(0);
1N/A
1N/A $encoding = lc($self->charset) unless defined $encoding;
1N/A
1N/A # Need to sort out the DTD before it's okay to call escapeHTML().
1N/A my(@result,$xml_dtd);
1N/A if ($dtd) {
1N/A if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
1N/A $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
1N/A } else {
1N/A $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
1N/A }
1N/A } else {
1N/A $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
1N/A }
1N/A
1N/A $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
1N/A $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
1N/A push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
1N/A
1N/A if (ref($dtd) && ref($dtd) eq 'ARRAY') {
1N/A push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
1N/A $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
1N/A } else {
1N/A push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
1N/A $DTD_PUBLIC_IDENTIFIER = $dtd;
1N/A }
1N/A
1N/A # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
1N/A # call escapeHTML(). Strangely enough, the title needs to be escaped as
1N/A # HTML while the author needs to be escaped as a URL.
1N/A $title = $self->_maybe_escapeHTML($title || 'Untitled Document');
1N/A $author = $self->escape($author);
1N/A
1N/A if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2|4\.01?)/i) {
1N/A $lang = "" unless defined $lang;
1N/A $XHTML = 0;
1N/A }
1N/A else {
1N/A $lang = 'en-US' unless defined $lang;
1N/A }
1N/A
1N/A my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
1N/A my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
1N/A if $XHTML && $encoding && !$declare_xml;
1N/A
1N/A push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
1N/A : ($lang ? qq(<html lang="$lang">) : "<html>")
1N/A . "<head><title>$title</title>");
1N/A if (defined $author) {
1N/A push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
1N/A : "<link rev=\"made\" href=\"mailto:$author\">");
1N/A }
1N/A
1N/A if ($base || $xbase || $target) {
1N/A my $href = $xbase || $self->url('-path'=>1);
1N/A my $t = $target ? qq/ target="$target"/ : '';
1N/A push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
1N/A }
1N/A
1N/A if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1N/A for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
1N/A : qq(<meta name="$_" content="$meta->{$_}">)); }
1N/A }
1N/A
1N/A my $meta_bits_set = 0;
1N/A if( $head ) {
1N/A if( ref $head ) {
1N/A push @result, @$head;
1N/A $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head;
1N/A }
1N/A else {
1N/A push @result, $head;
1N/A $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i;
1N/A }
1N/A }
1N/A
1N/A # handle the infrequently-used -style and -script parameters
1N/A push(@result,$self->_style($style)) if defined $style;
1N/A push(@result,$self->_script($script)) if defined $script;
1N/A push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set;
1N/A
1N/A # handle -noscript parameter
1N/A push(@result,<<END) if $noscript;
1N/A<noscript>
1N/A$noscript
1N/A</noscript>
1N/AEND
1N/A ;
1N/A my($other) = @other ? " @other" : '';
1N/A push(@result,"</head>\n<body$other>\n");
1N/A return join("\n",@result);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A### Method: _style
1N/A# internal method for generating a CSS style section
1N/A####
1N/A'_style' => <<'END_OF_FUNC',
1N/Asub _style {
1N/A my ($self,$style) = @_;
1N/A my (@result);
1N/A
1N/A my $type = 'text/css';
1N/A my $rel = 'stylesheet';
1N/A
1N/A
1N/A my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
1N/A my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
1N/A
1N/A my @s = ref($style) eq 'ARRAY' ? @$style : $style;
1N/A my $other = '';
1N/A
1N/A for my $s (@s) {
1N/A if (ref($s)) {
1N/A my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
1N/A rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
1N/A ('-foo'=>'bar',
1N/A ref($s) eq 'ARRAY' ? @$s : %$s));
1N/A my $type = defined $stype ? $stype : 'text/css';
1N/A my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
1N/A $other = "@other" if @other;
1N/A
1N/A if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
1N/A { # If it is, push a LINK tag for each one
1N/A for $src (@$src)
1N/A {
1N/A push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
1N/A : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
1N/A }
1N/A }
1N/A else
1N/A { # Otherwise, push the single -src, if it exists.
1N/A push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
1N/A : qq(<link rel="$rel" type="$type" href="$src"$other>)
1N/A ) if $src;
1N/A }
1N/A if ($verbatim) {
1N/A my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
1N/A push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v;
1N/A }
1N/A my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
1N/A push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
1N/A
1N/A } else {
1N/A my $src = $s;
1N/A push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
1N/A : qq(<link rel="$rel" type="$type" href="$src"$other>));
1N/A }
1N/A }
1N/A @result;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'_script' => <<'END_OF_FUNC',
1N/Asub _script {
1N/A my ($self,$script) = @_;
1N/A my (@result);
1N/A
1N/A my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1N/A for $script (@scripts) {
1N/A my($src,$code,$language,$charset);
1N/A if (ref($script)) { # script is a hash
1N/A ($src,$code,$type,$charset) =
1N/A rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'],
1N/A '-foo'=>'bar', # a trick to allow the '-' to be omitted
1N/A ref($script) eq 'ARRAY' ? @$script : %$script);
1N/A $type ||= 'text/javascript';
1N/A unless ($type =~ m!\w+/\w+!) {
1N/A $type =~ s/[\d.]+$//;
1N/A $type = "text/$type";
1N/A }
1N/A } else {
1N/A ($src,$code,$type,$charset) = ('',$script, 'text/javascript', '');
1N/A }
1N/A
1N/A my $comment = '//'; # javascript by default
1N/A $comment = '#' if $type=~/perl|tcl/i;
1N/A $comment = "'" if $type=~/vbscript/i;
1N/A
1N/A my ($cdata_start,$cdata_end);
1N/A if ($XHTML) {
1N/A $cdata_start = "$comment<![CDATA[\n";
1N/A $cdata_end .= "\n$comment]]>";
1N/A } else {
1N/A $cdata_start = "\n<!-- Hide script\n";
1N/A $cdata_end = $comment;
1N/A $cdata_end .= " End script hiding -->\n";
1N/A }
1N/A my(@satts);
1N/A push(@satts,'src'=>$src) if $src;
1N/A push(@satts,'type'=>$type);
1N/A push(@satts,'charset'=>$charset) if ($src && $charset);
1N/A $code = $cdata_start . $code . $cdata_end if defined $code;
1N/A push(@result,$self->script({@satts},$code || ''));
1N/A }
1N/A @result;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: end_html
1N/A# End an HTML document.
1N/A# Trivial method for completeness. Just returns "</body>"
1N/A####
1N/A'end_html' => <<'END_OF_FUNC',
1N/Asub end_html {
1N/A return "\n</body>\n</html>";
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A################################
1N/A# METHODS USED IN BUILDING FORMS
1N/A################################
1N/A
1N/A#### Method: isindex
1N/A# Just prints out the isindex tag.
1N/A# Parameters:
1N/A# $action -> optional URL of script to run
1N/A# Returns:
1N/A# A string containing a <isindex> tag
1N/A'isindex' => <<'END_OF_FUNC',
1N/Asub isindex {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($action,@other) = rearrange([ACTION],@p);
1N/A $action = qq/ action="$action"/ if $action;
1N/A my($other) = @other ? " @other" : '';
1N/A return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: startform
1N/A# This method is DEPRECATED
1N/A# Start a form
1N/A# Parameters:
1N/A# $method -> optional submission method to use (GET or POST)
1N/A# $action -> optional URL of script to run
1N/A# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1N/A'startform' => <<'END_OF_FUNC',
1N/Asub startform {
1N/A my($self,@p) = self_or_default(@_);
1N/A
1N/A my($method,$action,$enctype,@other) =
1N/A rearrange([METHOD,ACTION,ENCTYPE],@p);
1N/A
1N/A $method = $self->_maybe_escapeHTML(lc($method || 'post'));
1N/A $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
1N/A if (defined $action) {
1N/A $action = $self->_maybe_escapeHTML($action);
1N/A }
1N/A else {
1N/A $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
1N/A }
1N/A $action = qq(action="$action");
1N/A my($other) = @other ? " @other" : '';
1N/A $self->{'.parametersToAdd'}={};
1N/A return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: start_form
1N/A# Start a form
1N/A# Parameters:
1N/A# $method -> optional submission method to use (GET or POST)
1N/A# $action -> optional URL of script to run
1N/A# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1N/A'start_form' => <<'END_OF_FUNC',
1N/Asub start_form {
1N/A my($self,@p) = self_or_default(@_);
1N/A
1N/A my($method,$action,$enctype,@other) =
1N/A rearrange([METHOD,ACTION,ENCTYPE],@p);
1N/A
1N/A $method = $self->_maybe_escapeHTML(lc($method || 'post'));
1N/A
1N/A if( $XHTML ){
1N/A $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART);
1N/A }else{
1N/A $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
1N/A }
1N/A
1N/A if (defined $action) {
1N/A $action = $self->_maybe_escapeHTML($action);
1N/A }
1N/A else {
1N/A $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
1N/A }
1N/A $action = qq(action="$action");
1N/A my($other) = @other ? " @other" : '';
1N/A $self->{'.parametersToAdd'}={};
1N/A return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: start_multipart_form
1N/A'start_multipart_form' => <<'END_OF_FUNC',
1N/Asub start_multipart_form {
1N/A my($self,@p) = self_or_default(@_);
1N/A if (defined($p[0]) && substr($p[0],0,1) eq '-') {
1N/A return $self->start_form(-enctype=>&MULTIPART,@p);
1N/A } else {
1N/A my($method,$action,@other) =
1N/A rearrange([METHOD,ACTION],@p);
1N/A return $self->start_form($method,$action,&MULTIPART,@other);
1N/A }
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A
1N/A#### Method: end_form
1N/A# End a form
1N/A'end_form' => <<'END_OF_FUNC',
1N/Asub end_form {
1N/A my($self,@p) = self_or_default(@_);
1N/A if ( $NOSTICKY ) {
1N/A return wantarray ? ("</form>") : "\n</form>";
1N/A } else {
1N/A if (my @fields = $self->get_fields) {
1N/A return wantarray ? ("<div>",@fields,"</div>","</form>")
1N/A : "<div>".(join '',@fields)."</div>\n</form>";
1N/A } else {
1N/A return "</form>";
1N/A }
1N/A }
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: end_multipart_form
1N/A# end a multipart form
1N/A'end_multipart_form' => <<'END_OF_FUNC',
1N/Asub end_multipart_form {
1N/A &end_form;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A'_textfield' => <<'END_OF_FUNC',
1N/Asub _textfield {
1N/A my($self,$tag,@p) = self_or_default(@_);
1N/A my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
1N/A rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
1N/A
1N/A my $current = $override ? $default :
1N/A (defined($self->param($name)) ? $self->param($name) : $default);
1N/A
1N/A $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : '';
1N/A $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
1N/A my($s) = defined($size) ? qq/ size="$size"/ : '';
1N/A my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
1N/A my($other) = @other ? " @other" : '';
1N/A # this entered at cristy's request to fix problems with file upload fields
1N/A # and WebTV -- not sure it won't break stuff
1N/A my($value) = $current ne '' ? qq(value="$current") : '';
1N/A $tabindex = $self->element_tab($tabindex);
1N/A return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
1N/A : qq(<input type="$tag" name="$name" $value$s$m$other>);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: textfield
1N/A# Parameters:
1N/A# $name -> Name of the text field
1N/A# $default -> Optional default value of the field if not
1N/A# already defined.
1N/A# $size -> Optional width of field in characaters.
1N/A# $maxlength -> Optional maximum number of characters.
1N/A# Returns:
1N/A# A string containing a <input type="text"> field
1N/A#
1N/A'textfield' => <<'END_OF_FUNC',
1N/Asub textfield {
1N/A my($self,@p) = self_or_default(@_);
1N/A $self->_textfield('text',@p);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: filefield
1N/A# Parameters:
1N/A# $name -> Name of the file upload field
1N/A# $size -> Optional width of field in characaters.
1N/A# $maxlength -> Optional maximum number of characters.
1N/A# Returns:
1N/A# A string containing a <input type="file"> field
1N/A#
1N/A'filefield' => <<'END_OF_FUNC',
1N/Asub filefield {
1N/A my($self,@p) = self_or_default(@_);
1N/A $self->_textfield('file',@p);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: password
1N/A# Create a "secret password" entry field
1N/A# Parameters:
1N/A# $name -> Name of the field
1N/A# $default -> Optional default value of the field if not
1N/A# already defined.
1N/A# $size -> Optional width of field in characters.
1N/A# $maxlength -> Optional maximum characters that can be entered.
1N/A# Returns:
1N/A# A string containing a <input type="password"> field
1N/A#
1N/A'password_field' => <<'END_OF_FUNC',
1N/Asub password_field {
1N/A my ($self,@p) = self_or_default(@_);
1N/A $self->_textfield('password',@p);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: textarea
1N/A# Parameters:
1N/A# $name -> Name of the text field
1N/A# $default -> Optional default value of the field if not
1N/A# already defined.
1N/A# $rows -> Optional number of rows in text area
1N/A# $columns -> Optional number of columns in text area
1N/A# Returns:
1N/A# A string containing a <textarea></textarea> tag
1N/A#
1N/A'textarea' => <<'END_OF_FUNC',
1N/Asub textarea {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($name,$default,$rows,$cols,$override,$tabindex,@other) =
1N/A rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
1N/A
1N/A my($current)= $override ? $default :
1N/A (defined($self->param($name)) ? $self->param($name) : $default);
1N/A
1N/A $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
1N/A $current = defined($current) ? $self->_maybe_escapeHTML($current) : '';
1N/A my($r) = $rows ? qq/ rows="$rows"/ : '';
1N/A my($c) = $cols ? qq/ cols="$cols"/ : '';
1N/A my($other) = @other ? " @other" : '';
1N/A $tabindex = $self->element_tab($tabindex);
1N/A return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: button
1N/A# Create a javascript button.
1N/A# Parameters:
1N/A# $name -> (optional) Name for the button. (-name)
1N/A# $value -> (optional) Value of the button when selected (and visible name) (-value)
1N/A# $onclick -> (optional) Text of the JavaScript to run when the button is
1N/A# clicked.
1N/A# Returns:
1N/A# A string containing a <input type="button"> tag
1N/A####
1N/A'button' => <<'END_OF_FUNC',
1N/Asub button {
1N/A my($self,@p) = self_or_default(@_);
1N/A
1N/A my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
1N/A [ONCLICK,SCRIPT],TABINDEX],@p);
1N/A
1N/A $label=$self->_maybe_escapeHTML($label);
1N/A $value=$self->_maybe_escapeHTML($value,1);
1N/A $script=$self->_maybe_escapeHTML($script);
1N/A
1N/A $script ||= '';
1N/A
1N/A my($name) = '';
1N/A $name = qq/ name="$label"/ if $label;
1N/A $value = $value || $label;
1N/A my($val) = '';
1N/A $val = qq/ value="$value"/ if $value;
1N/A $script = qq/ onclick="$script"/ if $script;
1N/A my($other) = @other ? " @other" : '';
1N/A $tabindex = $self->element_tab($tabindex);
1N/A return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
1N/A : qq(<input type="button"$name$val$script$other>);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: submit
1N/A# Create a "submit query" button.
1N/A# Parameters:
1N/A# $name -> (optional) Name for the button.
1N/A# $value -> (optional) Value of the button when selected (also doubles as label).
1N/A# $label -> (optional) Label printed on the button(also doubles as the value).
1N/A# Returns:
1N/A# A string containing a <input type="submit"> tag
1N/A####
1N/A'submit' => <<'END_OF_FUNC',
1N/Asub submit {
1N/A my($self,@p) = self_or_default(@_);
1N/A
1N/A my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
1N/A
1N/A $label=$self->_maybe_escapeHTML($label);
1N/A $value=$self->_maybe_escapeHTML($value,1);
1N/A
1N/A my $name = $NOSTICKY ? '' : 'name=".submit" ';
1N/A $name = qq/name="$label" / if defined($label);
1N/A $value = defined($value) ? $value : $label;
1N/A my $val = '';
1N/A $val = qq/value="$value" / if defined($value);
1N/A $tabindex = $self->element_tab($tabindex);
1N/A my($other) = @other ? "@other " : '';
1N/A return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
1N/A : qq(<input type="submit" $name$val$other>);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: reset
1N/A# Create a "reset" button.
1N/A# Parameters:
1N/A# $name -> (optional) Name for the button.
1N/A# Returns:
1N/A# A string containing a <input type="reset"> tag
1N/A####
1N/A'reset' => <<'END_OF_FUNC',
1N/Asub reset {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
1N/A $label=$self->_maybe_escapeHTML($label);
1N/A $value=$self->_maybe_escapeHTML($value,1);
1N/A my ($name) = ' name=".reset"';
1N/A $name = qq/ name="$label"/ if defined($label);
1N/A $value = defined($value) ? $value : $label;
1N/A my($val) = '';
1N/A $val = qq/ value="$value"/ if defined($value);
1N/A my($other) = @other ? " @other" : '';
1N/A $tabindex = $self->element_tab($tabindex);
1N/A return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
1N/A : qq(<input type="reset"$name$val$other>);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: defaults
1N/A# Create a "defaults" button.
1N/A# Parameters:
1N/A# $name -> (optional) Name for the button.
1N/A# Returns:
1N/A# A string containing a <input type="submit" name=".defaults"> tag
1N/A#
1N/A# Note: this button has a special meaning to the initialization script,
1N/A# and tells it to ERASE the current query string so that your defaults
1N/A# are used again!
1N/A####
1N/A'defaults' => <<'END_OF_FUNC',
1N/Asub defaults {
1N/A my($self,@p) = self_or_default(@_);
1N/A
1N/A my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
1N/A
1N/A $label=$self->_maybe_escapeHTML($label,1);
1N/A $label = $label || "Defaults";
1N/A my($value) = qq/ value="$label"/;
1N/A my($other) = @other ? " @other" : '';
1N/A $tabindex = $self->element_tab($tabindex);
1N/A return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
1N/A : qq/<input type="submit" NAME=".defaults"$value$other>/;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: comment
1N/A# Create an HTML <!-- comment -->
1N/A# Parameters: a string
1N/A'comment' => <<'END_OF_FUNC',
1N/Asub comment {
1N/A my($self,@p) = self_or_CGI(@_);
1N/A return "<!-- @p -->";
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: checkbox
1N/A# Create a checkbox that is not logically linked to any others.
1N/A# The field value is "on" when the button is checked.
1N/A# Parameters:
1N/A# $name -> Name of the checkbox
1N/A# $checked -> (optional) turned on by default if true
1N/A# $value -> (optional) value of the checkbox, 'on' by default
1N/A# $label -> (optional) a user-readable label printed next to the box.
1N/A# Otherwise the checkbox name is used.
1N/A# Returns:
1N/A# A string containing a <input type="checkbox"> field
1N/A####
1N/A'checkbox' => <<'END_OF_FUNC',
1N/Asub checkbox {
1N/A my($self,@p) = self_or_default(@_);
1N/A
1N/A my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) =
1N/A rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
1N/A [OVERRIDE,FORCE],TABINDEX],@p);
1N/A
1N/A $value = defined $value ? $value : 'on';
1N/A
1N/A if (!$override && ($self->{'.fieldnames'}->{$name} ||
1N/A defined $self->param($name))) {
1N/A $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
1N/A } else {
1N/A $checked = $self->_checked($checked);
1N/A }
1N/A my($the_label) = defined $label ? $label : $name;
1N/A $name = $self->_maybe_escapeHTML($name);
1N/A $value = $self->_maybe_escapeHTML($value,1);
1N/A $the_label = $self->_maybe_escapeHTML($the_label);
1N/A my($other) = @other ? "@other " : '';
1N/A $tabindex = $self->element_tab($tabindex);
1N/A $self->register_parameter($name);
1N/A return $XHTML ? CGI::label($labelattributes,
1N/A qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
1N/A : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A
1N/A# Escape HTML
1N/A'escapeHTML' => <<'END_OF_FUNC',
1N/Asub escapeHTML {
1N/A # hack to work around earlier hacks
1N/A push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
1N/A my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
1N/A return undef unless defined($toencode);
1N/A $toencode =~ s{&}{&amp;}gso;
1N/A $toencode =~ s{<}{&lt;}gso;
1N/A $toencode =~ s{>}{&gt;}gso;
1N/A if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
1N/A # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
1N/A # <http://validator.w3.org/docs/errors.html#bad-entity> /
1N/A # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
1N/A $toencode =~ s{"}{&#34;}gso;
1N/A }
1N/A else {
1N/A $toencode =~ s{"}{&quot;}gso;
1N/A }
1N/A
1N/A # Handle bug in some browsers with Latin charsets
1N/A if ($self->{'.charset'}
1N/A && (uc($self->{'.charset'}) eq 'ISO-8859-1'
1N/A || uc($self->{'.charset'}) eq 'WINDOWS-1252')) {
1N/A $toencode =~ s{'}{&#39;}gso;
1N/A $toencode =~ s{\x8b}{&#8249;}gso;
1N/A $toencode =~ s{\x9b}{&#8250;}gso;
1N/A if (defined $newlinestoo && $newlinestoo) {
1N/A $toencode =~ s{\012}{&#10;}gso;
1N/A $toencode =~ s{\015}{&#13;}gso;
1N/A }
1N/A }
1N/A return $toencode;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# unescape HTML -- used internally
1N/A'unescapeHTML' => <<'END_OF_FUNC',
1N/Asub unescapeHTML {
1N/A # hack to work around earlier hacks
1N/A push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
1N/A my ($self,$string) = CGI::self_or_default(@_);
1N/A return undef unless defined($string);
1N/A my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
1N/A : 1;
1N/A # thanks to Randal Schwartz for the correct solution to this one
1N/A $string=~ s[&(\S*?);]{
1N/A local $_ = $1;
1N/A /^amp$/i ? "&" :
1N/A /^quot$/i ? '"' :
1N/A /^gt$/i ? ">" :
1N/A /^lt$/i ? "<" :
1N/A /^#(\d+)$/ && $latin ? chr($1) :
1N/A /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
1N/A $_
1N/A }gex;
1N/A return $string;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# Internal procedure - don't use
1N/A'_tableize' => <<'END_OF_FUNC',
1N/Asub _tableize {
1N/A my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1N/A my @rowheaders = $rowheaders ? @$rowheaders : ();
1N/A my @colheaders = $colheaders ? @$colheaders : ();
1N/A my($result);
1N/A
1N/A if (defined($columns)) {
1N/A $rows = int(0.99 + @elements/$columns) unless defined($rows);
1N/A }
1N/A if (defined($rows)) {
1N/A $columns = int(0.99 + @elements/$rows) unless defined($columns);
1N/A }
1N/A
1N/A # rearrange into a pretty table
1N/A $result = "<table>";
1N/A my($row,$column);
1N/A unshift(@colheaders,'') if @colheaders && @rowheaders;
1N/A $result .= "<tr>" if @colheaders;
1N/A for (@colheaders) {
1N/A $result .= "<th>$_</th>";
1N/A }
1N/A for ($row=0;$row<$rows;$row++) {
1N/A $result .= "<tr>";
1N/A $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
1N/A for ($column=0;$column<$columns;$column++) {
1N/A $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
1N/A if defined($elements[$column*$rows + $row]);
1N/A }
1N/A $result .= "</tr>";
1N/A }
1N/A $result .= "</table>";
1N/A return $result;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: radio_group
1N/A# Create a list of logically-linked radio buttons.
1N/A# Parameters:
1N/A# $name -> Common name for all the buttons.
1N/A# $values -> A pointer to a regular array containing the
1N/A# values for each button in the group.
1N/A# $default -> (optional) Value of the button to turn on by default. Pass '-'
1N/A# to turn _nothing_ on.
1N/A# $linebreak -> (optional) Set to true to place linebreaks
1N/A# between the buttons.
1N/A# $labels -> (optional)
1N/A# A pointer to a hash of labels to print next to each checkbox
1N/A# in the form $label{'value'}="Long explanatory label".
1N/A# Otherwise the provided values are used as the labels.
1N/A# Returns:
1N/A# An ARRAY containing a series of <input type="radio"> fields
1N/A####
1N/A'radio_group' => <<'END_OF_FUNC',
1N/Asub radio_group {
1N/A my($self,@p) = self_or_default(@_);
1N/A $self->_box_group('radio',@p);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: checkbox_group
1N/A# Create a list of logically-linked checkboxes.
1N/A# Parameters:
1N/A# $name -> Common name for all the check boxes
1N/A# $values -> A pointer to a regular array containing the
1N/A# values for each checkbox in the group.
1N/A# $defaults -> (optional)
1N/A# 1. If a pointer to a regular array of checkbox values,
1N/A# then this will be used to decide which
1N/A# checkboxes to turn on by default.
1N/A# 2. If a scalar, will be assumed to hold the
1N/A# value of a single checkbox in the group to turn on.
1N/A# $linebreak -> (optional) Set to true to place linebreaks
1N/A# between the buttons.
1N/A# $labels -> (optional)
1N/A# A pointer to a hash of labels to print next to each checkbox
1N/A# in the form $label{'value'}="Long explanatory label".
1N/A# Otherwise the provided values are used as the labels.
1N/A# Returns:
1N/A# An ARRAY containing a series of <input type="checkbox"> fields
1N/A####
1N/A
1N/A'checkbox_group' => <<'END_OF_FUNC',
1N/Asub checkbox_group {
1N/A my($self,@p) = self_or_default(@_);
1N/A $self->_box_group('checkbox',@p);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'_box_group' => <<'END_OF_FUNC',
1N/Asub _box_group {
1N/A my $self = shift;
1N/A my $box_type = shift;
1N/A
1N/A my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
1N/A $attributes,$rows,$columns,$rowheaders,$colheaders,
1N/A $override,$nolabels,$tabindex,$disabled,@other) =
1N/A rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
1N/A ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
1N/A [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
1N/A ],@_);
1N/A
1N/A
1N/A my($result,$checked,@elements,@values);
1N/A
1N/A @values = $self->_set_values_and_labels($values,\$labels,$name);
1N/A my %checked = $self->previous_or_default($name,$defaults,$override);
1N/A
1N/A # If no check array is specified, check the first by default
1N/A $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
1N/A
1N/A $name=$self->_maybe_escapeHTML($name);
1N/A
1N/A my %tabs = ();
1N/A if ($TABINDEX && $tabindex) {
1N/A if (!ref $tabindex) {
1N/A $self->element_tab($tabindex);
1N/A } elsif (ref $tabindex eq 'ARRAY') {
1N/A %tabs = map {$_=>$self->element_tab} @$tabindex;
1N/A } elsif (ref $tabindex eq 'HASH') {
1N/A %tabs = %$tabindex;
1N/A }
1N/A }
1N/A %tabs = map {$_=>$self->element_tab} @values unless %tabs;
1N/A my $other = @other ? "@other " : '';
1N/A my $radio_checked;
1N/A
1N/A # for disabling groups of radio/checkbox buttons
1N/A my %disabled;
1N/A for (@{$disabled}) {
1N/A $disabled{$_}=1;
1N/A }
1N/A
1N/A for (@values) {
1N/A my $disable="";
1N/A if ($disabled{$_}) {
1N/A $disable="disabled='1'";
1N/A }
1N/A
1N/A my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
1N/A : $checked{$_});
1N/A my($break);
1N/A if ($linebreak) {
1N/A $break = $XHTML ? "<br />" : "<br>";
1N/A }
1N/A else {
1N/A $break = '';
1N/A }
1N/A my($label)='';
1N/A unless (defined($nolabels) && $nolabels) {
1N/A $label = $_;
1N/A $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1N/A $label = $self->_maybe_escapeHTML($label,1);
1N/A $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
1N/A }
1N/A my $attribs = $self->_set_attributes($_, $attributes);
1N/A my $tab = $tabs{$_};
1N/A $_=$self->_maybe_escapeHTML($_);
1N/A
1N/A if ($XHTML) {
1N/A push @elements,
1N/A CGI::label($labelattributes,
1N/A qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
1N/A } else {
1N/A push(@elements,qq/<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable>${label}${break}/);
1N/A }
1N/A }
1N/A $self->register_parameter($name);
1N/A return wantarray ? @elements : "@elements"
1N/A unless defined($columns) || defined($rows);
1N/A return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: popup_menu
1N/A# Create a popup menu.
1N/A# Parameters:
1N/A# $name -> Name for all the menu
1N/A# $values -> A pointer to a regular array containing the
1N/A# text of each menu item.
1N/A# $default -> (optional) Default item to display
1N/A# $labels -> (optional)
1N/A# A pointer to a hash of labels to print next to each checkbox
1N/A# in the form $label{'value'}="Long explanatory label".
1N/A# Otherwise the provided values are used as the labels.
1N/A# Returns:
1N/A# A string containing the definition of a popup menu.
1N/A####
1N/A'popup_menu' => <<'END_OF_FUNC',
1N/Asub popup_menu {
1N/A my($self,@p) = self_or_default(@_);
1N/A
1N/A my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
1N/A rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
1N/A ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
1N/A my($result,%selected);
1N/A
1N/A if (!$override && defined($self->param($name))) {
1N/A $selected{$self->param($name)}++;
1N/A } elsif (defined $default) {
1N/A %selected = map {$_=>1} ref($default) eq 'ARRAY'
1N/A ? @$default
1N/A : $default;
1N/A }
1N/A $name=$self->_maybe_escapeHTML($name);
1N/A my($other) = @other ? " @other" : '';
1N/A
1N/A my(@values);
1N/A @values = $self->_set_values_and_labels($values,\$labels,$name);
1N/A $tabindex = $self->element_tab($tabindex);
1N/A $name = q{} if ! defined $name;
1N/A $result = qq/<select name="$name" $tabindex$other>\n/;
1N/A for (@values) {
1N/A if (/<optgroup/) {
1N/A for my $v (split(/\n/)) {
1N/A my $selectit = $XHTML ? 'selected="selected"' : 'selected';
1N/A for my $selected (keys %selected) {
1N/A $v =~ s/(value="\Q$selected\E")/$selectit $1/;
1N/A }
1N/A $result .= "$v\n";
1N/A }
1N/A }
1N/A else {
1N/A my $attribs = $self->_set_attributes($_, $attributes);
1N/A my($selectit) = $self->_selected($selected{$_});
1N/A my($label) = $_;
1N/A $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1N/A my($value) = $self->_maybe_escapeHTML($_);
1N/A $label = $self->_maybe_escapeHTML($label,1);
1N/A $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
1N/A }
1N/A }
1N/A
1N/A $result .= "</select>";
1N/A return $result;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: optgroup
1N/A# Create a optgroup.
1N/A# Parameters:
1N/A# $name -> Label for the group
1N/A# $values -> A pointer to a regular array containing the
1N/A# values for each option line in the group.
1N/A# $labels -> (optional)
1N/A# A pointer to a hash of labels to print next to each item
1N/A# in the form $label{'value'}="Long explanatory label".
1N/A# Otherwise the provided values are used as the labels.
1N/A# $labeled -> (optional)
1N/A# A true value indicates the value should be used as the label attribute
1N/A# in the option elements.
1N/A# The label attribute specifies the option label presented to the user.
1N/A# This defaults to the content of the <option> element, but the label
1N/A# attribute allows authors to more easily use optgroup without sacrificing
1N/A# compatibility with browsers that do not support option groups.
1N/A# $novals -> (optional)
1N/A# A true value indicates to suppress the val attribute in the option elements
1N/A# Returns:
1N/A# A string containing the definition of an option group.
1N/A####
1N/A'optgroup' => <<'END_OF_FUNC',
1N/Asub optgroup {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($name,$values,$attributes,$labeled,$noval,$labels,@other)
1N/A = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
1N/A
1N/A my($result,@values);
1N/A @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
1N/A my($other) = @other ? " @other" : '';
1N/A
1N/A $name = $self->_maybe_escapeHTML($name) || q{};
1N/A $result = qq/<optgroup label="$name"$other>\n/;
1N/A for (@values) {
1N/A if (/<optgroup/) {
1N/A for (split(/\n/)) {
1N/A my $selectit = $XHTML ? 'selected="selected"' : 'selected';
1N/A s/(value="$selected")/$selectit $1/ if defined $selected;
1N/A $result .= "$_\n";
1N/A }
1N/A }
1N/A else {
1N/A my $attribs = $self->_set_attributes($_, $attributes);
1N/A my($label) = $_;
1N/A $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1N/A $label=$self->_maybe_escapeHTML($label);
1N/A my($value)=$self->_maybe_escapeHTML($_,1);
1N/A $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
1N/A : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
1N/A : $novals ? "<option$attribs>$label</option>\n"
1N/A : "<option$attribs value=\"$value\">$label</option>\n";
1N/A }
1N/A }
1N/A $result .= "</optgroup>";
1N/A return $result;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: scrolling_list
1N/A# Create a scrolling list.
1N/A# Parameters:
1N/A# $name -> name for the list
1N/A# $values -> A pointer to a regular array containing the
1N/A# values for each option line in the list.
1N/A# $defaults -> (optional)
1N/A# 1. If a pointer to a regular array of options,
1N/A# then this will be used to decide which
1N/A# lines to turn on by default.
1N/A# 2. Otherwise holds the value of the single line to turn on.
1N/A# $size -> (optional) Size of the list.
1N/A# $multiple -> (optional) If set, allow multiple selections.
1N/A# $labels -> (optional)
1N/A# A pointer to a hash of labels to print next to each checkbox
1N/A# in the form $label{'value'}="Long explanatory label".
1N/A# Otherwise the provided values are used as the labels.
1N/A# Returns:
1N/A# A string containing the definition of a scrolling list.
1N/A####
1N/A'scrolling_list' => <<'END_OF_FUNC',
1N/Asub scrolling_list {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
1N/A = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1N/A SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
1N/A
1N/A my($result,@values);
1N/A @values = $self->_set_values_and_labels($values,\$labels,$name);
1N/A
1N/A $size = $size || scalar(@values);
1N/A
1N/A my(%selected) = $self->previous_or_default($name,$defaults,$override);
1N/A
1N/A my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
1N/A my($has_size) = $size ? qq/ size="$size"/: '';
1N/A my($other) = @other ? " @other" : '';
1N/A
1N/A $name=$self->_maybe_escapeHTML($name);
1N/A $tabindex = $self->element_tab($tabindex);
1N/A $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
1N/A for (@values) {
1N/A if (/<optgroup/) {
1N/A for my $v (split(/\n/)) {
1N/A my $selectit = $XHTML ? 'selected="selected"' : 'selected';
1N/A for my $selected (keys %selected) {
1N/A $v =~ s/(value="$selected")/$selectit $1/;
1N/A }
1N/A $result .= "$v\n";
1N/A }
1N/A }
1N/A else {
1N/A my $attribs = $self->_set_attributes($_, $attributes);
1N/A my($selectit) = $self->_selected($selected{$_});
1N/A my($label) = $_;
1N/A $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1N/A my($value) = $self->_maybe_escapeHTML($_);
1N/A $label = $self->_maybe_escapeHTML($label,1);
1N/A $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
1N/A }
1N/A }
1N/A
1N/A $result .= "</select>";
1N/A $self->register_parameter($name);
1N/A return $result;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: hidden
1N/A# Parameters:
1N/A# $name -> Name of the hidden field
1N/A# @default -> (optional) Initial values of field (may be an array)
1N/A# or
1N/A# $default->[initial values of field]
1N/A# Returns:
1N/A# A string containing a <input type="hidden" name="name" value="value">
1N/A####
1N/A'hidden' => <<'END_OF_FUNC',
1N/Asub hidden {
1N/A my($self,@p) = self_or_default(@_);
1N/A
1N/A # this is the one place where we departed from our standard
1N/A # calling scheme, so we have to special-case (darn)
1N/A my(@result,@value);
1N/A my($name,$default,$override,@other) =
1N/A rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
1N/A
1N/A my $do_override = 0;
1N/A if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
1N/A @value = ref($default) ? @{$default} : $default;
1N/A $do_override = $override;
1N/A } else {
1N/A for ($default,$override,@other) {
1N/A push(@value,$_) if defined($_);
1N/A }
1N/A undef @other;
1N/A }
1N/A
1N/A # use previous values if override is not set
1N/A my @prev = $self->param($name);
1N/A @value = @prev if !$do_override && @prev;
1N/A
1N/A $name=$self->_maybe_escapeHTML($name);
1N/A for (@value) {
1N/A $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : '';
1N/A push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
1N/A : qq(<input type="hidden" name="$name" value="$_" @other>);
1N/A }
1N/A return wantarray ? @result : join('',@result);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: image_button
1N/A# Parameters:
1N/A# $name -> Name of the button
1N/A# $src -> URL of the image source
1N/A# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
1N/A# Returns:
1N/A# A string containing a <input type="image" name="name" src="url" align="alignment">
1N/A####
1N/A'image_button' => <<'END_OF_FUNC',
1N/Asub image_button {
1N/A my($self,@p) = self_or_default(@_);
1N/A
1N/A my($name,$src,$alignment,@other) =
1N/A rearrange([NAME,SRC,ALIGN],@p);
1N/A
1N/A my($align) = $alignment ? " align=\L\"$alignment\"" : '';
1N/A my($other) = @other ? " @other" : '';
1N/A $name=$self->_maybe_escapeHTML($name);
1N/A return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
1N/A : qq/<input type="image" name="$name" src="$src"$align$other>/;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: self_url
1N/A# Returns a URL containing the current script and all its
1N/A# param/value pairs arranged as a query. You can use this
1N/A# to create a link that, when selected, will reinvoke the
1N/A# script with all its state information preserved.
1N/A####
1N/A'self_url' => <<'END_OF_FUNC',
1N/Asub self_url {
1N/A my($self,@p) = self_or_default(@_);
1N/A return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A# This is provided as a synonym to self_url() for people unfortunate
1N/A# enough to have incorporated it into their programs already!
1N/A'state' => <<'END_OF_FUNC',
1N/Asub state {
1N/A &self_url;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: url
1N/A# Like self_url, but doesn't return the query string part of
1N/A# the URL.
1N/A####
1N/A'url' => <<'END_OF_FUNC',
1N/Asub url {
1N/A my($self,@p) = self_or_default(@_);
1N/A my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
1N/A rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
1N/A my $url = '';
1N/A $full++ if $base || !($relative || $absolute);
1N/A $rewrite++ unless defined $rewrite;
1N/A
1N/A my $path = $self->path_info;
1N/A my $script_name = $self->script_name;
1N/A my $request_uri = unescape($self->request_uri) || '';
1N/A my $query_str = $self->query_string;
1N/A
1N/A my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
1N/A undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
1N/A
1N/A my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
1N/A $uri =~ s/\?.*$//s; # remove query string
1N/A $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO};
1N/A# $uri =~ s/\Q$path\E$// if defined $path; # remove path
1N/A
1N/A if ($full) {
1N/A my $protocol = $self->protocol();
1N/A $url = "$protocol://";
1N/A my $vh = http('x_forwarded_host') || http('host') || '';
1N/A $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
1N/A
1N/A $url .= $vh || server_name();
1N/A
1N/A my $port = $self->virtual_port;
1N/A
1N/A # add the port to the url unless it's the protocol's default port
1N/A $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80)
1N/A or (lc($protocol) eq 'https' && $port == 443);
1N/A
1N/A return $url if $base;
1N/A
1N/A $url .= $uri;
1N/A } elsif ($relative) {
1N/A ($url) = $uri =~ m!([^/]+)$!;
1N/A } elsif ($absolute) {
1N/A $url = $uri;
1N/A }
1N/A
1N/A $url .= $path if $path_info and defined $path;
1N/A $url .= "?$query_str" if $query and $query_str ne '';
1N/A $url ||= '';
1N/A $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
1N/A return $url;
1N/A}
1N/A
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: cookie
1N/A# Set or read a cookie from the specified name.
1N/A# Cookie can then be passed to header().
1N/A# Usual rules apply to the stickiness of -value.
1N/A# Parameters:
1N/A# -name -> name for this cookie (optional)
1N/A# -value -> value of this cookie (scalar, array or hash)
1N/A# -path -> paths for which this cookie is valid (optional)
1N/A# -domain -> internet domain in which this cookie is valid (optional)
1N/A# -secure -> if true, cookie only passed through secure channel (optional)
1N/A# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
1N/A####
1N/A'cookie' => <<'END_OF_FUNC',
1N/Asub cookie {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($name,$value,$path,$domain,$secure,$expires,$httponly) =
1N/A rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
1N/A
1N/A require CGI::Cookie;
1N/A
1N/A # if no value is supplied, then we retrieve the
1N/A # value of the cookie, if any. For efficiency, we cache the parsed
1N/A # cookies in our state variables.
1N/A unless ( defined($value) ) {
1N/A $self->{'.cookies'} = CGI::Cookie->fetch;
1N/A
1N/A # If no name is supplied, then retrieve the names of all our cookies.
1N/A return () unless $self->{'.cookies'};
1N/A return keys %{$self->{'.cookies'}} unless $name;
1N/A return () unless $self->{'.cookies'}->{$name};
1N/A return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
1N/A }
1N/A
1N/A # If we get here, we're creating a new cookie
1N/A return undef unless defined($name) && $name ne ''; # this is an error
1N/A
1N/A my @param;
1N/A push(@param,'-name'=>$name);
1N/A push(@param,'-value'=>$value);
1N/A push(@param,'-domain'=>$domain) if $domain;
1N/A push(@param,'-path'=>$path) if $path;
1N/A push(@param,'-expires'=>$expires) if $expires;
1N/A push(@param,'-secure'=>$secure) if $secure;
1N/A push(@param,'-httponly'=>$httponly) if $httponly;
1N/A
1N/A return CGI::Cookie->new(@param);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'parse_keywordlist' => <<'END_OF_FUNC',
1N/Asub parse_keywordlist {
1N/A my($self,$tosplit) = @_;
1N/A $tosplit = unescape($tosplit); # unescape the keywords
1N/A $tosplit=~tr/+/ /; # pluses to spaces
1N/A my(@keywords) = split(/\s+/,$tosplit);
1N/A return @keywords;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'param_fetch' => <<'END_OF_FUNC',
1N/Asub param_fetch {
1N/A my($self,@p) = self_or_default(@_);
1N/A my($name) = rearrange([NAME],@p);
1N/A return [] unless defined $name;
1N/A
1N/A unless (exists($self->{param}{$name})) {
1N/A $self->add_parameter($name);
1N/A $self->{param}{$name} = [];
1N/A }
1N/A
1N/A return $self->{param}{$name};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A###############################################
1N/A# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
1N/A###############################################
1N/A
1N/A#### Method: path_info
1N/A# Return the extra virtual path information provided
1N/A# after the URL (if any)
1N/A####
1N/A'path_info' => <<'END_OF_FUNC',
1N/Asub path_info {
1N/A my ($self,$info) = self_or_default(@_);
1N/A if (defined($info)) {
1N/A $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
1N/A $self->{'.path_info'} = $info;
1N/A } elsif (! defined($self->{'.path_info'}) ) {
1N/A my (undef,$path_info) = $self->_name_and_path_from_env;
1N/A $self->{'.path_info'} = $path_info || '';
1N/A }
1N/A return $self->{'.path_info'};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# This function returns a potentially modified version of SCRIPT_NAME
1N/A# and PATH_INFO. Some HTTP servers do sanitise the paths in those
1N/A# variables. It is the case of at least Apache 2. If for instance the
1N/A# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
1N/A# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
1N/A# SCRIPT_NAME=/path/to/env.cgi
1N/A# PATH_INFO=/x/y/x
1N/A#
1N/A# This is all fine except that some bogus CGI scripts expect
1N/A# PATH_INFO=/http://foo when the user requests
1N/A# http://xxx/script.cgi/http://foo
1N/A#
1N/A# Old versions of this module used to accomodate with those scripts, so
1N/A# this is why we do this here to keep those scripts backward compatible.
1N/A# Basically, we accomodate with those scripts but within limits, that is
1N/A# we only try to preserve the number of / that were provided by the user
1N/A# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
1N/A# of consecutive /.
1N/A#
1N/A# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
1N/A# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
1N/A# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
1N/A# possibly sanitised by the HTTP server, so in the case of Apache 2:
1N/A# script_name == /foo/x/z/script.cgi and path_info == /b/c.
1N/A#
1N/A# Future versions of this module may no longer do that, so one should
1N/A# avoid relying on the browser, proxy, server, and CGI.pm preserving the
1N/A# number of consecutive slashes as no guarantee can be made there.
1N/A'_name_and_path_from_env' => <<'END_OF_FUNC',
1N/Asub _name_and_path_from_env {
1N/A my $self = shift;
1N/A my $script_name = $ENV{SCRIPT_NAME} || '';
1N/A my $path_info = $ENV{PATH_INFO} || '';
1N/A my $uri = $self->request_uri || '';
1N/A
1N/A $uri =~ s/\?.*//s;
1N/A $uri = unescape($uri);
1N/A
1N/A if ($uri ne "$script_name$path_info") {
1N/A my $script_name_pattern = quotemeta($script_name);
1N/A my $path_info_pattern = quotemeta($path_info);
1N/A $script_name_pattern =~ s{(?:\\/)+}{/+}g;
1N/A $path_info_pattern =~ s{(?:\\/)+}{/+}g;
1N/A
1N/A if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
1N/A # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
1N/A # numer of consecutive slashes, so we can extract the info from
1N/A # REQUEST_URI:
1N/A ($script_name, $path_info) = ($1, $2);
1N/A }
1N/A }
1N/A return ($script_name,$path_info);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: request_method
1N/A# Returns 'POST', 'GET', 'PUT' or 'HEAD'
1N/A####
1N/A'request_method' => <<'END_OF_FUNC',
1N/Asub request_method {
1N/A return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: content_type
1N/A# Returns the content_type string
1N/A####
1N/A'content_type' => <<'END_OF_FUNC',
1N/Asub content_type {
1N/A return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: path_translated
1N/A# Return the physical path information provided
1N/A# by the URL (if any)
1N/A####
1N/A'path_translated' => <<'END_OF_FUNC',
1N/Asub path_translated {
1N/A return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: request_uri
1N/A# Return the literal request URI
1N/A####
1N/A'request_uri' => <<'END_OF_FUNC',
1N/Asub request_uri {
1N/A return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: query_string
1N/A# Synthesize a query string from our current
1N/A# parameters
1N/A####
1N/A'query_string' => <<'END_OF_FUNC',
1N/Asub query_string {
1N/A my($self) = self_or_default(@_);
1N/A my($param,$value,@pairs);
1N/A for $param ($self->param) {
1N/A my($eparam) = escape($param);
1N/A for $value ($self->param($param)) {
1N/A $value = escape($value);
1N/A next unless defined $value;
1N/A push(@pairs,"$eparam=$value");
1N/A }
1N/A }
1N/A for (keys %{$self->{'.fieldnames'}}) {
1N/A push(@pairs,".cgifields=".escape("$_"));
1N/A }
1N/A return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: accept
1N/A# Without parameters, returns an array of the
1N/A# MIME types the browser accepts.
1N/A# With a single parameter equal to a MIME
1N/A# type, will return undef if the browser won't
1N/A# accept it, 1 if the browser accepts it but
1N/A# doesn't give a preference, or a floating point
1N/A# value between 0.0 and 1.0 if the browser
1N/A# declares a quantitative score for it.
1N/A# This handles MIME type globs correctly.
1N/A####
1N/A'Accept' => <<'END_OF_FUNC',
1N/Asub Accept {
1N/A my($self,$search) = self_or_CGI(@_);
1N/A my(%prefs,$type,$pref,$pat);
1N/A
1N/A my(@accept) = defined $self->http('accept')
1N/A ? split(',',$self->http('accept'))
1N/A : ();
1N/A
1N/A for (@accept) {
1N/A ($pref) = /q=(\d\.\d+|\d+)/;
1N/A ($type) = m#(\S+/[^;]+)#;
1N/A next unless $type;
1N/A $prefs{$type}=$pref || 1;
1N/A }
1N/A
1N/A return keys %prefs unless $search;
1N/A
1N/A # if a search type is provided, we may need to
1N/A # perform a pattern matching operation.
1N/A # The MIME types use a glob mechanism, which
1N/A # is easily translated into a perl pattern match
1N/A
1N/A # First return the preference for directly supported
1N/A # types:
1N/A return $prefs{$search} if $prefs{$search};
1N/A
1N/A # Didn't get it, so try pattern matching.
1N/A for (keys %prefs) {
1N/A next unless /\*/; # not a pattern match
1N/A ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
1N/A $pat =~ s/\*/.*/g; # turn it into a pattern
1N/A return $prefs{$_} if $search=~/$pat/;
1N/A }
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: user_agent
1N/A# If called with no parameters, returns the user agent.
1N/A# If called with one parameter, does a pattern match (case
1N/A# insensitive) on the user agent.
1N/A####
1N/A'user_agent' => <<'END_OF_FUNC',
1N/Asub user_agent {
1N/A my($self,$match)=self_or_CGI(@_);
1N/A my $user_agent = $self->http('user_agent');
1N/A return $user_agent unless $match && $user_agent;
1N/A return $user_agent =~ /$match/i;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: raw_cookie
1N/A# Returns the magic cookies for the session.
1N/A# The cookies are not parsed or altered in any way, i.e.
1N/A# cookies are returned exactly as given in the HTTP
1N/A# headers. If a cookie name is given, only that cookie's
1N/A# value is returned, otherwise the entire raw cookie
1N/A# is returned.
1N/A####
1N/A'raw_cookie' => <<'END_OF_FUNC',
1N/Asub raw_cookie {
1N/A my($self,$key) = self_or_CGI(@_);
1N/A
1N/A require CGI::Cookie;
1N/A
1N/A if (defined($key)) {
1N/A $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
1N/A unless $self->{'.raw_cookies'};
1N/A
1N/A return () unless $self->{'.raw_cookies'};
1N/A return () unless $self->{'.raw_cookies'}->{$key};
1N/A return $self->{'.raw_cookies'}->{$key};
1N/A }
1N/A return $self->http('cookie') || $ENV{'COOKIE'} || '';
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: virtual_host
1N/A# Return the name of the virtual_host, which
1N/A# is not always the same as the server
1N/A######
1N/A'virtual_host' => <<'END_OF_FUNC',
1N/Asub virtual_host {
1N/A my $vh = http('x_forwarded_host') || http('host') || server_name();
1N/A $vh =~ s/:\d+$//; # get rid of port number
1N/A return $vh;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: remote_host
1N/A# Return the name of the remote host, or its IP
1N/A# address if unavailable. If this variable isn't
1N/A# defined, it returns "localhost" for debugging
1N/A# purposes.
1N/A####
1N/A'remote_host' => <<'END_OF_FUNC',
1N/Asub remote_host {
1N/A return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
1N/A || 'localhost';
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: remote_addr
1N/A# Return the IP addr of the remote host.
1N/A####
1N/A'remote_addr' => <<'END_OF_FUNC',
1N/Asub remote_addr {
1N/A return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: script_name
1N/A# Return the partial URL to this script for
1N/A# self-referencing scripts. Also see
1N/A# self_url(), which returns a URL with all state information
1N/A# preserved.
1N/A####
1N/A'script_name' => <<'END_OF_FUNC',
1N/Asub script_name {
1N/A my ($self,@p) = self_or_default(@_);
1N/A if (@p) {
1N/A $self->{'.script_name'} = shift @p;
1N/A } elsif (!exists $self->{'.script_name'}) {
1N/A my ($script_name,$path_info) = $self->_name_and_path_from_env();
1N/A $self->{'.script_name'} = $script_name;
1N/A }
1N/A return $self->{'.script_name'};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: referer
1N/A# Return the HTTP_REFERER: useful for generating
1N/A# a GO BACK button.
1N/A####
1N/A'referer' => <<'END_OF_FUNC',
1N/Asub referer {
1N/A my($self) = self_or_CGI(@_);
1N/A return $self->http('referer');
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: server_name
1N/A# Return the name of the server
1N/A####
1N/A'server_name' => <<'END_OF_FUNC',
1N/Asub server_name {
1N/A return $ENV{'SERVER_NAME'} || 'localhost';
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: server_software
1N/A# Return the name of the server software
1N/A####
1N/A'server_software' => <<'END_OF_FUNC',
1N/Asub server_software {
1N/A return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: virtual_port
1N/A# Return the server port, taking virtual hosts into account
1N/A####
1N/A'virtual_port' => <<'END_OF_FUNC',
1N/Asub virtual_port {
1N/A my($self) = self_or_default(@_);
1N/A my $vh = $self->http('x_forwarded_host') || $self->http('host');
1N/A my $protocol = $self->protocol;
1N/A if ($vh) {
1N/A return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
1N/A } else {
1N/A return $self->server_port();
1N/A }
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: server_port
1N/A# Return the tcp/ip port the server is running on
1N/A####
1N/A'server_port' => <<'END_OF_FUNC',
1N/Asub server_port {
1N/A return $ENV{'SERVER_PORT'} || 80; # for debugging
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: server_protocol
1N/A# Return the protocol (usually HTTP/1.0)
1N/A####
1N/A'server_protocol' => <<'END_OF_FUNC',
1N/Asub server_protocol {
1N/A return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: http
1N/A# Return the value of an HTTP variable, or
1N/A# the list of variables if none provided
1N/A####
1N/A'http' => <<'END_OF_FUNC',
1N/Asub http {
1N/A my ($self,$parameter) = self_or_CGI(@_);
1N/A if ( defined($parameter) ) {
1N/A $parameter =~ tr/-a-z/_A-Z/;
1N/A if ( $parameter =~ /^HTTP(?:_|$)/ ) {
1N/A return $ENV{$parameter};
1N/A }
1N/A return $ENV{"HTTP_$parameter"};
1N/A }
1N/A return grep { /^HTTP(?:_|$)/ } keys %ENV;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: https
1N/A# Return the value of HTTPS, or
1N/A# the value of an HTTPS variable, or
1N/A# the list of variables
1N/A####
1N/A'https' => <<'END_OF_FUNC',
1N/Asub https {
1N/A my ($self,$parameter) = self_or_CGI(@_);
1N/A if ( defined($parameter) ) {
1N/A $parameter =~ tr/-a-z/_A-Z/;
1N/A if ( $parameter =~ /^HTTPS(?:_|$)/ ) {
1N/A return $ENV{$parameter};
1N/A }
1N/A return $ENV{"HTTPS_$parameter"};
1N/A }
1N/A return wantarray
1N/A ? grep { /^HTTPS(?:_|$)/ } keys %ENV
1N/A : $ENV{'HTTPS'};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: protocol
1N/A# Return the protocol (http or https currently)
1N/A####
1N/A'protocol' => <<'END_OF_FUNC',
1N/Asub protocol {
1N/A local($^W)=0;
1N/A my $self = shift;
1N/A return 'https' if uc($self->https()) eq 'ON';
1N/A return 'https' if $self->server_port == 443;
1N/A my $prot = $self->server_protocol;
1N/A my($protocol,$version) = split('/',$prot);
1N/A return "\L$protocol\E";
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: remote_ident
1N/A# Return the identity of the remote user
1N/A# (but only if his host is running identd)
1N/A####
1N/A'remote_ident' => <<'END_OF_FUNC',
1N/Asub remote_ident {
1N/A return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: auth_type
1N/A# Return the type of use verification/authorization in use, if any.
1N/A####
1N/A'auth_type' => <<'END_OF_FUNC',
1N/Asub auth_type {
1N/A return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: remote_user
1N/A# Return the authorization name used for user
1N/A# verification.
1N/A####
1N/A'remote_user' => <<'END_OF_FUNC',
1N/Asub remote_user {
1N/A return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: user_name
1N/A# Try to return the remote user's name by hook or by
1N/A# crook
1N/A####
1N/A'user_name' => <<'END_OF_FUNC',
1N/Asub user_name {
1N/A my ($self) = self_or_CGI(@_);
1N/A return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: nosticky
1N/A# Set or return the NOSTICKY global flag
1N/A####
1N/A'nosticky' => <<'END_OF_FUNC',
1N/Asub nosticky {
1N/A my ($self,$param) = self_or_CGI(@_);
1N/A $CGI::NOSTICKY = $param if defined($param);
1N/A return $CGI::NOSTICKY;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: nph
1N/A# Set or return the NPH global flag
1N/A####
1N/A'nph' => <<'END_OF_FUNC',
1N/Asub nph {
1N/A my ($self,$param) = self_or_CGI(@_);
1N/A $CGI::NPH = $param if defined($param);
1N/A return $CGI::NPH;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#### Method: private_tempfiles
1N/A# Set or return the private_tempfiles global flag
1N/A####
1N/A'private_tempfiles' => <<'END_OF_FUNC',
1N/Asub private_tempfiles {
1N/A my ($self,$param) = self_or_CGI(@_);
1N/A $CGI::PRIVATE_TEMPFILES = $param if defined($param);
1N/A return $CGI::PRIVATE_TEMPFILES;
1N/A}
1N/AEND_OF_FUNC
1N/A#### Method: close_upload_files
1N/A# Set or return the close_upload_files global flag
1N/A####
1N/A'close_upload_files' => <<'END_OF_FUNC',
1N/Asub close_upload_files {
1N/A my ($self,$param) = self_or_CGI(@_);
1N/A $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
1N/A return $CGI::CLOSE_UPLOAD_FILES;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A#### Method: default_dtd
1N/A# Set or return the default_dtd global
1N/A####
1N/A'default_dtd' => <<'END_OF_FUNC',
1N/Asub default_dtd {
1N/A my ($self,$param,$param2) = self_or_CGI(@_);
1N/A if (defined $param2 && defined $param) {
1N/A $CGI::DEFAULT_DTD = [ $param, $param2 ];
1N/A } elsif (defined $param) {
1N/A $CGI::DEFAULT_DTD = $param;
1N/A }
1N/A return $CGI::DEFAULT_DTD;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# -------------- really private subroutines -----------------
1N/A'_maybe_escapeHTML' => <<'END_OF_FUNC',
1N/Asub _maybe_escapeHTML {
1N/A # hack to work around earlier hacks
1N/A push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
1N/A my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
1N/A return undef unless defined($toencode);
1N/A return $toencode if ref($self) && !$self->{'escape'};
1N/A return $self->escapeHTML($toencode, $newlinestoo);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'previous_or_default' => <<'END_OF_FUNC',
1N/Asub previous_or_default {
1N/A my($self,$name,$defaults,$override) = @_;
1N/A my(%selected);
1N/A
1N/A if (!$override && ($self->{'.fieldnames'}->{$name} ||
1N/A defined($self->param($name)) ) ) {
1N/A $selected{$_}++ for $self->param($name);
1N/A } elsif (defined($defaults) && ref($defaults) &&
1N/A (ref($defaults) eq 'ARRAY')) {
1N/A $selected{$_}++ for @{$defaults};
1N/A } else {
1N/A $selected{$defaults}++ if defined($defaults);
1N/A }
1N/A
1N/A return %selected;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'register_parameter' => <<'END_OF_FUNC',
1N/Asub register_parameter {
1N/A my($self,$param) = @_;
1N/A $self->{'.parametersToAdd'}->{$param}++;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'get_fields' => <<'END_OF_FUNC',
1N/Asub get_fields {
1N/A my($self) = @_;
1N/A return $self->CGI::hidden('-name'=>'.cgifields',
1N/A '-values'=>[keys %{$self->{'.parametersToAdd'}}],
1N/A '-override'=>1);
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'read_from_cmdline' => <<'END_OF_FUNC',
1N/Asub read_from_cmdline {
1N/A my($input,@words);
1N/A my($query_string);
1N/A my($subpath);
1N/A if ($DEBUG && @ARGV) {
1N/A @words = @ARGV;
1N/A } elsif ($DEBUG > 1) {
1N/A require "shellwords.pl";
1N/A print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
1N/A chomp(@lines = <STDIN>); # remove newlines
1N/A $input = join(" ",@lines);
1N/A @words = &shellwords($input);
1N/A }
1N/A for (@words) {
1N/A s/\\=/%3D/g;
1N/A s/\\&/%26/g;
1N/A }
1N/A
1N/A if ("@words"=~/=/) {
1N/A $query_string = join('&',@words);
1N/A } else {
1N/A $query_string = join('+',@words);
1N/A }
1N/A if ($query_string =~ /^(.*?)\?(.*)$/)
1N/A {
1N/A $query_string = $2;
1N/A $subpath = $1;
1N/A }
1N/A return { 'query_string' => $query_string, 'subpath' => $subpath };
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#####
1N/A# subroutine: read_multipart
1N/A#
1N/A# Read multipart data and store it into our parameters.
1N/A# An interesting feature is that if any of the parts is a file, we
1N/A# create a temporary file and open up a filehandle on it so that the
1N/A# caller can read from it if necessary.
1N/A#####
1N/A'read_multipart' => <<'END_OF_FUNC',
1N/Asub read_multipart {
1N/A my($self,$boundary,$length) = @_;
1N/A my($buffer) = $self->new_MultipartBuffer($boundary,$length);
1N/A return unless $buffer;
1N/A my(%header,$body);
1N/A my $filenumber = 0;
1N/A while (!$buffer->eof) {
1N/A %header = $buffer->readHeader;
1N/A
1N/A unless (%header) {
1N/A $self->cgi_error("400 Bad request (malformed multipart POST)");
1N/A return;
1N/A }
1N/A
1N/A $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
1N/A
1N/A my($param)= $header{'Content-Disposition'}=~/[\s;]name="([^"]*)"/;
1N/A $param .= $TAINTED;
1N/A
1N/A # See RFC 1867, 2183, 2045
1N/A # NB: File content will be loaded into memory should
1N/A # content-disposition parsing fail.
1N/A my ($filename) = $header{'Content-Disposition'}
1N/A =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
1N/A
1N/A $filename ||= ''; # quench uninit variable warning
1N/A
1N/A $filename =~ s/^"([^"]*)"$/$1/;
1N/A # Test for Opera's multiple upload feature
1N/A my($multipart) = ( defined( $header{'Content-Type'} ) &&
1N/A $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
1N/A 1 : 0;
1N/A
1N/A # add this parameter to our list
1N/A $self->add_parameter($param);
1N/A
1N/A # If no filename specified, then just read the data and assign it
1N/A # to our parameter list.
1N/A if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
1N/A my($value) = $buffer->readBody;
1N/A $value .= $TAINTED;
1N/A push(@{$self->{param}{$param}},$value);
1N/A next;
1N/A }
1N/A
1N/A my ($tmpfile,$tmp,$filehandle);
1N/A UPLOADS: {
1N/A # If we get here, then we are dealing with a potentially large
1N/A # uploaded form. Save the data to a temporary file, then open
1N/A # the file for reading.
1N/A
1N/A # skip the file if uploads disabled
1N/A if ($DISABLE_UPLOADS) {
1N/A while (defined($data = $buffer->read)) { }
1N/A last UPLOADS;
1N/A }
1N/A
1N/A # set the filename to some recognizable value
1N/A if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
1N/A $filename = "multipart/mixed";
1N/A }
1N/A
1N/A # choose a relatively unpredictable tmpfile sequence number
1N/A my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
1N/A for (my $cnt=10;$cnt>0;$cnt--) {
1N/A next unless $tmpfile = CGITempFile->new($seqno);
1N/A $tmp = $tmpfile->as_string;
1N/A last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
1N/A $seqno += int rand(100);
1N/A }
1N/A die "CGI.pm open of tmpfile $tmp/$filename failed: $!\n" unless defined $filehandle;
1N/A $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
1N/A && defined fileno($filehandle);
1N/A
1N/A # if this is an multipart/mixed attachment, save the header
1N/A # together with the body for later parsing with an external
1N/A # MIME parser module
1N/A if ( $multipart ) {
1N/A for ( keys %header ) {
1N/A print $filehandle "$_: $header{$_}${CRLF}";
1N/A }
1N/A print $filehandle "${CRLF}";
1N/A }
1N/A
1N/A my ($data);
1N/A local($\) = '';
1N/A my $totalbytes = 0;
1N/A while (defined($data = $buffer->read)) {
1N/A if (defined $self->{'.upload_hook'})
1N/A {
1N/A $totalbytes += length($data);
1N/A &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
1N/A }
1N/A print $filehandle $data if ($self->{'use_tempfile'});
1N/A }
1N/A
1N/A # back up to beginning of file
1N/A seek($filehandle,0,0);
1N/A
1N/A ## Close the filehandle if requested this allows a multipart MIME
1N/A ## upload to contain many files, and we won't die due to too many
1N/A ## open file handles. The user can access the files using the hash
1N/A ## below.
1N/A close $filehandle if $CLOSE_UPLOAD_FILES;
1N/A $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
1N/A
1N/A # Save some information about the uploaded file where we can get
1N/A # at it later.
1N/A # Use the typeglob as the key, as this is guaranteed to be
1N/A # unique for each filehandle. Don't use the file descriptor as
1N/A # this will be re-used for each filehandle if the
1N/A # close_upload_files feature is used.
1N/A $self->{'.tmpfiles'}->{$$filehandle}= {
1N/A hndl => $filehandle,
1N/A name => $tmpfile,
1N/A info => {%header},
1N/A };
1N/A push(@{$self->{param}{$param}},$filehandle);
1N/A }
1N/A }
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A#####
1N/A# subroutine: read_multipart_related
1N/A#
1N/A# Read multipart/related data and store it into our parameters. The
1N/A# first parameter sets the start of the data. The part identified by
1N/A# this Content-ID will not be stored as a file upload, but will be
1N/A# returned by this method. All other parts will be available as file
1N/A# uploads accessible by their Content-ID
1N/A#####
1N/A'read_multipart_related' => <<'END_OF_FUNC',
1N/Asub read_multipart_related {
1N/A my($self,$start,$boundary,$length) = @_;
1N/A my($buffer) = $self->new_MultipartBuffer($boundary,$length);
1N/A return unless $buffer;
1N/A my(%header,$body);
1N/A my $filenumber = 0;
1N/A my $returnvalue;
1N/A while (!$buffer->eof) {
1N/A %header = $buffer->readHeader;
1N/A
1N/A unless (%header) {
1N/A $self->cgi_error("400 Bad request (malformed multipart POST)");
1N/A return;
1N/A }
1N/A
1N/A my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
1N/A $param .= $TAINTED;
1N/A
1N/A # If this is the start part, then just read the data and assign it
1N/A # to our return variable.
1N/A if ( $param eq $start ) {
1N/A $returnvalue = $buffer->readBody;
1N/A $returnvalue .= $TAINTED;
1N/A next;
1N/A }
1N/A
1N/A # add this parameter to our list
1N/A $self->add_parameter($param);
1N/A
1N/A my ($tmpfile,$tmp,$filehandle);
1N/A UPLOADS: {
1N/A # If we get here, then we are dealing with a potentially large
1N/A # uploaded form. Save the data to a temporary file, then open
1N/A # the file for reading.
1N/A
1N/A # skip the file if uploads disabled
1N/A if ($DISABLE_UPLOADS) {
1N/A while (defined($data = $buffer->read)) { }
1N/A last UPLOADS;
1N/A }
1N/A
1N/A # choose a relatively unpredictable tmpfile sequence number
1N/A my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
1N/A for (my $cnt=10;$cnt>0;$cnt--) {
1N/A next unless $tmpfile = CGITempFile->new($seqno);
1N/A $tmp = $tmpfile->as_string;
1N/A last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
1N/A $seqno += int rand(100);
1N/A }
1N/A die "CGI open of tmpfile: $!\n" unless defined $filehandle;
1N/A $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
1N/A && defined fileno($filehandle);
1N/A
1N/A my ($data);
1N/A local($\) = '';
1N/A my $totalbytes;
1N/A while (defined($data = $buffer->read)) {
1N/A if (defined $self->{'.upload_hook'})
1N/A {
1N/A $totalbytes += length($data);
1N/A &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
1N/A }
1N/A print $filehandle $data if ($self->{'use_tempfile'});
1N/A }
1N/A
1N/A # back up to beginning of file
1N/A seek($filehandle,0,0);
1N/A
1N/A ## Close the filehandle if requested this allows a multipart MIME
1N/A ## upload to contain many files, and we won't die due to too many
1N/A ## open file handles. The user can access the files using the hash
1N/A ## below.
1N/A close $filehandle if $CLOSE_UPLOAD_FILES;
1N/A $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
1N/A
1N/A # Save some information about the uploaded file where we can get
1N/A # at it later.
1N/A # Use the typeglob as the key, as this is guaranteed to be
1N/A # unique for each filehandle. Don't use the file descriptor as
1N/A # this will be re-used for each filehandle if the
1N/A # close_upload_files feature is used.
1N/A $self->{'.tmpfiles'}->{$$filehandle}= {
1N/A hndl => $filehandle,
1N/A name => $tmpfile,
1N/A info => {%header},
1N/A };
1N/A push(@{$self->{param}{$param}},$filehandle);
1N/A }
1N/A }
1N/A return $returnvalue;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A'upload' =><<'END_OF_FUNC',
1N/Asub upload {
1N/A my($self,$param_name) = self_or_default(@_);
1N/A my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
1N/A return unless @param;
1N/A return wantarray ? @param : $param[0];
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'tmpFileName' => <<'END_OF_FUNC',
1N/Asub tmpFileName {
1N/A my($self,$filename) = self_or_default(@_);
1N/A return $self->{'.tmpfiles'}->{$$filename}->{name} ?
1N/A $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
1N/A : '';
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'uploadInfo' => <<'END_OF_FUNC',
1N/Asub uploadInfo {
1N/A my($self,$filename) = self_or_default(@_);
1N/A return $self->{'.tmpfiles'}->{$$filename}->{info};
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# internal routine, don't use
1N/A'_set_values_and_labels' => <<'END_OF_FUNC',
1N/Asub _set_values_and_labels {
1N/A my $self = shift;
1N/A my ($v,$l,$n) = @_;
1N/A $$l = $v if ref($v) eq 'HASH' && !ref($$l);
1N/A return $self->param($n) if !defined($v);
1N/A return $v if !ref($v);
1N/A return ref($v) eq 'HASH' ? keys %$v : @$v;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# internal routine, don't use
1N/A'_set_attributes' => <<'END_OF_FUNC',
1N/Asub _set_attributes {
1N/A my $self = shift;
1N/A my($element, $attributes) = @_;
1N/A return '' unless defined($attributes->{$element});
1N/A $attribs = ' ';
1N/A for my $attrib (keys %{$attributes->{$element}}) {
1N/A (my $clean_attrib = $attrib) =~ s/^-//;
1N/A $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
1N/A }
1N/A $attribs =~ s/ $//;
1N/A return $attribs;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'_compile_all' => <<'END_OF_FUNC',
1N/Asub _compile_all {
1N/A for (@_) {
1N/A next if defined(&$_);
1N/A $AUTOLOAD = "CGI::$_";
1N/A _compile();
1N/A }
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A);
1N/AEND_OF_AUTOLOAD
1N/A;
1N/A
1N/A#########################################################
1N/A# Globals and stubs for other packages that we use.
1N/A#########################################################
1N/A
1N/A################### Fh -- lightweight filehandle ###############
1N/Apackage Fh;
1N/A
1N/Ause overload
1N/A '""' => \&asString,
1N/A 'cmp' => \&compare,
1N/A 'fallback'=>1;
1N/A
1N/A$FH='fh00000';
1N/A
1N/A*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
1N/A
1N/Asub DESTROY {
1N/A my $self = shift;
1N/A close $self;
1N/A}
1N/A
1N/A$AUTOLOADED_ROUTINES = ''; # prevent -w error
1N/A$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
1N/A%SUBS = (
1N/A'asString' => <<'END_OF_FUNC',
1N/Asub asString {
1N/A my $self = shift;
1N/A # get rid of package name
1N/A (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
1N/A $i =~ s/%(..)/ chr(hex($1)) /eg;
1N/A return $i.$CGI::TAINTED;
1N/A# BEGIN DEAD CODE
1N/A# This was an extremely clever patch that allowed "use strict refs".
1N/A# Unfortunately it relied on another bug that caused leaky file descriptors.
1N/A# The underlying bug has been fixed, so this no longer works. However
1N/A# "strict refs" still works for some reason.
1N/A# my $self = shift;
1N/A# return ${*{$self}{SCALAR}};
1N/A# END DEAD CODE
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'compare' => <<'END_OF_FUNC',
1N/Asub compare {
1N/A my $self = shift;
1N/A my $value = shift;
1N/A return "$self" cmp $value;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'new' => <<'END_OF_FUNC',
1N/Asub new {
1N/A my($pack,$name,$file,$delete) = @_;
1N/A _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
1N/A require Fcntl unless defined &Fcntl::O_RDWR;
1N/A (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
1N/A my $fv = ++$FH . $safename;
1N/A my $ref = \*{"Fh::$fv"};
1N/A
1N/A # Note this same regex is also used elsewhere in the same file for CGITempFile::new
1N/A $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\\+-]+)$! || return;
1N/A my $safe = $1;
1N/A sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
1N/A unlink($safe) if $delete;
1N/A CORE::delete $Fh::{$fv};
1N/A return bless $ref,$pack;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'handle' => <<'END_OF_FUNC',
1N/Asub handle {
1N/A my $self = shift;
1N/A eval "require IO::Handle" unless IO::Handle->can('new_from_fd');
1N/A return IO::Handle->new_from_fd(fileno $self,"<");
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A);
1N/AEND_OF_AUTOLOAD
1N/A
1N/A######################## MultipartBuffer ####################
1N/Apackage MultipartBuffer;
1N/A
1N/Ause constant DEBUG => 0;
1N/A
1N/A# how many bytes to read at a time. We use
1N/A# a 4K buffer by default.
1N/A$INITIAL_FILLUNIT = 1024 * 4;
1N/A$TIMEOUT = 240*60; # 4 hour timeout for big files
1N/A$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
1N/A$CRLF=$CGI::CRLF;
1N/A
1N/A#reuse the autoload function
1N/A*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
1N/A
1N/A# avoid autoloader warnings
1N/Asub DESTROY {}
1N/A
1N/A###############################################################################
1N/A################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
1N/A###############################################################################
1N/A$AUTOLOADED_ROUTINES = ''; # prevent -w error
1N/A$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
1N/A%SUBS = (
1N/A
1N/A'new' => <<'END_OF_FUNC',
1N/Asub new {
1N/A my($package,$interface,$boundary,$length) = @_;
1N/A $FILLUNIT = $INITIAL_FILLUNIT;
1N/A $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
1N/A
1N/A # If the user types garbage into the file upload field,
1N/A # then Netscape passes NOTHING to the server (not good).
1N/A # We may hang on this read in that case. So we implement
1N/A # a read timeout. If nothing is ready to read
1N/A # by then, we return.
1N/A
1N/A # Netscape seems to be a little bit unreliable
1N/A # about providing boundary strings.
1N/A my $boundary_read = 0;
1N/A if ($boundary) {
1N/A
1N/A # Under the MIME spec, the boundary consists of the
1N/A # characters "--" PLUS the Boundary string
1N/A
1N/A # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
1N/A # the two extra hyphens. We do a special case here on the user-agent!!!!
1N/A $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
1N/A
1N/A } else { # otherwise we find it ourselves
1N/A my($old);
1N/A ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
1N/A $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
1N/A $length -= length($boundary);
1N/A chomp($boundary); # remove the CRLF
1N/A $/ = $old; # restore old line separator
1N/A $boundary_read++;
1N/A }
1N/A
1N/A my $self = {LENGTH=>$length,
1N/A CHUNKED=>!$length,
1N/A BOUNDARY=>$boundary,
1N/A INTERFACE=>$interface,
1N/A BUFFER=>'',
1N/A };
1N/A
1N/A $FILLUNIT = length($boundary)
1N/A if length($boundary) > $FILLUNIT;
1N/A
1N/A my $retval = bless $self,ref $package || $package;
1N/A
1N/A # Read the preamble and the topmost (boundary) line plus the CRLF.
1N/A unless ($boundary_read) {
1N/A while ($self->read(0)) { }
1N/A }
1N/A die "Malformed multipart POST: data truncated\n" if $self->eof;
1N/A
1N/A return $retval;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'readHeader' => <<'END_OF_FUNC',
1N/Asub readHeader {
1N/A my($self) = @_;
1N/A my($end);
1N/A my($ok) = 0;
1N/A my($bad) = 0;
1N/A
1N/A local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
1N/A
1N/A do {
1N/A $self->fillBuffer($FILLUNIT);
1N/A $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
1N/A $ok++ if $self->{BUFFER} eq '';
1N/A $bad++ if !$ok && $self->{LENGTH} <= 0;
1N/A # this was a bad idea
1N/A # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
1N/A } until $ok || $bad;
1N/A return () if $bad;
1N/A
1N/A #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
1N/A
1N/A my($header) = substr($self->{BUFFER},0,$end+2);
1N/A substr($self->{BUFFER},0,$end+4) = '';
1N/A my %return;
1N/A
1N/A if ($CGI::EBCDIC) {
1N/A warn "untranslated header=$header\n" if DEBUG;
1N/A $header = CGI::Util::ascii2ebcdic($header);
1N/A warn "translated header=$header\n" if DEBUG;
1N/A }
1N/A
1N/A # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
1N/A # (Folding Long Header Fields), 3.4.3 (Comments)
1N/A # and 3.4.5 (Quoted-Strings).
1N/A
1N/A my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
1N/A $header=~s/$CRLF\s+/ /og; # merge continuation lines
1N/A
1N/A while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
1N/A my ($field_name,$field_value) = ($1,$2);
1N/A $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
1N/A $return{$field_name}=$field_value;
1N/A }
1N/A return %return;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# This reads and returns the body as a single scalar value.
1N/A'readBody' => <<'END_OF_FUNC',
1N/Asub readBody {
1N/A my($self) = @_;
1N/A my($data);
1N/A my($returnval)='';
1N/A
1N/A #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
1N/A
1N/A while (defined($data = $self->read)) {
1N/A $returnval .= $data;
1N/A }
1N/A
1N/A if ($CGI::EBCDIC) {
1N/A warn "untranslated body=$returnval\n" if DEBUG;
1N/A $returnval = CGI::Util::ascii2ebcdic($returnval);
1N/A warn "translated body=$returnval\n" if DEBUG;
1N/A }
1N/A return $returnval;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A# This will read $bytes or until the boundary is hit, whichever happens
1N/A# first. After the boundary is hit, we return undef. The next read will
1N/A# skip over the boundary and begin reading again;
1N/A'read' => <<'END_OF_FUNC',
1N/Asub read {
1N/A my($self,$bytes) = @_;
1N/A
1N/A # default number of bytes to read
1N/A $bytes = $bytes || $FILLUNIT;
1N/A
1N/A # Fill up our internal buffer in such a way that the boundary
1N/A # is never split between reads.
1N/A $self->fillBuffer($bytes);
1N/A
1N/A my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
1N/A my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
1N/A
1N/A # Find the boundary in the buffer (it may not be there).
1N/A my $start = index($self->{BUFFER},$boundary_start);
1N/A
1N/A warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
1N/A
1N/A # protect against malformed multipart POST operations
1N/A die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0);
1N/A
1N/A #EBCDIC NOTE: want to translate boundary search into ASCII here.
1N/A
1N/A # If the boundary begins the data, then skip past it
1N/A # and return undef.
1N/A if ($start == 0) {
1N/A
1N/A # clear us out completely if we've hit the last boundary.
1N/A if (index($self->{BUFFER},$boundary_end)==0) {
1N/A $self->{BUFFER}='';
1N/A $self->{LENGTH}=0;
1N/A return undef;
1N/A }
1N/A
1N/A # just remove the boundary.
1N/A substr($self->{BUFFER},0,length($boundary_start))='';
1N/A $self->{BUFFER} =~ s/^\012\015?//;
1N/A return undef;
1N/A }
1N/A
1N/A my $bytesToReturn;
1N/A if ($start > 0) { # read up to the boundary
1N/A $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
1N/A } else { # read the requested number of bytes
1N/A # leave enough bytes in the buffer to allow us to read
1N/A # the boundary. Thanks to Kevin Hendrick for finding
1N/A # this one.
1N/A $bytesToReturn = $bytes - (length($boundary_start)+1);
1N/A }
1N/A
1N/A my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
1N/A substr($self->{BUFFER},0,$bytesToReturn)='';
1N/A
1N/A # If we hit the boundary, remove the CRLF from the end.
1N/A return ($bytesToReturn==$start)
1N/A ? substr($returnval,0,-2) : $returnval;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A# This fills up our internal buffer in such a way that the
1N/A# boundary is never split between reads
1N/A'fillBuffer' => <<'END_OF_FUNC',
1N/Asub fillBuffer {
1N/A my($self,$bytes) = @_;
1N/A return unless $self->{CHUNKED} || $self->{LENGTH};
1N/A
1N/A my($boundaryLength) = length($self->{BOUNDARY});
1N/A my($bufferLength) = length($self->{BUFFER});
1N/A my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
1N/A $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead;
1N/A
1N/A # Try to read some data. We may hang here if the browser is screwed up.
1N/A my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
1N/A $bytesToRead,
1N/A $bufferLength);
1N/A warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
1N/A $self->{BUFFER} = '' unless defined $self->{BUFFER};
1N/A
1N/A # An apparent bug in the Apache server causes the read()
1N/A # to return zero bytes repeatedly without blocking if the
1N/A # remote user aborts during a file transfer. I don't know how
1N/A # they manage this, but the workaround is to abort if we get
1N/A # more than SPIN_LOOP_MAX consecutive zero reads.
1N/A if ($bytesRead <= 0) {
1N/A die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
1N/A if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
1N/A } else {
1N/A $self->{ZERO_LOOP_COUNTER}=0;
1N/A }
1N/A
1N/A $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A
1N/A# Return true when we've finished reading
1N/A'eof' => <<'END_OF_FUNC'
1N/Asub eof {
1N/A my($self) = @_;
1N/A return 1 if (length($self->{BUFFER}) == 0)
1N/A && ($self->{LENGTH} <= 0);
1N/A undef;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A);
1N/AEND_OF_AUTOLOAD
1N/A
1N/A####################################################################################
1N/A################################## TEMPORARY FILES #################################
1N/A####################################################################################
1N/Apackage CGITempFile;
1N/A
1N/Asub find_tempdir {
1N/A $SL = $CGI::SL;
1N/A $MAC = $CGI::OS eq 'MACINTOSH';
1N/A my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
1N/A unless (defined $TMPDIRECTORY) {
1N/A @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
1N/A "C:${SL}temp","${SL}tmp","${SL}temp",
1N/A "${vol}${SL}Temporary Items",
1N/A "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
1N/A "C:${SL}system${SL}temp");
1N/A
1N/A if( $CGI::OS eq 'WINDOWS' ){
1N/A # PeterH: These evars may not exist if this is invoked within a service and untainting
1N/A # is in effect - with 'use warnings' the undefined array entries causes Perl to die
1N/A unshift(@TEMP,$ENV{TEMP}) if defined $ENV{TEMP};
1N/A unshift(@TEMP,$ENV{TMP}) if defined $ENV{TMP};
1N/A unshift(@TEMP,$ENV{WINDIR} . $SL . 'TEMP') if defined $ENV{WINDIR};
1N/A }
1N/A
1N/A unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
1N/A
1N/A # this feature was supposed to provide per-user tmpfiles, but
1N/A # it is problematic.
1N/A # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
1N/A # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
1N/A # : can generate a 'getpwuid() not implemented' exception, even though
1N/A # : it's never called. Found under DOS/Win with the DJGPP perl port.
1N/A # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
1N/A # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
1N/A
1N/A for (@TEMP) {
1N/A do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
1N/A }
1N/A }
1N/A $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
1N/A}
1N/A
1N/Afind_tempdir();
1N/A
1N/A$MAXTRIES = 5000;
1N/A
1N/A# cute feature, but overload implementation broke it
1N/A# %OVERLOAD = ('""'=>'as_string');
1N/A*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
1N/A
1N/Asub DESTROY {
1N/A my($self) = @_;
1N/A $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\~-]+)$! || return;
1N/A my $safe = $1; # untaint operation
1N/A unlink $safe; # get rid of the file
1N/A}
1N/A
1N/A###############################################################################
1N/A################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
1N/A###############################################################################
1N/A$AUTOLOADED_ROUTINES = ''; # prevent -w error
1N/A$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
1N/A%SUBS = (
1N/A
1N/A'new' => <<'END_OF_FUNC',
1N/Asub new {
1N/A my($package,$sequence) = @_;
1N/A my $filename;
1N/A unless (-w $TMPDIRECTORY) {
1N/A $TMPDIRECTORY = undef;
1N/A find_tempdir();
1N/A }
1N/A for (my $i = 0; $i < $MAXTRIES; $i++) {
1N/A last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
1N/A }
1N/A # check that it is a more-or-less valid filename
1N/A # Note this same regex is also used elsewhere in the same file for Fh::new
1N/A return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\\+-]+)$!;
1N/A # this used to untaint, now it doesn't
1N/A # $filename = $1;
1N/A return bless \$filename;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A'as_string' => <<'END_OF_FUNC'
1N/Asub as_string {
1N/A my($self) = @_;
1N/A return $$self;
1N/A}
1N/AEND_OF_FUNC
1N/A
1N/A);
1N/AEND_OF_AUTOLOAD
1N/A
1N/Apackage CGI;
1N/A
1N/A# We get a whole bunch of warnings about "possibly uninitialized variables"
1N/A# when running with the -w switch. Touch them all once to get rid of the
1N/A# warnings. This is ugly and I hate it.
1N/Aif ($^W) {
1N/A $CGI::CGI = '';
1N/A $CGI::CGI=<<EOF;
1N/A $CGI::VERSION;
1N/A $MultipartBuffer::SPIN_LOOP_MAX;
1N/A $MultipartBuffer::CRLF;
1N/A $MultipartBuffer::TIMEOUT;
1N/A $MultipartBuffer::INITIAL_FILLUNIT;
1N/AEOF
1N/A ;
1N/A}
1N/A
1N/A1;
1N/A
1N/A__END__
1N/A
1N/A=head1 NAME
1N/A
1N/ACGI - Handle Common Gateway Interface requests and responses
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/A use CGI;
1N/A
1N/A my $q = CGI->new;
1N/A
1N/A # Process an HTTP request
1N/A @values = $q->param('form_field');
1N/A
1N/A $fh = $q->upload('file_field');
1N/A
1N/A $riddle = $query->cookie('riddle_name');
1N/A %answers = $query->cookie('answers');
1N/A
1N/A # Prepare various HTTP responses
1N/A print $q->header();
1N/A print $q->header('application/json');
1N/A
1N/A $cookie1 = $q->cookie(-name=>'riddle_name', -value=>"The Sphynx's Question");
1N/A $cookie2 = $q->cookie(-name=>'answers', -value=>\%answers);
1N/A print $q->header(
1N/A -type => 'image/gif',
1N/A -expires => '+3d',
1N/A -cookie => [$cookie1,$cookie2]
1N/A );
1N/A
1N/A print $q->redirect('http://somewhere.else/in/movie/land');
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/ACGI.pm is a stable, complete and mature solution for processing and preparing
1N/AHTTP requests and responses. Major features including processing form
1N/Asubmissions, file uploads, reading and writing cookies, query string generation
1N/Aand manipulation, and processing and preparing HTTP headers. Some HTML
1N/Ageneration utilities are included as well.
1N/A
1N/ACGI.pm performs very well in in a vanilla CGI.pm environment and also comes
1N/Awith built-in support for mod_perl and mod_perl2 as well as FastCGI.
1N/A
1N/AIt has the benefit of having developed and refined over 10 years with input
1N/Afrom dozens of contributors and being deployed on thousands of websites.
1N/ACGI.pm has been included in the Perl distribution since Perl 5.4, and has
1N/Abecome a de-facto standard.
1N/A
1N/A=head2 PROGRAMMING STYLE
1N/A
1N/AThere are two styles of programming with CGI.pm, an object-oriented
1N/Astyle and a function-oriented style. In the object-oriented style you
1N/Acreate one or more CGI objects and then use object methods to create
1N/Athe various elements of the page. Each CGI object starts out with the
1N/Alist of named parameters that were passed to your CGI script by the
1N/Aserver. You can modify the objects, save them to a file or database
1N/Aand recreate them. Because each object corresponds to the "state" of
1N/Athe CGI script, and because each object's parameter list is
1N/Aindependent of the others, this allows you to save the state of the
1N/Ascript and restore it later.
1N/A
1N/AFor example, using the object oriented style, here is how you create
1N/Aa simple "Hello World" HTML page:
1N/A
1N/A #!/usr/local/bin/perl -w
1N/A use CGI; # load CGI routines
1N/A $q = CGI->new; # create new CGI object
1N/A print $q->header, # create the HTTP header
1N/A $q->start_html('hello world'), # start the HTML
1N/A $q->h1('hello world'), # level 1 header
1N/A $q->end_html; # end the HTML
1N/A
1N/AIn the function-oriented style, there is one default CGI object that
1N/Ayou rarely deal with directly. Instead you just call functions to
1N/Aretrieve CGI parameters, create HTML tags, manage cookies, and so
1N/Aon. This provides you with a cleaner programming interface, but
1N/Alimits you to using one CGI object at a time. The following example
1N/Aprints the same page, but uses the function-oriented interface.
1N/AThe main differences are that we now need to import a set of functions
1N/Ainto our name space (usually the "standard" functions), and we don't
1N/Aneed to create the CGI object.
1N/A
1N/A #!/usr/local/bin/perl
1N/A use CGI qw/:standard/; # load standard CGI routines
1N/A print header, # create the HTTP header
1N/A start_html('hello world'), # start the HTML
1N/A h1('hello world'), # level 1 header
1N/A end_html; # end the HTML
1N/A
1N/AThe examples in this document mainly use the object-oriented style.
1N/ASee HOW TO IMPORT FUNCTIONS for important information on
1N/Afunction-oriented programming in CGI.pm
1N/A
1N/A=head2 CALLING CGI.PM ROUTINES
1N/A
1N/AMost CGI.pm routines accept several arguments, sometimes as many as 20
1N/Aoptional ones! To simplify this interface, all routines use a named
1N/Aargument calling style that looks like this:
1N/A
1N/A print $q->header(-type=>'image/gif',-expires=>'+3d');
1N/A
1N/AEach argument name is preceded by a dash. Neither case nor order
1N/Amatters in the argument list. -type, -Type, and -TYPE are all
1N/Aacceptable. In fact, only the first argument needs to begin with a
1N/Adash. If a dash is present in the first argument, CGI.pm assumes
1N/Adashes for the subsequent ones.
1N/A
1N/ASeveral routines are commonly called with just one argument. In the
1N/Acase of these routines you can provide the single argument without an
1N/Aargument name. header() happens to be one of these routines. In this
1N/Acase, the single argument is the document type.
1N/A
1N/A print $q->header('text/html');
1N/A
1N/AOther such routines are documented below.
1N/A
1N/ASometimes named arguments expect a scalar, sometimes a reference to an
1N/Aarray, and sometimes a reference to a hash. Often, you can pass any
1N/Atype of argument and the routine will do whatever is most appropriate.
1N/AFor example, the param() routine is used to set a CGI parameter to a
1N/Asingle or a multi-valued value. The two cases are shown below:
1N/A
1N/A $q->param(-name=>'veggie',-value=>'tomato');
1N/A $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
1N/A
1N/AA large number of routines in CGI.pm actually aren't specifically
1N/Adefined in the module, but are generated automatically as needed.
1N/AThese are the "HTML shortcuts," routines that generate HTML tags for
1N/Ause in dynamically-generated pages. HTML tags have both attributes
1N/A(the attribute="value" pairs within the tag itself) and contents (the
1N/Apart between the opening and closing pairs.) To distinguish between
1N/Aattributes and contents, CGI.pm uses the convention of passing HTML
1N/Aattributes as a hash reference as the first argument, and the
1N/Acontents, if any, as any subsequent arguments. It works out like
1N/Athis:
1N/A
1N/A Code Generated HTML
1N/A ---- --------------
1N/A h1() <h1>
1N/A h1('some','contents'); <h1>some contents</h1>
1N/A h1({-align=>left}); <h1 align="LEFT">
1N/A h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
1N/A
1N/AHTML tags are described in more detail later.
1N/A
1N/AMany newcomers to CGI.pm are puzzled by the difference between the
1N/Acalling conventions for the HTML shortcuts, which require curly braces
1N/Aaround the HTML tag attributes, and the calling conventions for other
1N/Aroutines, which manage to generate attributes without the curly
1N/Abrackets. Don't be confused. As a convenience the curly braces are
1N/Aoptional in all but the HTML shortcuts. If you like, you can use
1N/Acurly braces when calling any routine that takes named arguments. For
1N/Aexample:
1N/A
1N/A print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
1N/A
1N/AIf you use the B<-w> switch, you will be warned that some CGI.pm argument
1N/Anames conflict with built-in Perl functions. The most frequent of
1N/Athese is the -values argument, used to create multi-valued menus,
1N/Aradio button clusters and the like. To get around this warning, you
1N/Ahave several choices:
1N/A
1N/A=over 4
1N/A
1N/A=item 1.
1N/A
1N/AUse another name for the argument, if one is available.
1N/AFor example, -value is an alias for -values.
1N/A
1N/A=item 2.
1N/A
1N/AChange the capitalization, e.g. -Values
1N/A
1N/A=item 3.
1N/A
1N/APut quotes around the argument name, e.g. '-values'
1N/A
1N/A=back
1N/A
1N/AMany routines will do something useful with a named argument that it
1N/Adoesn't recognize. For example, you can produce non-standard HTTP
1N/Aheader fields by providing them as named arguments:
1N/A
1N/A print $q->header(-type => 'text/html',
1N/A -cost => 'Three smackers',
1N/A -annoyance_level => 'high',
1N/A -complaints_to => 'bit bucket');
1N/A
1N/AThis will produce the following nonstandard HTTP header:
1N/A
1N/A HTTP/1.0 200 OK
1N/A Cost: Three smackers
1N/A Annoyance-level: high
1N/A Complaints-to: bit bucket
1N/A Content-type: text/html
1N/A
1N/ANotice the way that underscores are translated automatically into
1N/Ahyphens. HTML-generating routines perform a different type of
1N/Atranslation.
1N/A
1N/AThis feature allows you to keep up with the rapidly changing HTTP and
1N/AHTML "standards".
1N/A
1N/A=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
1N/A
1N/A $query = CGI->new;
1N/A
1N/AThis will parse the input (from both POST and GET methods) and store
1N/Ait into a perl5 object called $query.
1N/A
1N/AAny filehandles from file uploads will have their position reset to
1N/Athe beginning of the file.
1N/A
1N/A=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
1N/A
1N/A $query = CGI->new(INPUTFILE);
1N/A
1N/AIf you provide a file handle to the new() method, it will read
1N/Aparameters from the file (or STDIN, or whatever). The file can be in
1N/Aany of the forms describing below under debugging (i.e. a series of
1N/Anewline delimited TAG=VALUE pairs will work). Conveniently, this type
1N/Aof file is created by the save() method (see below). Multiple records
1N/Acan be saved and restored.
1N/A
1N/APerl purists will be pleased to know that this syntax accepts
1N/Areferences to file handles, or even references to filehandle globs,
1N/Awhich is the "official" way to pass a filehandle:
1N/A
1N/A $query = CGI->new(\*STDIN);
1N/A
1N/AYou can also initialize the CGI object with a FileHandle or IO::File
1N/Aobject.
1N/A
1N/AIf you are using the function-oriented interface and want to
1N/Ainitialize CGI state from a file handle, the way to do this is with
1N/AB<restore_parameters()>. This will (re)initialize the
1N/Adefault CGI object from the indicated file handle.
1N/A
1N/A open (IN,"test.in") || die;
1N/A restore_parameters(IN);
1N/A close IN;
1N/A
1N/AYou can also initialize the query object from a hash
1N/Areference:
1N/A
1N/A $query = CGI->new( {'dinosaur'=>'barney',
1N/A 'song'=>'I love you',
1N/A 'friends'=>[qw/Jessica George Nancy/]}
1N/A );
1N/A
1N/Aor from a properly formatted, URL-escaped query string:
1N/A
1N/A $query = CGI->new('dinosaur=barney&color=purple');
1N/A
1N/Aor from a previously existing CGI object (currently this clones the
1N/Aparameter list, but none of the other object-specific fields, such as
1N/Aautoescaping):
1N/A
1N/A $old_query = CGI->new;
1N/A $new_query = CGI->new($old_query);
1N/A
1N/ATo create an empty query, initialize it from an empty string or hash:
1N/A
1N/A $empty_query = CGI->new("");
1N/A
1N/A -or-
1N/A
1N/A $empty_query = CGI->new({});
1N/A
1N/A=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
1N/A
1N/A @keywords = $query->keywords
1N/A
1N/AIf the script was invoked as the result of an <ISINDEX> search, the
1N/Aparsed keywords can be obtained as an array using the keywords() method.
1N/A
1N/A=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
1N/A
1N/A @names = $query->param
1N/A
1N/AIf the script was invoked with a parameter list
1N/A(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
1N/Awill return the parameter names as a list. If the script was invoked
1N/Aas an <ISINDEX> script and contains a string without ampersands
1N/A(e.g. "value1+value2+value3") , there will be a single parameter named
1N/A"keywords" containing the "+"-delimited keywords.
1N/A
1N/ANOTE: As of version 1.5, the array of parameter names returned will
1N/Abe in the same order as they were submitted by the browser.
1N/AUsually this order is the same as the order in which the
1N/Aparameters are defined in the form (however, this isn't part
1N/Aof the spec, and so isn't guaranteed).
1N/A
1N/A=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
1N/A
1N/A @values = $query->param('foo');
1N/A
1N/A -or-
1N/A
1N/A $value = $query->param('foo');
1N/A
1N/APass the param() method a single argument to fetch the value of the
1N/Anamed parameter. If the parameter is multivalued (e.g. from multiple
1N/Aselections in a scrolling list), you can ask to receive an array. Otherwise
1N/Athe method will return a single value.
1N/A
1N/AIf a value is not given in the query string, as in the queries
1N/A"name1=&name2=", it will be returned as an empty string.
1N/A
1N/A
1N/AIf the parameter does not exist at all, then param() will return undef
1N/Ain a scalar context, and the empty list in a list context.
1N/A
1N/A
1N/A=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
1N/A
1N/A $query->param('foo','an','array','of','values');
1N/A
1N/AThis sets the value for the named parameter 'foo' to an array of
1N/Avalues. This is one way to change the value of a field AFTER
1N/Athe script has been invoked once before. (Another way is with
1N/Athe -override parameter accepted by all methods that generate
1N/Aform elements.)
1N/A
1N/Aparam() also recognizes a named parameter style of calling described
1N/Ain more detail later:
1N/A
1N/A $query->param(-name=>'foo',-values=>['an','array','of','values']);
1N/A
1N/A -or-
1N/A
1N/A $query->param(-name=>'foo',-value=>'the value');
1N/A
1N/A=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
1N/A
1N/A $query->append(-name=>'foo',-values=>['yet','more','values']);
1N/A
1N/AThis adds a value or list of values to the named parameter. The
1N/Avalues are appended to the end of the parameter if it already exists.
1N/AOtherwise the parameter is created. Note that this method only
1N/Arecognizes the named argument calling syntax.
1N/A
1N/A=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
1N/A
1N/A $query->import_names('R');
1N/A
1N/AThis creates a series of variables in the 'R' namespace. For example,
1N/A$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
1N/AIf no namespace is given, this method will assume 'Q'.
1N/AWARNING: don't import anything into 'main'; this is a major security
1N/Arisk!!!!
1N/A
1N/ANOTE 1: Variable names are transformed as necessary into legal Perl
1N/Avariable names. All non-legal characters are transformed into
1N/Aunderscores. If you need to keep the original names, you should use
1N/Athe param() method instead to access CGI variables by name.
1N/A
1N/ANOTE 2: In older versions, this method was called B<import()>. As of version 2.20,
1N/Athis name has been removed completely to avoid conflict with the built-in
1N/APerl module B<import> operator.
1N/A
1N/A=head2 DELETING A PARAMETER COMPLETELY:
1N/A
1N/A $query->delete('foo','bar','baz');
1N/A
1N/AThis completely clears a list of parameters. It sometimes useful for
1N/Aresetting parameters that you don't want passed down between script
1N/Ainvocations.
1N/A
1N/AIf you are using the function call interface, use "Delete()" instead
1N/Ato avoid conflicts with Perl's built-in delete operator.
1N/A
1N/A=head2 DELETING ALL PARAMETERS:
1N/A
1N/A $query->delete_all();
1N/A
1N/AThis clears the CGI object completely. It might be useful to ensure
1N/Athat all the defaults are taken when you create a fill-out form.
1N/A
1N/AUse Delete_all() instead if you are using the function call interface.
1N/A
1N/A=head2 HANDLING NON-URLENCODED ARGUMENTS
1N/A
1N/A
1N/AIf POSTed data is not of type application/x-www-form-urlencoded or
1N/Amultipart/form-data, then the POSTed data will not be processed, but
1N/Ainstead be returned as-is in a parameter named POSTDATA. To retrieve
1N/Ait, use code like this:
1N/A
1N/A my $data = $query->param('POSTDATA');
1N/A
1N/ALikewise if PUTed data can be retrieved with code like this:
1N/A
1N/A my $data = $query->param('PUTDATA');
1N/A
1N/A(If you don't know what the preceding means, don't worry about it. It
1N/Aonly affects people trying to use CGI for XML processing and other
1N/Aspecialized tasks.)
1N/A
1N/A
1N/A=head2 DIRECT ACCESS TO THE PARAMETER LIST:
1N/A
1N/A $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
1N/A unshift @{$q->param_fetch(-name=>'address')},'George Munster';
1N/A
1N/AIf you need access to the parameter list in a way that isn't covered
1N/Aby the methods given in the previous sections, you can obtain a direct
1N/Areference to it by
1N/Acalling the B<param_fetch()> method with the name of the parameter. This
1N/Awill return an array reference to the named parameter, which you then
1N/Acan manipulate in any way you like.
1N/A
1N/AYou can also use a named argument style using the B<-name> argument.
1N/A
1N/A=head2 FETCHING THE PARAMETER LIST AS A HASH:
1N/A
1N/A $params = $q->Vars;
1N/A print $params->{'address'};
1N/A @foo = split("\0",$params->{'foo'});
1N/A %params = $q->Vars;
1N/A
1N/A use CGI ':cgi-lib';
1N/A $params = Vars;
1N/A
1N/AMany people want to fetch the entire parameter list as a hash in which
1N/Athe keys are the names of the CGI parameters, and the values are the
1N/Aparameters' values. The Vars() method does this. Called in a scalar
1N/Acontext, it returns the parameter list as a tied hash reference.
1N/AChanging a key changes the value of the parameter in the underlying
1N/ACGI parameter list. Called in a list context, it returns the
1N/Aparameter list as an ordinary hash. This allows you to read the
1N/Acontents of the parameter list, but not to change it.
1N/A
1N/AWhen using this, the thing you must watch out for are multivalued CGI
1N/Aparameters. Because a hash cannot distinguish between scalar and
1N/Alist context, multivalued parameters will be returned as a packed
1N/Astring, separated by the "\0" (null) character. You must split this
1N/Apacked string in order to get at the individual values. This is the
1N/Aconvention introduced long ago by Steve Brenner in his cgi-lib.pl
1N/Amodule for Perl version 4.
1N/A
1N/AIf you wish to use Vars() as a function, import the I<:cgi-lib> set of
1N/Afunction calls (also see the section on CGI-LIB compatibility).
1N/A
1N/A=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
1N/A
1N/A $query->save(\*FILEHANDLE)
1N/A
1N/AThis will write the current state of the form to the provided
1N/Afilehandle. You can read it back in by providing a filehandle
1N/Ato the new() method. Note that the filehandle can be a file, a pipe,
1N/Aor whatever!
1N/A
1N/AThe format of the saved file is:
1N/A
1N/A NAME1=VALUE1
1N/A NAME1=VALUE1'
1N/A NAME2=VALUE2
1N/A NAME3=VALUE3
1N/A =
1N/A
1N/ABoth name and value are URL escaped. Multi-valued CGI parameters are
1N/Arepresented as repeated names. A session record is delimited by a
1N/Asingle = symbol. You can write out multiple records and read them
1N/Aback in with several calls to B<new>. You can do this across several
1N/Asessions by opening the file in append mode, allowing you to create
1N/Aprimitive guest books, or to keep a history of users' queries. Here's
1N/Aa short example of creating multiple session records:
1N/A
1N/A use CGI;
1N/A
1N/A open (OUT,'>>','test.out') || die;
1N/A $records = 5;
1N/A for (0..$records) {
1N/A my $q = CGI->new;
1N/A $q->param(-name=>'counter',-value=>$_);
1N/A $q->save(\*OUT);
1N/A }
1N/A close OUT;
1N/A
1N/A # reopen for reading
1N/A open (IN,'<','test.out') || die;
1N/A while (!eof(IN)) {
1N/A my $q = CGI->new(\*IN);
1N/A print $q->param('counter'),"\n";
1N/A }
1N/A
1N/AThe file format used for save/restore is identical to that used by the
1N/AWhitehead Genome Center's data exchange format "Boulderio", and can be
1N/Amanipulated and even databased using Boulderio utilities. See
1N/A
1N/A http://stein.cshl.org/boulder/
1N/A
1N/Afor further details.
1N/A
1N/AIf you wish to use this method from the function-oriented (non-OO)
1N/Ainterface, the exported name for this method is B<save_parameters()>.
1N/A
1N/A=head2 RETRIEVING CGI ERRORS
1N/A
1N/AErrors can occur while processing user input, particularly when
1N/Aprocessing uploaded files. When these errors occur, CGI will stop
1N/Aprocessing and return an empty parameter list. You can test for
1N/Athe existence and nature of errors using the I<cgi_error()> function.
1N/AThe error messages are formatted as HTTP status codes. You can either
1N/Aincorporate the error text into an HTML page, or use it as the value
1N/Aof the HTTP status:
1N/A
1N/A my $error = $q->cgi_error;
1N/A if ($error) {
1N/A print $q->header(-status=>$error),
1N/A $q->start_html('Problems'),
1N/A $q->h2('Request not processed'),
1N/A $q->strong($error);
1N/A exit 0;
1N/A }
1N/A
1N/AWhen using the function-oriented interface (see the next section),
1N/Aerrors may only occur the first time you call I<param()>. Be ready
1N/Afor this!
1N/A
1N/A=head2 USING THE FUNCTION-ORIENTED INTERFACE
1N/A
1N/ATo use the function-oriented interface, you must specify which CGI.pm
1N/Aroutines or sets of routines to import into your script's namespace.
1N/AThere is a small overhead associated with this importation, but it
1N/Aisn't much.
1N/A
1N/A use CGI <list of methods>;
1N/A
1N/AThe listed methods will be imported into the current package; you can
1N/Acall them directly without creating a CGI object first. This example
1N/Ashows how to import the B<param()> and B<header()>
1N/Amethods, and then use them directly:
1N/A
1N/A use CGI 'param','header';
1N/A print header('text/plain');
1N/A $zipcode = param('zipcode');
1N/A
1N/AMore frequently, you'll import common sets of functions by referring
1N/Ato the groups by name. All function sets are preceded with a ":"
1N/Acharacter as in ":html3" (for tags defined in the HTML 3 standard).
1N/A
1N/AHere is a list of the function sets you can import:
1N/A
1N/A=over 4
1N/A
1N/A=item B<:cgi>
1N/A
1N/AImport all CGI-handling methods, such as B<param()>, B<path_info()>
1N/Aand the like.
1N/A
1N/A=item B<:form>
1N/A
1N/AImport all fill-out form generating methods, such as B<textfield()>.
1N/A
1N/A=item B<:html2>
1N/A
1N/AImport all methods that generate HTML 2.0 standard elements.
1N/A
1N/A=item B<:html3>
1N/A
1N/AImport all methods that generate HTML 3.0 elements (such as
1N/A<table>, <super> and <sub>).
1N/A
1N/A=item B<:html4>
1N/A
1N/AImport all methods that generate HTML 4 elements (such as
1N/A<abbrev>, <acronym> and <thead>).
1N/A
1N/A=item B<:netscape>
1N/A
1N/AImport the <blink>, <fontsize> and <center> tags.
1N/A
1N/A=item B<:html>
1N/A
1N/AImport all HTML-generating shortcuts (i.e. 'html2', 'html3', 'html4' and 'netscape')
1N/A
1N/A=item B<:standard>
1N/A
1N/AImport "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
1N/A
1N/A=item B<:all>
1N/A
1N/AImport all the available methods. For the full list, see the CGI.pm
1N/Acode, where the variable %EXPORT_TAGS is defined.
1N/A
1N/A=back
1N/A
1N/AIf you import a function name that is not part of CGI.pm, the module
1N/Awill treat it as a new HTML tag and generate the appropriate
1N/Asubroutine. You can then use it like any other HTML tag. This is to
1N/Aprovide for the rapidly-evolving HTML "standard." For example, say
1N/AMicrosoft comes out with a new tag called <gradient> (which causes the
1N/Auser's desktop to be flooded with a rotating gradient fill until his
1N/Amachine reboots). You don't need to wait for a new version of CGI.pm
1N/Ato start using it immediately:
1N/A
1N/A use CGI qw/:standard :html3 gradient/;
1N/A print gradient({-start=>'red',-end=>'blue'});
1N/A
1N/ANote that in the interests of execution speed CGI.pm does B<not> use
1N/Athe standard L<Exporter> syntax for specifying load symbols. This may
1N/Achange in the future.
1N/A
1N/AIf you import any of the state-maintaining CGI or form-generating
1N/Amethods, a default CGI object will be created and initialized
1N/Aautomatically the first time you use any of the methods that require
1N/Aone to be present. This includes B<param()>, B<textfield()>,
1N/AB<submit()> and the like. (If you need direct access to the CGI
1N/Aobject, you can find it in the global variable B<$CGI::Q>). By
1N/Aimporting CGI.pm methods, you can create visually elegant scripts:
1N/A
1N/A use CGI qw/:standard/;
1N/A print
1N/A header,
1N/A start_html('Simple Script'),
1N/A h1('Simple Script'),
1N/A start_form,
1N/A "What's your name? ",textfield('name'),p,
1N/A "What's the combination?",
1N/A checkbox_group(-name=>'words',
1N/A -values=>['eenie','meenie','minie','moe'],
1N/A -defaults=>['eenie','moe']),p,
1N/A "What's your favorite color?",
1N/A popup_menu(-name=>'color',
1N/A -values=>['red','green','blue','chartreuse']),p,
1N/A submit,
1N/A end_form,
1N/A hr,"\n";
1N/A
1N/A if (param) {
1N/A print
1N/A "Your name is ",em(param('name')),p,
1N/A "The keywords are: ",em(join(", ",param('words'))),p,
1N/A "Your favorite color is ",em(param('color')),".\n";
1N/A }
1N/A print end_html;
1N/A
1N/A=head2 PRAGMAS
1N/A
1N/AIn addition to the function sets, there are a number of pragmas that
1N/Ayou can import. Pragmas, which are always preceded by a hyphen,
1N/Achange the way that CGI.pm functions in various ways. Pragmas,
1N/Afunction sets, and individual functions can all be imported in the
1N/Asame use() line. For example, the following use statement imports the
1N/Astandard set of functions and enables debugging mode (pragma
1N/A-debug):
1N/A
1N/A use CGI qw/:standard -debug/;
1N/A
1N/AThe current list of pragmas is as follows:
1N/A
1N/A=over 4
1N/A
1N/A=item -any
1N/A
1N/AWhen you I<use CGI -any>, then any method that the query object
1N/Adoesn't recognize will be interpreted as a new HTML tag. This allows
1N/Ayou to support the next I<ad hoc> HTML
1N/Aextension. This lets you go wild with new and unsupported tags:
1N/A
1N/A use CGI qw(-any);
1N/A $q=CGI->new;
1N/A print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
1N/A
1N/ASince using <cite>any</cite> causes any mistyped method name
1N/Ato be interpreted as an HTML tag, use it with care or not at
1N/Aall.
1N/A
1N/A=item -compile
1N/A
1N/AThis causes the indicated autoloaded methods to be compiled up front,
1N/Arather than deferred to later. This is useful for scripts that run
1N/Afor an extended period of time under FastCGI or mod_perl, and for
1N/Athose destined to be crunched by Malcolm Beattie's Perl compiler. Use
1N/Ait in conjunction with the methods or method families you plan to use.
1N/A
1N/A use CGI qw(-compile :standard :html3);
1N/A
1N/Aor even
1N/A
1N/A use CGI qw(-compile :all);
1N/A
1N/ANote that using the -compile pragma in this way will always have
1N/Athe effect of importing the compiled functions into the current
1N/Anamespace. If you want to compile without importing use the
1N/Acompile() method instead:
1N/A
1N/A use CGI();
1N/A CGI->compile();
1N/A
1N/AThis is particularly useful in a mod_perl environment, in which you
1N/Amight want to precompile all CGI routines in a startup script, and
1N/Athen import the functions individually in each mod_perl script.
1N/A
1N/A=item -nosticky
1N/A
1N/ABy default the CGI module implements a state-preserving behavior
1N/Acalled "sticky" fields. The way this works is that if you are
1N/Aregenerating a form, the methods that generate the form field values
1N/Awill interrogate param() to see if similarly-named parameters are
1N/Apresent in the query string. If they find a like-named parameter, they
1N/Awill use it to set their default values.
1N/A
1N/ASometimes this isn't what you want. The B<-nosticky> pragma prevents
1N/Athis behavior. You can also selectively change the sticky behavior in
1N/Aeach element that you generate.
1N/A
1N/A=item -tabindex
1N/A
1N/AAutomatically add tab index attributes to each form field. With this
1N/Aoption turned off, you can still add tab indexes manually by passing a
1N/A-tabindex option to each field-generating method.
1N/A
1N/A=item -no_undef_params
1N/A
1N/AThis keeps CGI.pm from including undef params in the parameter list.
1N/A
1N/A=item -no_xhtml
1N/A
1N/ABy default, CGI.pm versions 2.69 and higher emit XHTML
1N/A(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
1N/Afeature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
1N/Afeature.
1N/A
1N/AIf start_html()'s -dtd parameter specifies an HTML 2.0,
1N/A3.2, 4.0 or 4.01 DTD,
1N/AXHTML will automatically be disabled without needing to use this
1N/Apragma.
1N/A
1N/A=item -utf8
1N/A
1N/AThis makes CGI.pm treat all parameters as UTF-8 strings. Use this with
1N/Acare, as it will interfere with the processing of binary uploads. It
1N/Ais better to manually select which fields are expected to return utf-8
1N/Astrings and convert them using code like this:
1N/A
1N/A use Encode;
1N/A my $arg = decode utf8=>param('foo');
1N/A
1N/A=item -nph
1N/A
1N/AThis makes CGI.pm produce a header appropriate for an NPH (no
1N/Aparsed header) script. You may need to do other things as well
1N/Ato tell the server that the script is NPH. See the discussion
1N/Aof NPH scripts below.
1N/A
1N/A=item -newstyle_urls
1N/A
1N/ASeparate the name=value pairs in CGI parameter query strings with
1N/Asemicolons rather than ampersands. For example:
1N/A
1N/A ?name=fred;age=24;favorite_color=3
1N/A
1N/ASemicolon-delimited query strings are always accepted, and will be emitted by
1N/Aself_url() and query_string(). newstyle_urls became the default in version
1N/A2.64.
1N/A
1N/A=item -oldstyle_urls
1N/A
1N/ASeparate the name=value pairs in CGI parameter query strings with
1N/Aampersands rather than semicolons. This is no longer the default.
1N/A
1N/A=item -autoload
1N/A
1N/AThis overrides the autoloader so that any function in your program
1N/Athat is not recognized is referred to CGI.pm for possible evaluation.
1N/AThis allows you to use all the CGI.pm functions without adding them to
1N/Ayour symbol table, which is of concern for mod_perl users who are
1N/Aworried about memory consumption. I<Warning:> when
1N/AI<-autoload> is in effect, you cannot use "poetry mode"
1N/A(functions without the parenthesis). Use I<hr()> rather
1N/Athan I<hr>, or add something like I<use subs qw/hr p header/>
1N/Ato the top of your script.
1N/A
1N/A=item -no_debug
1N/A
1N/AThis turns off the command-line processing features. If you want to
1N/Arun a CGI.pm script from the command line to produce HTML, and you
1N/Adon't want it to read CGI parameters from the command line or STDIN,
1N/Athen use this pragma:
1N/A
1N/A use CGI qw(-no_debug :standard);
1N/A
1N/A=item -debug
1N/A
1N/AThis turns on full debugging. In addition to reading CGI arguments
1N/Afrom the command-line processing, CGI.pm will pause and try to read
1N/Aarguments from STDIN, producing the message "(offline mode: enter
1N/Aname=value pairs on standard input)" features.
1N/A
1N/ASee the section on debugging for more details.
1N/A
1N/A=item -private_tempfiles
1N/A
1N/ACGI.pm can process uploaded file. Ordinarily it spools the uploaded
1N/Afile to a temporary directory, then deletes the file when done.
1N/AHowever, this opens the risk of eavesdropping as described in the file
1N/Aupload section. Another CGI script author could peek at this data
1N/Aduring the upload, even if it is confidential information. On Unix
1N/Asystems, the -private_tempfiles pragma will cause the temporary file
1N/Ato be unlinked as soon as it is opened and before any data is written
1N/Ainto it, reducing, but not eliminating the risk of eavesdropping
1N/A(there is still a potential race condition). To make life harder for
1N/Athe attacker, the program chooses tempfile names by calculating a 32
1N/Abit checksum of the incoming HTTP headers.
1N/A
1N/ATo ensure that the temporary file cannot be read by other CGI scripts,
1N/Ause suEXEC or a CGI wrapper program to run your script. The temporary
1N/Afile is created with mode 0600 (neither world nor group readable).
1N/A
1N/AThe temporary directory is selected using the following algorithm:
1N/A
1N/A 1. if $CGITempFile::TMPDIRECTORY is already set, use that
1N/A
1N/A 2. if the environment variable TMPDIR exists, use the location
1N/A indicated.
1N/A
1N/A 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
1N/A /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
1N/A
1N/AEach of these locations is checked that it is a directory and is
1N/Awritable. If not, the algorithm tries the next choice.
1N/A
1N/A=back
1N/A
1N/A=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
1N/A
1N/AMany of the methods generate HTML tags. As described below, tag
1N/Afunctions automatically generate both the opening and closing tags.
1N/AFor example:
1N/A
1N/A print h1('Level 1 Header');
1N/A
1N/Aproduces
1N/A
1N/A <h1>Level 1 Header</h1>
1N/A
1N/AThere will be some times when you want to produce the start and end
1N/Atags yourself. In this case, you can use the form start_I<tag_name>
1N/Aand end_I<tag_name>, as in:
1N/A
1N/A print start_h1,'Level 1 Header',end_h1;
1N/A
1N/AWith a few exceptions (described below), start_I<tag_name> and
1N/Aend_I<tag_name> functions are not generated automatically when you
1N/AI<use CGI>. However, you can specify the tags you want to generate
1N/AI<start/end> functions for by putting an asterisk in front of their
1N/Aname, or, alternatively, requesting either "start_I<tag_name>" or
1N/A"end_I<tag_name>" in the import list.
1N/A
1N/AExample:
1N/A
1N/A use CGI qw/:standard *table start_ul/;
1N/A
1N/AIn this example, the following functions are generated in addition to
1N/Athe standard ones:
1N/A
1N/A=over 4
1N/A
1N/A=item 1. start_table() (generates a <table> tag)
1N/A
1N/A=item 2. end_table() (generates a </table> tag)
1N/A
1N/A=item 3. start_ul() (generates a <ul> tag)
1N/A
1N/A=item 4. end_ul() (generates a </ul> tag)
1N/A
1N/A=back
1N/A
1N/A=head1 GENERATING DYNAMIC DOCUMENTS
1N/A
1N/AMost of CGI.pm's functions deal with creating documents on the fly.
1N/AGenerally you will produce the HTTP header first, followed by the
1N/Adocument itself. CGI.pm provides functions for generating HTTP
1N/Aheaders of various types as well as for generating HTML. For creating
1N/AGIF images, see the GD.pm module.
1N/A
1N/AEach of these functions produces a fragment of HTML or HTTP which you
1N/Acan print out directly so that it displays in the browser window,
1N/Aappend to a string, or save to a file for later use.
1N/A
1N/A=head2 CREATING A STANDARD HTTP HEADER:
1N/A
1N/ANormally the first thing you will do in any CGI script is print out an
1N/AHTTP header. This tells the browser what type of document to expect,
1N/Aand gives other optional information, such as the language, expiration
1N/Adate, and whether to cache the document. The header can also be
1N/Amanipulated for special purposes, such as server push and pay per view
1N/Apages.
1N/A
1N/A print header;
1N/A
1N/A -or-
1N/A
1N/A print header('image/gif');
1N/A
1N/A -or-
1N/A
1N/A print header('text/html','204 No response');
1N/A
1N/A -or-
1N/A
1N/A print header(-type=>'image/gif',
1N/A -nph=>1,
1N/A -status=>'402 Payment required',
1N/A -expires=>'+3d',
1N/A -cookie=>$cookie,
1N/A -charset=>'utf-7',
1N/A -attachment=>'foo.gif',
1N/A -Cost=>'$2.00');
1N/A
1N/Aheader() returns the Content-type: header. You can provide your own
1N/AMIME type if you choose, otherwise it defaults to text/html. An
1N/Aoptional second parameter specifies the status code and a human-readable
1N/Amessage. For example, you can specify 204, "No response" to create a
1N/Ascript that tells the browser to do nothing at all.
1N/A
1N/AThe last example shows the named argument style for passing arguments
1N/Ato the CGI methods using named parameters. Recognized parameters are
1N/AB<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
1N/Aparameters will be stripped of their initial hyphens and turned into
1N/Aheader fields, allowing you to specify any HTTP header you desire.
1N/AInternal underscores will be turned into hyphens:
1N/A
1N/A print header(-Content_length=>3002);
1N/A
1N/AMost browsers will not cache the output from CGI scripts. Every time
1N/Athe browser reloads the page, the script is invoked anew. You can
1N/Achange this behavior with the B<-expires> parameter. When you specify
1N/Aan absolute or relative expiration interval with this parameter, some
1N/Abrowsers and proxy servers will cache the script's output until the
1N/Aindicated expiration date. The following forms are all valid for the
1N/A-expires field:
1N/A
1N/A +30s 30 seconds from now
1N/A +10m ten minutes from now
1N/A +1h one hour from now
1N/A -1d yesterday (i.e. "ASAP!")
1N/A now immediately
1N/A +3M in three months
1N/A +10y in ten years time
1N/A Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
1N/A
1N/AThe B<-cookie> parameter generates a header that tells the browser to provide
1N/Aa "magic cookie" during all subsequent transactions with your script.
1N/ASome cookies have a special format that includes interesting attributes
1N/Asuch as expiration time. Use the cookie() method to create and retrieve
1N/Asession cookies.
1N/A
1N/AThe B<-nph> parameter, if set to a true value, will issue the correct
1N/Aheaders to work with a NPH (no-parse-header) script. This is important
1N/Ato use with certain servers that expect all their scripts to be NPH.
1N/A
1N/AThe B<-charset> parameter can be used to control the character set
1N/Asent to the browser. If not provided, defaults to ISO-8859-1. As a
1N/Aside effect, this sets the charset() method as well.
1N/A
1N/AThe B<-attachment> parameter can be used to turn the page into an
1N/Aattachment. Instead of displaying the page, some browsers will prompt
1N/Athe user to save it to disk. The value of the argument is the
1N/Asuggested name for the saved file. In order for this to work, you may
1N/Ahave to set the B<-type> to "application/octet-stream".
1N/A
1N/AThe B<-p3p> parameter will add a P3P tag to the outgoing header. The
1N/Aparameter can be an arrayref or a space-delimited string of P3P tags.
1N/AFor example:
1N/A
1N/A print header(-p3p=>[qw(CAO DSP LAW CURa)]);
1N/A print header(-p3p=>'CAO DSP LAW CURa');
1N/A
1N/AIn either case, the outgoing header will be formatted as:
1N/A
1N/A P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
1N/A
1N/ACGI.pm will accept valid multi-line headers when each line is separated with a
1N/ACRLF value ("\r\n" on most platforms) followed by at least one space. For example:
1N/A
1N/A print header( -ingredients => "ham\r\n\seggs\r\n\sbacon" );
1N/A
1N/AInvalid multi-line header input will trigger in an exception. When multi-line headers
1N/Aare received, CGI.pm will always output them back as a single line, according to the
1N/Afolding rules of RFC 2616: the newlines will be removed, while the white space remains.
1N/A
1N/A=head2 GENERATING A REDIRECTION HEADER
1N/A
1N/A print $q->redirect('http://somewhere.else/in/movie/land');
1N/A
1N/ASometimes you don't want to produce a document yourself, but simply
1N/Aredirect the browser elsewhere, perhaps choosing a URL based on the
1N/Atime of day or the identity of the user.
1N/A
1N/AThe redirect() method redirects the browser to a different URL. If
1N/Ayou use redirection like this, you should B<not> print out a header as
1N/Awell.
1N/A
1N/AYou should always use full URLs (including the http: or ftp: part) in
1N/Aredirection requests. Relative URLs will not work correctly.
1N/A
1N/AYou can also use named arguments:
1N/A
1N/A print $q->redirect(
1N/A -uri=>'http://somewhere.else/in/movie/land',
1N/A -nph=>1,
1N/A -status=>301);
1N/A
1N/AAll names arguments recognized by header() are also recognized by
1N/Aredirect(). However, most HTTP headers, including those generated by
1N/A-cookie and -target, are ignored by the browser.
1N/A
1N/AThe B<-nph> parameter, if set to a true value, will issue the correct
1N/Aheaders to work with a NPH (no-parse-header) script. This is important
1N/Ato use with certain servers, such as Microsoft IIS, which
1N/Aexpect all their scripts to be NPH.
1N/A
1N/AThe B<-status> parameter will set the status of the redirect. HTTP
1N/Adefines three different possible redirection status codes:
1N/A
1N/A 301 Moved Permanently
1N/A 302 Found
1N/A 303 See Other
1N/A
1N/AThe default if not specified is 302, which means "moved temporarily."
1N/AYou may change the status to another status code if you wish. Be
1N/Aadvised that changing the status to anything other than 301, 302 or
1N/A303 will probably break redirection.
1N/A
1N/A=head2 CREATING THE HTML DOCUMENT HEADER
1N/A
1N/A print start_html(-title=>'Secrets of the Pyramids',
1N/A -author=>'fred@capricorn.org',
1N/A -base=>'true',
1N/A -target=>'_blank',
1N/A -meta=>{'keywords'=>'pharaoh secret mummy',
1N/A 'copyright'=>'copyright 1996 King Tut'},
1N/A -style=>{'src'=>'/styles/style1.css'},
1N/A -BGCOLOR=>'blue');
1N/A
1N/AThe start_html() routine creates the top of the
1N/Apage, along with a lot of optional information that controls the
1N/Apage's appearance and behavior.
1N/A
1N/AThis method returns a canned HTML header and the opening <body> tag.
1N/AAll parameters are optional. In the named parameter form, recognized
1N/Aparameters are -title, -author, -base, -xbase, -dtd, -lang and -target
1N/A(see below for the explanation). Any additional parameters you
1N/Aprovide, such as the unofficial BGCOLOR attribute, are added
1N/Ato the <body> tag. Additional parameters must be proceeded by a
1N/Ahyphen.
1N/A
1N/AThe argument B<-xbase> allows you to provide an HREF for the <base> tag
1N/Adifferent from the current location, as in
1N/A
1N/A -xbase=>"http://home.mcom.com/"
1N/A
1N/AAll relative links will be interpreted relative to this tag.
1N/A
1N/AThe argument B<-target> allows you to provide a default target frame
1N/Afor all the links and fill-out forms on the page. B<This is a
1N/Anon-standard HTTP feature which only works with some browsers!>
1N/A
1N/A -target=>"answer_window"
1N/A
1N/AAll relative links will be interpreted relative to this tag.
1N/AYou add arbitrary meta information to the header with the B<-meta>
1N/Aargument. This argument expects a reference to a hash
1N/Acontaining name/value pairs of meta information. These will be turned
1N/Ainto a series of header <meta> tags that look something like this:
1N/A
1N/A <meta name="keywords" content="pharaoh secret mummy">
1N/A <meta name="description" content="copyright 1996 King Tut">
1N/A
1N/ATo create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
1N/Abelow.
1N/A
1N/AThe B<-style> argument is used to incorporate cascading stylesheets
1N/Ainto your code. See the section on CASCADING STYLESHEETS for more
1N/Ainformation.
1N/A
1N/AThe B<-lang> argument is used to incorporate a language attribute into
1N/Athe <html> tag. For example:
1N/A
1N/A print $q->start_html(-lang=>'fr-CA');
1N/A
1N/AThe default if not specified is "en-US" for US English, unless the
1N/A-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
1N/Alang attribute is left off. You can force the lang attribute to left
1N/Aoff in other cases by passing an empty string (-lang=>'').
1N/A
1N/AThe B<-encoding> argument can be used to specify the character set for
1N/AXHTML. It defaults to iso-8859-1 if not specified.
1N/A
1N/AThe B<-dtd> argument can be used to specify a public DTD identifier string. For example:
1N/A
1N/A -dtd => '-//W3C//DTD HTML 4.01 Transitional//EN')
1N/A
1N/AAlternatively, it can take public and system DTD identifiers as an array:
1N/A
1N/A dtd => [ '-//W3C//DTD HTML 4.01 Transitional//EN', 'http://www.w3.org/TR/html4/loose.dtd' ]
1N/A
1N/AFor the public DTD identifier to be considered, it must be valid. Otherwise it
1N/Awill be replaced by the default DTD. If the public DTD contains 'XHTML', CGI.pm
1N/Awill emit XML.
1N/A
1N/AThe B<-declare_xml> argument, when used in conjunction with XHTML,
1N/Awill put a <?xml> declaration at the top of the HTML header. The sole
1N/Apurpose of this declaration is to declare the character set
1N/Aencoding. In the absence of -declare_xml, the output HTML will contain
1N/Aa <meta> tag that specifies the encoding, allowing the HTML to pass
1N/Amost validators. The default for -declare_xml is false.
1N/A
1N/AYou can place other arbitrary HTML elements to the <head> section with the
1N/AB<-head> tag. For example, to place a <link> element in the
1N/Ahead section, use this:
1N/A
1N/A print start_html(-head=>Link({-rel=>'shortcut icon',
1N/A -href=>'favicon.ico'}));
1N/A
1N/ATo incorporate multiple HTML elements into the <head> section, just pass an
1N/Aarray reference:
1N/A
1N/A print start_html(-head=>[
1N/A Link({-rel=>'next',
1N/A -href=>'http://www.capricorn.com/s2.html'}),
1N/A Link({-rel=>'previous',
1N/A -href=>'http://www.capricorn.com/s1.html'})
1N/A ]
1N/A );
1N/A
1N/AAnd here's how to create an HTTP-EQUIV <meta> tag:
1N/A
1N/A print start_html(-head=>meta({-http_equiv => 'Content-Type',
1N/A -content => 'text/html'}))
1N/A
1N/A
1N/AJAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
1N/AB<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
1N/Ato add JavaScript calls to your pages. B<-script> should
1N/Apoint to a block of text containing JavaScript function definitions.
1N/AThis block will be placed within a <script> block inside the HTML (not
1N/AHTTP) header. The block is placed in the header in order to give your
1N/Apage a fighting chance of having all its JavaScript functions in place
1N/Aeven if the user presses the stop button before the page has loaded
1N/Acompletely. CGI.pm attempts to format the script in such a way that
1N/AJavaScript-naive browsers will not choke on the code: unfortunately
1N/Athere are some browsers, such as Chimera for Unix, that get confused
1N/Aby it nevertheless.
1N/A
1N/AThe B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
1N/Acode to execute when the page is respectively opened and closed by the
1N/Abrowser. Usually these parameters are calls to functions defined in the
1N/AB<-script> field:
1N/A
1N/A $query = CGI->new;
1N/A print header;
1N/A $JSCRIPT=<<END;
1N/A // Ask a silly question
1N/A function riddle_me_this() {
1N/A var r = prompt("What walks on four legs in the morning, " +
1N/A "two legs in the afternoon, " +
1N/A "and three legs in the evening?");
1N/A response(r);
1N/A }
1N/A // Get a silly answer
1N/A function response(answer) {
1N/A if (answer == "man")
1N/A alert("Right you are!");
1N/A else
1N/A alert("Wrong! Guess again.");
1N/A }
1N/A END
1N/A print start_html(-title=>'The Riddle of the Sphinx',
1N/A -script=>$JSCRIPT);
1N/A
1N/AUse the B<-noScript> parameter to pass some HTML text that will be displayed on
1N/Abrowsers that do not have JavaScript (or browsers where JavaScript is turned
1N/Aoff).
1N/A
1N/AThe <script> tag, has several attributes including "type", "charset" and "src".
1N/A"src" allows you to keep JavaScript code in an external file. To use these
1N/Aattributes pass a HASH reference in the B<-script> parameter containing one or
1N/Amore of -type, -src, or -code:
1N/A
1N/A print $q->start_html(-title=>'The Riddle of the Sphinx',
1N/A -script=>{-type=>'JAVASCRIPT',
1N/A -src=>'/javascript/sphinx.js'}
1N/A );
1N/A
1N/A print $q->(-title=>'The Riddle of the Sphinx',
1N/A -script=>{-type=>'PERLSCRIPT',
1N/A -code=>'print "hello world!\n;"'}
1N/A );
1N/A
1N/A
1N/AA final feature allows you to incorporate multiple <script> sections into the
1N/Aheader. Just pass the list of script sections as an array reference.
1N/Athis allows you to specify different source files for different dialects
1N/Aof JavaScript. Example:
1N/A
1N/A print $q->start_html(-title=>'The Riddle of the Sphinx',
1N/A -script=>[
1N/A { -type => 'text/javascript',
1N/A -src => '/javascript/utilities10.js'
1N/A },
1N/A { -type => 'text/javascript',
1N/A -src => '/javascript/utilities11.js'
1N/A },
1N/A { -type => 'text/jscript',
1N/A -src => '/javascript/utilities12.js'
1N/A },
1N/A { -type => 'text/ecmascript',
1N/A -src => '/javascript/utilities219.js'
1N/A }
1N/A ]
1N/A );
1N/A
1N/AThe option "-language" is a synonym for -type, and is supported for
1N/Abackwards compatibility.
1N/A
1N/AThe old-style positional parameters are as follows:
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters:>
1N/A
1N/A=item 1.
1N/A
1N/AThe title
1N/A
1N/A=item 2.
1N/A
1N/AThe author's e-mail address (will create a <link rev="MADE"> tag if present
1N/A
1N/A=item 3.
1N/A
1N/AA 'true' flag if you want to include a <base> tag in the header. This
1N/Ahelps resolve relative addresses to absolute ones when the document is moved,
1N/Abut makes the document hierarchy non-portable. Use with care!
1N/A
1N/A=item 4, 5, 6...
1N/A
1N/AAny other parameters you want to include in the <body> tag. This is a good
1N/Aplace to put HTML extensions, such as colors and wallpaper patterns.
1N/A
1N/A=back
1N/A
1N/A=head2 ENDING THE HTML DOCUMENT:
1N/A
1N/A print end_html
1N/A
1N/AThis ends an HTML document by printing the </body></html> tags.
1N/A
1N/A=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
1N/A
1N/A $myself = self_url;
1N/A print q(<a href="$myself">I'm talking to myself.</a>);
1N/A
1N/Aself_url() will return a URL, that, when selected, will reinvoke
1N/Athis script with all its state information intact. This is most
1N/Auseful when you want to jump around within the document using
1N/Ainternal anchors but you don't want to disrupt the current contents
1N/Aof the form(s). Something like this will do the trick.
1N/A
1N/A $myself = self_url;
1N/A print "<a href=\"$myself#table1\">See table 1</a>";
1N/A print "<a href=\"$myself#table2\">See table 2</a>";
1N/A print "<a href=\"$myself#yourself\">See for yourself</a>";
1N/A
1N/AIf you want more control over what's returned, using the B<url()>
1N/Amethod instead.
1N/A
1N/AYou can also retrieve the unprocessed query string with query_string():
1N/A
1N/A $the_string = query_string;
1N/A
1N/A=head2 OBTAINING THE SCRIPT'S URL
1N/A
1N/A $full_url = url();
1N/A $full_url = url(-full=>1); #alternative syntax
1N/A $relative_url = url(-relative=>1);
1N/A $absolute_url = url(-absolute=>1);
1N/A $url_with_path = url(-path_info=>1);
1N/A $url_with_path_and_query = url(-path_info=>1,-query=>1);
1N/A $netloc = url(-base => 1);
1N/A
1N/AB<url()> returns the script's URL in a variety of formats. Called
1N/Awithout any arguments, it returns the full form of the URL, including
1N/Ahost name and port number
1N/A
1N/A http://your.host.com/path/to/script.cgi
1N/A
1N/AYou can modify this format with the following named arguments:
1N/A
1N/A=over 4
1N/A
1N/A=item B<-absolute>
1N/A
1N/AIf true, produce an absolute URL, e.g.
1N/A
1N/A /path/to/script.cgi
1N/A
1N/A=item B<-relative>
1N/A
1N/AProduce a relative URL. This is useful if you want to reinvoke your
1N/Ascript with different parameters. For example:
1N/A
1N/A script.cgi
1N/A
1N/A=item B<-full>
1N/A
1N/AProduce the full URL, exactly as if called without any arguments.
1N/AThis overrides the -relative and -absolute arguments.
1N/A
1N/A=item B<-path> (B<-path_info>)
1N/A
1N/AAppend the additional path information to the URL. This can be
1N/Acombined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
1N/Ais provided as a synonym.
1N/A
1N/A=item B<-query> (B<-query_string>)
1N/A
1N/AAppend the query string to the URL. This can be combined with
1N/AB<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
1N/Aas a synonym.
1N/A
1N/A=item B<-base>
1N/A
1N/AGenerate just the protocol and net location, as in http://www.foo.com:8000
1N/A
1N/A=item B<-rewrite>
1N/A
1N/AIf Apache's mod_rewrite is turned on, then the script name and path
1N/Ainfo probably won't match the request that the user sent. Set
1N/A-rewrite=>1 (default) to return URLs that match what the user sent
1N/A(the original request URI). Set -rewrite=>0 to return URLs that match
1N/Athe URL after mod_rewrite's rules have run. Because the additional
1N/Apath information only makes sense in the context of the rewritten URL,
1N/A-rewrite is set to false when you request path info in the URL.
1N/A
1N/A=back
1N/A
1N/A=head2 MIXING POST AND URL PARAMETERS
1N/A
1N/A $color = url_param('color');
1N/A
1N/AIt is possible for a script to receive CGI parameters in the URL as
1N/Awell as in the fill-out form by creating a form that POSTs to a URL
1N/Acontaining a query string (a "?" mark followed by arguments). The
1N/AB<param()> method will always return the contents of the POSTed
1N/Afill-out form, ignoring the URL's query string. To retrieve URL
1N/Aparameters, call the B<url_param()> method. Use it in the same way as
1N/AB<param()>. The main difference is that it allows you to read the
1N/Aparameters, but not set them.
1N/A
1N/A
1N/AUnder no circumstances will the contents of the URL query string
1N/Ainterfere with similarly-named CGI parameters in POSTed forms. If you
1N/Atry to mix a URL query string with a form submitted with the GET
1N/Amethod, the results will not be what you expect.
1N/A
1N/A=head1 CREATING STANDARD HTML ELEMENTS:
1N/A
1N/ACGI.pm defines general HTML shortcut methods for many HTML tags. HTML shortcuts are named after a single
1N/AHTML element and return a fragment of HTML text. Example:
1N/A
1N/A print $q->blockquote(
1N/A "Many years ago on the island of",
1N/A $q->a({href=>"http://crete.org/"},"Crete"),
1N/A "there lived a Minotaur named",
1N/A $q->strong("Fred."),
1N/A ),
1N/A $q->hr;
1N/A
1N/AThis results in the following HTML code (extra newlines have been
1N/Aadded for readability):
1N/A
1N/A <blockquote>
1N/A Many years ago on the island of
1N/A <a href="http://crete.org/">Crete</a> there lived
1N/A a minotaur named <strong>Fred.</strong>
1N/A </blockquote>
1N/A <hr>
1N/A
1N/AIf you find the syntax for calling the HTML shortcuts awkward, you can
1N/Aimport them into your namespace and dispense with the object syntax
1N/Acompletely (see the next section for more details):
1N/A
1N/A use CGI ':standard';
1N/A print blockquote(
1N/A "Many years ago on the island of",
1N/A a({href=>"http://crete.org/"},"Crete"),
1N/A "there lived a minotaur named",
1N/A strong("Fred."),
1N/A ),
1N/A hr;
1N/A
1N/A=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
1N/A
1N/AThe HTML methods will accept zero, one or multiple arguments. If you
1N/Aprovide no arguments, you get a single tag:
1N/A
1N/A print hr; # <hr>
1N/A
1N/AIf you provide one or more string arguments, they are concatenated
1N/Atogether with spaces and placed between opening and closing tags:
1N/A
1N/A print h1("Chapter","1"); # <h1>Chapter 1</h1>"
1N/A
1N/AIf the first argument is a hash reference, then the keys
1N/Aand values of the hash become the HTML tag's attributes:
1N/A
1N/A print a({-href=>'fred.html',-target=>'_new'},
1N/A "Open a new frame");
1N/A
1N/A <a href="fred.html",target="_new">Open a new frame</a>
1N/A
1N/AYou may dispense with the dashes in front of the attribute names if
1N/Ayou prefer:
1N/A
1N/A print img {src=>'fred.gif',align=>'LEFT'};
1N/A
1N/A <img align="LEFT" src="fred.gif">
1N/A
1N/ASometimes an HTML tag attribute has no argument. For example, ordered
1N/Alists can be marked as COMPACT. The syntax for this is an argument that
1N/Athat points to an undef string:
1N/A
1N/A print ol({compact=>undef},li('one'),li('two'),li('three'));
1N/A
1N/APrior to CGI.pm version 2.41, providing an empty ('') string as an
1N/Aattribute argument was the same as providing undef. However, this has
1N/Achanged in order to accommodate those who want to create tags of the form
1N/A<img alt="">. The difference is shown in these two pieces of code:
1N/A
1N/A CODE RESULT
1N/A img({alt=>undef}) <img alt>
1N/A img({alt=>''}) <img alt="">
1N/A
1N/A=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
1N/A
1N/AOne of the cool features of the HTML shortcuts is that they are
1N/Adistributive. If you give them an argument consisting of a
1N/AB<reference> to a list, the tag will be distributed across each
1N/Aelement of the list. For example, here's one way to make an ordered
1N/Alist:
1N/A
1N/A print ul(
1N/A li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
1N/A );
1N/A
1N/AThis example will result in HTML output that looks like this:
1N/A
1N/A <ul>
1N/A <li type="disc">Sneezy</li>
1N/A <li type="disc">Doc</li>
1N/A <li type="disc">Sleepy</li>
1N/A <li type="disc">Happy</li>
1N/A </ul>
1N/A
1N/AThis is extremely useful for creating tables. For example:
1N/A
1N/A print table({-border=>undef},
1N/A caption('When Should You Eat Your Vegetables?'),
1N/A Tr({-align=>'CENTER',-valign=>'TOP'},
1N/A [
1N/A th(['Vegetable', 'Breakfast','Lunch','Dinner']),
1N/A td(['Tomatoes' , 'no', 'yes', 'yes']),
1N/A td(['Broccoli' , 'no', 'no', 'yes']),
1N/A td(['Onions' , 'yes','yes', 'yes'])
1N/A ]
1N/A )
1N/A );
1N/A
1N/A=head2 HTML SHORTCUTS AND LIST INTERPOLATION
1N/A
1N/AConsider this bit of code:
1N/A
1N/A print blockquote(em('Hi'),'mom!'));
1N/A
1N/AIt will ordinarily return the string that you probably expect, namely:
1N/A
1N/A <blockquote><em>Hi</em> mom!</blockquote>
1N/A
1N/ANote the space between the element "Hi" and the element "mom!".
1N/ACGI.pm puts the extra space there using array interpolation, which is
1N/Acontrolled by the magic $" variable. Sometimes this extra space is
1N/Anot what you want, for example, when you are trying to align a series
1N/Aof images. In this case, you can simply change the value of $" to an
1N/Aempty string.
1N/A
1N/A {
1N/A local($") = '';
1N/A print blockquote(em('Hi'),'mom!'));
1N/A }
1N/A
1N/AI suggest you put the code in a block as shown here. Otherwise the
1N/Achange to $" will affect all subsequent code until you explicitly
1N/Areset it.
1N/A
1N/A=head2 NON-STANDARD HTML SHORTCUTS
1N/A
1N/AA few HTML tags don't follow the standard pattern for various
1N/Areasons.
1N/A
1N/AB<comment()> generates an HTML comment (<!-- comment -->). Call it
1N/Alike
1N/A
1N/A print comment('here is my comment');
1N/A
1N/ABecause of conflicts with built-in Perl functions, the following functions
1N/Abegin with initial caps:
1N/A
1N/A Select
1N/A Tr
1N/A Link
1N/A Delete
1N/A Accept
1N/A Sub
1N/A
1N/AIn addition, start_html(), end_html(), start_form(), end_form(),
1N/Astart_multipart_form() and all the fill-out form tags are special.
1N/ASee their respective sections.
1N/A
1N/A=head2 AUTOESCAPING HTML
1N/A
1N/ABy default, all HTML that is emitted by the form-generating functions
1N/Ais passed through a function called escapeHTML():
1N/A
1N/A=over 4
1N/A
1N/A=item $escaped_string = escapeHTML("unescaped string");
1N/A
1N/AEscape HTML formatting characters in a string.
1N/A
1N/A=back
1N/A
1N/AProvided that you have specified a character set of ISO-8859-1 (the
1N/Adefault), the standard HTML escaping rules will be used. The "<"
1N/Acharacter becomes "&lt;", ">" becomes "&gt;", "&" becomes "&amp;", and
1N/Athe quote character becomes "&quot;". In addition, the hexadecimal
1N/A0x8b and 0x9b characters, which some browsers incorrectly interpret
1N/Aas the left and right angle-bracket characters, are replaced by their
1N/Anumeric character entities ("&#8249" and "&#8250;"). If you manually change
1N/Athe charset, either by calling the charset() method explicitly or by
1N/Apassing a -charset argument to header(), then B<all> characters will
1N/Abe replaced by their numeric entities, since CGI.pm has no lookup
1N/Atable for all the possible encodings.
1N/A
1N/AC<escapeHTML()> expects the supplied string to be a character string. This means you
1N/Ashould Encode::decode data received from "outside" and Encode::encode your
1N/Astrings before sending them back outside. If your source code UTF-8 encoded and
1N/Ayou want to upgrade string literals in your source to character strings, you
1N/Acan use "use utf8". See L<perlunitut>, L<perlunifaq> and L<perlunicode> for more
1N/Ainformation on how Perl handles the difference between bytes and characters.
1N/A
1N/AThe automatic escaping does not apply to other shortcuts, such as
1N/Ah1(). You should call escapeHTML() yourself on untrusted data in
1N/Aorder to protect your pages against nasty tricks that people may enter
1N/Ainto guestbooks, etc.. To change the character set, use charset().
1N/ATo turn autoescaping off completely, use autoEscape(0):
1N/A
1N/A=over 4
1N/A
1N/A=item $charset = charset([$charset]);
1N/A
1N/AGet or set the current character set.
1N/A
1N/A=item $flag = autoEscape([$flag]);
1N/A
1N/AGet or set the value of the autoescape flag.
1N/A
1N/A=back
1N/A
1N/A=head2 PRETTY-PRINTING HTML
1N/A
1N/ABy default, all the HTML produced by these functions comes out as one
1N/Along line without carriage returns or indentation. This is yuck, but
1N/Ait does reduce the size of the documents by 10-20%. To get
1N/Apretty-printed output, please use L<CGI::Pretty>, a subclass
1N/Acontributed by Brian Paulsen.
1N/A
1N/A=head1 CREATING FILL-OUT FORMS:
1N/A
1N/AI<General note> The various form-creating methods all return strings
1N/Ato the caller, containing the tag or tags that will create the requested
1N/Aform element. You are responsible for actually printing out these strings.
1N/AIt's set up this way so that you can place formatting tags
1N/Aaround the form elements.
1N/A
1N/AI<Another note> The default values that you specify for the forms are only
1N/Aused the B<first> time the script is invoked (when there is no query
1N/Astring). On subsequent invocations of the script (when there is a query
1N/Astring), the former values are used even if they are blank.
1N/A
1N/AIf you want to change the value of a field from its previous value, you have two
1N/Achoices:
1N/A
1N/A(1) call the param() method to set it.
1N/A
1N/A(2) use the -override (alias -force) parameter (a new feature in version 2.15).
1N/AThis forces the default value to be used, regardless of the previous value:
1N/A
1N/A print textfield(-name=>'field_name',
1N/A -default=>'starting value',
1N/A -override=>1,
1N/A -size=>50,
1N/A -maxlength=>80);
1N/A
1N/AI<Yet another note> By default, the text and labels of form elements are
1N/Aescaped according to HTML rules. This means that you can safely use
1N/A"<CLICK ME>" as the label for a button. However, it also interferes with
1N/Ayour ability to incorporate special HTML character sequences, such as &Aacute;,
1N/Ainto your fields. If you wish to turn off automatic escaping, call the
1N/AautoEscape() method with a false value immediately after creating the CGI object:
1N/A
1N/A $query = CGI->new;
1N/A $query->autoEscape(0);
1N/A
1N/ANote that autoEscape() is exclusively used to effect the behavior of how some
1N/ACGI.pm HTML generation functions handle escaping. Calling escapeHTML()
1N/Aexplicitly will always escape the HTML.
1N/A
1N/AI<A Lurking Trap!> Some of the form-element generating methods return
1N/Amultiple tags. In a scalar context, the tags will be concatenated
1N/Atogether with spaces, or whatever is the current value of the $"
1N/Aglobal. In a list context, the methods will return a list of
1N/Aelements, allowing you to modify them if you wish. Usually you will
1N/Anot notice this behavior, but beware of this:
1N/A
1N/A printf("%s\n",end_form())
1N/A
1N/Aend_form() produces several tags, and only the first of them will be
1N/Aprinted because the format only expects one value.
1N/A
1N/A<p>
1N/A
1N/A
1N/A=head2 CREATING AN ISINDEX TAG
1N/A
1N/A print isindex(-action=>$action);
1N/A
1N/A -or-
1N/A
1N/A print isindex($action);
1N/A
1N/APrints out an <isindex> tag. Not very exciting. The parameter
1N/A-action specifies the URL of the script to process the query. The
1N/Adefault is to process the query with the current script.
1N/A
1N/A=head2 STARTING AND ENDING A FORM
1N/A
1N/A print start_form(-method=>$method,
1N/A -action=>$action,
1N/A -enctype=>$encoding);
1N/A <... various form stuff ...>
1N/A print end_form;
1N/A
1N/A -or-
1N/A
1N/A print start_form($method,$action,$encoding);
1N/A <... various form stuff ...>
1N/A print end_form;
1N/A
1N/Astart_form() will return a <form> tag with the optional method,
1N/Aaction and form encoding that you specify. The defaults are:
1N/A
1N/A method: POST
1N/A action: this script
1N/A enctype: application/x-www-form-urlencoded for non-XHTML
1N/A multipart/form-data for XHTML, see multipart/form-data below.
1N/A
1N/Aend_form() returns the closing </form> tag.
1N/A
1N/AStart_form()'s enctype argument tells the browser how to package the various
1N/Afields of the form before sending the form to the server. Two
1N/Avalues are possible:
1N/A
1N/AB<Note:> These methods were previously named startform() and endform().
1N/AThese methods are now DEPRECATED.
1N/APlease use start_form() and end_form() instead.
1N/A
1N/A=over 4
1N/A
1N/A=item B<application/x-www-form-urlencoded>
1N/A
1N/AThis is the older type of encoding. It is compatible with many CGI scripts and is
1N/Asuitable for short fields containing text data. For your
1N/Aconvenience, CGI.pm stores the name of this encoding
1N/Atype in B<&CGI::URL_ENCODED>.
1N/A
1N/A=item B<multipart/form-data>
1N/A
1N/AThis is the newer type of encoding.
1N/AIt is suitable for forms that contain very large fields or that
1N/Aare intended for transferring binary data. Most importantly,
1N/Ait enables the "file upload" feature. For
1N/Ayour convenience, CGI.pm stores the name of this encoding type
1N/Ain B<&CGI::MULTIPART>
1N/A
1N/AForms that use this type of encoding are not easily interpreted
1N/Aby CGI scripts unless they use CGI.pm or another library designed
1N/Ato handle them.
1N/A
1N/AIf XHTML is activated (the default), then forms will be automatically
1N/Acreated using this type of encoding.
1N/A
1N/A=back
1N/A
1N/AThe start_form() method uses the older form of encoding by
1N/Adefault unless XHTML is requested. If you want to use the
1N/Anewer form of encoding by default, you can call
1N/AB<start_multipart_form()> instead of B<start_form()>. The
1N/Amethod B<end_multipart_form()> is an alias to B<end_form()>.
1N/A
1N/AJAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
1N/Afor use with JavaScript. The -name parameter gives the
1N/Aform a name so that it can be identified and manipulated by
1N/AJavaScript functions. -onSubmit should point to a JavaScript
1N/Afunction that will be executed just before the form is submitted to your
1N/Aserver. You can use this opportunity to check the contents of the form
1N/Afor consistency and completeness. If you find something wrong, you
1N/Acan put up an alert box or maybe fix things up yourself. You can
1N/Aabort the submission by returning false from this function.
1N/A
1N/AUsually the bulk of JavaScript functions are defined in a <script>
1N/Ablock in the HTML header and -onSubmit points to one of these function
1N/Acall. See start_html() for details.
1N/A
1N/A=head2 FORM ELEMENTS
1N/A
1N/AAfter starting a form, you will typically create one or more
1N/Atextfields, popup menus, radio groups and other form elements. Each
1N/Aof these elements takes a standard set of named arguments. Some
1N/Aelements also have optional arguments. The standard arguments are as
1N/Afollows:
1N/A
1N/A=over 4
1N/A
1N/A=item B<-name>
1N/A
1N/AThe name of the field. After submission this name can be used to
1N/Aretrieve the field's value using the param() method.
1N/A
1N/A=item B<-value>, B<-values>
1N/A
1N/AThe initial value of the field which will be returned to the script
1N/Aafter form submission. Some form elements, such as text fields, take
1N/Aa single scalar -value argument. Others, such as popup menus, take a
1N/Areference to an array of values. The two arguments are synonyms.
1N/A
1N/A=item B<-tabindex>
1N/A
1N/AA numeric value that sets the order in which the form element receives
1N/Afocus when the user presses the tab key. Elements with lower values
1N/Areceive focus first.
1N/A
1N/A=item B<-id>
1N/A
1N/AA string identifier that can be used to identify this element to
1N/AJavaScript and DHTML.
1N/A
1N/A=item B<-override>
1N/A
1N/AA boolean, which, if true, forces the element to take on the value
1N/Aspecified by B<-value>, overriding the sticky behavior described
1N/Aearlier for the B<-nosticky> pragma.
1N/A
1N/A=item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect>
1N/A
1N/AThese are used to assign JavaScript event handlers. See the
1N/AJavaScripting section for more details.
1N/A
1N/A=back
1N/A
1N/AOther common arguments are described in the next section. In addition
1N/Ato these, all attributes described in the HTML specifications are
1N/Asupported.
1N/A
1N/A=head2 CREATING A TEXT FIELD
1N/A
1N/A print textfield(-name=>'field_name',
1N/A -value=>'starting value',
1N/A -size=>50,
1N/A -maxlength=>80);
1N/A -or-
1N/A
1N/A print textfield('field_name','starting value',50,80);
1N/A
1N/Atextfield() will return a text input field.
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters>
1N/A
1N/A=item 1.
1N/A
1N/AThe first parameter is the required name for the field (-name).
1N/A
1N/A=item 2.
1N/A
1N/AThe optional second parameter is the default starting value for the field
1N/Acontents (-value, formerly known as -default).
1N/A
1N/A=item 3.
1N/A
1N/AThe optional third parameter is the size of the field in
1N/A characters (-size).
1N/A
1N/A=item 4.
1N/A
1N/AThe optional fourth parameter is the maximum number of characters the
1N/A field will accept (-maxlength).
1N/A
1N/A=back
1N/A
1N/AAs with all these methods, the field will be initialized with its
1N/Aprevious contents from earlier invocations of the script.
1N/AWhen the form is processed, the value of the text field can be
1N/Aretrieved with:
1N/A
1N/A $value = param('foo');
1N/A
1N/AIf you want to reset it from its initial value after the script has been
1N/Acalled once, you can do so like this:
1N/A
1N/A param('foo',"I'm taking over this value!");
1N/A
1N/A=head2 CREATING A BIG TEXT FIELD
1N/A
1N/A print textarea(-name=>'foo',
1N/A -default=>'starting value',
1N/A -rows=>10,
1N/A -columns=>50);
1N/A
1N/A -or
1N/A
1N/A print textarea('foo','starting value',10,50);
1N/A
1N/Atextarea() is just like textfield, but it allows you to specify
1N/Arows and columns for a multiline text entry box. You can provide
1N/Aa starting value for the field, which can be long and contain
1N/Amultiple lines.
1N/A
1N/A=head2 CREATING A PASSWORD FIELD
1N/A
1N/A print password_field(-name=>'secret',
1N/A -value=>'starting value',
1N/A -size=>50,
1N/A -maxlength=>80);
1N/A -or-
1N/A
1N/A print password_field('secret','starting value',50,80);
1N/A
1N/Apassword_field() is identical to textfield(), except that its contents
1N/Awill be starred out on the web page.
1N/A
1N/A=head2 CREATING A FILE UPLOAD FIELD
1N/A
1N/A print filefield(-name=>'uploaded_file',
1N/A -default=>'starting value',
1N/A -size=>50,
1N/A -maxlength=>80);
1N/A -or-
1N/A
1N/A print filefield('uploaded_file','starting value',50,80);
1N/A
1N/Afilefield() will return a file upload field.
1N/AIn order to take full advantage of this I<you must use the new
1N/Amultipart encoding scheme> for the form. You can do this either
1N/Aby calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
1N/Aor by calling the new method B<start_multipart_form()> instead of
1N/Avanilla B<start_form()>.
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters>
1N/A
1N/A=item 1.
1N/A
1N/AThe first parameter is the required name for the field (-name).
1N/A
1N/A=item 2.
1N/A
1N/AThe optional second parameter is the starting value for the field contents
1N/Ato be used as the default file name (-default).
1N/A
1N/AFor security reasons, browsers don't pay any attention to this field,
1N/Aand so the starting value will always be blank. Worse, the field
1N/Aloses its "sticky" behavior and forgets its previous contents. The
1N/Astarting value field is called for in the HTML specification, however,
1N/Aand possibly some browser will eventually provide support for it.
1N/A
1N/A=item 3.
1N/A
1N/AThe optional third parameter is the size of the field in
1N/Acharacters (-size).
1N/A
1N/A=item 4.
1N/A
1N/AThe optional fourth parameter is the maximum number of characters the
1N/Afield will accept (-maxlength).
1N/A
1N/A=back
1N/A
1N/AJAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
1N/AB<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
1N/Arecognized. See textfield() for details.
1N/A
1N/A=head2 PROCESSING A FILE UPLOAD FIELD
1N/A
1N/A=head3 Basics
1N/A
1N/AWhen the form is processed, you can retrieve an L<IO::Handle> compatible
1N/Ahandle for a file upload field like this:
1N/A
1N/A $lightweight_fh = $q->upload('field_name');
1N/A
1N/A # undef may be returned if it's not a valid file handle
1N/A if (defined $lightweight_fh) {
1N/A # Upgrade the handle to one compatible with IO::Handle:
1N/A my $io_handle = $lightweight_fh->handle;
1N/A
1N/A open (OUTFILE,'>>','/usr/local/web/users/feedback');
1N/A while ($bytesread = $io_handle->read($buffer,1024)) {
1N/A print OUTFILE $buffer;
1N/A }
1N/A }
1N/A
1N/AIn a list context, upload() will return an array of filehandles.
1N/AThis makes it possible to process forms that use the same name for
1N/Amultiple upload fields.
1N/A
1N/AIf you want the entered file name for the file, you can just call param():
1N/A
1N/A $filename = $q->param('field_name');
1N/A
1N/ADifferent browsers will return slightly different things for the
1N/Aname. Some browsers return the filename only. Others return the full
1N/Apath to the file, using the path conventions of the user's machine.
1N/ARegardless, the name returned is always the name of the file on the
1N/AI<user's> machine, and is unrelated to the name of the temporary file
1N/Athat CGI.pm creates during upload spooling (see below).
1N/A
1N/AWhen a file is uploaded the browser usually sends along some
1N/Ainformation along with it in the format of headers. The information
1N/Ausually includes the MIME content type. To
1N/Aretrieve this information, call uploadInfo(). It returns a reference to
1N/Aa hash containing all the document headers.
1N/A
1N/A $filename = $q->param('uploaded_file');
1N/A $type = $q->uploadInfo($filename)->{'Content-Type'};
1N/A unless ($type eq 'text/html') {
1N/A die "HTML FILES ONLY!";
1N/A }
1N/A
1N/AIf you are using a machine that recognizes "text" and "binary" data
1N/Amodes, be sure to understand when and how to use them (see the Camel book).
1N/AOtherwise you may find that binary files are corrupted during file
1N/Auploads.
1N/A
1N/A=head3 Accessing the temp files directly
1N/A
1N/AWhen processing an uploaded file, CGI.pm creates a temporary file on your hard
1N/Adisk and passes you a file handle to that file. After you are finished with the
1N/Afile handle, CGI.pm unlinks (deletes) the temporary file. If you need to you
1N/Acan access the temporary file directly. You can access the temp file for a file
1N/Aupload by passing the file name to the tmpFileName() method:
1N/A
1N/A $filename = $query->param('uploaded_file');
1N/A $tmpfilename = $query->tmpFileName($filename);
1N/A
1N/AThe temporary file will be deleted automatically when your program exits unless
1N/Ayou manually rename it. On some operating systems (such as Windows NT), you
1N/Awill need to close the temporary file's filehandle before your program exits.
1N/AOtherwise the attempt to delete the temporary file will fail.
1N/A
1N/A=head3 Handling interrupted file uploads
1N/A
1N/AThere are occasionally problems involving parsing the uploaded file.
1N/AThis usually happens when the user presses "Stop" before the upload is
1N/Afinished. In this case, CGI.pm will return undef for the name of the
1N/Auploaded file and set I<cgi_error()> to the string "400 Bad request
1N/A(malformed multipart POST)". This error message is designed so that
1N/Ayou can incorporate it into a status code to be sent to the browser.
1N/AExample:
1N/A
1N/A $file = $q->upload('uploaded_file');
1N/A if (!$file && $q->cgi_error) {
1N/A print $q->header(-status=>$q->cgi_error);
1N/A exit 0;
1N/A }
1N/A
1N/AYou are free to create a custom HTML page to complain about the error,
1N/Aif you wish.
1N/A
1N/A=head3 Progress bars for file uploads and avoiding temp files
1N/A
1N/ACGI.pm gives you low-level access to file upload management through
1N/Aa file upload hook. You can use this feature to completely turn off
1N/Athe temp file storage of file uploads, or potentially write your own
1N/Afile upload progress meter.
1N/A
1N/AThis is much like the UPLOAD_HOOK facility available in L<Apache::Request>, with
1N/Athe exception that the first argument to the callback is an L<Apache::Upload>
1N/Aobject, here it's the remote filename.
1N/A
1N/A $q = CGI->new(\&hook [,$data [,$use_tempfile]]);
1N/A
1N/A sub hook {
1N/A my ($filename, $buffer, $bytes_read, $data) = @_;
1N/A print "Read $bytes_read bytes of $filename\n";
1N/A }
1N/A
1N/AThe C<< $data >> field is optional; it lets you pass configuration
1N/Ainformation (e.g. a database handle) to your hook callback.
1N/A
1N/AThe C<< $use_tempfile >> field is a flag that lets you turn on and off
1N/ACGI.pm's use of a temporary disk-based file during file upload. If you
1N/Aset this to a FALSE value (default true) then $q->param('uploaded_file')
1N/Awill no longer work, and the only way to get at the uploaded data is
1N/Avia the hook you provide.
1N/A
1N/AIf using the function-oriented interface, call the CGI::upload_hook()
1N/Amethod before calling param() or any other CGI functions:
1N/A
1N/A CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
1N/A
1N/AThis method is not exported by default. You will have to import it
1N/Aexplicitly if you wish to use it without the CGI:: prefix.
1N/A
1N/A=head3 Troubleshooting file uploads on Windows
1N/A
1N/AIf you are using CGI.pm on a Windows platform and find that binary
1N/Afiles get slightly larger when uploaded but that text files remain the
1N/Asame, then you have forgotten to activate binary mode on the output
1N/Afilehandle. Be sure to call binmode() on any handle that you create
1N/Ato write the uploaded file to disk.
1N/A
1N/A=head3 Older ways to process file uploads
1N/A
1N/A( This section is here for completeness. if you are building a new application with CGI.pm, you can skip it. )
1N/A
1N/AThe original way to process file uploads with CGI.pm was to use param(). The
1N/Avalue it returns has a dual nature as both a file name and a lightweight
1N/Afilehandle. This dual nature is problematic if you following the recommended
1N/Apractice of having C<use strict> in your code. Perl will complain when you try
1N/Ato use a string as a filehandle. More seriously, it is possible for the remote
1N/Auser to type garbage into the upload field, in which case what you get from
1N/Aparam() is not a filehandle at all, but a string.
1N/A
1N/ATo solve this problem the upload() method was added, which always returns a
1N/Alightweight filehandle. This generally works well, but will have trouble
1N/Ainteroperating with some other modules because the file handle is not derived
1N/Afrom L<IO::Handle>. So that brings us to current recommendation given above,
1N/Awhich is to call the handle() method on the file handle returned by upload().
1N/AThat upgrades the handle to an IO::Handle. It's a big win for compatibility for
1N/Aa small penalty of loading IO::Handle the first time you call it.
1N/A
1N/A
1N/A=head2 CREATING A POPUP MENU
1N/A
1N/A print popup_menu('menu_name',
1N/A ['eenie','meenie','minie'],
1N/A 'meenie');
1N/A
1N/A -or-
1N/A
1N/A %labels = ('eenie'=>'your first choice',
1N/A 'meenie'=>'your second choice',
1N/A 'minie'=>'your third choice');
1N/A %attributes = ('eenie'=>{'class'=>'class of first choice'});
1N/A print popup_menu('menu_name',
1N/A ['eenie','meenie','minie'],
1N/A 'meenie',\%labels,\%attributes);
1N/A
1N/A -or (named parameter style)-
1N/A
1N/A print popup_menu(-name=>'menu_name',
1N/A -values=>['eenie','meenie','minie'],
1N/A -default=>['meenie','minie'],
1N/A -labels=>\%labels,
1N/A -attributes=>\%attributes);
1N/A
1N/Apopup_menu() creates a menu.
1N/A
1N/A=over 4
1N/A
1N/A=item 1.
1N/A
1N/AThe required first argument is the menu's name (-name).
1N/A
1N/A=item 2.
1N/A
1N/AThe required second argument (-values) is an array B<reference>
1N/Acontaining the list of menu items in the menu. You can pass the
1N/Amethod an anonymous array, as shown in the example, or a reference to
1N/Aa named array, such as "\@foo".
1N/A
1N/A=item 3.
1N/A
1N/AThe optional third parameter (-default) is the name of the default
1N/Amenu choice. If not specified, the first item will be the default.
1N/AThe values of the previous choice will be maintained across
1N/Aqueries. Pass an array reference to select multiple defaults.
1N/A
1N/A=item 4.
1N/A
1N/AThe optional fourth parameter (-labels) is provided for people who
1N/Awant to use different values for the user-visible label inside the
1N/Apopup menu and the value returned to your script. It's a pointer to an
1N/Ahash relating menu values to user-visible labels. If you
1N/Aleave this parameter blank, the menu values will be displayed by
1N/Adefault. (You can also leave a label undefined if you want to).
1N/A
1N/A=item 5.
1N/A
1N/AThe optional fifth parameter (-attributes) is provided to assign
1N/Aany of the common HTML attributes to an individual menu item. It's
1N/Aa pointer to a hash relating menu values to another
1N/Ahash with the attribute's name as the key and the
1N/Aattribute's value as the value.
1N/A
1N/A=back
1N/A
1N/AWhen the form is processed, the selected value of the popup menu can
1N/Abe retrieved using:
1N/A
1N/A $popup_menu_value = param('menu_name');
1N/A
1N/A=head2 CREATING AN OPTION GROUP
1N/A
1N/ANamed parameter style
1N/A
1N/A print popup_menu(-name=>'menu_name',
1N/A -values=>[qw/eenie meenie minie/,
1N/A optgroup(-name=>'optgroup_name',
1N/A -values => ['moe','catch'],
1N/A -attributes=>{'catch'=>{'class'=>'red'}})],
1N/A -labels=>{'eenie'=>'one',
1N/A 'meenie'=>'two',
1N/A 'minie'=>'three'},
1N/A -default=>'meenie');
1N/A
1N/A Old style
1N/A print popup_menu('menu_name',
1N/A ['eenie','meenie','minie',
1N/A optgroup('optgroup_name', ['moe', 'catch'],
1N/A {'catch'=>{'class'=>'red'}})],'meenie',
1N/A {'eenie'=>'one','meenie'=>'two','minie'=>'three'});
1N/A
1N/Aoptgroup() creates an option group within a popup menu.
1N/A
1N/A=over 4
1N/A
1N/A=item 1.
1N/A
1N/AThe required first argument (B<-name>) is the label attribute of the
1N/Aoptgroup and is B<not> inserted in the parameter list of the query.
1N/A
1N/A=item 2.
1N/A
1N/AThe required second argument (B<-values>) is an array reference
1N/Acontaining the list of menu items in the menu. You can pass the
1N/Amethod an anonymous array, as shown in the example, or a reference
1N/Ato a named array, such as \@foo. If you pass a HASH reference,
1N/Athe keys will be used for the menu values, and the values will be
1N/Aused for the menu labels (see -labels below).
1N/A
1N/A=item 3.
1N/A
1N/AThe optional third parameter (B<-labels>) allows you to pass a reference
1N/Ato a hash containing user-visible labels for one or more
1N/Aof the menu items. You can use this when you want the user to see one
1N/Amenu string, but have the browser return your program a different one.
1N/AIf you don't specify this, the value string will be used instead
1N/A("eenie", "meenie" and "minie" in this example). This is equivalent
1N/Ato using a hash reference for the -values parameter.
1N/A
1N/A=item 4.
1N/A
1N/AAn optional fourth parameter (B<-labeled>) can be set to a true value
1N/Aand indicates that the values should be used as the label attribute
1N/Afor each option element within the optgroup.
1N/A
1N/A=item 5.
1N/A
1N/AAn optional fifth parameter (-novals) can be set to a true value and
1N/Aindicates to suppress the val attribute in each option element within
1N/Athe optgroup.
1N/A
1N/ASee the discussion on optgroup at W3C
1N/A(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
1N/Afor details.
1N/A
1N/A=item 6.
1N/A
1N/AAn optional sixth parameter (-attributes) is provided to assign
1N/Aany of the common HTML attributes to an individual menu item. It's
1N/Aa pointer to a hash relating menu values to another
1N/Ahash with the attribute's name as the key and the
1N/Aattribute's value as the value.
1N/A
1N/A=back
1N/A
1N/A=head2 CREATING A SCROLLING LIST
1N/A
1N/A print scrolling_list('list_name',
1N/A ['eenie','meenie','minie','moe'],
1N/A ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
1N/A -or-
1N/A
1N/A print scrolling_list('list_name',
1N/A ['eenie','meenie','minie','moe'],
1N/A ['eenie','moe'],5,'true',
1N/A \%labels,%attributes);
1N/A
1N/A -or-
1N/A
1N/A print scrolling_list(-name=>'list_name',
1N/A -values=>['eenie','meenie','minie','moe'],
1N/A -default=>['eenie','moe'],
1N/A -size=>5,
1N/A -multiple=>'true',
1N/A -labels=>\%labels,
1N/A -attributes=>\%attributes);
1N/A
1N/Ascrolling_list() creates a scrolling list.
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters:>
1N/A
1N/A=item 1.
1N/A
1N/AThe first and second arguments are the list name (-name) and values
1N/A(-values). As in the popup menu, the second argument should be an
1N/Aarray reference.
1N/A
1N/A=item 2.
1N/A
1N/AThe optional third argument (-default) can be either a reference to a
1N/Alist containing the values to be selected by default, or can be a
1N/Asingle value to select. If this argument is missing or undefined,
1N/Athen nothing is selected when the list first appears. In the named
1N/Aparameter version, you can use the synonym "-defaults" for this
1N/Aparameter.
1N/A
1N/A=item 3.
1N/A
1N/AThe optional fourth argument is the size of the list (-size).
1N/A
1N/A=item 4.
1N/A
1N/AThe optional fifth argument can be set to true to allow multiple
1N/Asimultaneous selections (-multiple). Otherwise only one selection
1N/Awill be allowed at a time.
1N/A
1N/A=item 5.
1N/A
1N/AThe optional sixth argument is a pointer to a hash
1N/Acontaining long user-visible labels for the list items (-labels).
1N/AIf not provided, the values will be displayed.
1N/A
1N/A=item 6.
1N/A
1N/AThe optional sixth parameter (-attributes) is provided to assign
1N/Aany of the common HTML attributes to an individual menu item. It's
1N/Aa pointer to a hash relating menu values to another
1N/Ahash with the attribute's name as the key and the
1N/Aattribute's value as the value.
1N/A
1N/AWhen this form is processed, all selected list items will be returned as
1N/Aa list under the parameter name 'list_name'. The values of the
1N/Aselected items can be retrieved with:
1N/A
1N/A @selected = param('list_name');
1N/A
1N/A=back
1N/A
1N/A=head2 CREATING A GROUP OF RELATED CHECKBOXES
1N/A
1N/A print checkbox_group(-name=>'group_name',
1N/A -values=>['eenie','meenie','minie','moe'],
1N/A -default=>['eenie','moe'],
1N/A -linebreak=>'true',
1N/A -disabled => ['moe'],
1N/A -labels=>\%labels,
1N/A -attributes=>\%attributes);
1N/A
1N/A print checkbox_group('group_name',
1N/A ['eenie','meenie','minie','moe'],
1N/A ['eenie','moe'],'true',\%labels,
1N/A {'moe'=>{'class'=>'red'}});
1N/A
1N/A HTML3-COMPATIBLE BROWSERS ONLY:
1N/A
1N/A print checkbox_group(-name=>'group_name',
1N/A -values=>['eenie','meenie','minie','moe'],
1N/A -rows=2,-columns=>2);
1N/A
1N/A
1N/Acheckbox_group() creates a list of checkboxes that are related
1N/Aby the same name.
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters:>
1N/A
1N/A=item 1.
1N/A
1N/AThe first and second arguments are the checkbox name and values,
1N/Arespectively (-name and -values). As in the popup menu, the second
1N/Aargument should be an array reference. These values are used for the
1N/Auser-readable labels printed next to the checkboxes as well as for the
1N/Avalues passed to your script in the query string.
1N/A
1N/A=item 2.
1N/A
1N/AThe optional third argument (-default) can be either a reference to a
1N/Alist containing the values to be checked by default, or can be a
1N/Asingle value to checked. If this argument is missing or undefined,
1N/Athen nothing is selected when the list first appears.
1N/A
1N/A=item 3.
1N/A
1N/AThe optional fourth argument (-linebreak) can be set to true to place
1N/Aline breaks between the checkboxes so that they appear as a vertical
1N/Alist. Otherwise, they will be strung together on a horizontal line.
1N/A
1N/A=back
1N/A
1N/A
1N/AThe optional B<-labels> argument is a pointer to a hash
1N/Arelating the checkbox values to the user-visible labels that will be
1N/Aprinted next to them. If not provided, the values will be used as the
1N/Adefault.
1N/A
1N/A
1N/AThe optional parameters B<-rows>, and B<-columns> cause
1N/Acheckbox_group() to return an HTML3 compatible table containing the
1N/Acheckbox group formatted with the specified number of rows and
1N/Acolumns. You can provide just the -columns parameter if you wish;
1N/Acheckbox_group will calculate the correct number of rows for you.
1N/A
1N/AThe option B<-disabled> takes an array of checkbox values and disables
1N/Athem by greying them out (this may not be supported by all browsers).
1N/A
1N/AThe optional B<-attributes> argument is provided to assign any of the
1N/Acommon HTML attributes to an individual menu item. It's a pointer to
1N/Aa hash relating menu values to another hash
1N/Awith the attribute's name as the key and the attribute's value as the
1N/Avalue.
1N/A
1N/AThe optional B<-tabindex> argument can be used to control the order in which
1N/Aradio buttons receive focus when the user presses the tab button. If
1N/Apassed a scalar numeric value, the first element in the group will
1N/Areceive this tab index and subsequent elements will be incremented by
1N/Aone. If given a reference to an array of radio button values, then
1N/Athe indexes will be jiggered so that the order specified in the array
1N/Awill correspond to the tab order. You can also pass a reference to a
1N/Ahash in which the hash keys are the radio button values and the values
1N/Aare the tab indexes of each button. Examples:
1N/A
1N/A -tabindex => 100 # this group starts at index 100 and counts up
1N/A -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
1N/A -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
1N/A
1N/AThe optional B<-labelattributes> argument will contain attributes
1N/Aattached to the <label> element that surrounds each button.
1N/A
1N/AWhen the form is processed, all checked boxes will be returned as
1N/Aa list under the parameter name 'group_name'. The values of the
1N/A"on" checkboxes can be retrieved with:
1N/A
1N/A @turned_on = param('group_name');
1N/A
1N/AThe value returned by checkbox_group() is actually an array of button
1N/Aelements. You can capture them and use them within tables, lists,
1N/Aor in other creative ways:
1N/A
1N/A @h = checkbox_group(-name=>'group_name',-values=>\@values);
1N/A &use_in_creative_way(@h);
1N/A
1N/A=head2 CREATING A STANDALONE CHECKBOX
1N/A
1N/A print checkbox(-name=>'checkbox_name',
1N/A -checked=>1,
1N/A -value=>'ON',
1N/A -label=>'CLICK ME');
1N/A
1N/A -or-
1N/A
1N/A print checkbox('checkbox_name','checked','ON','CLICK ME');
1N/A
1N/Acheckbox() is used to create an isolated checkbox that isn't logically
1N/Arelated to any others.
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters:>
1N/A
1N/A=item 1.
1N/A
1N/AThe first parameter is the required name for the checkbox (-name). It
1N/Awill also be used for the user-readable label printed next to the
1N/Acheckbox.
1N/A
1N/A=item 2.
1N/A
1N/AThe optional second parameter (-checked) specifies that the checkbox
1N/Ais turned on by default. Synonyms are -selected and -on.
1N/A
1N/A=item 3.
1N/A
1N/AThe optional third parameter (-value) specifies the value of the
1N/Acheckbox when it is checked. If not provided, the word "on" is
1N/Aassumed.
1N/A
1N/A=item 4.
1N/A
1N/AThe optional fourth parameter (-label) is the user-readable label to
1N/Abe attached to the checkbox. If not provided, the checkbox name is
1N/Aused.
1N/A
1N/A=back
1N/A
1N/AThe value of the checkbox can be retrieved using:
1N/A
1N/A $turned_on = param('checkbox_name');
1N/A
1N/A=head2 CREATING A RADIO BUTTON GROUP
1N/A
1N/A print radio_group(-name=>'group_name',
1N/A -values=>['eenie','meenie','minie'],
1N/A -default=>'meenie',
1N/A -linebreak=>'true',
1N/A -labels=>\%labels,
1N/A -attributes=>\%attributes);
1N/A
1N/A -or-
1N/A
1N/A print radio_group('group_name',['eenie','meenie','minie'],
1N/A 'meenie','true',\%labels,\%attributes);
1N/A
1N/A
1N/A HTML3-COMPATIBLE BROWSERS ONLY:
1N/A
1N/A print radio_group(-name=>'group_name',
1N/A -values=>['eenie','meenie','minie','moe'],
1N/A -rows=2,-columns=>2);
1N/A
1N/Aradio_group() creates a set of logically-related radio buttons
1N/A(turning one member of the group on turns the others off)
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters:>
1N/A
1N/A=item 1.
1N/A
1N/AThe first argument is the name of the group and is required (-name).
1N/A
1N/A=item 2.
1N/A
1N/AThe second argument (-values) is the list of values for the radio
1N/Abuttons. The values and the labels that appear on the page are
1N/Aidentical. Pass an array I<reference> in the second argument, either
1N/Ausing an anonymous array, as shown, or by referencing a named array as
1N/Ain "\@foo".
1N/A
1N/A=item 3.
1N/A
1N/AThe optional third parameter (-default) is the name of the default
1N/Abutton to turn on. If not specified, the first item will be the
1N/Adefault. You can provide a nonexistent button name, such as "-" to
1N/Astart up with no buttons selected.
1N/A
1N/A=item 4.
1N/A
1N/AThe optional fourth parameter (-linebreak) can be set to 'true' to put
1N/Aline breaks between the buttons, creating a vertical list.
1N/A
1N/A=item 5.
1N/A
1N/AThe optional fifth parameter (-labels) is a pointer to an associative
1N/Aarray relating the radio button values to user-visible labels to be
1N/Aused in the display. If not provided, the values themselves are
1N/Adisplayed.
1N/A
1N/A=back
1N/A
1N/A
1N/AAll modern browsers can take advantage of the optional parameters
1N/AB<-rows>, and B<-columns>. These parameters cause radio_group() to
1N/Areturn an HTML3 compatible table containing the radio group formatted
1N/Awith the specified number of rows and columns. You can provide just
1N/Athe -columns parameter if you wish; radio_group will calculate the
1N/Acorrect number of rows for you.
1N/A
1N/ATo include row and column headings in the returned table, you
1N/Acan use the B<-rowheaders> and B<-colheaders> parameters. Both
1N/Aof these accept a pointer to an array of headings to use.
1N/AThe headings are just decorative. They don't reorganize the
1N/Ainterpretation of the radio buttons -- they're still a single named
1N/Aunit.
1N/A
1N/AThe optional B<-tabindex> argument can be used to control the order in which
1N/Aradio buttons receive focus when the user presses the tab button. If
1N/Apassed a scalar numeric value, the first element in the group will
1N/Areceive this tab index and subsequent elements will be incremented by
1N/Aone. If given a reference to an array of radio button values, then
1N/Athe indexes will be jiggered so that the order specified in the array
1N/Awill correspond to the tab order. You can also pass a reference to a
1N/Ahash in which the hash keys are the radio button values and the values
1N/Aare the tab indexes of each button. Examples:
1N/A
1N/A -tabindex => 100 # this group starts at index 100 and counts up
1N/A -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
1N/A -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
1N/A
1N/A
1N/AThe optional B<-attributes> argument is provided to assign any of the
1N/Acommon HTML attributes to an individual menu item. It's a pointer to
1N/Aa hash relating menu values to another hash
1N/Awith the attribute's name as the key and the attribute's value as the
1N/Avalue.
1N/A
1N/AThe optional B<-labelattributes> argument will contain attributes
1N/Aattached to the <label> element that surrounds each button.
1N/A
1N/AWhen the form is processed, the selected radio button can
1N/Abe retrieved using:
1N/A
1N/A $which_radio_button = param('group_name');
1N/A
1N/AThe value returned by radio_group() is actually an array of button
1N/Aelements. You can capture them and use them within tables, lists,
1N/Aor in other creative ways:
1N/A
1N/A @h = radio_group(-name=>'group_name',-values=>\@values);
1N/A &use_in_creative_way(@h);
1N/A
1N/A=head2 CREATING A SUBMIT BUTTON
1N/A
1N/A print submit(-name=>'button_name',
1N/A -value=>'value');
1N/A
1N/A -or-
1N/A
1N/A print submit('button_name','value');
1N/A
1N/Asubmit() will create the query submission button. Every form
1N/Ashould have one of these.
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters:>
1N/A
1N/A=item 1.
1N/A
1N/AThe first argument (-name) is optional. You can give the button a
1N/Aname if you have several submission buttons in your form and you want
1N/Ato distinguish between them.
1N/A
1N/A=item 2.
1N/A
1N/AThe second argument (-value) is also optional. This gives the button
1N/Aa value that will be passed to your script in the query string. The
1N/Aname will also be used as the user-visible label.
1N/A
1N/A=item 3.
1N/A
1N/AYou can use -label as an alias for -value. I always get confused
1N/Aabout which of -name and -value changes the user-visible label on the
1N/Abutton.
1N/A
1N/A=back
1N/A
1N/AYou can figure out which button was pressed by using different
1N/Avalues for each one:
1N/A
1N/A $which_one = param('button_name');
1N/A
1N/A=head2 CREATING A RESET BUTTON
1N/A
1N/A print reset
1N/A
1N/Areset() creates the "reset" button. Note that it restores the
1N/Aform to its value from the last time the script was called,
1N/ANOT necessarily to the defaults.
1N/A
1N/ANote that this conflicts with the Perl reset() built-in. Use
1N/ACORE::reset() to get the original reset function.
1N/A
1N/A=head2 CREATING A DEFAULT BUTTON
1N/A
1N/A print defaults('button_label')
1N/A
1N/Adefaults() creates a button that, when invoked, will cause the
1N/Aform to be completely reset to its defaults, wiping out all the
1N/Achanges the user ever made.
1N/A
1N/A=head2 CREATING A HIDDEN FIELD
1N/A
1N/A print hidden(-name=>'hidden_name',
1N/A -default=>['value1','value2'...]);
1N/A
1N/A -or-
1N/A
1N/A print hidden('hidden_name','value1','value2'...);
1N/A
1N/Ahidden() produces a text field that can't be seen by the user. It
1N/Ais useful for passing state variable information from one invocation
1N/Aof the script to the next.
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters:>
1N/A
1N/A=item 1.
1N/A
1N/AThe first argument is required and specifies the name of this
1N/Afield (-name).
1N/A
1N/A=item 2.
1N/A
1N/AThe second argument is also required and specifies its value
1N/A(-default). In the named parameter style of calling, you can provide
1N/Aa single value here or a reference to a whole list
1N/A
1N/A=back
1N/A
1N/AFetch the value of a hidden field this way:
1N/A
1N/A $hidden_value = param('hidden_name');
1N/A
1N/ANote, that just like all the other form elements, the value of a
1N/Ahidden field is "sticky". If you want to replace a hidden field with
1N/Asome other values after the script has been called once you'll have to
1N/Ado it manually:
1N/A
1N/A param('hidden_name','new','values','here');
1N/A
1N/A=head2 CREATING A CLICKABLE IMAGE BUTTON
1N/A
1N/A print image_button(-name=>'button_name',
1N/A -src=>'/source/URL',
1N/A -align=>'MIDDLE');
1N/A
1N/A -or-
1N/A
1N/A print image_button('button_name','/source/URL','MIDDLE');
1N/A
1N/Aimage_button() produces a clickable image. When it's clicked on the
1N/Aposition of the click is returned to your script as "button_name.x"
1N/Aand "button_name.y", where "button_name" is the name you've assigned
1N/Ato it.
1N/A
1N/A=over 4
1N/A
1N/A=item B<Parameters:>
1N/A
1N/A=item 1.
1N/A
1N/AThe first argument (-name) is required and specifies the name of this
1N/Afield.
1N/A
1N/A=item 2.
1N/A
1N/AThe second argument (-src) is also required and specifies the URL
1N/A
1N/A=item 3.
1N/AThe third option (-align, optional) is an alignment type, and may be
1N/ATOP, BOTTOM or MIDDLE
1N/A
1N/A=back
1N/A
1N/AFetch the value of the button this way:
1N/A $x = param('button_name.x');
1N/A $y = param('button_name.y');
1N/A
1N/A=head2 CREATING A JAVASCRIPT ACTION BUTTON
1N/A
1N/A print button(-name=>'button_name',
1N/A -value=>'user visible label',
1N/A -onClick=>"do_something()");
1N/A
1N/A -or-
1N/A
1N/A print button('button_name',"user visible value","do_something()");
1N/A
1N/Abutton() produces an C<< <input> >> tag with C<type="button">. When it's
1N/Apressed the fragment of JavaScript code pointed to by the B<-onClick> parameter
1N/Awill be executed.
1N/A
1N/A=head1 HTTP COOKIES
1N/A
1N/ABrowsers support a so-called "cookie" designed to help maintain state
1N/Awithin a browser session. CGI.pm has several methods that support
1N/Acookies.
1N/A
1N/AA cookie is a name=value pair much like the named parameters in a CGI
1N/Aquery string. CGI scripts create one or more cookies and send
1N/Athem to the browser in the HTTP header. The browser maintains a list
1N/Aof cookies that belong to a particular Web server, and returns them
1N/Ato the CGI script during subsequent interactions.
1N/A
1N/AIn addition to the required name=value pair, each cookie has several
1N/Aoptional attributes:
1N/A
1N/A=over 4
1N/A
1N/A=item 1. an expiration time
1N/A
1N/AThis is a time/date string (in a special GMT format) that indicates
1N/Awhen a cookie expires. The cookie will be saved and returned to your
1N/Ascript until this expiration date is reached if the user exits
1N/Athe browser and restarts it. If an expiration date isn't specified, the cookie
1N/Awill remain active until the user quits the browser.
1N/A
1N/A=item 2. a domain
1N/A
1N/AThis is a partial or complete domain name for which the cookie is
1N/Avalid. The browser will return the cookie to any host that matches
1N/Athe partial domain name. For example, if you specify a domain name
1N/Aof ".capricorn.com", then the browser will return the cookie to
1N/AWeb servers running on any of the machines "www.capricorn.com",
1N/A"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
1N/Amust contain at least two periods to prevent attempts to match
1N/Aon top level domains like ".edu". If no domain is specified, then
1N/Athe browser will only return the cookie to servers on the host the
1N/Acookie originated from.
1N/A
1N/A=item 3. a path
1N/A
1N/AIf you provide a cookie path attribute, the browser will check it
1N/Aagainst your script's URL before returning the cookie. For example,
1N/Aif you specify the path "/cgi-bin", then the cookie will be returned
1N/Ato each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
1N/Aand "/cgi-bin/customer_service/complain.pl", but not to the script
1N/A"/cgi-private/site_admin.pl". By default, path is set to "/", which
1N/Acauses the cookie to be sent to any CGI script on your site.
1N/A
1N/A=item 4. a "secure" flag
1N/A
1N/AIf the "secure" attribute is set, the cookie will only be sent to your
1N/Ascript if the CGI request is occurring on a secure channel, such as SSL.
1N/A
1N/A=back
1N/A
1N/AThe interface to HTTP cookies is the B<cookie()> method:
1N/A
1N/A $cookie = cookie(-name=>'sessionID',
1N/A -value=>'xyzzy',
1N/A -expires=>'+1h',
1N/A -path=>'/cgi-bin/database',
1N/A -domain=>'.capricorn.org',
1N/A -secure=>1);
1N/A print header(-cookie=>$cookie);
1N/A
1N/AB<cookie()> creates a new cookie. Its parameters include:
1N/A
1N/A=over 4
1N/A
1N/A=item B<-name>
1N/A
1N/AThe name of the cookie (required). This can be any string at all.
1N/AAlthough browsers limit their cookie names to non-whitespace
1N/Aalphanumeric characters, CGI.pm removes this restriction by escaping
1N/Aand unescaping cookies behind the scenes.
1N/A
1N/A=item B<-value>
1N/A
1N/AThe value of the cookie. This can be any scalar value,
1N/Aarray reference, or even hash reference. For example,
1N/Ayou can store an entire hash into a cookie this way:
1N/A
1N/A $cookie=cookie(-name=>'family information',
1N/A -value=>\%childrens_ages);
1N/A
1N/A=item B<-path>
1N/A
1N/AThe optional partial path for which this cookie will be valid, as described
1N/Aabove.
1N/A
1N/A=item B<-domain>
1N/A
1N/AThe optional partial domain for which this cookie will be valid, as described
1N/Aabove.
1N/A
1N/A=item B<-expires>
1N/A
1N/AThe optional expiration date for this cookie. The format is as described
1N/Ain the section on the B<header()> method:
1N/A
1N/A "+1h" one hour from now
1N/A
1N/A=item B<-secure>
1N/A
1N/AIf set to true, this cookie will only be used within a secure
1N/ASSL session.
1N/A
1N/A=back
1N/A
1N/AThe cookie created by cookie() must be incorporated into the HTTP
1N/Aheader within the string returned by the header() method:
1N/A
1N/A use CGI ':standard';
1N/A print header(-cookie=>$my_cookie);
1N/A
1N/ATo create multiple cookies, give header() an array reference:
1N/A
1N/A $cookie1 = cookie(-name=>'riddle_name',
1N/A -value=>"The Sphynx's Question");
1N/A $cookie2 = cookie(-name=>'answers',
1N/A -value=>\%answers);
1N/A print header(-cookie=>[$cookie1,$cookie2]);
1N/A
1N/ATo retrieve a cookie, request it by name by calling cookie() method
1N/Awithout the B<-value> parameter. This example uses the object-oriented
1N/Aform:
1N/A
1N/A use CGI;
1N/A $query = CGI->new;
1N/A $riddle = $query->cookie('riddle_name');
1N/A %answers = $query->cookie('answers');
1N/A
1N/ACookies created with a single scalar value, such as the "riddle_name"
1N/Acookie, will be returned in that form. Cookies with array and hash
1N/Avalues can also be retrieved.
1N/A
1N/AThe cookie and CGI namespaces are separate. If you have a parameter
1N/Anamed 'answers' and a cookie named 'answers', the values retrieved by
1N/Aparam() and cookie() are independent of each other. However, it's
1N/Asimple to turn a CGI parameter into a cookie, and vice-versa:
1N/A
1N/A # turn a CGI parameter into a cookie
1N/A $c=cookie(-name=>'answers',-value=>[param('answers')]);
1N/A # vice-versa
1N/A param(-name=>'answers',-value=>[cookie('answers')]);
1N/A
1N/AIf you call cookie() without any parameters, it will return a list of
1N/Athe names of all cookies passed to your script:
1N/A
1N/A @cookies = cookie();
1N/A
1N/ASee the B<cookie.cgi> example script for some ideas on how to use
1N/Acookies effectively.
1N/A
1N/A=head1 WORKING WITH FRAMES
1N/A
1N/AIt's possible for CGI.pm scripts to write into several browser panels
1N/Aand windows using the HTML 4 frame mechanism. There are three
1N/Atechniques for defining new frames programmatically:
1N/A
1N/A=over 4
1N/A
1N/A=item 1. Create a <Frameset> document
1N/A
1N/AAfter writing out the HTTP header, instead of creating a standard
1N/AHTML document using the start_html() call, create a <frameset>
1N/Adocument that defines the frames on the page. Specify your script(s)
1N/A(with appropriate parameters) as the SRC for each of the frames.
1N/A
1N/AThere is no specific support for creating <frameset> sections
1N/Ain CGI.pm, but the HTML is very simple to write.
1N/A
1N/A=item 2. Specify the destination for the document in the HTTP header
1N/A
1N/AYou may provide a B<-target> parameter to the header() method:
1N/A
1N/A print header(-target=>'ResultsWindow');
1N/A
1N/AThis will tell the browser to load the output of your script into the
1N/Aframe named "ResultsWindow". If a frame of that name doesn't already
1N/Aexist, the browser will pop up a new window and load your script's
1N/Adocument into that. There are a number of magic names that you can
1N/Ause for targets. See the HTML C<< <frame> >> documentation for details.
1N/A
1N/A=item 3. Specify the destination for the document in the <form> tag
1N/A
1N/AYou can specify the frame to load in the FORM tag itself. With
1N/ACGI.pm it looks like this:
1N/A
1N/A print start_form(-target=>'ResultsWindow');
1N/A
1N/AWhen your script is reinvoked by the form, its output will be loaded
1N/Ainto the frame named "ResultsWindow". If one doesn't already exist
1N/Aa new window will be created.
1N/A
1N/A=back
1N/A
1N/AThe script "frameset.cgi" in the examples directory shows one way to
1N/Acreate pages in which the fill-out form and the response live in
1N/Aside-by-side frames.
1N/A
1N/A=head1 SUPPORT FOR JAVASCRIPT
1N/A
1N/AThe usual way to use JavaScript is to define a set of functions in a
1N/A<SCRIPT> block inside the HTML header and then to register event
1N/Ahandlers in the various elements of the page. Events include such
1N/Athings as the mouse passing over a form element, a button being
1N/Aclicked, the contents of a text field changing, or a form being
1N/Asubmitted. When an event occurs that involves an element that has
1N/Aregistered an event handler, its associated JavaScript code gets
1N/Acalled.
1N/A
1N/AThe elements that can register event handlers include the <BODY> of an
1N/AHTML document, hypertext links, all the various elements of a fill-out
1N/Aform, and the form itself. There are a large number of events, and
1N/Aeach applies only to the elements for which it is relevant. Here is a
1N/Apartial list:
1N/A
1N/A=over 4
1N/A
1N/A=item B<onLoad>
1N/A
1N/AThe browser is loading the current document. Valid in:
1N/A
1N/A + The HTML <BODY> section only.
1N/A
1N/A=item B<onUnload>
1N/A
1N/AThe browser is closing the current page or frame. Valid for:
1N/A
1N/A + The HTML <BODY> section only.
1N/A
1N/A=item B<onSubmit>
1N/A
1N/AThe user has pressed the submit button of a form. This event happens
1N/Ajust before the form is submitted, and your function can return a
1N/Avalue of false in order to abort the submission. Valid for:
1N/A
1N/A + Forms only.
1N/A
1N/A=item B<onClick>
1N/A
1N/AThe mouse has clicked on an item in a fill-out form. Valid for:
1N/A
1N/A + Buttons (including submit, reset, and image buttons)
1N/A + Checkboxes
1N/A + Radio buttons
1N/A
1N/A=item B<onChange>
1N/A
1N/AThe user has changed the contents of a field. Valid for:
1N/A
1N/A + Text fields
1N/A + Text areas
1N/A + Password fields
1N/A + File fields
1N/A + Popup Menus
1N/A + Scrolling lists
1N/A
1N/A=item B<onFocus>
1N/A
1N/AThe user has selected a field to work with. Valid for:
1N/A
1N/A + Text fields
1N/A + Text areas
1N/A + Password fields
1N/A + File fields
1N/A + Popup Menus
1N/A + Scrolling lists
1N/A
1N/A=item B<onBlur>
1N/A
1N/AThe user has deselected a field (gone to work somewhere else). Valid
1N/Afor:
1N/A
1N/A + Text fields
1N/A + Text areas
1N/A + Password fields
1N/A + File fields
1N/A + Popup Menus
1N/A + Scrolling lists
1N/A
1N/A=item B<onSelect>
1N/A
1N/AThe user has changed the part of a text field that is selected. Valid
1N/Afor:
1N/A
1N/A + Text fields
1N/A + Text areas
1N/A + Password fields
1N/A + File fields
1N/A
1N/A=item B<onMouseOver>
1N/A
1N/AThe mouse has moved over an element.
1N/A
1N/A + Text fields
1N/A + Text areas
1N/A + Password fields
1N/A + File fields
1N/A + Popup Menus
1N/A + Scrolling lists
1N/A
1N/A=item B<onMouseOut>
1N/A
1N/AThe mouse has moved off an element.
1N/A
1N/A + Text fields
1N/A + Text areas
1N/A + Password fields
1N/A + File fields
1N/A + Popup Menus
1N/A + Scrolling lists
1N/A
1N/A=back
1N/A
1N/AIn order to register a JavaScript event handler with an HTML element,
1N/Ajust use the event name as a parameter when you call the corresponding
1N/ACGI method. For example, to have your validateAge() JavaScript code
1N/Aexecuted every time the textfield named "age" changes, generate the
1N/Afield like this:
1N/A
1N/A print textfield(-name=>'age',-onChange=>"validateAge(this)");
1N/A
1N/AThis example assumes that you've already declared the validateAge()
1N/Afunction by incorporating it into a <SCRIPT> block. The CGI.pm
1N/Astart_html() method provides a convenient way to create this section.
1N/A
1N/ASimilarly, you can create a form that checks itself over for
1N/Aconsistency and alerts the user if some essential value is missing by
1N/Acreating it this way:
1N/A print start_form(-onSubmit=>"validateMe(this)");
1N/A
1N/ASee the javascript.cgi script for a demonstration of how this all
1N/Aworks.
1N/A
1N/A
1N/A=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
1N/A
1N/ACGI.pm has limited support for HTML3's cascading style sheets (css).
1N/ATo incorporate a stylesheet into your document, pass the
1N/Astart_html() method a B<-style> parameter. The value of this
1N/Aparameter may be a scalar, in which case it is treated as the source
1N/AURL for the stylesheet, or it may be a hash reference. In the latter
1N/Acase you should provide the hash with one or more of B<-src> or
1N/AB<-code>. B<-src> points to a URL where an externally-defined
1N/Astylesheet can be found. B<-code> points to a scalar value to be
1N/Aincorporated into a <style> section. Style definitions in B<-code>
1N/Aoverride similarly-named ones in B<-src>, hence the name "cascading."
1N/A
1N/AYou may also specify the type of the stylesheet by adding the optional
1N/AB<-type> parameter to the hash pointed to by B<-style>. If not
1N/Aspecified, the style defaults to 'text/css'.
1N/A
1N/ATo refer to a style within the body of your document, add the
1N/AB<-class> parameter to any HTML element:
1N/A
1N/A print h1({-class=>'Fancy'},'Welcome to the Party');
1N/A
1N/AOr define styles on the fly with the B<-style> parameter:
1N/A
1N/A print h1({-style=>'Color: red;'},'Welcome to Hell');
1N/A
1N/AYou may also use the new B<span()> element to apply a style to a
1N/Asection of text:
1N/A
1N/A print span({-style=>'Color: red;'},
1N/A h1('Welcome to Hell'),
1N/A "Where did that handbasket get to?"
1N/A );
1N/A
1N/ANote that you must import the ":html3" definitions to have the
1N/AB<span()> method available. Here's a quick and dirty example of using
1N/ACSS's. See the CSS specification at
1N/Ahttp://www.w3.org/Style/CSS/ for more information.
1N/A
1N/A use CGI qw/:standard :html3/;
1N/A
1N/A #here's a stylesheet incorporated directly into the page
1N/A $newStyle=<<END;
1N/A <!--
1N/A P.Tip {
1N/A margin-right: 50pt;
1N/A margin-left: 50pt;
1N/A color: red;
1N/A }
1N/A P.Alert {
1N/A font-size: 30pt;
1N/A font-family: sans-serif;
1N/A color: red;
1N/A }
1N/A -->
1N/A END
1N/A print header();
1N/A print start_html( -title=>'CGI with Style',
1N/A -style=>{-src=>'http://www.capricorn.com/style/st1.css',
1N/A -code=>$newStyle}
1N/A );
1N/A print h1('CGI with Style'),
1N/A p({-class=>'Tip'},
1N/A "Better read the cascading style sheet spec before playing with this!"),
1N/A span({-style=>'color: magenta'},
1N/A "Look Mom, no hands!",
1N/A p(),
1N/A "Whooo wee!"
1N/A );
1N/A print end_html;
1N/A
1N/APass an array reference to B<-code> or B<-src> in order to incorporate
1N/Amultiple stylesheets into your document.
1N/A
1N/AShould you wish to incorporate a verbatim stylesheet that includes
1N/Aarbitrary formatting in the header, you may pass a -verbatim tag to
1N/Athe -style hash, as follows:
1N/A
1N/Aprint start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");',
1N/A -src => '/server-common/css/core.css'});
1N/A
1N/A
1N/AThis will generate an HTML header that contains this:
1N/A
1N/A <link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
1N/A <style type="text/css">
1N/A @import url("/server-common/css/main.css");
1N/A </style>
1N/A
1N/AAny additional arguments passed in the -style value will be
1N/Aincorporated into the <link> tag. For example:
1N/A
1N/A start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
1N/A -media => 'all'});
1N/A
1N/AThis will give:
1N/A
1N/A <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
1N/A <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
1N/A
1N/A<p>
1N/A
1N/ATo make more complicated <link> tags, use the Link() function
1N/Aand pass it to start_html() in the -head argument, as in:
1N/A
1N/A @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
1N/A Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
1N/A print start_html({-head=>\@h})
1N/A
1N/ATo create primary and "alternate" stylesheet, use the B<-alternate> option:
1N/A
1N/A start_html(-style=>{-src=>[
1N/A {-src=>'/styles/print.css'},
1N/A {-src=>'/styles/alt.css',-alternate=>1}
1N/A ]
1N/A });
1N/A
1N/A=head1 DEBUGGING
1N/A
1N/AIf you are running the script from the command line or in the perl
1N/Adebugger, you can pass the script a list of keywords or
1N/Aparameter=value pairs on the command line or from standard input (you
1N/Adon't have to worry about tricking your script into reading from
1N/Aenvironment variables). You can pass keywords like this:
1N/A
1N/A your_script.pl keyword1 keyword2 keyword3
1N/A
1N/Aor this:
1N/A
1N/A your_script.pl keyword1+keyword2+keyword3
1N/A
1N/Aor this:
1N/A
1N/A your_script.pl name1=value1 name2=value2
1N/A
1N/Aor this:
1N/A
1N/A your_script.pl name1=value1&name2=value2
1N/A
1N/ATo turn off this feature, use the -no_debug pragma.
1N/A
1N/ATo test the POST method, you may enable full debugging with the -debug
1N/Apragma. This will allow you to feed newline-delimited name=value
1N/Apairs to the script on standard input.
1N/A
1N/AWhen debugging, you can use quotes and backslashes to escape
1N/Acharacters in the familiar shell manner, letting you place
1N/Aspaces and other funny characters in your parameter=value
1N/Apairs:
1N/A
1N/A your_script.pl "name1='I am a long value'" "name2=two\ words"
1N/A
1N/AFinally, you can set the path info for the script by prefixing the first
1N/Aname/value parameter with the path followed by a question mark (?):
1N/A
1N/A your_script.pl /your/path/here?name1=value1&name2=value2
1N/A
1N/A=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
1N/A
1N/AThe Dump() method produces a string consisting of all the query's
1N/Aname/value pairs formatted nicely as a nested list. This is useful
1N/Afor debugging purposes:
1N/A
1N/A print Dump
1N/A
1N/A
1N/AProduces something that looks like:
1N/A
1N/A <ul>
1N/A <li>name1
1N/A <ul>
1N/A <li>value1
1N/A <li>value2
1N/A </ul>
1N/A <li>name2
1N/A <ul>
1N/A <li>value1
1N/A </ul>
1N/A </ul>
1N/A
1N/AAs a shortcut, you can interpolate the entire CGI object into a string
1N/Aand it will be replaced with the a nice HTML dump shown above:
1N/A
1N/A $query=CGI->new;
1N/A print "<h2>Current Values</h2> $query\n";
1N/A
1N/A=head1 FETCHING ENVIRONMENT VARIABLES
1N/A
1N/ASome of the more useful environment variables can be fetched
1N/Athrough this interface. The methods are as follows:
1N/A
1N/A=over 4
1N/A
1N/A=item B<Accept()>
1N/A
1N/AReturn a list of MIME types that the remote browser accepts. If you
1N/Agive this method a single argument corresponding to a MIME type, as in
1N/AAccept('text/html'), it will return a floating point value
1N/Acorresponding to the browser's preference for this type from 0.0
1N/A(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
1N/Alist are handled correctly.
1N/A
1N/ANote that the capitalization changed between version 2.43 and 2.44 in
1N/Aorder to avoid conflict with Perl's accept() function.
1N/A
1N/A=item B<raw_cookie()>
1N/A
1N/AReturns the HTTP_COOKIE variable. Cookies have a special format, and
1N/Athis method call just returns the raw form (?cookie dough). See
1N/Acookie() for ways of setting and retrieving cooked cookies.
1N/A
1N/ACalled with no parameters, raw_cookie() returns the packed cookie
1N/Astructure. You can separate it into individual cookies by splitting
1N/Aon the character sequence "; ". Called with the name of a cookie,
1N/Aretrieves the B<unescaped> form of the cookie. You can use the
1N/Aregular cookie() method to get the names, or use the raw_fetch()
1N/Amethod from the CGI::Cookie module.
1N/A
1N/A=item B<user_agent()>
1N/A
1N/AReturns the HTTP_USER_AGENT variable. If you give
1N/Athis method a single argument, it will attempt to
1N/Apattern match on it, allowing you to do something
1N/Alike user_agent(Mozilla);
1N/A
1N/A=item B<path_info()>
1N/A
1N/AReturns additional path information from the script URL.
1N/AE.G. fetching /cgi-bin/your_script/additional/stuff will result in
1N/Apath_info() returning "/additional/stuff".
1N/A
1N/ANOTE: The Microsoft Internet Information Server
1N/Ais broken with respect to additional path information. If
1N/Ayou use the Perl DLL library, the IIS server will attempt to
1N/Aexecute the additional path information as a Perl script.
1N/AIf you use the ordinary file associations mapping, the
1N/Apath information will be present in the environment,
1N/Abut incorrect. The best thing to do is to avoid using additional
1N/Apath information in CGI scripts destined for use with IIS.
1N/A
1N/A=item B<path_translated()>
1N/A
1N/AAs per path_info() but returns the additional
1N/Apath information translated into a physical path, e.g.
1N/A"/usr/local/etc/httpd/htdocs/additional/stuff".
1N/A
1N/AThe Microsoft IIS is broken with respect to the translated
1N/Apath as well.
1N/A
1N/A=item B<remote_host()>
1N/A
1N/AReturns either the remote host name or IP address.
1N/Aif the former is unavailable.
1N/A
1N/A=item B<remote_addr()>
1N/A
1N/AReturns the remote host IP address, or
1N/A127.0.0.1 if the address is unavailable.
1N/A
1N/A=item B<script_name()>
1N/AReturn the script name as a partial URL, for self-referring
1N/Ascripts.
1N/A
1N/A=item B<referer()>
1N/A
1N/AReturn the URL of the page the browser was viewing
1N/Aprior to fetching your script. Not available for all
1N/Abrowsers.
1N/A
1N/A=item B<auth_type ()>
1N/A
1N/AReturn the authorization/verification method in use for this
1N/Ascript, if any.
1N/A
1N/A=item B<server_name ()>
1N/A
1N/AReturns the name of the server, usually the machine's host
1N/Aname.
1N/A
1N/A=item B<virtual_host ()>
1N/A
1N/AWhen using virtual hosts, returns the name of the host that
1N/Athe browser attempted to contact
1N/A
1N/A=item B<server_port ()>
1N/A
1N/AReturn the port that the server is listening on.
1N/A
1N/A=item B<virtual_port ()>
1N/A
1N/ALike server_port() except that it takes virtual hosts into account.
1N/AUse this when running with virtual hosts.
1N/A
1N/A=item B<server_software ()>
1N/A
1N/AReturns the server software and version number.
1N/A
1N/A=item B<remote_user ()>
1N/A
1N/AReturn the authorization/verification name used for user
1N/Averification, if this script is protected.
1N/A
1N/A=item B<user_name ()>
1N/A
1N/AAttempt to obtain the remote user's name, using a variety of different
1N/Atechniques. This only works with older browsers such as Mosaic.
1N/ANewer browsers do not report the user name for privacy reasons!
1N/A
1N/A=item B<request_method()>
1N/A
1N/AReturns the method used to access your script, usually
1N/Aone of 'POST', 'GET' or 'HEAD'.
1N/A
1N/A=item B<content_type()>
1N/A
1N/AReturns the content_type of data submitted in a POST, generally
1N/Amultipart/form-data or application/x-www-form-urlencoded
1N/A
1N/A=item B<http()>
1N/A
1N/ACalled with no arguments returns the list of HTTP environment
1N/Avariables, including such things as HTTP_USER_AGENT,
1N/AHTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
1N/Alike-named HTTP header fields in the request. Called with the name of
1N/Aan HTTP header field, returns its value. Capitalization and the use
1N/Aof hyphens versus underscores are not significant.
1N/A
1N/AFor example, all three of these examples are equivalent:
1N/A
1N/A $requested_language = http('Accept-language');
1N/A $requested_language = http('Accept_language');
1N/A $requested_language = http('HTTP_ACCEPT_LANGUAGE');
1N/A
1N/A=item B<https()>
1N/A
1N/AThe same as I<http()>, but operates on the HTTPS environment variables
1N/Apresent when the SSL protocol is in effect. Can be used to determine
1N/Awhether SSL is turned on.
1N/A
1N/A=back
1N/A
1N/A=head1 USING NPH SCRIPTS
1N/A
1N/ANPH, or "no-parsed-header", scripts bypass the server completely by
1N/Asending the complete HTTP header directly to the browser. This has
1N/Aslight performance benefits, but is of most use for taking advantage
1N/Aof HTTP extensions that are not directly supported by your server,
1N/Asuch as server push and PICS headers.
1N/A
1N/AServers use a variety of conventions for designating CGI scripts as
1N/ANPH. Many Unix servers look at the beginning of the script's name for
1N/Athe prefix "nph-". The Macintosh WebSTAR server and Microsoft's
1N/AInternet Information Server, in contrast, try to decide whether a
1N/Aprogram is an NPH script by examining the first line of script output.
1N/A
1N/A
1N/ACGI.pm supports NPH scripts with a special NPH mode. When in this
1N/Amode, CGI.pm will output the necessary extra header information when
1N/Athe header() and redirect() methods are
1N/Acalled.
1N/A
1N/AThe Microsoft Internet Information Server requires NPH mode. As of
1N/Aversion 2.30, CGI.pm will automatically detect when the script is
1N/Arunning under IIS and put itself into this mode. You do not need to
1N/Ado this manually, although it won't hurt anything if you do. However,
1N/Anote that if you have applied Service Pack 6, much of the
1N/Afunctionality of NPH scripts, including the ability to redirect while
1N/Asetting a cookie, B<do not work at all> on IIS without a special patch
1N/Afrom Microsoft. See
1N/Ahttp://web.archive.org/web/20010812012030/http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP
1N/ANon-Parsed Headers Stripped From CGI Applications That Have nph-
1N/APrefix in Name.
1N/A
1N/A=over 4
1N/A
1N/A=item In the B<use> statement
1N/A
1N/ASimply add the "-nph" pragma to the list of symbols to be imported into
1N/Ayour script:
1N/A
1N/A use CGI qw(:standard -nph)
1N/A
1N/A=item By calling the B<nph()> method:
1N/A
1N/ACall B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
1N/A
1N/A CGI->nph(1)
1N/A
1N/A=item By using B<-nph> parameters
1N/A
1N/Ain the B<header()> and B<redirect()> statements:
1N/A
1N/A print header(-nph=>1);
1N/A
1N/A=back
1N/A
1N/A=head1 Server Push
1N/A
1N/ACGI.pm provides four simple functions for producing multipart
1N/Adocuments of the type needed to implement server push. These
1N/Afunctions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
1N/Aimport these into your namespace, you must import the ":push" set.
1N/AYou are also advised to put the script into NPH mode and to set $| to
1N/A1 to avoid buffering problems.
1N/A
1N/AHere is a simple script that demonstrates server push:
1N/A
1N/A #!/usr/local/bin/perl
1N/A use CGI qw/:push -nph/;
1N/A $| = 1;
1N/A print multipart_init(-boundary=>'----here we go!');
1N/A for (0 .. 4) {
1N/A print multipart_start(-type=>'text/plain'),
1N/A "The current time is ",scalar(localtime),"\n";
1N/A if ($_ < 4) {
1N/A print multipart_end;
1N/A } else {
1N/A print multipart_final;
1N/A }
1N/A sleep 1;
1N/A }
1N/A
1N/AThis script initializes server push by calling B<multipart_init()>.
1N/AIt then enters a loop in which it begins a new multipart section by
1N/Acalling B<multipart_start()>, prints the current local time,
1N/Aand ends a multipart section with B<multipart_end()>. It then sleeps
1N/Aa second, and begins again. On the final iteration, it ends the
1N/Amultipart section with B<multipart_final()> rather than with
1N/AB<multipart_end()>.
1N/A
1N/A=over 4
1N/A
1N/A=item multipart_init()
1N/A
1N/A multipart_init(-boundary=>$boundary);
1N/A
1N/AInitialize the multipart system. The -boundary argument specifies
1N/Awhat MIME boundary string to use to separate parts of the document.
1N/AIf not provided, CGI.pm chooses a reasonable boundary for you.
1N/A
1N/A=item multipart_start()
1N/A
1N/A multipart_start(-type=>$type)
1N/A
1N/AStart a new part of the multipart document using the specified MIME
1N/Atype. If not specified, text/html is assumed.
1N/A
1N/A=item multipart_end()
1N/A
1N/A multipart_end()
1N/A
1N/AEnd a part. You must remember to call multipart_end() once for each
1N/Amultipart_start(), except at the end of the last part of the multipart
1N/Adocument when multipart_final() should be called instead of multipart_end().
1N/A
1N/A=item multipart_final()
1N/A
1N/A multipart_final()
1N/A
1N/AEnd all parts. You should call multipart_final() rather than
1N/Amultipart_end() at the end of the last part of the multipart document.
1N/A
1N/A=back
1N/A
1N/AUsers interested in server push applications should also have a look
1N/Aat the CGI::Push module.
1N/A
1N/A=head1 Avoiding Denial of Service Attacks
1N/A
1N/AA potential problem with CGI.pm is that, by default, it attempts to
1N/Aprocess form POSTings no matter how large they are. A wily hacker
1N/Acould attack your site by sending a CGI script a huge POST of many
1N/Amegabytes. CGI.pm will attempt to read the entire POST into a
1N/Avariable, growing hugely in size until it runs out of memory. While
1N/Athe script attempts to allocate the memory the system may slow down
1N/Adramatically. This is a form of denial of service attack.
1N/A
1N/AAnother possible attack is for the remote user to force CGI.pm to
1N/Aaccept a huge file upload. CGI.pm will accept the upload and store it
1N/Ain a temporary directory even if your script doesn't expect to receive
1N/Aan uploaded file. CGI.pm will delete the file automatically when it
1N/Aterminates, but in the meantime the remote user may have filled up the
1N/Aserver's disk space, causing problems for other programs.
1N/A
1N/AThe best way to avoid denial of service attacks is to limit the amount
1N/Aof memory, CPU time and disk space that CGI scripts can use. Some Web
1N/Aservers come with built-in facilities to accomplish this. In other
1N/Acases, you can use the shell I<limit> or I<ulimit>
1N/Acommands to put ceilings on CGI resource usage.
1N/A
1N/A
1N/ACGI.pm also has some simple built-in protections against denial of
1N/Aservice attacks, but you must activate them before you can use them.
1N/AThese take the form of two global variables in the CGI name space:
1N/A
1N/A=over 4
1N/A
1N/A=item B<$CGI::POST_MAX>
1N/A
1N/AIf set to a non-negative integer, this variable puts a ceiling
1N/Aon the size of POSTings, in bytes. If CGI.pm detects a POST
1N/Athat is greater than the ceiling, it will immediately exit with an error
1N/Amessage. This value will affect both ordinary POSTs and
1N/Amultipart POSTs, meaning that it limits the maximum size of file
1N/Auploads as well. You should set this to a reasonably high
1N/Avalue, such as 1 megabyte.
1N/A
1N/A=item B<$CGI::DISABLE_UPLOADS>
1N/A
1N/AIf set to a non-zero value, this will disable file uploads
1N/Acompletely. Other fill-out form values will work as usual.
1N/A
1N/A=back
1N/A
1N/AYou can use these variables in either of two ways.
1N/A
1N/A=over 4
1N/A
1N/A=item B<1. On a script-by-script basis>
1N/A
1N/ASet the variable at the top of the script, right after the "use" statement:
1N/A
1N/A use CGI qw/:standard/;
1N/A use CGI::Carp 'fatalsToBrowser';
1N/A $CGI::POST_MAX=1024 * 100; # max 100K posts
1N/A $CGI::DISABLE_UPLOADS = 1; # no uploads
1N/A
1N/A=item B<2. Globally for all scripts>
1N/A
1N/AOpen up CGI.pm, find the definitions for $POST_MAX and
1N/A$DISABLE_UPLOADS, and set them to the desired values. You'll
1N/Afind them towards the top of the file in a subroutine named
1N/Ainitialize_globals().
1N/A
1N/A=back
1N/A
1N/AAn attempt to send a POST larger than $POST_MAX bytes will cause
1N/AI<param()> to return an empty CGI parameter list. You can test for
1N/Athis event by checking I<cgi_error()>, either after you create the CGI
1N/Aobject or, if you are using the function-oriented interface, call
1N/A<param()> for the first time. If the POST was intercepted, then
1N/Acgi_error() will return the message "413 POST too large".
1N/A
1N/AThis error message is actually defined by the HTTP protocol, and is
1N/Adesigned to be returned to the browser as the CGI script's status
1N/A code. For example:
1N/A
1N/A $uploaded_file = param('upload');
1N/A if (!$uploaded_file && cgi_error()) {
1N/A print header(-status=>cgi_error());
1N/A exit 0;
1N/A }
1N/A
1N/AHowever it isn't clear that any browser currently knows what to do
1N/Awith this status code. It might be better just to create an
1N/AHTML page that warns the user of the problem.
1N/A
1N/A=head1 COMPATIBILITY WITH CGI-LIB.PL
1N/A
1N/ATo make it easier to port existing programs that use cgi-lib.pl the
1N/Acompatibility routine "ReadParse" is provided. Porting is simple:
1N/A
1N/AOLD VERSION
1N/A
1N/A require "cgi-lib.pl";
1N/A &ReadParse;
1N/A print "The value of the antique is $in{antique}.\n";
1N/A
1N/ANEW VERSION
1N/A
1N/A use CGI;
1N/A CGI::ReadParse();
1N/A print "The value of the antique is $in{antique}.\n";
1N/A
1N/ACGI.pm's ReadParse() routine creates a tied variable named %in,
1N/Awhich can be accessed to obtain the query variables. Like
1N/AReadParse, you can also provide your own variable. Infrequently
1N/Aused features of ReadParse, such as the creation of @in and $in
1N/Avariables, are not supported.
1N/A
1N/AOnce you use ReadParse, you can retrieve the query object itself
1N/Athis way:
1N/A
1N/A $q = $in{CGI};
1N/A print $q->textfield(-name=>'wow',
1N/A -value=>'does this really work?');
1N/A
1N/AThis allows you to start using the more interesting features
1N/Aof CGI.pm without rewriting your old scripts from scratch.
1N/A
1N/AAn even simpler way to mix cgi-lib calls with CGI.pm calls is to import both the
1N/AC<:cgi-lib> and C<:standard> method:
1N/A
1N/A use CGI qw(:cgi-lib :standard);
1N/A &ReadParse;
1N/A print "The price of your purchase is $in{price}.\n";
1N/A print textfield(-name=>'price', -default=>'$1.99');
1N/A
1N/A=head2 Cgi-lib functions that are available in CGI.pm
1N/A
1N/AIn compatability mode, the following cgi-lib.pl functions are
1N/Aavailable for your use:
1N/A
1N/A ReadParse()
1N/A PrintHeader()
1N/A HtmlTop()
1N/A HtmlBot()
1N/A SplitParam()
1N/A MethGet()
1N/A MethPost()
1N/A
1N/A=head2 Cgi-lib functions that are not available in CGI.pm
1N/A
1N/A * Extended form of ReadParse()
1N/A The extended form of ReadParse() that provides for file upload
1N/A spooling, is not available.
1N/A
1N/A * MyBaseURL()
1N/A This function is not available. Use CGI.pm's url() method instead.
1N/A
1N/A * MyFullURL()
1N/A This function is not available. Use CGI.pm's self_url() method
1N/A instead.
1N/A
1N/A * CgiError(), CgiDie()
1N/A These functions are not supported. Look at CGI::Carp for the way I
1N/A prefer to handle error messages.
1N/A
1N/A * PrintVariables()
1N/A This function is not available. To achieve the same effect,
1N/A just print out the CGI object:
1N/A
1N/A use CGI qw(:standard);
1N/A $q = CGI->new;
1N/A print h1("The Variables Are"),$q;
1N/A
1N/A * PrintEnv()
1N/A This function is not available. You'll have to roll your own if you really need it.
1N/A
1N/A=head1 AUTHOR INFORMATION
1N/A
1N/AThe CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
1N/Adistributed under GPL and the Artistic License 2.0.
1N/A
1N/AAddress bug reports and comments to: lstein@cshl.org. When sending
1N/Abug reports, please provide the version of CGI.pm, the version of
1N/APerl, the name and version of your Web server, and the name and
1N/Aversion of the operating system you are using. If the problem is even
1N/Aremotely browser dependent, please provide information about the
1N/Aaffected browsers as well.
1N/A
1N/A=head1 CREDITS
1N/A
1N/AThanks very much to:
1N/A
1N/A=over 4
1N/A
1N/A=item Matt Heffron (heffron@falstaff.css.beckman.com)
1N/A
1N/A=item James Taylor (james.taylor@srs.gov)
1N/A
1N/A=item Scott Anguish <sanguish@digifix.com>
1N/A
1N/A=item Mike Jewell (mlj3u@virginia.edu)
1N/A
1N/A=item Timothy Shimmin (tes@kbs.citri.edu.au)
1N/A
1N/A=item Joergen Haegg (jh@axis.se)
1N/A
1N/A=item Laurent Delfosse (delfosse@delfosse.com)
1N/A
1N/A=item Richard Resnick (applepi1@aol.com)
1N/A
1N/A=item Craig Bishop (csb@barwonwater.vic.gov.au)
1N/A
1N/A=item Tony Curtis (tc@vcpc.univie.ac.at)
1N/A
1N/A=item Tim Bunce (Tim.Bunce@ig.co.uk)
1N/A
1N/A=item Tom Christiansen (tchrist@convex.com)
1N/A
1N/A=item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
1N/A
1N/A=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
1N/A
1N/A=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
1N/A
1N/A=item Stephen Dahmen (joyfire@inxpress.net)
1N/A
1N/A=item Ed Jordan (ed@fidalgo.net)
1N/A
1N/A=item David Alan Pisoni (david@cnation.com)
1N/A
1N/A=item Doug MacEachern (dougm@opengroup.org)
1N/A
1N/A=item Robin Houston (robin@oneworld.org)
1N/A
1N/A=item ...and many many more...
1N/A
1N/Afor suggestions and bug fixes.
1N/A
1N/A=back
1N/A
1N/A=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
1N/A
1N/A
1N/A #!/usr/local/bin/perl
1N/A
1N/A use CGI ':standard';
1N/A
1N/A print header;
1N/A print start_html("Example CGI.pm Form");
1N/A print "<h1> Example CGI.pm Form</h1>\n";
1N/A print_prompt();
1N/A do_work();
1N/A print_tail();
1N/A print end_html;
1N/A
1N/A sub print_prompt {
1N/A print start_form;
1N/A print "<em>What's your name?</em><br>";
1N/A print textfield('name');
1N/A print checkbox('Not my real name');
1N/A
1N/A print "<p><em>Where can you find English Sparrows?</em><br>";
1N/A print checkbox_group(
1N/A -name=>'Sparrow locations',
1N/A -values=>[England,France,Spain,Asia,Hoboken],
1N/A -linebreak=>'yes',
1N/A -defaults=>[England,Asia]);
1N/A
1N/A print "<p><em>How far can they fly?</em><br>",
1N/A radio_group(
1N/A -name=>'how far',
1N/A -values=>['10 ft','1 mile','10 miles','real far'],
1N/A -default=>'1 mile');
1N/A
1N/A print "<p><em>What's your favorite color?</em> ";
1N/A print popup_menu(-name=>'Color',
1N/A -values=>['black','brown','red','yellow'],
1N/A -default=>'red');
1N/A
1N/A print hidden('Reference','Monty Python and the Holy Grail');
1N/A
1N/A print "<p><em>What have you got there?</em><br>";
1N/A print scrolling_list(
1N/A -name=>'possessions',
1N/A -values=>['A Coconut','A Grail','An Icon',
1N/A 'A Sword','A Ticket'],
1N/A -size=>5,
1N/A -multiple=>'true');
1N/A
1N/A print "<p><em>Any parting comments?</em><br>";
1N/A print textarea(-name=>'Comments',
1N/A -rows=>10,
1N/A -columns=>50);
1N/A
1N/A print "<p>",reset;
1N/A print submit('Action','Shout');
1N/A print submit('Action','Scream');
1N/A print end_form;
1N/A print "<hr>\n";
1N/A }
1N/A
1N/A sub do_work {
1N/A
1N/A print "<h2>Here are the current settings in this form</h2>";
1N/A
1N/A for my $key (param) {
1N/A print "<strong>$key</strong> -> ";
1N/A my @values = param($key);
1N/A print join(", ",@values),"<br>\n";
1N/A }
1N/A }
1N/A
1N/A sub print_tail {
1N/A print <<END;
1N/A <hr>
1N/A <address>Lincoln D. Stein</address><br>
1N/A <a href="/">Home Page</a>
1N/A END
1N/A }
1N/A
1N/A=head1 BUGS
1N/A
1N/APlease report them.
1N/A
1N/A=head1 SEE ALSO
1N/A
1N/AL<CGI::Carp> - provides a L<Carp> implementation tailored to the CGI environment.
1N/A
1N/AL<CGI::Fast> - supports running CGI applications under FastCGI
1N/A
1N/AL<CGI::Pretty> - pretty prints HTML generated by CGI.pm (with a performance penalty)
1N/A
1N/A=cut
1N/A