From f9f3ab3056d94292adb4ab2e1451645bee989769 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Tue, 16 Jun 2015 06:44:29 +0000 Subject: CGI-4.21 --- lib/CGI.pm | 3856 ++++++++++++++++++++++++++++++++++++++++++++ lib/CGI.pod | 1843 +++++++++++++++++++++ lib/CGI/Carp.pm | 615 +++++++ lib/CGI/Cookie.pm | 537 ++++++ lib/CGI/File/Temp.pm | 39 + lib/CGI/HTML/Functions.pm | 8 + lib/CGI/HTML/Functions.pod | 1927 ++++++++++++++++++++++ lib/CGI/Pretty.pm | 85 + lib/CGI/Push.pm | 306 ++++ lib/CGI/Util.pm | 354 ++++ lib/Fh.pm | 7 + 11 files changed, 9577 insertions(+) create mode 100644 lib/CGI.pm create mode 100644 lib/CGI.pod create mode 100644 lib/CGI/Carp.pm create mode 100644 lib/CGI/Cookie.pm create mode 100644 lib/CGI/File/Temp.pm create mode 100644 lib/CGI/HTML/Functions.pm create mode 100644 lib/CGI/HTML/Functions.pod create mode 100644 lib/CGI/Pretty.pm create mode 100644 lib/CGI/Push.pm create mode 100644 lib/CGI/Util.pm create mode 100644 lib/Fh.pm (limited to 'lib') diff --git a/lib/CGI.pm b/lib/CGI.pm new file mode 100644 index 0000000..3ed0d0e --- /dev/null +++ b/lib/CGI.pm @@ -0,0 +1,3856 @@ +package CGI; +require 5.008001; +use if $] >= 5.019, 'deprecate'; +use Carp 'croak'; + +$CGI::VERSION='4.21'; + +use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); + +$_XHTML_DTD = ['-//W3C//DTD XHTML 1.0 Transitional//EN', + 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd']; + +{ + local $^W = 0; + $TAINTED = substr("$0$^X",0,0); +} + +$MOD_PERL = 0; # no mod_perl by default + +#global settings +$POST_MAX = -1; # no limit to uploaded files +$DISABLE_UPLOADS = 0; +$UNLINK_TMP_FILES = 1; +$LIST_CONTEXT_WARN = 1; +$ENCODE_ENTITIES = q{&<>"'}; + +@SAVED_SYMBOLS = (); + +# >>>>> Here are some globals that you might want to adjust <<<<<< +sub initialize_globals { + # Set this to 1 to generate XTML-compatible output + $XHTML = 1; + + # Change this to the preferred DTD to print in start_html() + # or use default_dtd('text of DTD to use'); + $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN', + 'http://www.w3.org/TR/html4/loose.dtd' ] ; + + # Set this to 1 to enable NOSTICKY scripts + # or: + # 1) use CGI '-nosticky'; + # 2) $CGI::NOSTICKY = 1; + $NOSTICKY = 0; + + # Set this to 1 to enable NPH scripts + # or: + # 1) use CGI qw(-nph) + # 2) CGI::nph(1) + # 3) print header(-nph=>1) + $NPH = 0; + + # Set this to 1 to enable debugging from @ARGV + # Set to 2 to enable debugging from STDIN + $DEBUG = 1; + + # Set this to 1 to generate automatic tab indexes + $TABINDEX = 0; + + # Set this to 1 to cause files uploaded in multipart documents + # to be closed, instead of caching the file handle + # or: + # 1) use CGI qw(:close_upload_files) + # 2) $CGI::close_upload_files(1); + # Uploads with many files run out of file handles. + # Also, for performance, since the file is already on disk, + # it can just be renamed, instead of read and written. + $CLOSE_UPLOAD_FILES = 0; + + # Automatically determined -- don't change + $EBCDIC = 0; + + # Change this to 1 to suppress redundant HTTP headers + $HEADERS_ONCE = 0; + + # separate the name=value pairs by semicolons rather than ampersands + $USE_PARAM_SEMICOLONS = 1; + + # Do not include undefined params parsed from query string + # use CGI qw(-no_undef_params); + $NO_UNDEF_PARAMS = 0; + + # return everything as utf-8 + $PARAM_UTF8 = 0; + + # make param('PUTDATA') act like file upload + $PUTDATA_UPLOAD = 0; + + # Other globals that you shouldn't worry about. + undef $Q; + $BEEN_THERE = 0; + $DTD_PUBLIC_IDENTIFIER = ""; + undef @QUERY_PARAM; + undef %EXPORT; + undef $QUERY_CHARSET; + undef %QUERY_FIELDNAMES; + undef %QUERY_TMPFILES; + + # prevent complaints by mod_perl + 1; +} + +# ------------------ START OF THE LIBRARY ------------ + +# make mod_perlhappy +initialize_globals(); + +# FIGURE OUT THE OS WE'RE RUNNING UNDER +# Some systems support the $^O variable. If not +# available then require() the Config library +unless ($OS) { + unless ($OS = $^O) { + require Config; + $OS = $Config::Config{'osname'}; + } +} +if ($OS =~ /^MSWin/i) { + $OS = 'WINDOWS'; +} elsif ($OS =~ /^VMS/i) { + $OS = 'VMS'; +} elsif ($OS =~ /^dos/i) { + $OS = 'DOS'; +} elsif ($OS =~ /^MacOS/i) { + $OS = 'MACINTOSH'; +} elsif ($OS =~ /^os2/i) { + $OS = 'OS2'; +} elsif ($OS =~ /^epoc/i) { + $OS = 'EPOC'; +} elsif ($OS =~ /^cygwin/i) { + $OS = 'CYGWIN'; +} elsif ($OS =~ /^NetWare/i) { + $OS = 'NETWARE'; +} else { + $OS = 'UNIX'; +} + +# Some OS logic. Binary mode enabled on DOS, NT and VMS +$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN|NETWARE)/; + +# This is the default class for the CGI object to use when all else fails. +$DefaultClass = 'CGI' unless defined $CGI::DefaultClass; + +# The path separator is a slash, backslash or semicolon, depending +# on the platform. +$SL = { + UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', NETWARE => '/', + WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/' + }->{$OS}; + +# This no longer seems to be necessary +# Turn on NPH scripts by default when running under IIS server! +# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; +$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; + +# Turn on special checking for ActiveState's PerlEx +$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + +# Turn on special checking for Doug MacEachern's modperl +# PerlEx::DBI tries to fool DBI by setting MOD_PERL +if (exists $ENV{MOD_PERL} && ! $PERLEX) { + # mod_perl handlers may run system() on scripts using CGI.pm; + # Make sure so we don't get fooled by inherited $ENV{MOD_PERL} + if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $MOD_PERL = 2; + require Apache2::Response; + require Apache2::RequestRec; + require Apache2::RequestUtil; + require Apache2::RequestIO; + require APR::Pool; + } else { + $MOD_PERL = 1; + require Apache; + } +} + +# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning +# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF +# and sometimes CR). The most popular VMS web server +# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't +# use ASCII, so \015\012 means something different. I find this all +# really annoying. +$EBCDIC = "\t" ne "\011"; +if ($OS eq 'VMS') { + $CRLF = "\n"; +} elsif ($EBCDIC) { + $CRLF= "\r\n"; +} else { + $CRLF = "\015\012"; +} + +_set_binmode() if ($needs_binmode); + +sub _set_binmode { + + # rt #57524 - don't set binmode on filehandles if there are + # already none default layers set on them + my %default_layers = ( + unix => 1, + perlio => 1, + stdio => 1, + crlf => 1, + ); + + foreach my $fh ( + \*main::STDOUT, + \*main::STDIN, + \*main::STDERR, + ) { + my @modes = grep { ! $default_layers{$_} } + PerlIO::get_layers( $fh ); + + if ( ! @modes ) { + $CGI::DefaultClass->binmode( $fh ); + } + } +} + +%EXPORT_TAGS = ( + ':html2' => [ 'h1' .. 'h6', qw/ + p br hr ol ul li dl dt dd menu code var strong em + tt u i b blockquote pre img a address cite samp dfn html head + base body Link nextid title meta kbd start_html end_html + input Select option comment charset escapeHTML + / ], + ':html3' => [ qw/ + div table caption th td TR Tr sup Sub strike applet Param nobr + embed basefont style span layer ilayer font frameset frame script small big Area Map + / ], + ':html4' => [ qw/ + abbr acronym bdo col colgroup del fieldset iframe + ins label legend noframes noscript object optgroup Q + thead tbody tfoot + / ], + ':form' => [ qw/ + textfield textarea filefield password_field hidden checkbox checkbox_group + submit reset defaults radio_group popup_menu button autoEscape + scrolling_list image_button start_form end_form + start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART + / ], + ':cgi' => [ qw/ + param multi_param upload path_info path_translated request_uri url self_url script_name + cookie Dump raw_cookie request_method query_string Accept user_agent remote_host content_type + remote_addr referer server_name server_software server_port server_protocol virtual_port + virtual_host remote_ident auth_type http append save_parameters restore_parameters param_fetch + remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error env_query_string + / ], + ':netscape' => [qw/blink fontsize center/], + ':ssl' => [qw/https/], + ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], + ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/], + + # bulk export/import + ':html' => [qw/:html2 :html3 :html4 :netscape/], + ':standard' => [qw/:html2 :html3 :html4 :form :cgi :ssl/], + ':all' => [qw/:html2 :html3 :html4 :netscape :form :cgi :ssl :push/] +); + +# to import symbols into caller +sub import { + my $self = shift; + + # This causes modules to clash. + undef %EXPORT_OK; + undef %EXPORT; + + $self->_setup_symbols(@_); + my ($callpack, $callfile, $callline) = caller; + + if ( $callpack eq 'CGI::Fast' ) { + # fixes GH #11 (and GH #12 in CGI::Fast since + # sub import was added to CGI::Fast in 9537f90 + # so we need to move up a level to export the + # routines to the namespace of whatever is using + # CGI::Fast + ($callpack, $callfile, $callline) = caller(1); + } + + # To allow overriding, search through the packages + # Till we find one in which the correct subroutine is defined. + my @packages = ($self,@{"$self\:\:ISA"}); + for $sym (keys %EXPORT) { + my $pck; + my $def = $DefaultClass; + for $pck (@packages) { + if (defined(&{"$pck\:\:$sym"})) { + $def = $pck; + last; + } + } + *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; + } +} + +sub expand_tags { + my($tag) = @_; + return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; + my(@r); + return ($tag) unless $EXPORT_TAGS{$tag}; + for (@{$EXPORT_TAGS{$tag}}) { + push(@r,&expand_tags($_)); + } + return @r; +} + +#### Method: new +# The new routine. This will check the current environment +# for an existing query string, and initialize itself, if so. +#### +sub new { + my($class,@initializer) = @_; + my $self = {}; + + bless $self,ref $class || $class || $DefaultClass; + + # always use a tempfile + $self->{'use_tempfile'} = 1; + + if (ref($initializer[0]) + && (UNIVERSAL::isa($initializer[0],'Apache') + || + UNIVERSAL::isa($initializer[0],'Apache2::RequestRec') + )) { + $self->r(shift @initializer); + } + if (ref($initializer[0]) + && (UNIVERSAL::isa($initializer[0],'CODE'))) { + $self->upload_hook(shift @initializer, shift @initializer); + $self->{'use_tempfile'} = shift @initializer if (@initializer > 0); + } + if ($MOD_PERL) { + if ($MOD_PERL == 1) { + $self->r(Apache->request) unless $self->r; + my $r = $self->r; + $r->register_cleanup(\&CGI::_reset_globals); + $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; + } + else { + # XXX: once we have the new API + # will do a real PerlOptions -SetupEnv check + $self->r(Apache2::RequestUtil->request) unless $self->r; + my $r = $self->r; + $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; + $r->pool->cleanup_register(\&CGI::_reset_globals); + $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; + } + undef $NPH; + } + $self->_reset_globals if $PERLEX; + $self->init(@initializer); + return $self; +} + +sub r { + my $self = shift; + my $r = $self->{'.r'}; + $self->{'.r'} = shift if @_; + $r; +} + +sub upload_hook { + my $self; + if (ref $_[0] eq 'CODE') { + $CGI::Q = $self = $CGI::DefaultClass->new(@_); + } else { + $self = shift; + } + my ($hook,$data,$use_tempfile) = @_; + $self->{'.upload_hook'} = $hook; + $self->{'.upload_data'} = $data; + $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile; +} + +#### Method: param / multi_param +# Returns the value(s)of a named parameter. +# If invoked in a list context, returns the +# entire list. Otherwise returns the first +# member of the list. +# If name is not provided, return a list of all +# the known parameters names available. +# If more than one argument is provided, the +# second and subsequent arguments are used to +# set the value of the parameter. +# +# note that calling param() in list context +# will raise a warning about potential bad +# things, hence the multi_param method +#### +sub multi_param { + # we don't need to set $LIST_CONTEXT_WARN to 0 here + # because param() will check the caller before warning + my @list_of_params = param( @_ ); + return @list_of_params; +} + +sub param { + my($self,@p) = self_or_default(@_); + + return $self->all_parameters unless @p; + + # list context can be dangerous so warn: + # http://blog.gerv.net/2014.10/new-class-of-vulnerability-in-perl-web-applications + if ( wantarray && $LIST_CONTEXT_WARN ) { + my ( $package, $filename, $line ) = caller; + if ( $package ne 'CGI' ) { + warn "CGI::param called in list context from $filename line $line, this can lead to vulnerabilities. " + . 'See the warning in "Fetching the value or values of a single named parameter"'; + } + } + + my($name,$value,@other); + + # For compatibility between old calling style and use_named_parameters() style, + # we have to special case for a single parameter present. + if (@p > 1) { + ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); + my(@values); + + if (substr($p[0],0,1) eq '-') { + @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); + } else { + for ($value,@other) { + push(@values,$_) if defined($_); + } + } + # If values is provided, then we set it. + if (@values or defined $value) { + $self->add_parameter($name); + $self->{param}{$name}=[@values]; + } + } else { + $name = $p[0]; + } + + return unless defined($name) && $self->{param}{$name}; + + my @result = @{$self->{param}{$name}}; + + if ($PARAM_UTF8 && $name ne 'PUTDATA' && $name ne 'POSTDATA') { + eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions + @result = map {ref $_ ? $_ : $self->_decode_utf8($_) } @result; + } + + return wantarray ? @result : $result[0]; +} + +sub _decode_utf8 { + my ($self, $val) = @_; + + if (Encode::is_utf8($val)) { + return $val; + } + else { + return Encode::decode(utf8 => $val); + } +} + +sub self_or_default { + return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); + unless (defined($_[0]) && + (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case + ) { + $Q = $CGI::DefaultClass->new unless defined($Q); + unshift(@_,$Q); + } + return wantarray ? @_ : $Q; +} + +sub self_or_CGI { + local $^W=0; # prevent a warning + if (defined($_[0]) && + (substr(ref($_[0]),0,3) eq 'CGI' + || UNIVERSAL::isa($_[0],'CGI'))) { + return @_; + } else { + return ($DefaultClass,@_); + } +} + +######################################## +# THESE METHODS ARE MORE OR LESS PRIVATE +# GO TO THE __DATA__ SECTION TO SEE MORE +# PUBLIC METHODS +######################################## + +# Initialize the query object from the environment. +# If a parameter list is found, this object will be set +# to a hash in which parameter names are keys +# and the values are stored as lists +# If a keyword list is found, this method creates a bogus +# parameter list with the single parameter 'keywords'. + +sub init { + my $self = shift; + my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); + + my $is_xforms; + + my $initializer = shift; # for backward compatibility + local($/) = "\n"; + + # set autoescaping on by default + $self->{'escape'} = 1; + + # if we get called more than once, we want to initialize + # ourselves from the original query (which may be gone + # if it was read from STDIN originally.) + if (@QUERY_PARAM && !defined($initializer)) { + for my $name (@QUERY_PARAM) { + my $val = $QUERY_PARAM{$name}; # always an arrayref; + $self->param('-name'=>$name,'-value'=> $val); + if (defined $val and ref $val eq 'ARRAY') { + for my $fh (grep {defined($_) && ref($_) && defined(fileno($_))} @$val) { + seek($fh,0,0); # reset the filehandle. + } + + } + } + $self->charset($QUERY_CHARSET); + $self->{'.fieldnames'} = {%QUERY_FIELDNAMES}; + $self->{'.tmpfiles'} = {%QUERY_TMPFILES}; + return; + } + + $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); + $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; + + $fh = to_filehandle($initializer) if $initializer; + + # set charset to the safe ISO-8859-1 + $self->charset('ISO-8859-1'); + + METHOD: { + + # avoid unreasonably large postings + if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { + #discard the post, unread + $self->cgi_error("413 Request entity too large"); + last METHOD; + } + + # Process multipart postings, but only if the initializer is + # not defined. + if ($meth eq 'POST' + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| + && !defined($initializer) + ) { + my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; + $self->read_multipart($boundary,$content_length); + last METHOD; + } + + # Process XForms postings. We know that we have XForms in the + # following cases: + # method eq 'POST' && content-type eq 'application/xml' + # method eq 'POST' && content-type =~ /multipart\/related.+start=/ + # There are more cases, actually, but for now, we don't support other + # methods for XForm posts. + # In a XForm POST, the QUERY_STRING is parsed normally. + # If the content-type is 'application/xml', we just set the param + # XForms:Model (referring to the xml syntax) param containing the + # unparsed XML data. + # In the case of multipart/related we set XForms:Model as above, but + # the other parts are available as uploads with the Content-ID as the + # the key. + # See the URL below for XForms specs on this issue. + # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options + if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) { + if ($ENV{'CONTENT_TYPE'} eq 'application/xml') { + my($param) = 'XForms:Model'; + my($value) = ''; + $self->add_parameter($param); + $self->read_from_client(\$value,$content_length,0) + if $content_length > 0; + push (@{$self->{param}{$param}},$value); + $is_xforms = 1; + } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\]+)\>?\"?/) { + my($boundary,$start) = ($1,$2); + my($param) = 'XForms:Model'; + $self->add_parameter($param); + my($value) = $self->read_multipart_related($start,$boundary,$content_length,0); + push (@{$self->{param}{$param}},$value); + $query_string = $self->_get_query_string_from_env; + $is_xforms = 1; + } + } + + + # If initializer is defined, then read parameters + # from it. + if (!$is_xforms && defined($initializer)) { + if (UNIVERSAL::isa($initializer,'CGI')) { + $query_string = $initializer->query_string; + last METHOD; + } + if (ref($initializer) && ref($initializer) eq 'HASH') { + for (keys %$initializer) { + $self->param('-name'=>$_,'-value'=>$initializer->{$_}); + } + last METHOD; + } + + if (defined($fh) && ($fh ne '')) { + while (my $line = <$fh>) { + chomp $line; + last if $line =~ /^=$/; + push(@lines,$line); + } + # massage back into standard format + if ("@lines" =~ /=/) { + $query_string=join("&",@lines); + } else { + $query_string=join("+",@lines); + } + last METHOD; + } + + # last chance -- treat it as a string + $initializer = $$initializer if ref($initializer) eq 'SCALAR'; + $query_string = $initializer; + + last METHOD; + } + + # If method is GET, HEAD or DELETE, fetch the query from + # the environment. + if ($is_xforms || $meth=~/^(GET|HEAD|DELETE)$/) { + $query_string = $self->_get_query_string_from_env; + $self->param($meth . 'DATA', $self->param('XForms:Model')) + if $is_xforms; + last METHOD; + } + + if ($meth eq 'POST' || $meth eq 'PUT') { + if ( $content_length > 0 ) { + if ( ( $PUTDATA_UPLOAD || $self->{'.upload_hook'} ) && !$is_xforms && ($meth eq 'POST' || $meth eq 'PUT') + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| + && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ){ + my $postOrPut = $meth . 'DATA' ; # POSTDATA/PUTDATA + $self->read_postdata_putdata( $postOrPut, $content_length, $ENV{'CONTENT_TYPE'} ); + $meth = ''; # to skip xform testing + undef $query_string ; + } else { + $self->read_from_client(\$query_string,$content_length,0); + } + } + # Some people want to have their cake and eat it too! + # Uncomment this line to have the contents of the query string + # APPENDED to the POST data. + # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; + last METHOD; + } + + # If $meth is not of GET, POST, PUT or HEAD, assume we're + # being debugged offline. + # Check the command line and then the standard input for data. + # We use the shellwords package in order to behave the way that + # UN*X programmers expect. + if ($DEBUG) + { + my $cmdline_ret = read_from_cmdline(); + $query_string = $cmdline_ret->{'query_string'}; + if (defined($cmdline_ret->{'subpath'})) + { + $self->path_info($cmdline_ret->{'subpath'}); + } + } + } + +# YL: Begin Change for XML handler 10/19/2001 + if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT') + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| + && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) { + my($param) = $meth . 'DATA' ; + $self->add_parameter($param) ; + push (@{$self->{param}{$param}},$query_string); + undef $query_string ; + } +# YL: End Change for XML handler 10/19/2001 + + # We now have the query string in hand. We do slightly + # different things for keyword lists and parameter lists. + if (defined $query_string && length $query_string) { + if ($query_string =~ /[&=;]/) { + $self->parse_params($query_string); + } else { + $self->add_parameter('keywords'); + $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)]; + } + } + + # Special case. Erase everything if there is a field named + # .defaults. + if ($self->param('.defaults')) { + $self->delete_all(); + } + + # hash containing our defined fieldnames + $self->{'.fieldnames'} = {}; + for ($self->param('.cgifields')) { + $self->{'.fieldnames'}->{$_}++; + } + + # Clear out our default submission button flag if present + $self->delete('.submit'); + $self->delete('.cgifields'); + + $self->save_request unless defined $initializer; +} + +sub _get_query_string_from_env { + my $self = shift; + my $query_string = ''; + + if ( $MOD_PERL ) { + $query_string = $self->r->args; + if ( ! $query_string && $MOD_PERL == 2 ) { + # possibly a redirect, inspect prev request + # (->prev only supported under mod_perl2) + if ( my $prev = $self->r->prev ) { + $query_string = $prev->args; + } + } + } + + $query_string ||= $ENV{'QUERY_STRING'} + if defined $ENV{'QUERY_STRING'}; + + if ( ! $query_string ) { + # try to get from REDIRECT_ env variables, support + # 5 levels of redirect and no more (RT #36312) + REDIRECT: foreach my $r ( 1 .. 5 ) { + my $key = join( '',( 'REDIRECT_' x $r ) ); + $query_string ||= $ENV{"${key}QUERY_STRING"} + if defined $ENV{"${key}QUERY_STRING"}; + last REDIRECT if $query_string; + } + } + + return $query_string; +} + +# FUNCTIONS TO OVERRIDE: +# Turn a string into a filehandle +sub to_filehandle { + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } + } + return undef; +} + +# send output to the browser +sub put { + my($self,@p) = self_or_default(@_); + $self->print(@p); +} + +# print to standard output (for overriding in mod_perl) +sub print { + shift; + CORE::print(@_); +} + +# get/set last cgi_error +sub cgi_error { + my ($self,$err) = self_or_default(@_); + $self->{'.cgi_error'} = $err if defined $err; + return $self->{'.cgi_error'}; +} + +sub save_request { + my($self) = @_; + # We're going to play with the package globals now so that if we get called + # again, we initialize ourselves in exactly the same way. This allows + # us to have several of these objects. + @QUERY_PARAM = $self->param; # save list of parameters + for (@QUERY_PARAM) { + next unless defined $_; + $QUERY_PARAM{$_}=$self->{param}{$_}; + } + $QUERY_CHARSET = $self->charset; + %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; + %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} }; +} + +sub parse_params { + my($self,$tosplit) = @_; + my(@pairs) = split(/[&;]/,$tosplit); + my($param,$value); + for (@pairs) { + ($param,$value) = split('=',$_,2); + next unless defined $param; + next if $NO_UNDEF_PARAMS and not defined $value; + $value = '' unless defined $value; + $param = unescape($param); + $value = unescape($value); + $self->add_parameter($param); + push (@{$self->{param}{$param}},$value); + } +} + +sub add_parameter { + my($self,$param)=@_; + return unless defined $param; + push (@{$self->{'.parameters'}},$param) + unless defined($self->{param}{$param}); +} + +sub all_parameters { + my $self = shift; + return () unless defined($self) && $self->{'.parameters'}; + return () unless @{$self->{'.parameters'}}; + return @{$self->{'.parameters'}}; +} + +# put a filehandle into binary mode (DOS) +sub binmode { + return unless defined($_[1]) && ref ($_[1]) && defined fileno($_[1]); + CORE::binmode($_[1]); +} + +# back compatibility html tag generation functions - noop +# since this is now the default having removed AUTOLOAD +sub compile { 1; } + +sub _all_html_tags { + return qw/ + a abbr acronym address applet Area + b base basefont bdo big blink blockquote body br + caption center cite code col colgroup + dd del dfn div dl dt + em embed + fieldset font fontsize frame frameset + h1 h2 h3 h4 h5 h6 head hr html + i iframe ilayer img input ins + kbd + label layer legend li Link + Map menu meta + nextid nobr noframes noscript + object ol option + p Param pre + Q + samp script Select small span + strike strong style Sub sup + table tbody td tfoot th thead title Tr TR tt + u ul + var + / +} + +foreach my $tag ( _all_html_tags() ) { + *$tag = sub { return _tag_func($tag,@_); }; + + # start_html and end_html already exist as custom functions + next if ($tag eq 'html'); + + foreach my $start_end ( qw/ start end / ) { + my $start_end_function = "${start_end}_${tag}"; + *$start_end_function = sub { return _tag_func($start_end_function,@_); }; + } +} + +sub _tag_func { + my $tagname = shift; + my ($q,$a,@rest) = self_or_default(@_); + + my($attr) = ''; + + if (ref($a) && ref($a) eq 'HASH') { + my(@attr) = make_attributes($a,$q->{'escape'}); + $attr = " @attr" if @attr; + } else { + unshift @rest,$a if defined $a; + } + + $tagname = lc( $tagname ); + + if ($tagname=~/start_(\w+)/i) { + return "<$1$attr>"; + } elsif ($tagname=~/end_(\w+)/i) { + return ""; + } else { + return $XHTML ? "<$tagname$attr />" : "<$tagname$attr>" unless @rest; + my($tag,$untag) = ("<$tagname$attr>",""); + my @result = map { "$tag$_$untag" } + (ref($rest[0]) eq 'ARRAY') ? @{$rest[0]} : "@rest"; + return "@result"; + } +} + +sub _selected { + my $self = shift; + my $value = shift; + return '' unless $value; + return $XHTML ? qq(selected="selected" ) : qq(selected ); +} + +sub _checked { + my $self = shift; + my $value = shift; + return '' unless $value; + return $XHTML ? qq(checked="checked" ) : qq(checked ); +} + +sub _reset_globals { initialize_globals(); } + +sub _setup_symbols { + my $self = shift; + + # to avoid reexporting unwanted variables + undef %EXPORT; + + for (@_) { + + if ( /^[:-]any$/ ) { + warn "CGI -any pragma has been REMOVED. You should audit your code for any use " + . "of none supported / incorrectly spelled tags and remove them" + ; + next; + } + $HEADERS_ONCE++, next if /^[:-]unique_headers$/; + $NPH++, next if /^[:-]nph$/; + $NOSTICKY++, next if /^[:-]nosticky$/; + $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; + $DEBUG=2, next if /^[:-][Dd]ebug$/; + $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $PUTDATA_UPLOAD++, next if /^[:-](?:putdata_upload|postdata_upload)$/; + $PARAM_UTF8++, next if /^[:-]utf8$/; + $XHTML++, next if /^[:-]xhtml$/; + $XHTML=0, next if /^[:-]no_?xhtml$/; + $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; + $TABINDEX++, next if /^[:-]tabindex$/; + $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; + $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/; + + for (&expand_tags($_)) { + tr/a-zA-Z0-9_//cd; # don't allow weird function names + $EXPORT{$_}++; + } + } + @SAVED_SYMBOLS = @_; +} + +sub charset { + my ($self,$charset) = self_or_default(@_); + $self->{'.charset'} = $charset if defined $charset; + $self->{'.charset'}; +} + +sub element_id { + my ($self,$new_value) = self_or_default(@_); + $self->{'.elid'} = $new_value if defined $new_value; + sprintf('%010d',$self->{'.elid'}++); +} + +sub element_tab { + my ($self,$new_value) = self_or_default(@_); + $self->{'.etab'} ||= 1; + $self->{'.etab'} = $new_value if defined $new_value; + my $tab = $self->{'.etab'}++; + return '' unless $TABINDEX or defined $new_value; + return qq(tabindex="$tab" ); +} + +##### +# subroutine: read_postdata_putdata +# +# Unless file uploads are disabled +# Reads BODY of POST/PUT request and stuffs it into tempfile +# accessible as param POSTDATA/PUTDATA +# +# Also respects upload_hook +# +# based on subroutine read_multipart_related +##### +sub read_postdata_putdata { + my ( $self, $postOrPut, $content_length, $content_type ) = @_; + my %header = ( + "Content-Type" => $content_type, + ); + my $param = $postOrPut; + # add this parameter to our list + $self->add_parameter($param); + + + UPLOADS: { + + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + + # while (defined($data = $buffer->read)) { } + my $buff; + my $unit = $MultipartBuffer::INITIAL_FILLUNIT; + my $len = $content_length; + while ( $len > 0 ) { + my $read = $self->read_from_client( \$buf, $unit, 0 ); + $len -= $read; + } + last UPLOADS; + } + + # SHOULD PROBABLY SKIP THIS IF NOT $self->{'use_tempfile'} + # BUT THE REST OF CGI.PM DOESN'T, SO WHATEVER + my $tmp_dir = $CGI::OS eq 'WINDOWS' + ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) + : undef; # File::Temp defaults to TMPDIR + + require CGI::File::Temp; + my $filehandle = CGI::File::Temp->new( + UNLINK => $UNLINK_TMP_FILES, + DIR => $tmp_dir, + ); + $filehandle->_mp_filename( $postOrPut ); + + $CGI::DefaultClass->binmode($filehandle) + if $CGI::needs_binmode + && defined fileno($filehandle); + + my ($data); + local ($\) = ''; + my $totalbytes; + my $unit = $MultipartBuffer::INITIAL_FILLUNIT; + my $len = $content_length; + $unit = $len; + my $ZERO_LOOP_COUNTER =0; + + while( $len > 0 ) + { + + my $bytesRead = $self->read_from_client( \$data, $unit, 0 ); + $len -= $bytesRead ; + + # An apparent bug in the Apache server causes the read() + # to return zero bytes repeatedly without blocking if the + # remote user aborts during a file transfer. I don't know how + # they manage this, but the workaround is to abort if we get + # more than SPIN_LOOP_MAX consecutive zero reads. + if ($bytesRead <= 0) { + die "CGI.pm: Server closed socket during read_postdata_putdata (client aborted?).\n" if $ZERO_LOOP_COUNTER++ >= $SPIN_LOOP_MAX; + } else { + $ZERO_LOOP_COUNTER = 0; + } + + if ( defined $self->{'.upload_hook'} ) { + $totalbytes += length($data); + &{ $self->{'.upload_hook'} }( $param, $data, $totalbytes, + $self->{'.upload_data'} ); + } + print $filehandle $data if ( $self->{'use_tempfile'} ); + undef $data; + } + + # back up to beginning of file + seek( $filehandle, 0, 0 ); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob + filename as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { + hndl => $filehandle, + name => $filehandle->filename, + info => {%header}, + }; + push( @{ $self->{param}{$param} }, $filehandle ); + } + return; +} + +sub URL_ENCODED { 'application/x-www-form-urlencoded'; } + +sub MULTIPART { 'multipart/form-data'; } + +sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; } + +# Create a new multipart buffer +sub new_MultipartBuffer { + my($self,$boundary,$length) = @_; + return MultipartBuffer->new($self,$boundary,$length); +} + +# Read data from a file handle +sub read_from_client { + my($self, $buff, $len, $offset) = @_; + local $^W=0; # prevent a warning + return $MOD_PERL + ? $self->r->read($$buff, $len, $offset) + : read(\*STDIN, $$buff, $len, $offset); +} + +#### Method: delete +# Deletes the named parameter entirely. +#### +sub delete { + my($self,@p) = self_or_default(@_); + my(@names) = rearrange([NAME],@p); + my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names; + my %to_delete; + for my $name (@to_delete) + { + CORE::delete $self->{param}{$name}; + CORE::delete $self->{'.fieldnames'}->{$name}; + $to_delete{$name}++; + } + @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); + return; +} + +#### Method: import_names +# Import all parameters into the given namespace. +# Assumes namespace 'Q' if not specified +#### +sub import_names { + my($self,$namespace,$delete) = self_or_default(@_); + $namespace = 'Q' unless defined($namespace); + die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; + if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { + # can anyone find an easier way to do this? + for (keys %{"${namespace}::"}) { + local *symbol = "${namespace}::${_}"; + undef $symbol; + undef @symbol; + undef %symbol; + } + } + my($param,@value,$var); + for $param ($self->param) { + # protect against silly names + ($var = $param)=~tr/a-zA-Z0-9_/_/c; + $var =~ s/^(?=\d)/_/; + local *symbol = "${namespace}::$var"; + @value = $self->param($param); + @symbol = @value; + $symbol = $value[0]; + } +} + +#### Method: keywords +# Keywords acts a bit differently. Calling it in a list context +# returns the list of keywords. +# Calling it in a scalar context gives you the size of the list. +#### +sub keywords { + my($self,@values) = self_or_default(@_); + # If values is provided, then we set it. + $self->{param}{'keywords'}=[@values] if @values; + my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : (); + @result; +} + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines +sub Vars { + my $q = shift; + my %in; + tie(%in,CGI,$q); + return %in if wantarray; + return \%in; +} + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines +sub ReadParse { + local(*in); + if (@_) { + *in = $_[0]; + } else { + my $pkg = caller(); + *in=*{"${pkg}::in"}; + } + tie(%in,CGI); + return scalar(keys %in); +} + +sub PrintHeader { + my($self) = self_or_default(@_); + return $self->header(); +} + +sub HtmlTop { + my($self,@p) = self_or_default(@_); + return $self->start_html(@p); +} + +sub HtmlBot { + my($self,@p) = self_or_default(@_); + return $self->end_html(@p); +} + +sub SplitParam { + my ($param) = @_; + my (@params) = split ("\0", $param); + return (wantarray ? @params : $params[0]); +} + +sub MethGet { + return request_method() eq 'GET'; +} + +sub MethPost { + return request_method() eq 'POST'; +} + +sub MethPut { + return request_method() eq 'PUT'; +} + +sub TIEHASH { + my $class = shift; + my $arg = $_[0]; + if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) { + return $arg; + } + return $Q ||= $class->new(@_); +} + +sub STORE { + my $self = shift; + my $tag = shift; + my $vals = shift; + my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; + $self->param(-name=>$tag,-value=>\@vals); +} + +sub FETCH { + return $_[0] if $_[1] eq 'CGI'; + return undef unless defined $_[0]->param($_[1]); + return join("\0",$_[0]->param($_[1])); +} + +sub FIRSTKEY { + $_[0]->{'.iterator'}=0; + $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; +} + +sub NEXTKEY { + $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; +} + +sub EXISTS { + exists $_[0]->{param}{$_[1]}; +} + +sub DELETE { + my ($self, $param) = @_; + my $value = $self->FETCH($param); + $self->delete($param); + return $value; +} + +sub CLEAR { + %{$_[0]}=(); +} +#### + +#### +# Append a new value to an existing query +#### +sub append { + my($self,@p) = self_or_default(@_); + my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); + my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); + if (@values) { + $self->add_parameter($name); + push(@{$self->{param}{$name}},@values); + } + return $self->param($name); +} + +#### Method: delete_all +# Delete all parameters +#### +sub delete_all { + my($self) = self_or_default(@_); + my @param = $self->param(); + $self->delete(@param); +} + +sub Delete { + my($self,@p) = self_or_default(@_); + $self->delete(@p); +} + +sub Delete_all { + my($self,@p) = self_or_default(@_); + $self->delete_all(@p); +} + +#### Method: autoescape +# If you want to turn off the autoescaping features, +# call this method with undef as the argument +sub autoEscape { + my($self,$escape) = self_or_default(@_); + my $d = $self->{'escape'}; + $self->{'escape'} = $escape; + $d; +} + +#### Method: version +# Return the current version +#### +sub version { + return $VERSION; +} + +#### Method: url_param +# Return a parameter in the QUERY_STRING, regardless of +# whether this was a POST or a GET +#### +sub url_param { + my ($self,@p) = self_or_default(@_); + my $name = shift(@p); + return undef unless exists($ENV{QUERY_STRING}); + unless (exists($self->{'.url_param'})) { + $self->{'.url_param'}={}; # empty hash + if ($ENV{QUERY_STRING} =~ /=/) { + my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); + my($param,$value); + for (@pairs) { + ($param,$value) = split('=',$_,2); + next if ! defined($param); + $param = unescape($param); + $value = unescape($value); + push(@{$self->{'.url_param'}->{$param}},$value); + } + } else { + my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING}); + $self->{'.url_param'}{'keywords'} = \@keywords if @keywords; + } + } + return keys %{$self->{'.url_param'}} unless defined($name); + return () unless $self->{'.url_param'}->{$name}; + return wantarray ? @{$self->{'.url_param'}->{$name}} + : $self->{'.url_param'}->{$name}->[0]; +} + +#### Method: Dump +# Returns a string in which all the known parameter/value +# pairs are represented as nested lists, mainly for the purposes +# of debugging. +#### +sub Dump { + my($self) = self_or_default(@_); + my($param,$value,@result); + return '' unless $self->param; + push(@result,""); + return join("\n",@result); +} + +#### Method as_string +# +# synonym for "dump" +#### +sub as_string { + &Dump(@_); +} + +#### Method: save +# Write values out to a filehandle in such a way that they can +# be reinitialized by the filehandle form of the new() method +#### +sub save { + my($self,$filehandle) = self_or_default(@_); + $filehandle = to_filehandle($filehandle); + my($param); + local($,) = ''; # set print field separator back to a sane value + local($\) = ''; # set output line separator to a sane value + for $param ($self->param) { + my($escaped_param) = escape($param); + my($value); + for $value ($self->param($param)) { + print $filehandle "$escaped_param=",escape("$value"),"\n" + if length($escaped_param) or length($value); + } + } + for (keys %{$self->{'.fieldnames'}}) { + print $filehandle ".cgifields=",escape("$_"),"\n"; + } + print $filehandle "=\n"; # end of record +} + +#### Method: save_parameters +# An alias for save() that is a better name for exportation. +# Only intended to be used with the function (non-OO) interface. +#### +sub save_parameters { + my $fh = shift; + return save(to_filehandle($fh)); +} + +#### Method: restore_parameters +# A way to restore CGI parameters from an initializer. +# Only intended to be used with the function (non-OO) interface. +#### +sub restore_parameters { + $Q = $CGI::DefaultClass->new(@_); +} + +#### Method: multipart_init +# Return a Content-Type: style header for server-push +# This has to be NPH on most web servers, and it is advisable to set $| = 1 +# +# Many thanks to Ed Jordan for this +# contribution, updated by Andrew Benham (adsb@bigfoot.com) +#### +sub multipart_init { + my($self,@p) = self_or_default(@_); + my($boundary,$charset,@other) = rearrange_header([BOUNDARY,CHARSET],@p); + if (!$boundary) { + $boundary = '------- =_'; + my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z'); + for (1..17) { + $boundary .= $chrs[rand(scalar @chrs)]; + } + } + + $self->{'separator'} = "$CRLF--$boundary$CRLF"; + $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; + $type = SERVER_PUSH($boundary); + return $self->header( + -nph => 0, + -type => $type, + -charset => $charset, + (map { split "=", $_, 2 } @other), + ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; +} + +#### Method: multipart_start +# Return a Content-Type: style header for server-push, start of section +# +# Many thanks to Ed Jordan for this +# contribution, updated by Andrew Benham (adsb@bigfoot.com) +#### +sub multipart_start { + my(@header); + my($self,@p) = self_or_default(@_); + my($type,$charset,@other) = rearrange([TYPE,CHARSET],@p); + $type = $type || 'text/html'; + if ($charset) { + push(@header,"Content-Type: $type; charset=$charset"); + } else { + push(@header,"Content-Type: $type"); + } + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + for (@other) { + # Don't use \s because of perl bug 21951 + next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; + ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e; + } + push(@header,@other); + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + return $header; +} + +#### Method: multipart_end +# Return a MIME boundary separator for server-push, end of section +# +# Many thanks to Ed Jordan for this +# contribution +#### +sub multipart_end { + my($self,@p) = self_or_default(@_); + return $self->{'separator'}; +} + +#### Method: multipart_final +# Return a MIME boundary separator for server-push, end of all sections +# +# Contributed by Andrew Benham (adsb@bigfoot.com) +#### +sub multipart_final { + my($self,@p) = self_or_default(@_); + return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF; +} + +#### Method: header +# Return a Content-Type: style header +# +#### +sub header { + my($self,@p) = self_or_default(@_); + my(@header); + + return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; + + my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = + rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], + 'STATUS',['COOKIE','COOKIES','SET-COOKIE'],'TARGET', + 'EXPIRES','NPH','CHARSET', + 'ATTACHMENT','P3P'],@p); + + # Since $cookie and $p3p may be array references, + # we must stringify them before CR escaping is done. + my @cookie; + for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) { + my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; + push(@cookie,$cs) if defined $cs and $cs ne ''; + } + $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY'; + + # CR escaping for values, per RFC 822 + for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) { + if (defined $header) { + # From RFC 822: + # Unfolding is accomplished by regarding CRLF immediately + # followed by a LWSP-char as equivalent to the LWSP-char. + $header =~ s/$CRLF(\s)/$1/g; + + # All other uses of newlines are invalid input. + if ($header =~ m/$CRLF|\015|\012/) { + # shorten very long values in the diagnostic + $header = substr($header,0,72).'...' if (length $header > 72); + die "Invalid header value contains a newline not followed by whitespace: $header"; + } + } + } + + $nph ||= $NPH; + + $type ||= 'text/html' unless defined($type); + + # sets if $charset is given, gets if not + $charset = $self->charset( $charset ); + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + for (@other) { + # Don't use \s because of perl bug 21951 + next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s; + ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; + } + + $type .= "; charset=$charset" + if $type ne '' + and $type !~ /\bcharset\b/ + and defined $charset + and $charset ne ''; + + # Maybe future compatibility. Maybe not. + my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; + push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; + push(@header,"Server: " . &server_software()) if $nph; + + push(@header,"Status: $status") if $status; + push(@header,"Window-Target: $target") if $target; + push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p; + # push all the cookies -- there may be several + push(@header,map {"Set-Cookie: $_"} @cookie); + # if the user indicates an expiration time, then we need + # both an Expires and a Date header (so that the browser is + # uses OUR clock) + push(@header,"Expires: " . expires($expires,'http')) + if $expires; + push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; + push(@header,"Pragma: no-cache") if $self->cache(); + push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; + push(@header,map {ucfirst $_} @other); + push(@header,"Content-Type: $type") if $type ne ''; + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + if (($MOD_PERL >= 1) && !$nph) { + $self->r->send_cgi_header($header); + return ''; + } + return $header; +} + +#### Method: cache +# Control whether header() will produce the no-cache +# Pragma directive. +#### +sub cache { + my($self,$new_value) = self_or_default(@_); + $new_value = '' unless $new_value; + if ($new_value ne '') { + $self->{'cache'} = $new_value; + } + return $self->{'cache'}; +} + +#### Method: redirect +# Return a Location: style header +# +#### +sub redirect { + my($self,@p) = self_or_default(@_); + my($url,$target,$status,$cookie,$nph,@other) = + rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES','SET-COOKIE'],NPH],@p); + $status = '302 Found' unless defined $status; + $url ||= $self->self_url; + my(@o); + for (@other) { tr/\"//d; push(@o,split("=",$_,2)); } + unshift(@o, + '-Status' => $status, + '-Location'=> $url, + '-nph' => $nph); + unshift(@o,'-Target'=>$target) if $target; + unshift(@o,'-Type'=>''); + my @unescaped; + unshift(@unescaped,'-Cookie'=>$cookie) if $cookie; + return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped); +} + +#### Method: start_html +# Canned HTML header +# +# Parameters: +# $title -> (optional) The title for this HTML document (-title) +# $author -> (optional) e-mail address of the author (-author) +# $base -> (optional) if set to true, will enter the BASE address of this document +# for resolving relative references (-base) +# $xbase -> (optional) alternative base at some remote location (-xbase) +# $target -> (optional) target window to load all links into (-target) +# $script -> (option) Javascript code (-script) +# $no_script -> (option) Javascript +END + ; + my($other) = @other ? " @other" : ''; + push(@result,"\n\n"); + return join("\n",@result); +} + +### Method: _style +# internal method for generating a CSS style section +#### +sub _style { + my ($self,$style) = @_; + my (@result); + + my $type = 'text/css'; + my $rel = 'stylesheet'; + + + my $cdata_start = $XHTML ? "\n\n" : " -->\n"; + + my @s = ref($style) eq 'ARRAY' ? @$style : $style; + my $other = ''; + + for my $s (@s) { + if (ref($s)) { + my($src,$code,$verbatim,$stype,$alternate,$foo,@other) = + rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)], + ('-foo'=>'bar', + ref($s) eq 'ARRAY' ? @$s : %$s)); + my $type = defined $stype ? $stype : 'text/css'; + my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet'; + $other = "@other" if @other; + + if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference + { # If it is, push a LINK tag for each one + for $src (@$src) + { + push(@result,$XHTML ? qq() + : qq()) if $src; + } + } + else + { # Otherwise, push the single -src, if it exists. + push(@result,$XHTML ? qq() + : qq() + ) if $src; + } + if ($verbatim) { + my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim; + push(@result, "") for @v; + } + if ($code) { + my @c = ref($code) eq 'ARRAY' ? @$code : $code; + push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c; + } + + } else { + my $src = $s; + push(@result,$XHTML ? qq() + : qq()); + } + } + @result; +} + +sub _script { + my ($self,$script) = @_; + my (@result); + + my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); + for $script (@scripts) { + my($src,$code,$language,$charset); + if (ref($script)) { # script is a hash + ($src,$code,$type,$charset) = + rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'], + '-foo'=>'bar', # a trick to allow the '-' to be omitted + ref($script) eq 'ARRAY' ? @$script : %$script); + $type ||= 'text/javascript'; + unless ($type =~ m!\w+/\w+!) { + $type =~ s/[\d.]+$//; + $type = "text/$type"; + } + } else { + ($src,$code,$type,$charset) = ('',$script, 'text/javascript', ''); + } + + my $comment = '//'; # javascript by default + $comment = '#' if $type=~/perl|tcl/i; + $comment = "'" if $type=~/vbscript/i; + + my ($cdata_start,$cdata_end); + if ($XHTML) { + $cdata_start = "$comment"; + } else { + $cdata_start = "\n\n"; + } + my(@satts); + push(@satts,'src'=>$src) if $src; + push(@satts,'type'=>$type); + push(@satts,'charset'=>$charset) if ($src && $charset); + $code = $cdata_start . $code . $cdata_end if defined $code; + push(@result,$self->script({@satts},$code || '')); + } + @result; +} + +#### Method: end_html +# End an HTML document. +# Trivial method for completeness. Just returns "" +#### +sub end_html { + return "\n\n"; +} + +################################ +# METHODS USED IN BUILDING FORMS +################################ + +#### Method: isindex +# Just prints out the isindex tag. +# Parameters: +# $action -> optional URL of script to run +# Returns: +# A string containing a tag +sub isindex { + my($self,@p) = self_or_default(@_); + my($action,@other) = rearrange([ACTION],@p); + $action = qq/ action="$action"/ if $action; + my($other) = @other ? " @other" : ''; + return $XHTML ? "" : ""; +} + +#### Method: start_form +# Start a form +# Parameters: +# $method -> optional submission method to use (GET or POST) +# $action -> optional URL of script to run +# $enctype ->encoding to use (URL_ENCODED or MULTIPART) +sub start_form { + my($self,@p) = self_or_default(@_); + + my($method,$action,$enctype,@other) = + rearrange([METHOD,ACTION,ENCTYPE],@p); + + $method = $self->_maybe_escapeHTML(lc($method || 'post')); + + if( $XHTML ){ + $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART); + }else{ + $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED); + } + + if (defined $action) { + $action = $self->_maybe_escapeHTML($action); + } + else { + $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url); + } + $action = qq(action="$action"); + my($other) = @other ? " @other" : ''; + $self->{'.parametersToAdd'}={}; + return qq/
/; +} + +#### Method: start_multipart_form +sub start_multipart_form { + my($self,@p) = self_or_default(@_); + if (defined($p[0]) && substr($p[0],0,1) eq '-') { + return $self->start_form(-enctype=>&MULTIPART,@p); + } else { + my($method,$action,@other) = + rearrange([METHOD,ACTION],@p); + return $self->start_form($method,$action,&MULTIPART,@other); + } +} + +#### Method: end_form +# End a form +# Note: This repeated below under the older name. +sub end_form { + my($self,@p) = self_or_default(@_); + if ( $NOSTICKY ) { + return wantarray ? ("
") : "\n"; + } else { + if (my @fields = $self->get_fields) { + return wantarray ? ("
",@fields,"
","") + : "
".(join '',@fields)."
\n"; + } else { + return ""; + } + } +} + +#### Method: end_multipart_form +# end a multipart form +sub end_multipart_form { + &end_form; +} + +sub _textfield { + my($self,$tag,@p) = self_or_default(@_); + my($name,$default,$size,$maxlength,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p); + + my $current = $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : ''; + $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; + my($s) = defined($size) ? qq/ size="$size"/ : ''; + my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : ''; + my($other) = @other ? " @other" : ''; + # this entered at cristy's request to fix problems with file upload fields + # and WebTV -- not sure it won't break stuff + my($value) = $current ne '' ? qq(value="$current") : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); +} + +#### Method: textfield +# Parameters: +# $name -> Name of the text field +# $default -> Optional default value of the field if not +# already defined. +# $size -> Optional width of field in characaters. +# $maxlength -> Optional maximum number of characters. +# Returns: +# A string containing a field +# +sub textfield { + my($self,@p) = self_or_default(@_); + $self->_textfield('text',@p); +} + +#### Method: filefield +# Parameters: +# $name -> Name of the file upload field +# $size -> Optional width of field in characaters. +# $maxlength -> Optional maximum number of characters. +# Returns: +# A string containing a field +# +sub filefield { + my($self,@p) = self_or_default(@_); + $self->_textfield('file',@p); +} + +#### Method: password +# Create a "secret password" entry field +# Parameters: +# $name -> Name of the field +# $default -> Optional default value of the field if not +# already defined. +# $size -> Optional width of field in characters. +# $maxlength -> Optional maximum characters that can be entered. +# Returns: +# A string containing a field +# +sub password_field { + my ($self,@p) = self_or_default(@_); + $self->_textfield('password',@p); +} + +#### Method: textarea +# Parameters: +# $name -> Name of the text field +# $default -> Optional default value of the field if not +# already defined. +# $rows -> Optional number of rows in text area +# $columns -> Optional number of columns in text area +# Returns: +# A string containing a tag +# +sub textarea { + my($self,@p) = self_or_default(@_); + my($name,$default,$rows,$cols,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p); + + my($current)= $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; + $current = defined($current) ? $self->_maybe_escapeHTML($current) : ''; + my($r) = $rows ? qq/ rows="$rows"/ : ''; + my($c) = $cols ? qq/ cols="$cols"/ : ''; + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return qq{}; +} + +#### Method: button +# Create a javascript button. +# Parameters: +# $name -> (optional) Name for the button. (-name) +# $value -> (optional) Value of the button when selected (and visible name) (-value) +# $onclick -> (optional) Text of the JavaScript to run when the button is +# clicked. +# Returns: +# A string containing a tag +#### +sub button { + my($self,@p) = self_or_default(@_); + + my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL], + [ONCLICK,SCRIPT],TABINDEX],@p); + + $label=$self->_maybe_escapeHTML($label); + $value=$self->_maybe_escapeHTML($value,1); + $script=$self->_maybe_escapeHTML($script); + + $script ||= ''; + + my($name) = ''; + $name = qq/ name="$label"/ if $label; + $value = $value || $label; + my($val) = ''; + $val = qq/ value="$value"/ if $value; + $script = qq/ onclick="$script"/ if $script; + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); +} + +#### Method: submit +# Create a "submit query" button. +# Parameters: +# $name -> (optional) Name for the button. +# $value -> (optional) Value of the button when selected (also doubles as label). +# $label -> (optional) Label printed on the button(also doubles as the value). +# Returns: +# A string containing a tag +#### +sub submit { + my($self,@p) = self_or_default(@_); + + my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p); + + $label=$self->_maybe_escapeHTML($label); + $value=$self->_maybe_escapeHTML($value,1); + + my $name = $NOSTICKY ? '' : 'name=".submit" '; + $name = qq/name="$label" / if defined($label); + $value = defined($value) ? $value : $label; + my $val = ''; + $val = qq/value="$value" / if defined($value); + $tabindex = $self->element_tab($tabindex); + my($other) = @other ? "@other " : ''; + return $XHTML ? qq() + : qq(); +} + +#### Method: reset +# Create a "reset" button. +# Parameters: +# $name -> (optional) Name for the button. +# Returns: +# A string containing a tag +#### +sub reset { + my($self,@p) = self_or_default(@_); + my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p); + $label=$self->_maybe_escapeHTML($label); + $value=$self->_maybe_escapeHTML($value,1); + my ($name) = ' name=".reset"'; + $name = qq/ name="$label"/ if defined($label); + $value = defined($value) ? $value : $label; + my($val) = ''; + $val = qq/ value="$value"/ if defined($value); + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); +} + +#### Method: defaults +# Create a "defaults" button. +# Parameters: +# $name -> (optional) Name for the button. +# Returns: +# A string containing a tag +# +# Note: this button has a special meaning to the initialization script, +# and tells it to ERASE the current query string so that your defaults +# are used again! +#### +sub defaults { + my($self,@p) = self_or_default(@_); + + my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p); + + $label=$self->_maybe_escapeHTML($label,1); + $label = $label || "Defaults"; + my($value) = qq/ value="$label"/; + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq//; +} + +#### Method: comment +# Create an HTML +# Parameters: a string +sub comment { + my($self,@p) = self_or_CGI(@_); + return ""; +} + +#### Method: checkbox +# Create a checkbox that is not logically linked to any others. +# The field value is "on" when the button is checked. +# Parameters: +# $name -> Name of the checkbox +# $checked -> (optional) turned on by default if true +# $value -> (optional) value of the checkbox, 'on' by default +# $label -> (optional) a user-readable label printed next to the box. +# Otherwise the checkbox name is used. +# Returns: +# A string containing a field +#### +sub checkbox { + my($self,@p) = self_or_default(@_); + + my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) = + rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES, + [OVERRIDE,FORCE],TABINDEX],@p); + + $value = defined $value ? $value : 'on'; + + if (!$override && ($self->{'.fieldnames'}->{$name} || + defined $self->param($name))) { + $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : ''; + } else { + $checked = $self->_checked($checked); + } + my($the_label) = defined $label ? $label : $name; + $name = $self->_maybe_escapeHTML($name); + $value = $self->_maybe_escapeHTML($value,1); + $the_label = $self->_maybe_escapeHTML($the_label); + my($other) = @other ? "@other " : ''; + $tabindex = $self->element_tab($tabindex); + $self->register_parameter($name); + return $XHTML ? CGI::label($labelattributes, + qq{$the_label}) + : qq{$the_label}; +} + +# Escape HTML +sub escapeHTML { + require HTML::Entities; + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); + return undef unless defined($toencode); + my $encode_entities = $ENCODE_ENTITIES; + $encode_entities .= "\012\015" if ( $encode_entities && $newlinestoo ); + return HTML::Entities::encode_entities($toencode,$encode_entities); +} + +# unescape HTML -- used internally +sub unescapeHTML { + require HTML::Entities; + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$string) = CGI::self_or_default(@_); + return undef unless defined($string); + return HTML::Entities::decode_entities($string); +} + +# Internal procedure - don't use +sub _tableize { + my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; + my @rowheaders = $rowheaders ? @$rowheaders : (); + my @colheaders = $colheaders ? @$colheaders : (); + my($result); + + if (defined($columns)) { + $rows = int(0.99 + @elements/$columns) unless defined($rows); + } + if (defined($rows)) { + $columns = int(0.99 + @elements/$rows) unless defined($columns); + } + + # rearrange into a pretty table + $result = ""; + my($row,$column); + unshift(@colheaders,'') if @colheaders && @rowheaders; + $result .= "" if @colheaders; + for (@colheaders) { + $result .= ""; + } + for ($row=0;$row<$rows;$row++) { + $result .= ""; + $result .= "" if @rowheaders; + for ($column=0;$column<$columns;$column++) { + $result .= "" + if defined($elements[$column*$rows + $row]); + } + $result .= ""; + } + $result .= "
$_
$rowheaders[$row]" . $elements[$column*$rows + $row] . "
"; + return $result; +} + +#### Method: radio_group +# Create a list of logically-linked radio buttons. +# Parameters: +# $name -> Common name for all the buttons. +# $values -> A pointer to a regular array containing the +# values for each button in the group. +# $default -> (optional) Value of the button to turn on by default. Pass '-' +# to turn _nothing_ on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of fields +#### +sub radio_group { + my($self,@p) = self_or_default(@_); + $self->_box_group('radio',@p); +} + +#### Method: checkbox_group +# Create a list of logically-linked checkboxes. +# Parameters: +# $name -> Common name for all the check boxes +# $values -> A pointer to a regular array containing the +# values for each checkbox in the group. +# $defaults -> (optional) +# 1. If a pointer to a regular array of checkbox values, +# then this will be used to decide which +# checkboxes to turn on by default. +# 2. If a scalar, will be assumed to hold the +# value of a single checkbox in the group to turn on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of fields +#### + +sub checkbox_group { + my($self,@p) = self_or_default(@_); + $self->_box_group('checkbox',@p); +} + +sub _box_group { + my $self = shift; + my $box_type = shift; + + my($name,$values,$defaults,$linebreak,$labels,$labelattributes, + $attributes,$rows,$columns,$rowheaders,$colheaders, + $override,$nolabels,$tabindex,$disabled,@other) = + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES, + ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER], + [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED + ],@_); + + + my($result,$checked,@elements,@values); + + @values = $self->_set_values_and_labels($values,\$labels,$name); + my %checked = $self->previous_or_default($name,$defaults,$override); + + # If no check array is specified, check the first by default + $checked{$values[0]}++ if $box_type eq 'radio' && !%checked; + + $name=$self->_maybe_escapeHTML($name); + + my %tabs = (); + if ($TABINDEX && $tabindex) { + if (!ref $tabindex) { + $self->element_tab($tabindex); + } elsif (ref $tabindex eq 'ARRAY') { + %tabs = map {$_=>$self->element_tab} @$tabindex; + } elsif (ref $tabindex eq 'HASH') { + %tabs = %$tabindex; + } + } + %tabs = map {$_=>$self->element_tab} @values unless %tabs; + my $other = @other ? "@other " : ''; + my $radio_checked; + + # for disabling groups of radio/checkbox buttons + my %disabled; + for (@{$disabled}) { + $disabled{$_}=1; + } + + for (@values) { + my $disable=""; + if ($disabled{$_}) { + $disable="disabled='1'"; + } + + my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++) + : $checked{$_}); + my($break); + if ($linebreak) { + $break = $XHTML ? "
" : "
"; + } + else { + $break = ''; + } + my($label)=''; + unless (defined($nolabels) && $nolabels) { + $label = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + $label = $self->_maybe_escapeHTML($label,1); + $label = "$label" if $disabled{$_}; + } + my $attribs = $self->_set_attributes($_, $attributes); + my $tab = $tabs{$_}; + $_=$self->_maybe_escapeHTML($_); + + if ($XHTML) { + push @elements, + CGI::label($labelattributes, + qq($label)).${break}; + } else { + push(@elements,qq/${label}${break}/); + } + } + $self->register_parameter($name); + return wantarray ? @elements : "@elements" + unless defined($columns) || defined($rows); + return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); +} + +#### Method: popup_menu +# Create a popup menu. +# Parameters: +# $name -> Name for all the menu +# $values -> A pointer to a regular array containing the +# text of each menu item. +# $default -> (optional) Default item to display +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# A string containing the definition of a popup menu. +#### +sub popup_menu { + my($self,@p) = self_or_default(@_); + + my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) = + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, + ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); + my($result,%selected); + + if (!$override && defined($self->param($name))) { + $selected{$self->param($name)}++; + } elsif (defined $default) { + %selected = map {$_=>1} ref($default) eq 'ARRAY' + ? @$default + : $default; + } + $name=$self->_maybe_escapeHTML($name); + # RT #30057 - ignore -multiple, if you need this + # then use scrolling_list + @other = grep { $_ !~ /^multiple=/i } @other; + my($other) = @other ? " @other" : ''; + + my(@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); + $tabindex = $self->element_tab($tabindex); + $name = q{} if ! defined $name; + $result = qq/"; + return $result; +} + +#### Method: optgroup +# Create a optgroup. +# Parameters: +# $name -> Label for the group +# $values -> A pointer to a regular array containing the +# values for each option line in the group. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each item +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# $labeled -> (optional) +# A true value indicates the value should be used as the label attribute +# in the option elements. +# The label attribute specifies the option label presented to the user. +# This defaults to the content of the \n/; + for (@values) { + if (/_set_attributes($_, $attributes); + my($label) = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + $label=$self->_maybe_escapeHTML($label); + my($value)=$self->_maybe_escapeHTML($_,1); + $result .= $labeled ? $novals ? "$label\n" + : "$label\n" + : $novals ? "$label\n" + : "$label\n"; + } + } + $result .= ""; + return $result; +} + +#### Method: scrolling_list +# Create a scrolling list. +# Parameters: +# $name -> name for the list +# $values -> A pointer to a regular array containing the +# values for each option line in the list. +# $defaults -> (optional) +# 1. If a pointer to a regular array of options, +# then this will be used to decide which +# lines to turn on by default. +# 2. Otherwise holds the value of the single line to turn on. +# $size -> (optional) Size of the list. +# $multiple -> (optional) If set, allow multiple selections. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# A string containing the definition of a scrolling list. +#### +sub scrolling_list { + my($self,@p) = self_or_default(@_); + my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other) + = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], + SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); + + my($result,@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); + + $size = $size || scalar(@values); + + my(%selected) = $self->previous_or_default($name,$defaults,$override); + + my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : ''; + my($has_size) = $size ? qq/ size="$size"/: ''; + my($other) = @other ? " @other" : ''; + + $name=$self->_maybe_escapeHTML($name); + $tabindex = $self->element_tab($tabindex); + $result = qq/"; + $self->register_parameter($name); + return $result; +} + +#### Method: hidden +# Parameters: +# $name -> Name of the hidden field +# @default -> (optional) Initial values of field (may be an array) +# or +# $default->[initial values of field] +# Returns: +# A string containing a +#### +sub hidden { + my($self,@p) = self_or_default(@_); + + # this is the one place where we departed from our standard + # calling scheme, so we have to special-case (darn) + my(@result,@value); + my($name,$default,$override,@other) = + rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); + + my $do_override = 0; + if ( ref($p[0]) || substr($p[0],0,1) eq '-') { + @value = ref($default) ? @{$default} : $default; + $do_override = $override; + } else { + for ($default,$override,@other) { + push(@value,$_) if defined($_); + } + undef @other; + } + + # use previous values if override is not set + my @prev = $self->param($name); + @value = @prev if !$do_override && @prev; + + $name=$self->_maybe_escapeHTML($name); + for (@value) { + $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : ''; + push @result,$XHTML ? qq() + : qq(); + } + return wantarray ? @result : join('',@result); +} + +#### Method: image_button +# Parameters: +# $name -> Name of the button +# $src -> URL of the image source +# $align -> Alignment style (TOP, BOTTOM or MIDDLE) +# Returns: +# A string containing a +#### +sub image_button { + my($self,@p) = self_or_default(@_); + + my($name,$src,$alignment,@other) = + rearrange([NAME,SRC,ALIGN],@p); + + my($align) = $alignment ? " align=\L\"$alignment\"" : ''; + my($other) = @other ? " @other" : ''; + $name=$self->_maybe_escapeHTML($name); + return $XHTML ? qq() + : qq//; +} + +#### Method: self_url +# Returns a URL containing the current script and all its +# param/value pairs arranged as a query. You can use this +# to create a link that, when selected, will reinvoke the +# script with all its state information preserved. +#### +sub self_url { + my($self,@p) = self_or_default(@_); + return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); +} + +# This is provided as a synonym to self_url() for people unfortunate +# enough to have incorporated it into their programs already! +sub state { + &self_url; +} + +#### Method: url +# Like self_url, but doesn't return the query string part of +# the URL. +#### +sub url { + my($self,@p) = self_or_default(@_); + my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) = + rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p); + my $url = ''; + $full++ if $base || !($relative || $absolute); + $rewrite++ unless defined $rewrite; + + my $path = $self->path_info; + my $script_name = $self->script_name; + my $request_uri = $self->request_uri || ''; + my $query_str = $query ? $self->query_string : ''; + + $request_uri =~ s/\?.*$//s; # remove query string + $request_uri = unescape($request_uri); + + my $uri = $rewrite && $request_uri ? $request_uri : $script_name; + $uri =~ s/\?.*$//s; # remove query string + + if ( defined( $ENV{PATH_INFO} ) ) { + # IIS sometimes sets PATH_INFO to the same value as SCRIPT_NAME so only sub it out + # if SCRIPT_NAME isn't defined or isn't the same value as PATH_INFO + $uri =~ s/\Q$ENV{PATH_INFO}\E$// + if ( ! defined( $ENV{SCRIPT_NAME} ) or $ENV{PATH_INFO} ne $ENV{SCRIPT_NAME} ); + + # if we're not IIS then keep to spec, the relevant info is here: + # https://tools.ietf.org/html/rfc3875#section-4.1.13, namely + # "No PATH_INFO segment (see section 4.1.5) is included in the + # SCRIPT_NAME value." (see GH #126, GH #152, GH #176) + if ( ! $IIS ) { + $uri =~ s/\Q$ENV{PATH_INFO}\E$//; + } + } + + if ($full) { + my $protocol = $self->protocol(); + $url = "$protocol://"; + my $vh = http('x_forwarded_host') || http('host') || ''; + $vh =~ s/^.*,\s*//; # x_forwarded_host may be a comma-separated list (e.g. when the request has + # passed through multiple reverse proxies. Take the last one. + $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it. + + $url .= $vh || server_name(); + + my $port = $self->virtual_port; + + # add the port to the url unless it's the protocol's default port + $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80) + or (lc($protocol) eq 'https' && $port == 443); + + return $url if $base; + + $url .= $uri; + } elsif ($relative) { + ($url) = $uri =~ m!([^/]+)$!; + } elsif ($absolute) { + $url = $uri; + } + + $url .= $path if $path_info and defined $path; + $url .= "?$query_str" if $query and $query_str ne ''; + $url ||= ''; + $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; + return $url; +} + +#### Method: cookie +# Set or read a cookie from the specified name. +# Cookie can then be passed to header(). +# Usual rules apply to the stickiness of -value. +# Parameters: +# -name -> name for this cookie (optional) +# -value -> value of this cookie (scalar, array or hash) +# -path -> paths for which this cookie is valid (optional) +# -domain -> internet domain in which this cookie is valid (optional) +# -secure -> if true, cookie only passed through secure channel (optional) +# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) +#### +sub cookie { + my($self,@p) = self_or_default(@_); + my($name,$value,$path,$domain,$secure,$expires,$httponly) = + rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p); + + require CGI::Cookie; + + # if no value is supplied, then we retrieve the + # value of the cookie, if any. For efficiency, we cache the parsed + # cookies in our state variables. + unless ( defined($value) ) { + $self->{'.cookies'} = CGI::Cookie->fetch; + + # If no name is supplied, then retrieve the names of all our cookies. + return () unless $self->{'.cookies'}; + return keys %{$self->{'.cookies'}} unless $name; + return () unless $self->{'.cookies'}->{$name}; + return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; + } + + # If we get here, we're creating a new cookie + return undef unless defined($name) && $name ne ''; # this is an error + + my @param; + push(@param,'-name'=>$name); + push(@param,'-value'=>$value); + push(@param,'-domain'=>$domain) if $domain; + push(@param,'-path'=>$path) if $path; + push(@param,'-expires'=>$expires) if $expires; + push(@param,'-secure'=>$secure) if $secure; + push(@param,'-httponly'=>$httponly) if $httponly; + + return CGI::Cookie->new(@param); +} + +sub parse_keywordlist { + my($self,$tosplit) = @_; + $tosplit = unescape($tosplit); # unescape the keywords + $tosplit=~tr/+/ /; # pluses to spaces + my(@keywords) = split(/\s+/,$tosplit); + return @keywords; +} + +sub param_fetch { + my($self,@p) = self_or_default(@_); + my($name) = rearrange([NAME],@p); + return [] unless defined $name; + + unless (exists($self->{param}{$name})) { + $self->add_parameter($name); + $self->{param}{$name} = []; + } + + return $self->{param}{$name}; +} + +############################################### +# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT +############################################### + +#### Method: path_info +# Return the extra virtual path information provided +# after the URL (if any) +#### +sub path_info { + my ($self,$info) = self_or_default(@_); + if (defined($info)) { + $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; + $self->{'.path_info'} = $info; + } elsif (! defined($self->{'.path_info'}) ) { + my (undef,$path_info) = $self->_name_and_path_from_env; + $self->{'.path_info'} = $path_info || ''; + } + return $self->{'.path_info'}; +} + +# This function returns a potentially modified version of SCRIPT_NAME +# and PATH_INFO. Some HTTP servers do sanitise the paths in those +# variables. It is the case of at least Apache 2. If for instance the +# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set: +# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y +# SCRIPT_NAME=/path/to/env.cgi +# PATH_INFO=/x/y/x +# +# This is all fine except that some bogus CGI scripts expect +# PATH_INFO=/http://foo when the user requests +# http://xxx/script.cgi/http://foo +# +# Old versions of this module used to accomodate with those scripts, so +# this is why we do this here to keep those scripts backward compatible. +# Basically, we accomodate with those scripts but within limits, that is +# we only try to preserve the number of / that were provided by the user +# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number +# of consecutive /. +# +# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a +# script_name of /x//y/script.cgi and a path_info of /a//b, but in: +# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions +# possibly sanitised by the HTTP server, so in the case of Apache 2: +# script_name == /foo/x/z/script.cgi and path_info == /b/c. +# +# Future versions of this module may no longer do that, so one should +# avoid relying on the browser, proxy, server, and CGI.pm preserving the +# number of consecutive slashes as no guarantee can be made there. +sub _name_and_path_from_env { + my $self = shift; + my $script_name = $ENV{SCRIPT_NAME} || ''; + my $path_info = $ENV{PATH_INFO} || ''; + my $uri = $self->request_uri || ''; + + $uri =~ s/\?.*//s; + $uri = unescape($uri); + + if ( $IIS ) { + # IIS doesn't set $ENV{PATH_INFO} correctly. It sets it to + # $ENV{SCRIPT_NAME}path_info + # IIS also doesn't set $ENV{REQUEST_URI} so we don't want to do + # the test below, hence this comes first + $path_info =~ s/^\Q$script_name\E(.*)/$1/; + } elsif ($uri ne "$script_name$path_info") { + my $script_name_pattern = quotemeta($script_name); + my $path_info_pattern = quotemeta($path_info); + $script_name_pattern =~ s{(?:\\/)+}{/+}g; + $path_info_pattern =~ s{(?:\\/)+}{/+}g; + + if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) { + # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the + # numer of consecutive slashes, so we can extract the info from + # REQUEST_URI: + ($script_name, $path_info) = ($1, $2); + } + } + return ($script_name,$path_info); +} + +#### Method: request_method +# Returns 'POST', 'GET', 'PUT' or 'HEAD' +#### +sub request_method { + return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef; +} + +#### Method: content_type +# Returns the content_type string +#### +sub content_type { + return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef; +} + +#### Method: path_translated +# Return the physical path information provided +# by the URL (if any) +#### +sub path_translated { + return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef; +} + +#### Method: request_uri +# Return the literal request URI +#### +sub request_uri { + return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef; +} + +#### Method: query_string +# Synthesize a query string from our current +# parameters +#### +sub query_string { + my($self) = self_or_default(@_); + my($param,$value,@pairs); + for $param ($self->param) { + my($eparam) = escape($param); + for $value ($self->param($param)) { + $value = escape($value); + next unless defined $value; + push(@pairs,"$eparam=$value"); + } + } + for (keys %{$self->{'.fieldnames'}}) { + push(@pairs,".cgifields=".escape("$_")); + } + return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); +} + +sub env_query_string { + return (defined $ENV{'QUERY_STRING'}) ? $ENV{'QUERY_STRING'} : undef; +} + +#### Method: accept +# Without parameters, returns an array of the +# MIME types the browser accepts. +# With a single parameter equal to a MIME +# type, will return undef if the browser won't +# accept it, 1 if the browser accepts it but +# doesn't give a preference, or a floating point +# value between 0.0 and 1.0 if the browser +# declares a quantitative score for it. +# This handles MIME type globs correctly. +#### +sub Accept { + my($self,$search) = self_or_CGI(@_); + my(%prefs,$type,$pref,$pat); + + my(@accept) = defined $self->http('accept') + ? split(',',$self->http('accept')) + : (); + + for (@accept) { + ($pref) = /q=(\d\.\d+|\d+)/; + ($type) = m#(\S+/[^;]+)#; + next unless $type; + $prefs{$type}=$pref || 1; + } + + return keys %prefs unless $search; + + # if a search type is provided, we may need to + # perform a pattern matching operation. + # The MIME types use a glob mechanism, which + # is easily translated into a perl pattern match + + # First return the preference for directly supported + # types: + return $prefs{$search} if $prefs{$search}; + + # Didn't get it, so try pattern matching. + for (keys %prefs) { + next unless /\*/; # not a pattern match + ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters + $pat =~ s/\*/.*/g; # turn it into a pattern + return $prefs{$_} if $search=~/$pat/; + } +} + +#### Method: user_agent +# If called with no parameters, returns the user agent. +# If called with one parameter, does a pattern match (case +# insensitive) on the user agent. +#### +sub user_agent { + my($self,$match)=self_or_CGI(@_); + my $user_agent = $self->http('user_agent'); + return $user_agent unless defined $match && $match && $user_agent; + return $user_agent =~ /$match/i; +} + +#### Method: raw_cookie +# Returns the magic cookies for the session. +# The cookies are not parsed or altered in any way, i.e. +# cookies are returned exactly as given in the HTTP +# headers. If a cookie name is given, only that cookie's +# value is returned, otherwise the entire raw cookie +# is returned. +#### +sub raw_cookie { + my($self,$key) = self_or_CGI(@_); + + require CGI::Cookie; + + if (defined($key)) { + $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch + unless $self->{'.raw_cookies'}; + + return () unless $self->{'.raw_cookies'}; + return () unless $self->{'.raw_cookies'}->{$key}; + return $self->{'.raw_cookies'}->{$key}; + } + return $self->http('cookie') || $ENV{'COOKIE'} || ''; +} + +#### Method: virtual_host +# Return the name of the virtual_host, which +# is not always the same as the server +###### +sub virtual_host { + my $vh = http('x_forwarded_host') || http('host') || server_name(); + $vh =~ s/:\d+$//; # get rid of port number + return $vh; +} + +#### Method: remote_host +# Return the name of the remote host, or its IP +# address if unavailable. If this variable isn't +# defined, it returns "localhost" for debugging +# purposes. +#### +sub remote_host { + return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} + || 'localhost'; +} + +#### Method: remote_addr +# Return the IP addr of the remote host. +#### +sub remote_addr { + return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; +} + +#### Method: script_name +# Return the partial URL to this script for +# self-referencing scripts. Also see +# self_url(), which returns a URL with all state information +# preserved. +#### +sub script_name { + my ($self,@p) = self_or_default(@_); + if (@p) { + $self->{'.script_name'} = shift @p; + } elsif (!exists $self->{'.script_name'}) { + my ($script_name,$path_info) = $self->_name_and_path_from_env(); + $self->{'.script_name'} = $script_name; + } + return $self->{'.script_name'}; +} + +#### Method: referer +# Return the HTTP_REFERER: useful for generating +# a GO BACK button. +#### +sub referer { + my($self) = self_or_CGI(@_); + return $self->http('referer'); +} + +#### Method: server_name +# Return the name of the server +#### +sub server_name { + return $ENV{'SERVER_NAME'} || 'localhost'; +} + +#### Method: server_software +# Return the name of the server software +#### +sub server_software { + return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; +} + +#### Method: virtual_port +# Return the server port, taking virtual hosts into account +#### +sub virtual_port { + my($self) = self_or_default(@_); + my $vh = $self->http('x_forwarded_host') || $self->http('host'); + my $protocol = $self->protocol; + if ($vh) { + return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80); + } else { + return $self->server_port(); + } +} + +#### Method: server_port +# Return the tcp/ip port the server is running on +#### +sub server_port { + return $ENV{'SERVER_PORT'} || 80; # for debugging +} + +#### Method: server_protocol +# Return the protocol (usually HTTP/1.0) +#### +sub server_protocol { + return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging +} + +#### Method: http +# Return the value of an HTTP variable, or +# the list of variables if none provided +#### +sub http { + my ($self,$parameter) = self_or_CGI(@_); + if ( defined($parameter) ) { + $parameter =~ tr/-a-z/_A-Z/; + if ( $parameter =~ /^HTTP(?:_|$)/ ) { + return $ENV{$parameter}; + } + return $ENV{"HTTP_$parameter"}; + } + return grep { /^HTTP(?:_|$)/ } keys %ENV; +} + +#### Method: https +# Return the value of HTTPS, or +# the value of an HTTPS variable, or +# the list of variables +#### +sub https { + my ($self,$parameter) = self_or_CGI(@_); + if ( defined($parameter) ) { + $parameter =~ tr/-a-z/_A-Z/; + if ( $parameter =~ /^HTTPS(?:_|$)/ ) { + return $ENV{$parameter}; + } + return $ENV{"HTTPS_$parameter"}; + } + return wantarray + ? grep { /^HTTPS(?:_|$)/ } keys %ENV + : $ENV{'HTTPS'}; +} + +#### Method: protocol +# Return the protocol (http or https currently) +#### +sub protocol { + local($^W)=0; + my $self = shift; + return 'https' if uc($self->https()) eq 'ON'; + return 'https' if $self->server_port == 443; + my $prot = $self->server_protocol; + my($protocol,$version) = split('/',$prot); + return "\L$protocol\E"; +} + +#### Method: remote_ident +# Return the identity of the remote user +# (but only if his host is running identd) +#### +sub remote_ident { + return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef; +} + +#### Method: auth_type +# Return the type of use verification/authorization in use, if any. +#### +sub auth_type { + return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef; +} + +#### Method: remote_user +# Return the authorization name used for user +# verification. +#### +sub remote_user { + return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef; +} + +#### Method: user_name +# Try to return the remote user's name by hook or by +# crook +#### +sub user_name { + my ($self) = self_or_CGI(@_); + return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; +} + +#### Method: nosticky +# Set or return the NOSTICKY global flag +#### +sub nosticky { + my ($self,$param) = self_or_CGI(@_); + $CGI::NOSTICKY = $param if defined($param); + return $CGI::NOSTICKY; +} + +#### Method: nph +# Set or return the NPH global flag +#### +sub nph { + my ($self,$param) = self_or_CGI(@_); + $CGI::NPH = $param if defined($param); + return $CGI::NPH; +} + +#### Method: private_tempfiles +# Set or return the private_tempfiles global flag +#### +sub private_tempfiles { + warn "private_tempfiles has been deprecated"; + return 0; +} +#### Method: close_upload_files +# Set or return the close_upload_files global flag +#### +sub close_upload_files { + my ($self,$param) = self_or_CGI(@_); + $CGI::CLOSE_UPLOAD_FILES = $param if defined($param); + return $CGI::CLOSE_UPLOAD_FILES; +} + +#### Method: default_dtd +# Set or return the default_dtd global +#### +sub default_dtd { + my ($self,$param,$param2) = self_or_CGI(@_); + if (defined $param2 && defined $param) { + $CGI::DEFAULT_DTD = [ $param, $param2 ]; + } elsif (defined $param) { + $CGI::DEFAULT_DTD = $param; + } + return $CGI::DEFAULT_DTD; +} + +# -------------- really private subroutines ----------------- +sub _maybe_escapeHTML { + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); + return undef unless defined($toencode); + return $toencode if ref($self) && !$self->{'escape'}; + return $self->escapeHTML($toencode, $newlinestoo); +} + +sub previous_or_default { + my($self,$name,$defaults,$override) = @_; + my(%selected); + + if (!$override && ($self->{'.fieldnames'}->{$name} || + defined($self->param($name)) ) ) { + $selected{$_}++ for $self->param($name); + } elsif (defined($defaults) && ref($defaults) && + (ref($defaults) eq 'ARRAY')) { + $selected{$_}++ for @{$defaults}; + } else { + $selected{$defaults}++ if defined($defaults); + } + + return %selected; +} + +sub register_parameter { + my($self,$param) = @_; + $self->{'.parametersToAdd'}->{$param}++; +} + +sub get_fields { + my($self) = @_; + return $self->CGI::hidden('-name'=>'.cgifields', + '-values'=>[keys %{$self->{'.parametersToAdd'}}], + '-override'=>1); +} + +sub read_from_cmdline { + my($input,@words); + my($query_string); + my($subpath); + if ($DEBUG && @ARGV) { + @words = @ARGV; + } elsif ($DEBUG > 1) { + require Text::ParseWords; + print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; + chomp(@lines = ); # remove newlines + $input = join(" ",@lines); + @words = &Text::ParseWords::old_shellwords($input); + } + for (@words) { + s/\\=/%3D/g; + s/\\&/%26/g; + } + + if ("@words"=~/=/) { + $query_string = join('&',@words); + } else { + $query_string = join('+',@words); + } + if ($query_string =~ /^(.*?)\?(.*)$/) + { + $query_string = $2; + $subpath = $1; + } + return { 'query_string' => $query_string, 'subpath' => $subpath }; +} + +##### +# subroutine: read_multipart +# +# Read multipart data and store it into our parameters. +# An interesting feature is that if any of the parts is a file, we +# create a temporary file and open up a filehandle on it so that the +# caller can read from it if necessary. +##### +sub read_multipart { + my($self,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); + return unless $buffer; + my(%header,$body); + my $filenumber = 0; + while (!$buffer->eof) { + %header = $buffer->readHeader; + + unless (%header) { + $self->cgi_error("400 Bad request (malformed multipart POST)"); + return; + } + + $header{'Content-Disposition'} ||= ''; # quench uninit variable warning + + my($param)= $header{'Content-Disposition'}=~/[\s;]name="([^"]*)"/; + $param .= $TAINTED; + + # See RFC 1867, 2183, 2045 + # NB: File content will be loaded into memory should + # content-disposition parsing fail. + my ($filename) = $header{'Content-Disposition'} + =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i; + + $filename ||= ''; # quench uninit variable warning + + $filename =~ s/^"([^"]*)"$/$1/; + # Test for Opera's multiple upload feature + my($multipart) = ( defined( $header{'Content-Type'} ) && + $header{'Content-Type'} =~ /multipart\/mixed/ ) ? + 1 : 0; + + # add this parameter to our list + $self->add_parameter($param); + + # If no filename specified, then just read the data and assign it + # to our parameter list. + if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) { + my($value) = $buffer->readBody; + $value .= $TAINTED; + push(@{$self->{param}{$param}},$value); + next; + } + + UPLOADS: { + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + while (defined($data = $buffer->read)) { } + last UPLOADS; + } + + # set the filename to some recognizable value + if ( ( !defined($filename) || $filename eq '' ) && $multipart ) { + $filename = "multipart/mixed"; + } + + my $tmp_dir = $CGI::OS eq 'WINDOWS' + ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) + : undef; # File::Temp defaults to TMPDIR + + require CGI::File::Temp; + my $filehandle = CGI::File::Temp->new( + UNLINK => $UNLINK_TMP_FILES, + DIR => $tmp_dir, + ); + $filehandle->_mp_filename( $filename ); + + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode + && defined fileno($filehandle); + + # if this is an multipart/mixed attachment, save the header + # together with the body for later parsing with an external + # MIME parser module + if ( $multipart ) { + for ( keys %header ) { + print $filehandle "$_: $header{$_}${CRLF}"; + } + print $filehandle "${CRLF}"; + } + + my ($data); + local($\) = ''; + my $totalbytes = 0; + while (defined($data = $buffer->read)) { + if (defined $self->{'.upload_hook'}) + { + $totalbytes += length($data); + &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); + } + print $filehandle $data if ($self->{'use_tempfile'}); + } + + # back up to beginning of file + seek($filehandle,0,0); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob + filename as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { + hndl => $filehandle, + name => $filehandle->filename, + info => {%header}, + }; + push(@{$self->{param}{$param}},$filehandle); + } + } +} + +##### +# subroutine: read_multipart_related +# +# Read multipart/related data and store it into our parameters. The +# first parameter sets the start of the data. The part identified by +# this Content-ID will not be stored as a file upload, but will be +# returned by this method. All other parts will be available as file +# uploads accessible by their Content-ID +##### +sub read_multipart_related { + my($self,$start,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); + return unless $buffer; + my(%header,$body); + my $filenumber = 0; + my $returnvalue; + while (!$buffer->eof) { + %header = $buffer->readHeader; + + unless (%header) { + $self->cgi_error("400 Bad request (malformed multipart POST)"); + return; + } + + my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/; + $param .= $TAINTED; + + # If this is the start part, then just read the data and assign it + # to our return variable. + if ( $param eq $start ) { + $returnvalue = $buffer->readBody; + $returnvalue .= $TAINTED; + next; + } + + # add this parameter to our list + $self->add_parameter($param); + + UPLOADS: { + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + while (defined($data = $buffer->read)) { } + last UPLOADS; + } + + my $tmp_dir = $CGI::OS eq 'WINDOWS' + ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) + : undef; # File::Temp defaults to TMPDIR + + require CGI::File::Temp; + my $filehandle = CGI::File::Temp->new( + UNLINK => $UNLINK_TMP_FILES, + DIR => $tmp_dir, + ); + $filehandle->_mp_filename( $filehandle->filename ); + + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode + && defined fileno($filehandle); + + my ($data); + local($\) = ''; + my $totalbytes; + while (defined($data = $buffer->read)) { + if (defined $self->{'.upload_hook'}) + { + $totalbytes += length($data); + &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'}); + } + print $filehandle $data if ($self->{'use_tempfile'}); + } + + # back up to beginning of file + seek($filehandle,0,0); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob + filename as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { + hndl => $filehandle, + name => $filehandle->filename, + info => {%header}, + }; + push(@{$self->{param}{$param}},$filehandle); + } + } + return $returnvalue; +} + +sub upload { + my($self,$param_name) = self_or_default(@_); + my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name); + return unless @param; + return wantarray ? @param : $param[0]; +} + +sub tmpFileName { + my($self,$filename) = self_or_default(@_); + + # preferred calling convention: $filename came directly from param or upload + if (ref $filename) { + return $self->{'.tmpfiles'}->{$$filename . $filename}->{name} || ''; + } + + # backwards compatible with older versions: $filename is merely equal to + # one of our filenames when compared as strings + foreach my $param_name ($self->param) { + foreach my $filehandle ($self->multi_param($param_name)) { + if ($filehandle eq $filename) { + return $self->{'.tmpfiles'}->{$$filehandle . $filehandle}->{name} || ''; + } + } + } + + return ''; +} + +sub uploadInfo { + my($self,$filename) = self_or_default(@_); + return if ! defined $$filename; + return $self->{'.tmpfiles'}->{$$filename . $filename}->{info}; +} + +# internal routine, don't use +sub _set_values_and_labels { + my $self = shift; + my ($v,$l,$n) = @_; + $$l = $v if ref($v) eq 'HASH' && !ref($$l); + return $self->param($n) if !defined($v); + return $v if !ref($v); + return ref($v) eq 'HASH' ? keys %$v : @$v; +} + +# internal routine, don't use +sub _set_attributes { + my $self = shift; + my($element, $attributes) = @_; + return '' unless defined($attributes->{$element}); + $attribs = ' '; + for my $attrib (keys %{$attributes->{$element}}) { + (my $clean_attrib = $attrib) =~ s/^-//; + $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" "; + } + $attribs =~ s/ $//; + return $attribs; +} + +######################################################### +# Globals and stubs for other packages that we use. +######################################################### + +######################## MultipartBuffer #################### + +package MultipartBuffer; + +$_DEBUG = 0; + +# how many bytes to read at a time. We use +# a 4K buffer by default. +$INITIAL_FILLUNIT = 1024 * 4; +$TIMEOUT = 240*60; # 4 hour timeout for big files +$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers +$CRLF=$CGI::CRLF; + +sub new { + my($package,$interface,$boundary,$length) = @_; + $FILLUNIT = $INITIAL_FILLUNIT; + $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always + + # If the user types garbage into the file upload field, + # then Netscape passes NOTHING to the server (not good). + # We may hang on this read in that case. So we implement + # a read timeout. If nothing is ready to read + # by then, we return. + + # Netscape seems to be a little bit unreliable + # about providing boundary strings. + my $boundary_read = 0; + if ($boundary) { + + # Under the MIME spec, the boundary consists of the + # characters "--" PLUS the Boundary string + + # BUG: IE 3.01 on the Macintosh uses just the boundary -- not + # the two extra hyphens. We do a special case here on the user-agent!!!! + $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport'); + + } else { # otherwise we find it ourselves + my($old); + ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line + $boundary = ; # BUG: This won't work correctly under mod_perl + $length -= length($boundary); + chomp($boundary); # remove the CRLF + $/ = $old; # restore old line separator + $boundary_read++; + } + + my $self = {LENGTH=>$length, + CHUNKED=>!$length, + BOUNDARY=>$boundary, + INTERFACE=>$interface, + BUFFER=>'', + }; + + $FILLUNIT = length($boundary) + if length($boundary) > $FILLUNIT; + + my $retval = bless $self,ref $package || $package; + + # Read the preamble and the topmost (boundary) line plus the CRLF. + unless ($boundary_read) { + while ($self->read(0)) { } + } + die "Malformed multipart POST: data truncated\n" if $self->eof; + + return $retval; +} + +sub readHeader { + my($self) = @_; + my($end); + my($ok) = 0; + my($bad) = 0; + + local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; + + do { + $self->fillBuffer($FILLUNIT); + $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; + $ok++ if $self->{BUFFER} eq ''; + $bad++ if !$ok && $self->{LENGTH} <= 0; + # this was a bad idea + # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; + } until $ok || $bad; + return () if $bad; + + #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines! + + my($header) = substr($self->{BUFFER},0,$end+2); + substr($self->{BUFFER},0,$end+4) = ''; + my %return; + + if ($CGI::EBCDIC) { + warn "untranslated header=$header\n" if $_DEBUG; + $header = CGI::Util::ascii2ebcdic($header); + warn "translated header=$header\n" if $_DEBUG; + } + + # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 + # (Folding Long Header Fields), 3.4.3 (Comments) + # and 3.4.5 (Quoted-Strings). + + my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; + $header=~s/$CRLF\s+/ /og; # merge continuation lines + + while ($header=~/($token+):\s+([^$CRLF]*)/mgox) { + my ($field_name,$field_value) = ($1,$2); + $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize + $return{$field_name}=$field_value; + } + return %return; +} + +# This reads and returns the body as a single scalar value. +sub readBody { + my($self) = @_; + my($data); + my($returnval)=''; + + #EBCDIC NOTE: want to translate returnval into EBCDIC HERE + + while (defined($data = $self->read)) { + $returnval .= $data; + } + + if ($CGI::EBCDIC) { + warn "untranslated body=$returnval\n" if $_DEBUG; + $returnval = CGI::Util::ascii2ebcdic($returnval); + warn "translated body=$returnval\n" if $_DEBUG; + } + return $returnval; +} + +# This will read $bytes or until the boundary is hit, whichever happens +# first. After the boundary is hit, we return undef. The next read will +# skip over the boundary and begin reading again; +sub read { + my($self,$bytes) = @_; + + # default number of bytes to read + $bytes = $bytes || $FILLUNIT; + + # Fill up our internal buffer in such a way that the boundary + # is never split between reads. + $self->fillBuffer($bytes); + + my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY}; + my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--'; + + # Find the boundary in the buffer (it may not be there). + my $start = index($self->{BUFFER},$boundary_start); + + warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if $_DEBUG; + + # protect against malformed multipart POST operations + die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0); + + #EBCDIC NOTE: want to translate boundary search into ASCII here. + + # If the boundary begins the data, then skip past it + # and return undef. + if ($start == 0) { + + # clear us out completely if we've hit the last boundary. + if (index($self->{BUFFER},$boundary_end)==0) { + $self->{BUFFER}=''; + $self->{LENGTH}=0; + return undef; + } + + # just remove the boundary. + substr($self->{BUFFER},0,length($boundary_start))=''; + $self->{BUFFER} =~ s/^\012\015?//; + return undef; + } + + my $bytesToReturn; + if ($start > 0) { # read up to the boundary + $bytesToReturn = $start-2 > $bytes ? $bytes : $start; + } else { # read the requested number of bytes + # leave enough bytes in the buffer to allow us to read + # the boundary. Thanks to Kevin Hendrick for finding + # this one. + $bytesToReturn = $bytes - (length($boundary_start)+1); + } + + my $returnval=substr($self->{BUFFER},0,$bytesToReturn); + substr($self->{BUFFER},0,$bytesToReturn)=''; + + # If we hit the boundary, remove the CRLF from the end. + return ($bytesToReturn==$start) + ? substr($returnval,0,-2) : $returnval; +} + +# This fills up our internal buffer in such a way that the +# boundary is never split between reads +sub fillBuffer { + my($self,$bytes) = @_; + return unless $self->{CHUNKED} || $self->{LENGTH}; + + my($boundaryLength) = length($self->{BOUNDARY}); + my($bufferLength) = length($self->{BUFFER}); + my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; + $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead; + + # Try to read some data. We may hang here if the browser is screwed up. + my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER}, + $bytesToRead, + $bufferLength); + warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if $_DEBUG; + $self->{BUFFER} = '' unless defined $self->{BUFFER}; + + # An apparent bug in the Apache server causes the read() + # to return zero bytes repeatedly without blocking if the + # remote user aborts during a file transfer. I don't know how + # they manage this, but the workaround is to abort if we get + # more than SPIN_LOOP_MAX consecutive zero reads. + if ($bytesRead <= 0) { + die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" + if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); + } else { + $self->{ZERO_LOOP_COUNTER}=0; + } + + $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead; +} + +# Return true when we've finished reading +sub eof { + my($self) = @_; + return 1 if (length($self->{BUFFER}) == 0) + && ($self->{LENGTH} <= 0); + undef; +} + +1; + +package CGI; + +# We get a whole bunch of warnings about "possibly uninitialized variables" +# when running with the -w switch. Touch them all once to get rid of the +# warnings. This is ugly and I hate it. +if ($^W) { + $CGI::CGI = ''; + $CGI::CGI=<Build Status +Coverage Status + +=head1 SYNOPSIS + + use strict; + use warnings; + + use CGI; + + my $q = CGI->new; + + # Process an HTTP request + my @values = $q->multi_param('form_field'); + my $value = $q->param('param_name'); + + my $fh = $q->upload('file_field'); + + my $riddle = $query->cookie('riddle_name'); + my %answers = $query->cookie('answers'); + + # Prepare various HTTP responses + print $q->header(); + print $q->header('application/json'); + + my $cookie1 = $q->cookie( + -name => 'riddle_name', + -value => "The Sphynx's Question" + ); + + my $cookie2 = $q->cookie( + -name => 'answers', + -value => \%answers + ); + + print $q->header( + -type => 'image/gif', + -expires => '+3d', + -cookie => [ $cookie1,$cookie2 ] + ); + + print $q->redirect('http://somewhere.else/in/movie/land'); + +=head1 DESCRIPTION + +CGI.pm is a stable, complete and mature solution for processing and preparing +HTTP requests and responses. Major features including processing form +submissions, file uploads, reading and writing cookies, query string generation +and manipulation, and processing and preparing HTTP headers. + +CGI.pm performs very well in a vanilla CGI.pm environment and also comes +with built-in support for mod_perl and mod_perl2 as well as FastCGI. + +It has the benefit of having developed and refined over 20 years with input +from dozens of contributors and being deployed on thousands of websites. +CGI.pm was included in the perl distribution from perl v5.4 to v5.20, however +is has now been removed from the perl core... + +=head1 CGI.pm HAS BEEN REMOVED FROM THE PERL CORE + +L + +If you upgrade to a new version of perl or if you rely on a +system or vendor perl and get an updated version of perl through a system +update, then you will have to install CGI.pm yourself with cpan/cpanm/a vendor +package/manually. To make this a little easier the L module has been +split into its own distribution, meaning you do not need access to a compiler +to install CGI.pm + +The rationale for this decision is that CGI.pm is no longer considered good +practice for developing web applications, B quick prototyping and +small web scripts. There are far better, cleaner, quicker, easier, safer, +more scalable, more extensible, more modern alternatives available at this point +in time. These will be documented with L. + +For more discussion on the removal of CGI.pm from core please see: + +L + +Note that the v4 releases of CGI.pm will retain back compatibility B +B, however you may need to make some minor changes to your code +if you are using deprecated methods or some of the more obscure features of the +module. If you plan to upgrade to v4.00 and beyond you should read the Changes +file for more information and B against CGI.pm before deploying +it. + +=head1 HTML Generation functions should no longer be used + +B HTML generation functions within CGI.pm are no longer being +maintained. Any issues, bugs, or patches will be rejected unless +they relate to fundamentally broken page rendering. + +The rationale for this is that the HTML generation functions of CGI.pm +are an obfuscation at best and a maintenance nightmare at worst. You +should be using a template engine for better separation of concerns. +See L for an example of using CGI.pm with the +L module. + +These functions, and perldoc for them, will continue to exist in the +v4 releases of CGI.pm but may be deprecated (soft) in v5 and beyond. +All documentation for these functions has been moved to L. + +=head1 Programming style + +There are two styles of programming with CGI.pm, an object-oriented (OO) +style and a function-oriented style. You are recommended to use the OO +style as CGI.pm will create an internal default object when the functions +are called procedurally and you will not have to worry about method names +clashing with perl builtins. + +In the object-oriented style you create one or more CGI objects and then +use object methods to create the various elements of the page. Each CGI +object starts out with the list of named parameters that were passed to +your CGI script by the server. You can modify the objects, save them to a +file or database and recreate them. Because each object corresponds to the +"state" of the CGI script, and because each object's parameter list is +independent of the others, this allows you to save the state of the +script and restore it later. + +For example, using the object oriented style: + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI; # load CGI routines + + my $q = CGI->new; # create new CGI object + print $q->header; # create the HTTP header + + ... + +In the function-oriented style, there is one default CGI object that +you rarely deal with directly. Instead you just call functions to +retrieve CGI parameters, manage cookies, and so on. The following example +is identical to above, in terms of output, but uses the function-oriented +interface. The main differences are that we now need to import a set of +functions into our name space (usually the "standard" functions), and we don't +need to create the CGI object. + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI qw/:standard/; # load standard CGI routines + print header(); # create the HTTP header + + ... + +The examples in this document mainly use the object-oriented style. See HOW +TO IMPORT FUNCTIONS for important information on function-oriented programming +in CGI.pm + +=head2 Calling CGI.pm routines + +Most CGI.pm routines accept several arguments, sometimes as many as 20 +optional ones! To simplify this interface, all routines use a named +argument calling style that looks like this: + + print $q->header( + -type => 'image/gif', + -expires => '+3d', + ); + +Each argument name is preceded by a dash. Neither case nor order matters in +the argument list: -type, -Type, and -TYPE are all acceptable. In fact, only +the first argument needs to begin with a dash. If a dash is present in the +first argument CGI.pm assumes dashes for the subsequent ones. + +Several routines are commonly called with just one argument. In the case +of these routines you can provide the single argument without an argument +name. header() happens to be one of these routines. In this case, the single +argument is the document type. + + print $q->header('text/html'); + +Other such routines are documented below. + +Sometimes named arguments expect a scalar, sometimes a reference to an array, +and sometimes a reference to a hash. Often, you can pass any type of argument +and the routine will do whatever is most appropriate. For example, the param() +routine is used to set a CGI parameter to a single or a multi-valued value. +The two cases are shown below: + + $q->param( + -name => 'veggie', + -value => 'tomato', + ); + + $q->param( + -name => 'veggie', + -value => [ qw/tomato tomahto potato potahto/ ], + ); + + +Many routines will do something useful with a named argument that it doesn't +recognize. For example, you can produce non-standard HTTP header fields by +providing them as named arguments: + + print $q->header( + -type => 'text/html', + -cost => 'Three smackers', + -annoyance_level => 'high', + -complaints_to => 'bit bucket', + ); + +This will produce the following nonstandard HTTP header: + + HTTP/1.0 200 OK + Cost: Three smackers + Annoyance-level: high + Complaints-to: bit bucket + Content-type: text/html + +Notice the way that underscores are translated automatically into hyphens. + +=head2 Creating a new query object (object-oriented style) + + my $query = CGI->new; + +This will parse the input (from POST, GET and DELETE methods) and store +it into a perl5 object called $query. Note that because the input parsing +happens at object instantiation you have to set any CGI package variables +that control parsing B you call CGI->new. + +Any filehandles from file uploads will have their position reset to the +beginning of the file. + +=head2 Creating a new query object from an input file + + my $query = CGI->new( $input_filehandle ); + +If you provide a file handle to the new() method, it will read parameters +from the file (or STDIN, or whatever). The file can be in any of the forms +describing below under debugging (i.e. a series of newline delimited +TAG=VALUE pairs will work). Conveniently, this type of file is created by +the save() method (see below). Multiple records can be saved and restored. + +Perl purists will be pleased to know that this syntax accepts references to +file handles, or even references to filehandle globs, which is the "official" +way to pass a filehandle. You can also initialize the CGI object with a +FileHandle or IO::File object. + +If you are using the function-oriented interface and want to initialize CGI +state from a file handle, the way to do this is with B. +This will (re)initialize the default CGI object from the indicated file handle. + + open( my $in_fh,'<',"test.in") || die "Couldn't open test.in for read: $!"; + restore_parameters( $in_fh ); + close( $in_fh ); + +You can also initialize the query object from a hash reference: + + my $query = CGI->new( { + 'dinosaur' => 'barney', + 'song' => 'I love you', + 'friends' => [ qw/ Jessica George Nancy / ] + } ); + +or from a properly formatted, URL-escaped query string: + + my $query = CGI->new('dinosaur=barney&color=purple'); + +or from a previously existing CGI object (currently this clones the parameter +list, but none of the other object-specific fields, such as autoescaping): + + my $old_query = CGI->new; + my $new_query = CGI->new($old_query); + +To create an empty query, initialize it from an empty string or hash: + + my $empty_query = CGI->new(""); + + -or- + + my $empty_query = CGI->new({}); + +=head2 Fetching a list of keywords from the query + + my @keywords = $query->keywords + +If the script was invoked as the result of an ISINDEX search, the parsed +keywords can be obtained as an array using the keywords() method. + +=head2 Fetching the names of all the parameters passed to your script + + my @names = $query->multi_param + + my @names = $query->param + +If the script was invoked with a parameter list +(e.g. "name1=value1&name2=value2&name3=value3"), the param() / multi_param() +methods will return the parameter names as a list. If the script was invoked +as an ISINDEX script and contains a string without ampersands +(e.g. "value1+value2+value3"), there will be a single parameter named +"keywords" containing the "+"-delimited keywords. + +The array of parameter names returned will be in the same order as they were +submitted by the browser. Usually this order is the same as the order in which +the parameters are defined in the form (however, this isn't part of the spec, +and so isn't guaranteed). + +=head2 Fetching the value or values of a single named parameter + + my @values = $query->multi_param('foo'); + + -or- + + my $value = $query->param('foo'); + +Pass the param() / multi_param() method a single argument to fetch the value +of the named parameter. If the parameter is multivalued (e.g. from multiple +selections in a scrolling list), you can ask to receive an array. Otherwise +the method will return a single value. + +B - calling param() in list context can lead to vulnerabilities if +you do not sanitise user input as it is possible to inject other param +keys and values into your code. This is why the multi_param() method exists, +to make it clear that a list is being returned, note that param() can still +be called in list context and will return a list for back compatibility. + +The following code is an example of a vulnerability as the call to param will +be evaluated in list context and thus possibly inject extra keys and values +into the hash: + + my %user_info = ( + id => 1, + name => $query->param('name'), + ); + +The fix for the above is to force scalar context on the call to ->param by +prefixing it with "scalar" + + name => scalar $query->param('name'), + +If you call param() in list context with an argument a warning will be raised +by CGI.pm, you can disable this warning by setting $CGI::LIST_CONTEXT_WARN to 0 +or by using the multi_param() method instead + +If a value is not given in the query string, as in the queries "name1=&name2=", +it will be returned as an empty string. + +If the parameter does not exist at all, then param() will return undef in scalar +context, and the empty list in a list context. + +=head2 Setting the value(s) of a named parameter + + $query->param('foo','an','array','of','values'); + +This sets the value for the named parameter 'foo' to an array of values. This +is one way to change the value of a field AFTER the script has been invoked +once before. + +param() also recognizes a named parameter style of calling described in more +detail later: + + $query->param( + -name => 'foo', + -values => ['an','array','of','values'], + ); + + -or- + + $query->param( + -name => 'foo', + -value => 'the value', + ); + +=head2 Appending additional values to a named parameter + + $query->append( + -name =>'foo', + -values =>['yet','more','values'], + ); + +This adds a value or list of values to the named parameter. The values are +appended to the end of the parameter if it already exists. Otherwise the +parameter is created. Note that this method only recognizes the named argument +calling syntax. + +=head2 Importing all parameters into a namespace + + $query->import_names('R'); + +This creates a series of variables in the 'R' namespace. For example, $R::foo, +@R:foo. For keyword lists, a variable @R::keywords will appear. If no namespace +is given, this method will assume 'Q'. B: don't import anything into +'main'; this is a major security risk! + +NOTE 1: Variable names are transformed as necessary into legal perl variable +names. All non-legal characters are transformed into underscores. If you need +to keep the original names, you should use the param() method instead to access +CGI variables by name. + +In fact, you should probably not use this method at all given the above caveats +and security risks. + +=head2 Deleting a parameter completely + + $query->delete('foo','bar','baz'); + +This completely clears a list of parameters. It sometimes useful for resetting +parameters that you don't want passed down between script invocations. + +If you are using the function call interface, use "Delete()" instead to avoid +conflicts with perl's built-in delete operator. + +=head2 Deleting all parameters + + $query->delete_all(); + +This clears the CGI object completely. It might be useful to ensure that all +the defaults are taken when you create a fill-out form. + +Use Delete_all() instead if you are using the function call interface. + +=head2 Handling non-urlencoded arguments + +If POSTed data is not of type application/x-www-form-urlencoded or +multipart/form-data, then the POSTed data will not be processed, but instead +be returned as-is in a parameter named POSTDATA. To retrieve it, use code like +this: + + my $data = $query->param('POSTDATA'); + +Likewise if PUTed data can be retrieved with code like this: + + my $data = $query->param('PUTDATA'); + +(If you don't know what the preceding means, worry not. It only affects people +trying to use CGI for XML processing and other specialized tasks) + +PUTDATA/POSTDATA are also available via +L, +and as L via L +option. + +=head2 Direct access to the parameter list + + $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; + unshift @{$q->param_fetch(-name=>'address')},'George Munster'; + +If you need access to the parameter list in a way that isn't covered by the +methods given in the previous sections, you can obtain a direct reference to +it by calling the B method with the name of the parameter. This +will return an array reference to the named parameter, which you then can +manipulate in any way you like. + +You can also use a named argument style using the B<-name> argument. + +=head2 Fetching the parameter list as a hash + + my $params = $q->Vars; + print $params->{'address'}; + my @foo = split("\0",$params->{'foo'}); + my %params = $q->Vars; + + use CGI ':cgi-lib'; + my $params = Vars(); + +Many people want to fetch the entire parameter list as a hash in which the keys +are the names of the CGI parameters, and the values are the parameters' values. +The Vars() method does this. Called in a scalar context, it returns the +parameter list as a tied hash reference. Changing a key changes the value of +the parameter in the underlying CGI parameter list. Called in a list context, +it returns the parameter list as an ordinary hash. This allows you to read the +contents of the parameter list, but not to change it. + +When using this, the thing you must watch out for are multivalued CGI +parameters. Because a hash cannot distinguish between scalar and list context, +multivalued parameters will be returned as a packed string, separated by the +"\0" (null) character. You must split this packed string in order to get at the +individual values. This is the convention introduced long ago by Steve Brenner +in his cgi-lib.pl module for perl version 4, and may be replaced in future +versions with array references. + +If you wish to use Vars() as a function, import the I<:cgi-lib> set of function +calls (also see the section on CGI-LIB compatibility). + +=head2 Saving the state of the script to a file + + $query->save(\*FILEHANDLE) + +This will write the current state of the form to the provided filehandle. You +can read it back in by providing a filehandle to the new() method. Note that +the filehandle can be a file, a pipe, or whatever. + +The format of the saved file is: + + NAME1=VALUE1 + NAME1=VALUE1' + NAME2=VALUE2 + NAME3=VALUE3 + = + +Both name and value are URL escaped. Multi-valued CGI parameters are represented +as repeated names. A session record is delimited by a single = symbol. You can +write out multiple records and read them back in with several calls to B. +You can do this across several sessions by opening the file in append mode, +allowing you to create primitive guest books, or to keep a history of users' +queries. Here's a short example of creating multiple session records: + + use strict; + use warnings; + use CGI; + + open (my $out_fh,'>>','test.out') || die "Can't open test.out: $!"; + my $records = 5; + for ( 0 .. $records ) { + my $q = CGI->new; + $q->param( -name => 'counter',-value => $_ ); + $q->save( $out_fh ); + } + close( $out_fh ); + + # reopen for reading + open (my $in_fh,'<','test.out') || die "Can't open test.out: $!"; + while (!eof($in_fh)) { + my $q = CGI->new($in_fh); + print $q->param('counter'),"\n"; + } + +The file format used for save/restore is identical to that used by the Whitehead +Genome Center's data exchange format "Boulderio", and can be manipulated and +even databased using Boulderio utilities. See L for further details. + +If you wish to use this method from the function-oriented (non-OO) interface, +the exported name for this method is B. + +=head2 Retrieving cgi errors + +Errors can occur while processing user input, particularly when processing +uploaded files. When these errors occur, CGI will stop processing and return +an empty parameter list. You can test for the existence and nature of errors +using the I function. The error messages are formatted as HTTP +status codes. You can either incorporate the error text into a page, or use +it as the value of the HTTP status: + + if ( my $error = $q->cgi_error ) { + print $q->header( -status => $error ); + print "Error: $error"; + exit 0; + } + +When using the function-oriented interface (see the next section), errors may +only occur the first time you call I. Be ready for this! + +=head2 Using the function-oriented interface + +To use the function-oriented interface, you must specify which CGI.pm +routines or sets of routines to import into your script's namespace. +There is a small overhead associated with this importation, but it +isn't much. + + use strict; + use warnings; + + use CGI qw/ list of methods /; + +The listed methods will be imported into the current package; you can +call them directly without creating a CGI object first. This example +shows how to import the B and B +methods, and then use them directly: + + use strict; + use warnings; + + use CGI qw/ param header /; + print header('text/plain'); + my $zipcode = param('zipcode'); + +More frequently, you'll import common sets of functions by referring +to the groups by name. All function sets are preceded with a ":" +character as in ":cgi" (for CGI protocol handling methods). + +Here is a list of the function sets you can import: + +=over 4 + +=item B<:cgi> + +Import all CGI-handling methods, such as B, B +and the like. + +=item B<:all> + +Import all the available methods. For the full list, see the CGI.pm +code, where the variable %EXPORT_TAGS is defined. (N.B. the :cgi-lib +imports will B be included in the :all import, you will have to +import :cgi-lib to get those) + +=back + +Note that in the interests of execution speed CGI.pm does B use +the standard L syntax for specifying load symbols. This may +change in the future. + +=head2 Pragmas + +In addition to the function sets, there are a number of pragmas that you can +import. Pragmas, which are always preceded by a hyphen, change the way that +CGI.pm functions in various ways. Pragmas, function sets, and individual +functions can all be imported in the same use() line. For example, the +following use statement imports the cgi set of functions and enables +debugging mode (pragma -debug): + + use strict; + use warninigs; + use CGI qw/ :cgi -debug /; + +The current list of pragmas is as follows: + +=over 4 + +=item -no_undef_params + +This keeps CGI.pm from including undef params in the parameter list. + +=item -utf8 + +This makes CGI.pm treat all parameters as text strings rather than binary +strings (see L for the distinction), assuming UTF-8 for the +encoding. + +CGI.pm does the decoding from the UTF-8 encoded input data, restricting this +decoding to input text as distinct from binary upload data which are left +untouched. Therefore, a ':utf8' layer must B be used on STDIN. + +If you do not use this option you can manually select which fields are +expected to return utf-8 strings and convert them using code like this: + + use strict; + use warnings; + + use CGI; + use Encode qw/ decode /; + + my $cgi = CGI->new; + my $param = $cgi->param('foo'); + $param = decode( 'UTF-8',$param ); + +=item -putdata_upload + +Makes C<<< $cgi->param('PUTDATA'); >>> and C<<< $cgi->param('POSTDATA'); >>> +act like file uploads named PUTDATA and POSTDATA. See +L and L +PUTDATA/POSTDATA are also available via +L. + +=item -nph + +This makes CGI.pm produce a header appropriate for an NPH (no parsed header) +script. You may need to do other things as well to tell the server that the +script is NPH. See the discussion of NPH scripts below. + +=item -newstyle_urls + +Separate the name=value pairs in CGI parameter query strings with semicolons +rather than ampersands. For example: + + ?name=fred;age=24;favorite_color=3 + +Semicolon-delimited query strings are always accepted, and will be emitted by +self_url() and query_string(). newstyle_urls became the default in version +2.64. + +=item -oldstyle_urls + +Separate the name=value pairs in CGI parameter query strings with ampersands +rather than semicolons. This is no longer the default. + +=item -no_debug + +This turns off the command-line processing features. If you want to run a CGI.pm +script from the command line, and you don't want it to read CGI parameters from +the command line or STDIN, then use this pragma: + + use CGI qw/ -no_debug :standard /; + +=item -debug + +This turns on full debugging. In addition to reading CGI arguments from the +command-line processing, CGI.pm will pause and try to read arguments from STDIN, +producing the message "(offline mode: enter name=value pairs on standard input)" +features. + +See the section on debugging for more details. + +=back + +=head1 GENERATING DYNAMIC DOCUMENTS + +Most of CGI.pm's functions deal with creating documents on the fly. Generally +you will produce the HTTP header first, followed by the document itself. CGI.pm +provides functions for generating HTTP headers of various types. + +Each of these functions produces a fragment of HTTP which you can print out +directly so that it is processed by the browser, appended to a string, or saved +to a file for later use. + +=head2 Creating a standard http header + +Normally the first thing you will do in any CGI script is print out an HTTP +header. This tells the browser what type of document to expect, and gives other +optional information, such as the language, expiration date, and whether to +cache the document. The header can also be manipulated for special purposes, +such as server push and pay per view pages. + + use strict; + use warnings; + + use CGI; + + my $cgi = CGI->new; + + print $cgi->header; + + -or- + + print $cgi->header('image/gif'); + + -or- + + print $cgi->header('text/html','204 No response'); + + -or- + + print $cgi->header( + -type => 'image/gif', + -nph => 1, + -status => '402 Payment required', + -expires => '+3d', + -cookie => $cookie, + -charset => 'utf-8', + -attachment => 'foo.gif', + -Cost => '$2.00' + ); + +header() returns the Content-type: header. You can provide your own MIME type +if you choose, otherwise it defaults to text/html. An optional second parameter +specifies the status code and a human-readable message. For example, you can +specify 204, "No response" to create a script that tells the browser to do +nothing at all. Note that RFC 2616 expects the human-readable phase to be there +as well as the numeric status code. + +The last example shows the named argument style for passing arguments to the CGI +methods using named parameters. Recognized parameters are B<-type>, B<-status>, +B<-expires>, and B<-cookie>. Any other named parameters will be stripped of +their initial hyphens and turned into header fields, allowing you to specify +any HTTP header you desire. Internal underscores will be turned into hyphens: + + print $cgi->header( -Content_length => 3002 ); + +Most browsers will not cache the output from CGI scripts. Every time the browser +reloads the page, the script is invoked anew. You can change this behavior with +the B<-expires> parameter. When you specify an absolute or relative expiration +interval with this parameter, some browsers and proxy servers will cache the +script's output until the indicated expiration date. The following forms are all +valid for the -expires field: + + +30s 30 seconds from now + +10m ten minutes from now + +1h one hour from now + -1d yesterday (i.e. "ASAP!") + now immediately + +3M in three months + +10y in ten years time + Thursday, 25-Apr-2018 00:40:33 GMT at the indicated time & date + +The B<-cookie> parameter generates a header that tells the browser to provide +a "magic cookie" during all subsequent transactions with your script. Some +cookies have a special format that includes interesting attributes such as +expiration time. Use the cookie() method to create and retrieve session cookies. + +The B<-nph> parameter, if set to a true value, will issue the correct headers +to work with a NPH (no-parse-header) script. This is important to use with +certain servers that expect all their scripts to be NPH. + +The B<-charset> parameter can be used to control the character set sent to the +browser. If not provided, defaults to ISO-8859-1. As a side effect, this sets +the charset() method as well. B that the default being ISO-8859-1 may not +make sense for all content types, e.g.: + + Content-Type: image/gif; charset=ISO-8859-1 + +In the above case you need to pass -charset => '' to prevent the default being +used. + +The B<-attachment> parameter can be used to turn the page into an attachment. +Instead of displaying the page, some browsers will prompt the user to save it +to disk. The value of the argument is the suggested name for the saved file. In +order for this to work, you may have to set the B<-type> to +"application/octet-stream". + +The B<-p3p> parameter will add a P3P tag to the outgoing header. The parameter +can be an arrayref or a space-delimited string of P3P tags. For example: + + print $cgi->header( -p3p => [ qw/ CAO DSP LAW CURa / ] ); + print $cgi->header( -p3p => 'CAO DSP LAW CURa' ); + +In either case, the outgoing header will be formatted as: + + P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa" + +CGI.pm will accept valid multi-line headers when each line is separated with a +CRLF value ("\r\n" on most platforms) followed by at least one space. For +example: + + print $cgi->header( -ingredients => "ham\r\n\seggs\r\n\sbacon" ); + +Invalid multi-line header input will trigger in an exception. When multi-line +headers are received, CGI.pm will always output them back as a single line, +according to the folding rules of RFC 2616: the newlines will be removed, while +the white space remains. + +=head2 Generating a redirection header + + print $q->redirect( 'http://somewhere.else/in/movie/land' ); + +Sometimes you don't want to produce a document yourself, but simply redirect +the browser elsewhere, perhaps choosing a URL based on the time of day or the +identity of the user. + +The redirect() method redirects the browser to a different URL. If you use +redirection like this, you should B print out a header as well. + +You should always use full URLs (including the http: or ftp: part) in +redirection requests. Relative URLs will not work correctly. + +You can also use named arguments: + + print $q->redirect( + -uri => 'http://somewhere.else/in/movie/land', + -nph => 1, + -status => '301 Moved Permanently' + ); + +All names arguments recognized by header() are also recognized by redirect(). +However, most HTTP headers, including those generated by -cookie and -target, +are ignored by the browser. + +The B<-nph> parameter, if set to a true value, will issue the correct headers +to work with a NPH (no-parse-header) script. This is important to use with +certain servers, such as Microsoft IIS, which expect all their scripts to be +NPH. + +The B<-status> parameter will set the status of the redirect. HTTP defines +several different possible redirection status codes, and the default if not +specified is 302, which means "moved temporarily." You may change the status +to another status code if you wish. + +Note that the human-readable phrase is also expected to be present to conform +with RFC 2616, section 6.1. + +=head2 Creating a self-referencing url that preserves state information + + my $myself = $q->self_url; + print qq(I'm talking to myself.); + +self_url() will return a URL, that, when selected, will re-invoke this script +with all its state information intact. This is most useful when you want to +jump around within the document using internal anchors but you don't want to +disrupt the current contents of the form(s). Something like this will do the +trick: + + my $myself = $q->self_url; + print "See table 1"; + print "See table 2"; + print "See for yourself"; + +If you want more control over what's returned, using the B method +instead. + +You can also retrieve a query string representation of the current object +state with query_string(): + + my $the_string = $q->query_string(); + +The behavior of calling query_string is currently undefined when the HTTP method +is something other than GET. + +If you want to retrieved the query string as set in the webserver, namely the +environment variable, you can call env_query_string() + +=head2 Obtaining the script's url + + my $full_url = url(); + my $full_url = url( -full =>1 ); # alternative syntax + my $relative_url = url( -relative => 1 ); + my $absolute_url = url( -absolute =>1 ); + my $url_with_path = url( -path_info => 1 ); + my $url_path_qry = url( -path_info => 1, -query =>1 ); + my $netloc = url( -base => 1 ); + +B returns the script's URL in a variety of formats. Called without any +arguments, it returns the full form of the URL, including host name and port +number + + http://your.host.com/path/to/script.cgi + +You can modify this format with the following named arguments: + +=over 4 + +=item B<-absolute> + +If true, produce an absolute URL, e.g. + + /path/to/script.cgi + +=item B<-relative> + +Produce a relative URL. This is useful if you want to re-invoke your +script with different parameters. For example: + + script.cgi + +=item B<-full> + +Produce the full URL, exactly as if called without any arguments. This overrides +the -relative and -absolute arguments. + +=item B<-path> (B<-path_info>) + +Append the additional path information to the URL. This can be combined with +B<-full>, B<-absolute> or B<-relative>. B<-path_info> is provided as a synonym. + +=item B<-query> (B<-query_string>) + +Append the query string to the URL. This can be combined with B<-full>, +B<-absolute> or B<-relative>. B<-query_string> is provided as a synonym. + +=item B<-base> + +Generate just the protocol and net location, as in http://www.foo.com:8000 + +=item B<-rewrite> + +If Apache's mod_rewrite is turned on, then the script name and path info +probably won't match the request that the user sent. Set -rewrite => 1 (default) +to return URLs that match what the user sent (the original request URI). Set +-rewrite => 0 to return URLs that match the URL after the mod_rewrite rules have +run. + +=back + +=head2 Mixing post and url parameters + + my $color = url_param('color'); + +It is possible for a script to receive CGI parameters in the URL as well as in +the fill-out form by creating a form that POSTs to a URL containing a query +string (a "?" mark followed by arguments). The B method will always +return the contents of the POSTed fill-out form, ignoring the URL's query +string. To retrieve URL parameters, call the B method. Use it in +the same way as B. The main difference is that it allows you to read +the parameters, but not set them. + +Under no circumstances will the contents of the URL query string interfere with +similarly-named CGI parameters in POSTed forms. If you try to mix a URL query +string with a form submitted with the GET method, the results will not be what +you expect. + +=head2 Processing a file upload field + +=head3 Basics + +When the form is processed, you can retrieve an L compatible handle +for a file upload field like this: + + use autodie; + + # undef may be returned if it's not a valid file handle + if ( my $io_handle = $q->upload('field_name') ) { + open ( my $out_file,'>>','/usr/local/web/users/feedback' ); + while ( my $bytesread = $io_handle->read($buffer,1024) ) { + print $out_file $buffer; + } + } + +In a list context, upload() will return an array of filehandles. This makes it +possible to process forms that use the same name for multiple upload fields. + +If you want the entered file name for the file, you can just call param(): + + my $filename = $q->param('field_name'); + +Different browsers will return slightly different things for the name. Some +browsers return the filename only. Others return the full path to the file, +using the path conventions of the user's machine. Regardless, the name returned +is always the name of the file on the I machine, and is unrelated to +the name of the temporary file that CGI.pm creates during upload spooling +(see below). + +When a file is uploaded the browser usually sends along some information along +with it in the format of headers. The information usually includes the MIME +content type. To retrieve this information, call uploadInfo(). It returns a +reference to a hash containing all the document headers. + + my $filehandle = $q->upload( 'uploaded_file' ); + my $type = $q->uploadInfo( $filehandle )->{'Content-Type'}; + if ( $type ne 'text/html' ) { + die "HTML FILES ONLY!"; + } + +Note that you must use ->upload or ->param to get the file-handle to pass into +uploadInfo as internally this is represented as a File::Temp object (which is +what will be returned by ->upload or ->param). When using ->Vars you will get +the literal filename rather than the File::Temp object, which will not return +anything when passed to uploadInfo. So don't use ->Vars. + +If you are using a machine that recognizes "text" and "binary" data modes, be +sure to understand when and how to use them (see the Camel book). Otherwise +you may find that binary files are corrupted during file uploads. + +=head3 Accessing the temp files directly + +When processing an uploaded file, CGI.pm creates a temporary file on your hard +disk and passes you a file handle to that file. After you are finished with the +file handle, CGI.pm unlinks (deletes) the temporary file. If you need to you +can access the temporary file directly. You can access the temp file for a file +upload by passing the file name to the tmpFileName() method: + + my $filehandle = $query->upload( 'uploaded_file' ); + my $tmpfilename = $query->tmpFileName( $filehandle ); + +As with ->uploadInfo, using the reference returned by ->upload or ->param is +preferred, although unlike ->uploadInfo, plain filenames also work if possible +for backwards compatibility. + +The temporary file will be deleted automatically when your program exits unless +you manually rename it or set $CGI::UNLINK_TMP_FILES to 0. On some operating +systems (such as Windows NT), you will need to close the temporary file's +filehandle before your program exits. Otherwise the attempt to delete the +temporary file will fail. + +=head3 Changes in temporary file handling (v4.05+) + +CGI.pm had its temporary file handling significantly refactored, this logic is +now all deferred to File::Temp (which is wrapped in a compatibility object, +CGI::File::Temp - B). As a consequence the +PRIVATE_TEMPFILES variable has been removed along with deprecation of the +private_tempfiles routine and B removal of the CGITempFile package. +The $CGITempFile::TMPDIRECTORY is no longer used to set the temp directory, +refer to the perldoc for File::Temp if you want to override the default +settings in that package (the TMPDIR env variable is still available on some +platforms). For Windows platforms the temporary directory order remains +as before: TEMP > TMP > WINDIR ( > TMPDIR ) so if you have any of these in +use in existing scripts they should still work. + +The Fh package still exists but does nothing, the CGI::File::Temp class is +a subclass of both File::Temp and the empty Fh package, so if you have any +code that checks that the filehandle isa Fh this should still work. + +When you get the internal file handle you will receive a File::Temp object, +this should be transparent as File::Temp isa IO::Handle and isa IO::Seekable +meaning it behaves as previously. If you are doing anything out of the ordinary +with regards to temp files you should test your code before deploying this +update and refer to the File::Temp documentation for more information. + +=head3 Handling interrupted file uploads + +There are occasionally problems involving parsing the uploaded file. This +usually happens when the user presses "Stop" before the upload is finished. In +this case, CGI.pm will return undef for the name of the uploaded file and set +I to the string "400 Bad request (malformed multipart POST)". This +error message is designed so that you can incorporate it into a status code to +be sent to the browser. Example: + + my $file = $q->upload( 'uploaded_file' ); + if ( !$file && $q->cgi_error ) { + print $q->header( -status => $q->cgi_error ); + exit 0; + } + +=head3 Progress bars for file uploads and avoiding temp files + +CGI.pm gives you low-level access to file upload management through a file +upload hook. You can use this feature to completely turn off the temp file +storage of file uploads, or potentially write your own file upload progress +meter. + +This is much like the UPLOAD_HOOK facility available in L, +with the exception that the first argument to the callback is an +L object, here it's the remote filename. + + my $q = CGI->new( \&hook [,$data [,$use_tempfile]] ); + + sub hook { + my ( $filename, $buffer, $bytes_read, $data ) = @_; + print "Read $bytes_read bytes of $filename\n"; + } + +The C<< $data >> field is optional; it lets you pass configuration information +(e.g. a database handle) to your hook callback. + +The C<< $use_tempfile >> field is a flag that lets you turn on and off CGI.pm's +use of a temporary disk-based file during file upload. If you set this to a +FALSE value (default true) then $q->param('uploaded_file') will no longer work, +and the only way to get at the uploaded data is via the hook you provide. + +If using the function-oriented interface, call the CGI::upload_hook() method +before calling param() or any other CGI functions: + + CGI::upload_hook( \&hook [,$data [,$use_tempfile]] ); + +This method is not exported by default. You will have to import it explicitly +if you wish to use it without the CGI:: prefix. + +=head3 Troubleshooting file uploads on Windows + +If you are using CGI.pm on a Windows platform and find that binary files get +slightly larger when uploaded but that text files remain the same, then you +have forgotten to activate binary mode on the output filehandle. Be sure to call +binmode() on any handle that you create to write the uploaded file to disk. + +=head3 Older ways to process file uploads + +This section is here for completeness. if you are building a new application +with CGI.pm, you can skip it. + +The original way to process file uploads with CGI.pm was to use param(). The +value it returns has a dual nature as both a file name and a lightweight +filehandle. This dual nature is problematic if you following the recommended +practice of having C in your code. perl will complain when you try +to use a string as a filehandle. More seriously, it is possible for the remote +user to type garbage into the upload field, in which case what you get from +param() is not a filehandle at all, but a string. + +To solve this problem the upload() method was added, which always returns a +lightweight filehandle. This generally works well, but will have trouble +interoperating with some other modules because the file handle is not derived +from L. So that brings us to current recommendation given above, +which is to call the handle() method on the file handle returned by upload(). +That upgrades the handle to an IO::File. It's a big win for compatibility for +a small penalty of loading IO::File the first time you call it. + +=head1 HTTP COOKIES + +CGI.pm has several methods that support cookies. + +A cookie is a name=value pair much like the named parameters in a CGI query +string. CGI scripts create one or more cookies and send them to the browser +in the HTTP header. The browser maintains a list of cookies that belong to a +particular Web server, and returns them to the CGI script during subsequent +interactions. + +In addition to the required name=value pair, each cookie has several optional +attributes: + +=over 4 + +=item 1. an expiration time + +This is a time/date string (in a special GMT format) that indicates when a +cookie expires. The cookie will be saved and returned to your script until this +expiration date is reached if the user exits the browser and restarts it. If an +expiration date isn't specified, the cookie will remain active until the user +quits the browser. + +=item 2. a domain + +This is a partial or complete domain name for which the cookie is valid. The +browser will return the cookie to any host that matches the partial domain name. +For example, if you specify a domain name of ".capricorn.com", then the browser +will return the cookie to Web servers running on any of the machines +"www.capricorn.com", "www2.capricorn.com", "feckless.capricorn.com", etc. Domain +names must contain at least two periods to prevent attempts to match on top +level domains like ".edu". If no domain is specified, then the browser will +only return the cookie to servers on the host the cookie originated from. + +=item 3. a path + +If you provide a cookie path attribute, the browser will check it against your +script's URL before returning the cookie. For example, if you specify the path +"/cgi-bin", then the cookie will be returned to each of the scripts +"/cgi-bin/tally.pl", "/cgi-bin/order.pl", and +"/cgi-bin/customer_service/complain.pl", but not to the script +"/cgi-private/site_admin.pl". By default, path is set to "/", which causes the +cookie to be sent to any CGI script on your site. + +=item 4. a "secure" flag + +If the "secure" attribute is set, the cookie will only be sent to your script +if the CGI request is occurring on a secure channel, such as SSL. + +=back + +The interface to HTTP cookies is the B method: + + my $cookie = $q->cookie( + -name => 'sessionID', + -value => 'xyzzy', + -expires => '+1h', + -path => '/cgi-bin/database', + -domain => '.capricorn.org', + -secure => 1 + ); + + print $q->header( -cookie => $cookie ); + +B creates a new cookie. Its parameters include: + +=over 4 + +=item B<-name> + +The name of the cookie (required). This can be any string at all. Although +browsers limit their cookie names to non-whitespace alphanumeric characters, +CGI.pm removes this restriction by escaping and unescaping cookies behind the +scenes. + +=item B<-value> + +The value of the cookie. This can be any scalar value, array reference, or even +hash reference. For example, you can store an entire hash into a cookie this +way: + + my $cookie = $q->cookie( + -name => 'family information', + -value => \%childrens_ages + ); + +=item B<-path> + +The optional partial path for which this cookie will be valid, as described +above. + +=item B<-domain> + +The optional partial domain for which this cookie will be valid, as described +above. + +=item B<-expires> + +The optional expiration date for this cookie. The format is as described in the +section on the B method: + + "+1h" one hour from now + +=item B<-secure> + +If set to true, this cookie will only be used within a secure SSL session. + +=back + +The cookie created by cookie() must be incorporated into the HTTP header within +the string returned by the header() method: + + use strict; + use warnings; + + use CGI; + + my $q = CGI->new; + my $cookie = ... + print $q->header( -cookie => $cookie ); + +To create multiple cookies, give header() an array reference: + + my $cookie1 = $q->cookie( + -name => 'riddle_name', + -value => "The Sphynx's Question" + ); + + my $cookie2 = $q->cookie( + -name => 'answers', + -value => \%answers + ); + + print $q->header( -cookie => [ $cookie1,$cookie2 ] ); + +To retrieve a cookie, request it by name by calling cookie() method without the +B<-value> parameter. This example uses the object-oriented form: + + my $riddle = $q->cookie('riddle_name'); + my %answers = $query->cookie('answers'); + +Cookies created with a single scalar value, such as the "riddle_name" cookie, +will be returned in that form. Cookies with array and hash values can also be +retrieved. + +The cookie and CGI namespaces are separate. If you have a parameter named +'answers' and a cookie named 'answers', the values retrieved by param() and +cookie() are independent of each other. However, it's simple to turn a CGI +parameter into a cookie, and vice-versa: + + # turn a CGI parameter into a cookie + my $c = cookie( -name => 'answers',-value => [$q->param('answers')] ); + # vice-versa + $q->param( -name => 'answers',-value => [ $q->cookie('answers')] ); + +If you call cookie() without any parameters, it will return a list of +the names of all cookies passed to your script: + + my @cookies = $q->cookie(); + +See the B example script for some ideas on how to use cookies +effectively. + +=head1 DEBUGGING + +If you are running the script from the command line or in the perl debugger, +you can pass the script a list of keywords or parameter=value pairs on the +command line or from standard input (you don't have to worry about tricking +your script into reading from environment variables). You can pass keywords +like this: + + your_script.pl keyword1 keyword2 keyword3 + +or this: + + your_script.pl keyword1+keyword2+keyword3 + +or this: + + your_script.pl name1=value1 name2=value2 + +or this: + + your_script.pl name1=value1&name2=value2 + +To turn off this feature, use the -no_debug pragma. + +To test the POST method, you may enable full debugging with the -debug pragma. +This will allow you to feed newline-delimited name=value pairs to the script on +standard input. + +When debugging, you can use quotes and backslashes to escape characters in the +familiar shell manner, letting you place spaces and other funny characters in +your parameter=value pairs: + + your_script.pl "name1='I am a long value'" "name2=two\ words" + +Finally, you can set the path info for the script by prefixing the first +name/value parameter with the path followed by a question mark (?): + + your_script.pl /your/path/here?name1=value1&name2=value2 + +=head1 FETCHING ENVIRONMENT VARIABLES + +Some of the more useful environment variables can be fetched through this +interface. The methods are as follows: + +=over 4 + +=item B + +Return a list of MIME types that the remote browser accepts. If you give this +method a single argument corresponding to a MIME type, as in +Accept('text/html'), it will return a floating point value corresponding to the +browser's preference for this type from 0.0 (don't want) to 1.0. Glob types +(e.g. text/*) in the browser's accept list are handled correctly. + +Note that the capitalization changed between version 2.43 and 2.44 in order to +avoid conflict with perl's accept() function. + +=item B + +Returns the HTTP_COOKIE variable. Cookies have a special format, and this +method call just returns the raw form (?cookie dough). See cookie() for ways +of setting and retrieving cooked cookies. + +Called with no parameters, raw_cookie() returns the packed cookie structure. +You can separate it into individual cookies by splitting on the character +sequence "; ". Called with the name of a cookie, retrieves the B +form of the cookie. You can use the regular cookie() method to get the names, +or use the raw_fetch() method from the CGI::Cookie module. + +=item B + +Returns the QUERY_STRING variable, note that this is the original value as set +in the environment by the webserver and (possibly) not the same value as +returned by query_string(), which represents the object state + +=item B + +Returns the HTTP_USER_AGENT variable. If you give this method a single +argument, it will attempt to pattern match on it, allowing you to do something +like user_agent(Mozilla); + +=item B + +Returns additional path information from the script URL. E.G. fetching +/cgi-bin/your_script/additional/stuff will result in path_info() returning +"/additional/stuff". + +NOTE: The Microsoft Internet Information Server is broken with respect to +additional path information. If you use the perl DLL library, the IIS server +will attempt to execute the additional path information as a perl script. If +you use the ordinary file associations mapping, the path information will be +present in the environment, but incorrect. The best thing to do is to avoid +using additional path information in CGI scripts destined for use with IIS. A +best attempt has been made to make CGI.pm do the right thing. + +=item B + +As per path_info() but returns the additional path information translated into +a physical path, e.g. "/usr/local/etc/httpd/htdocs/additional/stuff". + +The Microsoft IIS is broken with respect to the translated path as well. + +=item B + +Returns either the remote host name or IP address if the former is unavailable. + +=item B + +Returns the name of the remote user (as returned by identd) or undef if not set + +=item B + +Returns the remote host IP address, or 127.0.0.1 if the address is unavailable. + +=item B + +Returns the interpreted pathname of the requested document or CGI (relative to +the document root). Or undef if not set. + +=item B + +Return the script name as a partial URL, for self-referring scripts. + +=item B + +Return the URL of the page the browser was viewing prior to fetching your +script. + +=item B + +Return the authorization/verification method in use for this script, if any. + +=item B + +Returns the name of the server, usually the machine's host name. + +=item B + +When using virtual hosts, returns the name of the host that the browser +attempted to contact + +=item B + +Return the port that the server is listening on. + +=item B + +Returns the protocol and revision of the incoming request, or defaults to +HTTP/1.0 if this is not set + +=item B + +Like server_port() except that it takes virtual hosts into account. Use this +when running with virtual hosts. + +=item B + +Returns the server software and version number. + +=item B + +Return the authorization/verification name used for user verification, if this +script is protected. + +=item B + +Attempt to obtain the remote user's name, using a variety of different +techniques. May not work in all browsers. + +=item B + +Returns the method used to access your script, usually one of 'POST', 'GET' +or 'HEAD'. + +=item B + +Returns the content_type of data submitted in a POST, generally +multipart/form-data or application/x-www-form-urlencoded + +=item B + +Called with no arguments returns the list of HTTP environment variables, +including such things as HTTP_USER_AGENT, HTTP_ACCEPT_LANGUAGE, and +HTTP_ACCEPT_CHARSET, corresponding to the like-named HTTP header fields in the +request. Called with the name of an HTTP header field, returns its value. +Capitalization and the use of hyphens versus underscores are not significant. + +For example, all three of these examples are equivalent: + + my $requested_language = $q->http('Accept-language'); + + my $requested_language = $q->http('Accept_language'); + + my $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE'); + +=item B + +The same as I, but operates on the HTTPS environment variables present +when the SSL protocol is in effect. Can be used to determine whether SSL is +turned on. + +=back + +=head1 USING NPH SCRIPTS + +NPH, or "no-parsed-header", scripts bypass the server completely by sending the +complete HTTP header directly to the browser. This has slight performance +benefits, but is of most use for taking advantage of HTTP extensions that are +not directly supported by your server, such as server push and PICS headers. + +Servers use a variety of conventions for designating CGI scripts as NPH. Many +Unix servers look at the beginning of the script's name for the prefix "nph-". +The Macintosh WebSTAR server and Microsoft's Internet Information Server, in +contrast, try to decide whether a program is an NPH script by examining the +first line of script output. + +CGI.pm supports NPH scripts with a special NPH mode. When in this mode, CGI.pm +will output the necessary extra header information when the header() and +redirect() methods are called. + +The Microsoft Internet Information Server requires NPH mode. As of version 2.30, +CGI.pm will automatically detect when the script is running under IIS and put +itself into this mode. You do not need to do this manually, although it won't +hurt anything if you do. + +=over 4 + +=item In the B statement + +Simply add the "-nph" pragma to the list of symbols to be imported into +your script: + + use CGI qw(:standard -nph) + +=item By calling the B method: + +Call B with a non-zero parameter at any point after using CGI.pm in your +program. + + CGI->nph(1) + +=item By using B<-nph> parameters + +in the B and B statements: + + print header(-nph=>1); + +=back + +=head1 SERVER PUSH + +CGI.pm provides four simple functions for producing multipart documents of the +type needed to implement server push. These functions were graciously provided +by Ed Jordan . To import these into your namespace, you must +import the ":push" set. You are also advised to put the script into NPH mode +and to set $| to 1 to avoid buffering problems. + +Here is a simple script that demonstrates server push: + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI qw/:push -nph/; + + $| = 1; + print multipart_init( -boundary=>'----here we go!' ); + for (0 .. 4) { + print multipart_start( -type=>'text/plain' ), + "The current time is ",scalar( localtime ),"\n"; + if ($_ < 4) { + print multipart_end(); + } else { + print multipart_final(); + } + sleep 1; + } + +This script initializes server push by calling B. It then +enters a loop in which it begins a new multipart section by calling +B, prints the current local time, and ends a multipart +section with B. It then sleeps a second, and begins again. +On the final iteration, it ends the multipart section with +B rather than with B. + +=over 4 + +=item multipart_init() + + multipart_init( -boundary => $boundary, -charset => $charset ); + +Initialize the multipart system. The -boundary argument specifies what MIME +boundary string to use to separate parts of the document. If not provided, +CGI.pm chooses a reasonable boundary for you. + +The -charset provides the character set, if not provided this will default to +ISO-8859-1 + +=item multipart_start() + + multipart_start( -type => $type, -charset => $charset ); + +Start a new part of the multipart document using the specified MIME type and +charset. If not specified, text/html ISO-8859-1 is assumed. + +=item multipart_end() + + multipart_end() + +End a part. You must remember to call multipart_end() once for each +multipart_start(), except at the end of the last part of the multipart document +when multipart_final() should be called instead of multipart_end(). + +=item multipart_final() + + multipart_final() + +End all parts. You should call multipart_final() rather than multipart_end() +at the end of the last part of the multipart document. + +=back + +Users interested in server push applications should also have a look at the +CGI::Push module. + +=head1 AVOIDING DENIAL OF SERVICE ATTACKS + +A potential problem with CGI.pm is that, by default, it attempts to process +form POSTings no matter how large they are. A wily hacker could attack your +site by sending a CGI script a huge POST of many gigabytes. CGI.pm will attempt +to read the entire POST into a variable, growing hugely in size until it runs +out of memory. While the script attempts to allocate the memory the system may +slow down dramatically. This is a form of denial of service attack. + +Another possible attack is for the remote user to force CGI.pm to accept a huge +file upload. CGI.pm will accept the upload and store it in a temporary directory +even if your script doesn't expect to receive an uploaded file. CGI.pm will +delete the file automatically when it terminates, but in the meantime the remote +user may have filled up the server's disk space, causing problems for other +programs. + +The best way to avoid denial of service attacks is to limit the amount of +memory, CPU time and disk space that CGI scripts can use. Some Web servers come +with built-in facilities to accomplish this. In other cases, you can use the +shell I or I commands to put ceilings on CGI resource usage. + +CGI.pm also has some simple built-in protections against denial of service +attacks, but you must activate them before you can use them. These take the +form of two global variables in the CGI name space: + +=over 4 + +=item B<$CGI::POST_MAX> + +If set to a non-negative integer, this variable puts a ceiling on the size of +POSTings, in bytes. If CGI.pm detects a POST that is greater than the ceiling, +it will immediately exit with an error message. This value will affect both +ordinary POSTs and multipart POSTs, meaning that it limits the maximum size of +file uploads as well. You should set this to a reasonably high +value, such as 10 megabytes. + +=item B<$CGI::DISABLE_UPLOADS> + +If set to a non-zero value, this will disable file uploads completely. Other +fill-out form values will work as usual. + +=back + +To use these variables, set the variable at the top of the script, right after +the "use" statement: + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI; + + $CGI::POST_MAX = 1024 * 1024 * 10; # max 10MB posts + $CGI::DISABLE_UPLOADS = 1; # no uploads + +An attempt to send a POST larger than $POST_MAX bytes will cause I to +return an empty CGI parameter list. You can test for this event by checking +I, either after you create the CGI object or, if you are using the +function-oriented interface, call for the first time. If the POST was +intercepted, then cgi_error() will return the message "413 POST too large". + +This error message is actually defined by the HTTP protocol, and is designed to +be returned to the browser as the CGI script's status code. For example: + + my $uploaded_file = $q->param('upload'); + if ( !$uploaded_file && $q->cgi_error() ) { + print $q->header( -status => $q->cgi_error() ); + exit 0; + } + +However it isn't clear that any browser currently knows what to do with this +status code. It might be better just to create a page that warns the user of +the problem. + +=head1 COMPATIBILITY WITH CGI-LIB.PL + +To make it easier to port existing programs that use cgi-lib.pl the +compatibility routine "ReadParse" is provided. Porting is simple: + +OLD VERSION + + require "cgi-lib.pl"; + &ReadParse; + print "The value of the antique is $in{antique}.\n"; + +NEW VERSION + + use CGI; + CGI::ReadParse(); + print "The value of the antique is $in{antique}.\n"; + +CGI.pm's ReadParse() routine creates a tied variable named %in, which can be +accessed to obtain the query variables. Like ReadParse, you can also provide +your own variable. Infrequently used features of ReadParse, such as the creation +of @in and $in variables, are not supported. + +Once you use ReadParse, you can retrieve the query object itself this way: + + my $q = $in{CGI}; + +This allows you to start using the more interesting features of CGI.pm without +rewriting your old scripts from scratch. + +An even simpler way to mix cgi-lib calls with CGI.pm calls is to import both the +C<:cgi-lib> and C<:standard> method: + + use CGI qw(:cgi-lib :standard); + &ReadParse; + print "The price of your purchase is $in{price}.\n"; + print textfield(-name=>'price', -default=>'$1.99'); + +=head2 Cgi-lib functions that are available in CGI.pm + +In compatibility mode, the following cgi-lib.pl functions are +available for your use: + + ReadParse() + PrintHeader() + SplitParam() + MethGet() + MethPost() + +=head1 LICENSE + +The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is +distributed under GPL and the Artistic License 2.0. It is currently maintained +by Lee Johnson (LEEJO) with help from many contributors. + +=head1 CREDITS + +Thanks very much to: + +=over 4 + +=item Mark Stosberg (mark@stosberg.com) + +=item Matt Heffron (heffron@falstaff.css.beckman.com) + +=item James Taylor (james.taylor@srs.gov) + +=item Scott Anguish + +=item Mike Jewell (mlj3u@virginia.edu) + +=item Timothy Shimmin (tes@kbs.citri.edu.au) + +=item Joergen Haegg (jh@axis.se) + +=item Laurent Delfosse (delfosse@delfosse.com) + +=item Richard Resnick (applepi1@aol.com) + +=item Craig Bishop (csb@barwonwater.vic.gov.au) + +=item Tony Curtis (tc@vcpc.univie.ac.at) + +=item Tim Bunce (Tim.Bunce@ig.co.uk) + +=item Tom Christiansen (tchrist@convex.com) + +=item Andreas Koenig (k@franz.ww.TU-Berlin.DE) + +=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au) + +=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu) + +=item Stephen Dahmen (joyfire@inxpress.net) + +=item Ed Jordan (ed@fidalgo.net) + +=item David Alan Pisoni (david@cnation.com) + +=item Doug MacEachern (dougm@opengroup.org) + +=item Robin Houston (robin@oneworld.org) + +=item ...and many many more... + +for suggestions and bug fixes. + +=back + +=head1 BUGS + +Address bug reports and comments to: L + +The original bug tracker can be found at: +L + +When sending bug reports, please provide the version of CGI.pm, the version of +perl, the name and version of your Web server, and the name and version of the +operating system you are using. If the problem is even remotely browser +dependent, please provide information about the affected browsers as well. + +Failing tests cases are appreciated with issues, and if you submit a patch then +it will *not* be accepted unless you provide a reasonable automated test case +with it (please see the existing tests in t/ for examples). + +Please note the CGI.pm is now considered "done". See also "mature" and "legacy". +Feature requests and none critical issues will be outright rejected. The module +is now in maintenance mode for critical issues only. + +=head1 SEE ALSO + +L - provides L implementation tailored to the CGI environment. + +L - supports running CGI applications under FastCGI + +=cut diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm new file mode 100644 index 0000000..d215732 --- /dev/null +++ b/lib/CGI/Carp.pm @@ -0,0 +1,615 @@ +package CGI::Carp; +use if $] >= 5.019, 'deprecate'; + +=head1 NAME + +B - CGI routines for writing to the HTTPD (or other) error log + +=head1 SYNOPSIS + + use CGI::Carp; + + croak "We're outta here!"; + confess "It was my fault: $!"; + carp "It was your fault!"; + warn "I'm confused"; + die "I'm dying.\n"; + + use CGI::Carp qw(cluck); + cluck "I wouldn't do that if I were you"; + + use CGI::Carp qw(fatalsToBrowser); + die "Fatal error messages are now sent to browser"; + +=head1 DESCRIPTION + +CGI scripts have a nasty habit of leaving warning messages in the error +logs that are neither time stamped nor fully identified. Tracking down +the script that caused the error is a pain. This fixes that. Replace +the usual + + use Carp; + +with + + use CGI::Carp + +The standard warn(), die (), croak(), confess() and carp() calls will +be replaced with functions that write time-stamped messages to the +HTTP server error log. + +For example: + + [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3. + [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied. + [Fri Nov 17 21:40:43 1995] test.pl: I'm dying. + +=head1 REDIRECTING ERROR MESSAGES + +By default, error messages are sent to STDERR. Most HTTPD servers +direct STDERR to the server's error log. Some applications may wish +to keep private error logs, distinct from the server's error log, or +they may wish to direct error messages to STDOUT so that the browser +will receive them. + +The C function is provided for this purpose. Since +carpout() is not exported by default, you must import it explicitly by +saying + + use CGI::Carp qw(carpout); + +The carpout() function requires one argument, a reference to an open +filehandle for writing errors. It should be called in a C +block at the top of the CGI application so that compiler errors will +be caught. Example: + + BEGIN { + use CGI::Carp qw(carpout); + open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or + die("Unable to open mycgi-log: $!\n"); + carpout(LOG); + } + +carpout() does not handle file locking on the log for you at this +point. Also, note that carpout() does not work with in-memory file +handles, although a patch would be welcome to address that. + +The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. +Some servers, when dealing with CGI scripts, close their connection to +the browser when the script closes STDOUT and STDERR. +CGI::Carp::SAVEERR is there to prevent this from happening +prematurely. + +You can pass filehandles to carpout() in a variety of ways. The "correct" +way according to Tom Christiansen is to pass a reference to a filehandle +GLOB: + + carpout(\*LOG); + +This looks weird to mere mortals however, so the following syntaxes are +accepted as well: + + carpout(LOG); + carpout(main::LOG); + carpout(main'LOG); + carpout(\LOG); + carpout(\'main::LOG'); + + ... and so on + +FileHandle and other objects work as well. + +Use of carpout() is not great for performance, so it is recommended +for debugging purposes or for moderate-use applications. A future +version of this module may delay redirecting STDERR until one of the +CGI::Carp methods is called to prevent the performance hit. + +=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW + +If you want to send fatal (die, confess) errors to the browser, import +the special "fatalsToBrowser" subroutine: + + use CGI::Carp qw(fatalsToBrowser); + die "Bad error here"; + +Fatal errors will now be echoed to the browser as well as to the log. +CGI::Carp arranges to send a minimal HTTP header to the browser so +that even errors that occur in the early compile phase will be seen. +Nonfatal errors will still be directed to the log file only (unless +redirected with carpout). + +Note that fatalsToBrowser may B work well with mod_perl version 2.0 +and higher. + +=head2 Changing the default message + +By default, the software error message is followed by a note to +contact the Webmaster by e-mail with the time and date of the error. +If this message is not to your liking, you can change it using the +set_message() routine. This is not imported by default; you should +import it on the use() line: + + use CGI::Carp qw(fatalsToBrowser set_message); + set_message("It's not a bug, it's a feature!"); + +You may also pass in a code reference in order to create a custom +error message. At run time, your code will be called with the text +of the error message that caused the script to die. Example: + + use CGI::Carp qw(fatalsToBrowser set_message); + BEGIN { + sub handle_errors { + my $msg = shift; + print "

Oh gosh

"; + print "

Got an error: $msg

"; + } + set_message(\&handle_errors); + } + +In order to correctly intercept compile-time errors, you should call +set_message() from within a BEGIN{} block. + +=head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS + +If fatalsToBrowser in conjunction with set_message does not provide +you with all of the functionality you need, you can go one step +further by specifying a function to be executed any time a script +calls "die", has a syntax error, or dies unexpectedly at runtime +with a line like "undef->explode();". + + use CGI::Carp qw(set_die_handler); + BEGIN { + sub handle_errors { + my $msg = shift; + print "content-type: text/html\n\n"; + print "

Oh gosh

"; + print "

Got an error: $msg

"; + + #proceed to send an email to a system administrator, + #write a detailed message to the browser and/or a log, + #etc.... + } + set_die_handler(\&handle_errors); + } + +Notice that if you use set_die_handler(), you must handle sending +HTML headers to the browser yourself if you are printing a message. + +If you use set_die_handler(), you will most likely interfere with +the behavior of fatalsToBrowser, so you must use this or that, not +both. + +Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser), +and there is only one SIG{__DIE__}. This means that if you are +attempting to set SIG{__DIE__} yourself, you may interfere with +this module's functionality, or this module may interfere with +your module's functionality. + +=head1 SUPPRESSING PERL ERRORS APPEARING IN THE BROWSER WINDOW + +A problem sometimes encountered when using fatalsToBrowser is +when a C is done inside an C body or expression. +Even though the +fatalsToBrower support takes precautions to avoid this, +you still may get the error message printed to STDOUT. +This may have some undesirable effects when the purpose of doing the +eval is to determine which of several algorithms is to be used. + +By setting C<$CGI::Carp::TO_BROWSER> to 0 you can suppress printing +the C messages but without all of the complexity of using +C. You can localize this effect to inside C +bodies if this is desirable: For example: + + eval { + local $CGI::Carp::TO_BROWSER = 0; + die "Fatal error messages not sent browser" + } + # $@ will contain error message + + +=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS + +It is also possible to make non-fatal errors appear as HTML comments +embedded in the output of your program. To enable this feature, +export the new "warningsToBrowser" subroutine. Since sending warnings +to the browser before the HTTP headers have been sent would cause an +error, any warnings are stored in an internal buffer until you call +the warningsToBrowser() subroutine with a true argument: + + use CGI::Carp qw(fatalsToBrowser warningsToBrowser); + use CGI qw(:standard); + print header(); + warningsToBrowser(1); + +You may also give a false argument to warningsToBrowser() to prevent +warnings from being sent to the browser while you are printing some +content where HTML comments are not allowed: + + warningsToBrowser(0); # disable warnings + print "\n"; + warningsToBrowser(1); # re-enable warnings + +Note: In this respect warningsToBrowser() differs fundamentally from +fatalsToBrowser(), which you should never call yourself! + +=head1 OVERRIDING THE NAME OF THE PROGRAM + +CGI::Carp includes the name of the program that generated the error or +warning in the messages written to the log and the browser window. +Sometimes, Perl can get confused about what the actual name of the +executed program was. In these cases, you can override the program +name that CGI::Carp will use for all messages. + +The quick way to do that is to tell CGI::Carp the name of the program +in its use statement. You can do that by adding +"name=cgi_carp_log_name" to your "use" statement. For example: + + use CGI::Carp qw(name=cgi_carp_log_name); + +. If you want to change the program name partway through the program, +you can use the C function instead. It is not +exported by default, you must import it explicitly by saying + + use CGI::Carp qw(set_progname); + +Once you've done that, you can change the logged name of the program +at any time by calling + + set_progname(new_program_name); + +You can set the program back to the default by calling + + set_progname(undef); + +Note that this override doesn't happen until after the program has +compiled, so any compile-time errors will still show up with the +non-overridden program name + +=head1 TURNING OFF TIMESTAMPS IN MESSAGES + +If your web server automatically adds a timestamp to each log line, +you may not need CGI::Carp to add its own. You can disable timestamping +by importing "noTimestamp": + + use CGI::Carp qw(noTimestamp); + +Alternatively you can set C<$CGI::Carp::NO_TIMESTAMP> to 1. + +Note that the name of the program is still automatically included in +the message. + +=head1 GETTING THE FULL PATH OF THE SCRIPT IN MESSAGES + +Set C<$CGI::Carp::FULL_PATH> to 1. + +=head1 AUTHOR INFORMATION + +The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is +distributed under GPL and the Artistic License 2.0. It is currently +maintained by Lee Johnson with help from many contributors. + +Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues + +The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm + +When sending bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and version of the +operating system you are using. If the problem is even remotely browser +dependent, please provide information about the affected browsers as well. + +=head1 SEE ALSO + +L, L, L, L, +L, L, L. + +=cut + +require 5.000; +use Exporter; +#use Carp; +BEGIN { + require Carp; + *CORE::GLOBAL::die = \&CGI::Carp::die; +} + +use File::Spec; + +@ISA = qw(Exporter); +@EXPORT = qw(confess croak carp); +@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap noTimestamp set_message set_die_handler set_progname cluck ^name= die); + +$main::SIG{__WARN__}=\&CGI::Carp::warn; + +$CGI::Carp::VERSION = '4.21'; +$CGI::Carp::CUSTOM_MSG = undef; +$CGI::Carp::DIE_HANDLER = undef; +$CGI::Carp::TO_BROWSER = 1; +$CGI::Carp::NO_TIMESTAMP= 0; +$CGI::Carp::FULL_PATH = 0; + +# fancy import routine detects and handles 'errorWrap' specially. +sub import { + my $pkg = shift; + my(%routines); + my(@name); + if (@name=grep(/^name=/,@_)) + { + my($n) = (split(/=/,$name[0]))[1]; + set_progname($n); + @_=grep(!/^name=/,@_); + } + + grep($routines{$_}++,@_,@EXPORT); + $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; + $WARN++ if $routines{'warningsToBrowser'}; + my($oldlevel) = $Exporter::ExportLevel; + $Exporter::ExportLevel = 1; + Exporter::import($pkg,keys %routines); + $Exporter::ExportLevel = $oldlevel; + $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'}; + $CGI::Carp::NO_TIMESTAMP = 1 if $routines{'noTimestamp'}; +} + +# These are the originals +sub realwarn { CORE::warn(@_); } +sub realdie { CORE::die(@_); } + +sub id { + my $level = shift; + my($pack,$file,$line,$sub) = caller($level); + my($dev,$dirs,$id) = File::Spec->splitpath($file); + return ($file,$line,$id); +} + +sub stamp { + my $frame = 0; + my ($id,$pack,$file,$dev,$dirs); + if (defined($CGI::Carp::PROGNAME)) { + $id = $CGI::Carp::PROGNAME; + } else { + do { + $id = $file; + ($pack,$file) = caller($frame++); + } until !$file; + } + if (! $CGI::Carp::FULL_PATH) { + ($dev,$dirs,$id) = File::Spec->splitpath($id); + } + return "$id: " if $CGI::Carp::NO_TIMESTAMP; + my $time = scalar(localtime); + return "[$time] $id: "; +} + +sub set_progname { + $CGI::Carp::PROGNAME = shift; + return $CGI::Carp::PROGNAME; +} + + +sub warn { + my $message = shift; + my($file,$line,$id) = id(1); + $message .= " at $file line $line.\n" unless $message=~/\n$/; + _warn($message) if $WARN; + my $stamp = stamp; + $message=~s/^/$stamp/gm; + realwarn $message; +} + +sub _warn { + my $msg = shift; + if ($EMIT_WARNINGS) { + # We need to mangle the message a bit to make it a valid HTML + # comment. This is done by substituting similar-looking ISO + # 8859-1 characters for <, > and -. This is a hack. + $msg =~ tr/<>-/\253\273\255/; + chomp $msg; + print STDOUT "\n"; + } else { + push @WARNINGS, $msg; + } +} + + +# The mod_perl package Apache::Registry loads CGI programs by calling +# eval. These evals don't count when looking at the stack backtrace. +sub _longmess { + my $message = Carp::longmess(); + $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s + if exists $ENV{MOD_PERL}; + return $message; +} + +sub ineval { + (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m +} + +sub die { + # if no argument is passed, propagate $@ like + # the real die + my ($arg,@rest) = @_ ? @_ + : $@ ? "$@\t...propagated" + : "Died" + ; + + &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER; + + # the "$arg" is done on purpose! + # if called as die( $object, 'string' ), + # all is stringified, just like with + # the real 'die' + $arg = join '' => "$arg", @rest if @rest; + + my($file,$line,$id) = id(1); + + $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/; + + realdie $arg if ineval(); + &fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER); + + $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL}; + + $arg .= "\n" unless $arg =~ /\n$/; + + realdie $arg; +} + +sub set_message { + $CGI::Carp::CUSTOM_MSG = shift; + return $CGI::Carp::CUSTOM_MSG; +} + +sub set_die_handler { + + my ($handler) = shift; + + #setting SIG{__DIE__} here is necessary to catch runtime + #errors which are not called by literally saying "die", + #such as the line "undef->explode();". however, doing this + #will interfere with fatalsToBrowser, which also sets + #SIG{__DIE__} in the import() function above (or the + #import() function above may interfere with this). for + #this reason, you should choose to either set the die + #handler here, or use fatalsToBrowser, not both. + $main::SIG{__DIE__} = $handler; + + $CGI::Carp::DIE_HANDLER = $handler; + + return $CGI::Carp::DIE_HANDLER; +} + +sub confess { CGI::Carp::die Carp::longmess @_; } +sub croak { CGI::Carp::die Carp::shortmess @_; } +sub carp { CGI::Carp::warn Carp::shortmess @_; } +sub cluck { CGI::Carp::warn Carp::longmess @_; } + +# We have to be ready to accept a filehandle as a reference +# or a string. +sub carpout { + my($in) = @_; + my($no) = fileno(to_filehandle($in)); + realdie("Invalid filehandle $in\n") unless defined $no; + + open(SAVEERR, ">&STDERR"); + open(STDERR, ">&$no") or + ( print SAVEERR "Unable to redirect >&$no: $!\n" and exit(1) ); +} + +sub warningsToBrowser { + $EMIT_WARNINGS = @_ ? shift : 1; + _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS; +} + +# headers +sub fatalsToBrowser { + my $msg = shift; + + $msg = "$msg" if ref $msg; + + $msg=~s/&/&/g; + $msg=~s/>/>/g; + $msg=~s/$ENV{SERVER_ADMIN})] : + "this site's webmaster"; + my ($outer_message) = <Software error: +
$msg
+

+$outer_message +

+END + ; + + if ($mod_perl) { + my $r; + if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $mod_perl = 2; + require Apache2::RequestRec; + require Apache2::RequestIO; + require Apache2::RequestUtil; + require APR::Pool; + require ModPerl::Util; + require Apache2::Response; + $r = Apache2::RequestUtil->request; + } + else { + $r = Apache->request; + } + # If bytes have already been sent, then + # we print the message out directly. + # Otherwise we make a custom error + # handler to produce the doc for us. + if ($r->bytes_sent) { + $r->print($mess); + $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit; + } else { + # MSIE won't display a custom 500 response unless it is >512 bytes! + if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) { + $mess = "\n$mess"; + } + $r->custom_response(500,$mess); + } + } else { + my $bytes_written = eval{tell STDOUT}; + if (defined $bytes_written && $bytes_written > 0) { + print STDOUT $mess; + } + else { + print STDOUT "Status: 500\n"; + print STDOUT "Content-type: text/html\n\n"; + # MSIE won't display a custom 500 response unless it is >512 bytes! + if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) { + $mess = "\n$mess"; + } + print STDOUT $mess; + } + } + + warningsToBrowser(1); # emit warnings before dying +} + +# Cut and paste from CGI.pm so that we don't have the overhead of +# always loading the entire CGI module. +sub to_filehandle { + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } + } + return undef; +} + +1; diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm new file mode 100644 index 0000000..d403b95 --- /dev/null +++ b/lib/CGI/Cookie.pm @@ -0,0 +1,537 @@ +package CGI::Cookie; + +use strict; +use warnings; + +use if $] >= 5.019, 'deprecate'; + +our $VERSION='4.21'; + +use CGI::Util qw(rearrange unescape escape); +use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback' => 1; + +my $PERLEX = 0; +# Turn on special checking for ActiveState's PerlEx +$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + +# Turn on special checking for mod_perl +# PerlEx::DBI tries to fool DBI by setting MOD_PERL +my $MOD_PERL = 0; +if (exists $ENV{MOD_PERL} && ! $PERLEX) { + if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $MOD_PERL = 2; + require Apache2::RequestUtil; + require APR::Table; + } else { + $MOD_PERL = 1; + require Apache; + } +} + +# fetch a list of cookies from the environment and +# return as a hash. the cookies are parsed as normal +# escaped URL data. +sub fetch { + my $class = shift; + my $raw_cookie = get_raw_cookie(@_) or return; + return $class->parse($raw_cookie); +} + +# Fetch a list of cookies from the environment or the incoming headers and +# return as a hash. The cookie values are not unescaped or altered in any way. + sub raw_fetch { + my $class = shift; + my $raw_cookie = get_raw_cookie(@_) or return; + my %results; + my($key,$value); + + my @pairs = split("[;,] ?",$raw_cookie); + for my $pair ( @pairs ) { + $pair =~ s/^\s+|\s+$//g; # trim leading trailing whitespace + my ( $key, $value ) = split "=", $pair; + + $value = defined $value ? $value : ''; + $results{$key} = $value; + } + return wantarray ? %results : \%results; +} + +sub get_raw_cookie { + my $r = shift; + $r ||= eval { $MOD_PERL == 2 ? + Apache2::RequestUtil->request() : + Apache->request } if $MOD_PERL; + + return $r->headers_in->{'Cookie'} if $r; + + die "Run $r->subprocess_env; before calling fetch()" + if $MOD_PERL and !exists $ENV{REQUEST_METHOD}; + + return $ENV{HTTP_COOKIE} || $ENV{COOKIE}; +} + + +sub parse { + my ($self,$raw_cookie) = @_; + return wantarray ? () : {} unless $raw_cookie; + + my %results; + + my @pairs = split("[;,] ?",$raw_cookie); + for (@pairs) { + s/^\s+//; + s/\s+$//; + + my($key,$value) = split("=",$_,2); + + # Some foreign cookies are not in name=value format, so ignore + # them. + next if !defined($value); + my @values = (); + if ($value ne '') { + @values = map unescape($_),split(/[&;]/,$value.'&dmy'); + pop @values; + } + $key = unescape($key); + # A bug in Netscape can cause several cookies with same name to + # appear. The FIRST one in HTTP_COOKIE is the most recent version. + $results{$key} ||= $self->new(-name=>$key,-value=>\@values); + } + return wantarray ? %results : \%results; +} + +sub new { + my ( $class, @params ) = @_; + $class = ref( $class ) || $class; + # Ignore mod_perl request object--compatibility with Apache::Cookie. + shift if ref $params[0] + && eval { $params[0]->isa('Apache::Request::Req') || $params[0]->isa('Apache') }; + my ( $name, $value, $path, $domain, $secure, $expires, $max_age, $httponly ) + = rearrange( + [ + 'NAME', [ 'VALUE', 'VALUES' ], + 'PATH', 'DOMAIN', + 'SECURE', 'EXPIRES', + 'MAX-AGE','HTTPONLY' + ], + @params + ); + return undef unless defined $name and defined $value; + my $self = {}; + bless $self, $class; + $self->name( $name ); + $self->value( $value ); + $path ||= "/"; + $self->path( $path ) if defined $path; + $self->domain( $domain ) if defined $domain; + $self->secure( $secure ) if defined $secure; + $self->expires( $expires ) if defined $expires; + $self->max_age( $max_age ) if defined $max_age; + $self->httponly( $httponly ) if defined $httponly; + return $self; +} + +sub as_string { + my $self = shift; + return "" unless $self->name; + + no warnings; # some things may be undefined, that's OK. + + my $name = escape( $self->name ); + my $value = join "&", map { escape($_) } $self->value; + my @cookie = ( "$name=$value" ); + + push @cookie,"domain=".$self->domain if $self->domain; + push @cookie,"path=".$self->path if $self->path; + push @cookie,"expires=".$self->expires if $self->expires; + push @cookie,"max-age=".$self->max_age if $self->max_age; + push @cookie,"secure" if $self->secure; + push @cookie,"HttpOnly" if $self->httponly; + + return join "; ", @cookie; +} + +sub compare { + my ( $self, $value ) = @_; + return "$self" cmp $value; +} + +sub bake { + my ($self, $r) = @_; + + $r ||= eval { + $MOD_PERL == 2 + ? Apache2::RequestUtil->request() + : Apache->request + } if $MOD_PERL; + if ($r) { + $r->headers_out->add('Set-Cookie' => $self->as_string); + } else { + require CGI; + print CGI::header(-cookie => $self); + } + +} + +# accessors +sub name { + my ( $self, $name ) = @_; + $self->{'name'} = $name if defined $name; + return $self->{'name'}; +} + +sub value { + my ( $self, $value ) = @_; + if ( defined $value ) { + my @values + = ref $value eq 'ARRAY' ? @$value + : ref $value eq 'HASH' ? %$value + : ( $value ); + $self->{'value'} = [@values]; + } + return wantarray ? @{ $self->{'value'} } : $self->{'value'}->[0]; +} + +sub domain { + my ( $self, $domain ) = @_; + $self->{'domain'} = lc $domain if defined $domain; + return $self->{'domain'}; +} + +sub secure { + my ( $self, $secure ) = @_; + $self->{'secure'} = $secure if defined $secure; + return $self->{'secure'}; +} + +sub expires { + my ( $self, $expires ) = @_; + $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires; + return $self->{'expires'}; +} + +sub max_age { + my ( $self, $max_age ) = @_; + $self->{'max-age'} = CGI::Util::expire_calc($max_age)-time() if defined $max_age; + return $self->{'max-age'}; +} + +sub path { + my ( $self, $path ) = @_; + $self->{'path'} = $path if defined $path; + return $self->{'path'}; +} + + +sub httponly { # HttpOnly + my ( $self, $httponly ) = @_; + $self->{'httponly'} = $httponly if defined $httponly; + return $self->{'httponly'}; +} + +1; + +=head1 NAME + +CGI::Cookie - Interface to HTTP Cookies + +=head1 SYNOPSIS + + use CGI qw/:standard/; + use CGI::Cookie; + + # Create new cookies and send them + $cookie1 = CGI::Cookie->new(-name=>'ID',-value=>123456); + $cookie2 = CGI::Cookie->new(-name=>'preferences', + -value=>{ font => Helvetica, + size => 12 } + ); + print header(-cookie=>[$cookie1,$cookie2]); + + # fetch existing cookies + %cookies = CGI::Cookie->fetch; + $id = $cookies{'ID'}->value; + + # create cookies returned from an external source + %cookies = CGI::Cookie->parse($ENV{COOKIE}); + +=head1 DESCRIPTION + +CGI::Cookie is an interface to HTTP/1.1 cookies, a mechanism +that allows Web servers to store persistent information on +the browser's side of the connection. Although CGI::Cookie is +intended to be used in conjunction with CGI.pm (and is in fact used by +it internally), you can use this module independently. + +For full information on cookies see + + https://tools.ietf.org/html/rfc6265 + +=head1 USING CGI::Cookie + +CGI::Cookie is object oriented. Each cookie object has a name and a +value. The name is any scalar value. The value is any scalar or +array value (associative arrays are also allowed). Cookies also have +several optional attributes, including: + +=over 4 + +=item B<1. expiration date> + +The expiration date tells the browser how long to hang on to the +cookie. If the cookie specifies an expiration date in the future, the +browser will store the cookie information in a disk file and return it +to the server every time the user reconnects (until the expiration +date is reached). If the cookie species an expiration date in the +past, the browser will remove the cookie from the disk file. If the +expiration date is not specified, the cookie will persist only until +the user quits the browser. + +=item B<2. domain> + +This is a partial or complete domain name for which the cookie is +valid. The browser will return the cookie to any host that matches +the partial domain name. For example, if you specify a domain name +of ".capricorn.com", then the browser will return the cookie to +Web servers running on any of the machines "www.capricorn.com", +"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names +must contain at least two periods to prevent attempts to match +on top level domains like ".edu". If no domain is specified, then +the browser will only return the cookie to servers on the host the +cookie originated from. + +=item B<3. path> + +If you provide a cookie path attribute, the browser will check it +against your script's URL before returning the cookie. For example, +if you specify the path "/cgi-bin", then the cookie will be returned +to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and +"/cgi-bin/customer_service/complain.pl", but not to the script +"/cgi-private/site_admin.pl". By default, the path is set to "/", so +that all scripts at your site will receive the cookie. + +=item B<4. secure flag> + +If the "secure" attribute is set, the cookie will only be sent to your +script if the CGI request is occurring on a secure channel, such as SSL. + +=item B<5. httponly flag> + +If the "httponly" attribute is set, the cookie will only be accessible +through HTTP Requests. This cookie will be inaccessible via JavaScript +(to prevent XSS attacks). + +This feature is supported by nearly all modern browsers. + +See these URLs for more information: + + http://msdn.microsoft.com/en-us/library/ms533046.aspx + http://www.browserscope.org/?category=security&v=top + +=back + +=head2 Creating New Cookies + + my $c = CGI::Cookie->new(-name => 'foo', + -value => 'bar', + -expires => '+3M', + '-max-age' => '+3M', + -domain => '.capricorn.com', + -path => '/cgi-bin/database', + -secure => 1 + ); + +Create cookies from scratch with the B method. The B<-name> and +B<-value> parameters are required. The name must be a scalar value. +The value can be a scalar, an array reference, or a hash reference. +(At some point in the future cookies will support one of the Perl +object serialization protocols for full generality). + +B<-expires> accepts any of the relative or absolute date formats +recognized by CGI.pm, for example "+3M" for three months in the +future. See CGI.pm's documentation for details. + +B<-max-age> accepts the same data formats as B<< -expires >>, but sets a +relative value instead of an absolute like B<< -expires >>. This is intended to be +more secure since a clock could be changed to fake an absolute time. In +practice, as of 2011, C<< -max-age >> still does not enjoy the widespread support +that C<< -expires >> has. You can set both, and browsers that support +C<< -max-age >> should ignore the C<< Expires >> header. The drawback +to this approach is the bit of bandwidth for sending an extra header on each cookie. + +B<-domain> points to a domain name or to a fully qualified host name. +If not specified, the cookie will be returned only to the Web server +that created it. + +B<-path> points to a partial URL on the current server. The cookie +will be returned to all URLs beginning with the specified path. If +not specified, it defaults to '/', which returns the cookie to all +pages at your site. + +B<-secure> if set to a true value instructs the browser to return the +cookie only when a cryptographic protocol is in use. + +B<-httponly> if set to a true value, the cookie will not be accessible +via JavaScript. + +For compatibility with Apache::Cookie, you may optionally pass in +a mod_perl request object as the first argument to C. It will +simply be ignored: + + my $c = CGI::Cookie->new($r, + -name => 'foo', + -value => ['bar','baz']); + +=head2 Sending the Cookie to the Browser + +The simplest way to send a cookie to the browser is by calling the bake() +method: + + $c->bake; + +This will print the Set-Cookie HTTP header to STDOUT using CGI.pm. CGI.pm +will be loaded for this purpose if it is not already. Otherwise CGI.pm is not +required or used by this module. + +Under mod_perl, pass in an Apache request object: + + $c->bake($r); + +If you want to set the cookie yourself, Within a CGI script you can send +a cookie to the browser by creating one or more Set-Cookie: fields in the +HTTP header. Here is a typical sequence: + + my $c = CGI::Cookie->new(-name => 'foo', + -value => ['bar','baz'], + -expires => '+3M'); + + print "Set-Cookie: $c\n"; + print "Content-Type: text/html\n\n"; + +To send more than one cookie, create several Set-Cookie: fields. + +If you are using CGI.pm, you send cookies by providing a -cookie +argument to the header() method: + + print header(-cookie=>$c); + +Mod_perl users can set cookies using the request object's header_out() +method: + + $r->headers_out->set('Set-Cookie' => $c); + +Internally, Cookie overloads the "" operator to call its as_string() +method when incorporated into the HTTP header. as_string() turns the +Cookie's internal representation into an RFC-compliant text +representation. You may call as_string() yourself if you prefer: + + print "Set-Cookie: ",$c->as_string,"\n"; + +=head2 Recovering Previous Cookies + + %cookies = CGI::Cookie->fetch; + +B returns an associative array consisting of all cookies +returned by the browser. The keys of the array are the cookie names. You +can iterate through the cookies this way: + + %cookies = CGI::Cookie->fetch; + for (keys %cookies) { + do_something($cookies{$_}); + } + +In a scalar context, fetch() returns a hash reference, which may be more +efficient if you are manipulating multiple cookies. + +CGI.pm uses the URL escaping methods to save and restore reserved characters +in its cookies. If you are trying to retrieve a cookie set by a foreign server, +this escaping method may trip you up. Use raw_fetch() instead, which has the +same semantics as fetch(), but performs no unescaping. + +You may also retrieve cookies that were stored in some external +form using the parse() class method: + + $COOKIES = `cat /usr/tmp/Cookie_stash`; + %cookies = CGI::Cookie->parse($COOKIES); + +If you are in a mod_perl environment, you can save some overhead by +passing the request object to fetch() like this: + + CGI::Cookie->fetch($r); + +If the value passed to parse() is undefined, an empty array will returned in list +context, and an empty hashref will be returned in scalar context. + +=head2 Manipulating Cookies + +Cookie objects have a series of accessor methods to get and set cookie +attributes. Each accessor has a similar syntax. Called without +arguments, the accessor returns the current value of the attribute. +Called with an argument, the accessor changes the attribute and +returns its new value. + +=over 4 + +=item B + +Get or set the cookie's name. Example: + + $name = $c->name; + $new_name = $c->name('fred'); + +=item B + +Get or set the cookie's value. Example: + + $value = $c->value; + @new_value = $c->value(['a','b','c','d']); + +B is context sensitive. In a list context it will return +the current value of the cookie as an array. In a scalar context it +will return the B value of a multivalued cookie. + +=item B + +Get or set the cookie's domain. + +=item B + +Get or set the cookie's path. + +=item B + +Get or set the cookie's expiration time. + +=item B + +Get or set the cookie's max_age value. + +=back + + +=head1 AUTHOR INFORMATION + +The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is +distributed under GPL and the Artistic License 2.0. It is currently +maintained by Lee Johnson with help from many contributors. + +Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues + +The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm + +When sending bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and version of the +operating system you are using. If the problem is even remotely browser +dependent, please provide information about the affected browsers as well. + +=head1 BUGS + +This section intentionally left blank. + +=head1 SEE ALSO + +L, L + +L, L + +=cut diff --git a/lib/CGI/File/Temp.pm b/lib/CGI/File/Temp.pm new file mode 100644 index 0000000..0c8136a --- /dev/null +++ b/lib/CGI/File/Temp.pm @@ -0,0 +1,39 @@ +# this is a back compatibility wrapper around File::Temp. DO NOT +# use this package outside of CGI, i won't provide any help if +# you use it directly and your code breaks horribly. +package CGI::File::Temp; + +$CGI::File::Temp::VERSION = '4.21'; + +use parent File::Temp; +use parent Fh; + +use overload + '""' => \&asString, + 'cmp' => \&compare, + 'fallback'=>1; + +# back compatibility method since we now return a File::Temp object +# as the filehandle (which isa IO::Handle) so calling ->handle on +# it will fail. FIXME: deprecate this method in v5+ +sub handle { return shift; }; + +sub compare { + my ( $self,$value ) = @_; + return "$self" cmp $value; +} + +sub _mp_filename { + my ( $self,$filename ) = @_; + ${*$self}->{ _mp_filename } = $filename + if $filename; + return ${*$self}->{_mp_filename}; +} + +sub asString { + my ( $self ) = @_; + return $self->_mp_filename; +} + +1; + diff --git a/lib/CGI/HTML/Functions.pm b/lib/CGI/HTML/Functions.pm new file mode 100644 index 0000000..e4983ca --- /dev/null +++ b/lib/CGI/HTML/Functions.pm @@ -0,0 +1,8 @@ +package CGI::HTML::Functions; + +use strict; +use warnings; + +# nothing here yet... may move functions here in the long term + +1; diff --git a/lib/CGI/HTML/Functions.pod b/lib/CGI/HTML/Functions.pod new file mode 100644 index 0000000..8c00c27 --- /dev/null +++ b/lib/CGI/HTML/Functions.pod @@ -0,0 +1,1927 @@ +=head1 NAME + +CGI::HTML::Functions - Documentation for CGI.pm Legacy HTML Functionality + +=head1 SYNOPSIS + +Nothing here - please do not use this functionality, it is considered to +be legacy and essentially deprecated. This documentation exists solely to +aid in maintenance and migration of legacy code using this functionality. + +This functionality is likely to be removed in future versions of CGI.pm so +you are strongly encouraged to migrate away from it. If you are working +on new code you should be using a template engine. For more information see +L. + +=head1 DESCRIPTION + +The documentation here should be considered an addendum to the sections in the +L documentation - the sections here are named the same as those within the +CGI perldoc. + +=head1 Calling CGI.pm routines + +HTML tag functions have both attributes (the attribute="value" pairs within the +tag itself) and contents (the part between the opening and closing pairs). To +distinguish between attributes and contents, CGI.pm uses the convention of +passing HTML attributes as a hash reference as the first argument, and the +contents, if any, as any subsequent arguments. It works out like +this: + + Code Generated HTML + ---- -------------- + h1()

+ h1('some','contents');

some contents

+ h1({-align=>left});

+ h1({-align=>left},'contents');

contents

+ +Many newcomers to CGI.pm are puzzled by the difference between the calling +conventions for the HTML shortcuts, which require curly braces around the HTML +tag attributes, and the calling conventions for other routines, which manage +to generate attributes without the curly brackets. Don't be confused. As a +convenience the curly braces are optional in all but the HTML shortcuts. If you +like, you can use curly braces when calling any routine that takes named +arguments. For example: + + print $q->header( { -type => 'image/gif', -expires => '+3d' } ); + +If you use warnings, you will be warned that some CGI.pm argument names +conflict with built-in perl functions. The most frequent of these is the +-values argument, used to create multi-valued menus, radio button clusters +and the like. To get around this warning, you have several choices: + +=over 4 + +=item 1. + +Use another name for the argument, if one is available. +For example, -value is an alias for -values. + +=item 2. + +Change the capitalization, e.g. -Values + +=item 3. + +Put quotes around the argument name, e.g. '-values' + +=back + +=head2 Function-oriented interface HTML exports + +Here is a list of the HTML related function sets you can import: + +=over 4 + +=item B<:form> + +Import all fill-out form generating methods, such as B. + +=item B<:html2> + +Import all methods that generate HTML 2.0 standard elements. + +=item B<:html3> + +Import all methods that generate HTML 3.0 elements (such as +, and ). + +=item B<:html4> + +Import all methods that generate HTML 4 elements (such as +, and ). + +=item B<:netscape> + +Import the , and
tags. + +=item B<:html> + +Import all HTML-generating shortcuts (i.e. 'html2', 'html3', 'html4' and 'netscape') + +=item B<:standard> + +Import "standard" features, 'html2', 'html3', 'html4', 'ssl', 'form' and 'cgi'. + +=back + +If you import any of the state-maintaining CGI or form-generating methods, +a default CGI object will be created and initialized automatically the first +time you use any of the methods that require one to be present. This includes +B, B, B and the like. (If you need direct access +to the CGI object, you can find it in the global variable B<$CGI::Q>). + +=head2 Pragmas + +Additional HTML generation related pragms: + +=over 4 + +=item -nosticky + +By default the CGI module implements a state-preserving behavior called +"sticky" fields. The way this works is that if you are regenerating a form, +the methods that generate the form field values will interrogate param() +to see if similarly-named parameters are present in the query string. If +they find a like-named parameter, they will use it to set their default values. + +Sometimes this isn't what you want. The B<-nosticky> pragma prevents this +behavior. You can also selectively change the sticky behavior in each element +that you generate. + +=item -tabindex + +Automatically add tab index attributes to each form field. With this option +turned off, you can still add tab indexes manually by passing a -tabindex +option to each field-generating method. + +=item -no_xhtml + +By default, CGI.pm versions 2.69 and higher emit XHTML +(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this feature. +Thanks to Michalis Kabrianis for this feature. + +If start_html()'s -dtd parameter specifies an HTML 2.0, 3.2, 4.0 or 4.01 DTD, +XHTML will automatically be disabled without needing to use this pragma. + +=back + +=head2 Special forms for importing HTML-tag functions + +Many of the methods generate HTML tags. As described below, tag functions +automatically generate both the opening and closing tags. For example: + + print h1('Level 1 Header'); + +produces + +

Level 1 Header

+ +There will be some times when you want to produce the start and end tags +yourself. In this case, you can use the form start_I and +end_I, as in: + + print start_h1,'Level 1 Header',end_h1; + +=head2 Creating the HTML document header + + print start_html( + -title => 'Secrets of the Pyramids', + -author => 'fred@capricorn.org', + -base => 'true', + -target => '_blank', + -meta => {'keywords'=>'pharaoh secret mummy', + 'copyright' => 'copyright 1996 King Tut'}, + -style => {'src'=>'/styles/style1.css'}, + -BGCOLOR => 'blue' + ); + +The start_html() routine creates the top of the page, along with a lot of +optional information that controls the page's appearance and behavior. + +This method returns a canned HTML header and the opening tag. All +parameters are optional. In the named parameter form, recognized parameters +are -title, -author, -base, -xbase, -dtd, -lang and -target (see below for the +explanation). Any additional parameters you provide, such as the unofficial +BGCOLOR attribute, are added to the tag. Additional parameters must be +proceeded by a hyphen. + +The argument B<-xbase> allows you to provide an HREF for the tag different +from the current location, as in + + -xbase => "http://home.mcom.com/" + +All relative links will be interpreted relative to this tag. + +The argument B<-target> allows you to provide a default target frame for all the +links and fill-out forms on the page. B +B + + -target => "answer_window" + +All relative links will be interpreted relative to this tag. You add arbitrary +meta information to the header with the B<-meta> argument. This argument expects +a reference to a hash containing name/value pairs of meta information. These will +be turned into a series of header tags that look something like this: + + + + +To create an HTTP-EQUIV type of tag, use B<-head>, described below. + +The B<-style> argument is used to incorporate cascading stylesheets into your +code. See the section on CASCADING STYLESHEETS for more information. + +The B<-lang> argument is used to incorporate a language attribute into the +tag. For example: + + print $q->start_html( -lang => 'fr-CA' ); + +The default if not specified is "en-US" for US English, unless the -dtd parameter +specifies an HTML 2.0 or 3.2 DTD, in which case the lang attribute is left off. +You can force the lang attribute to left off in other cases by passing an empty +string (-lang=>''). + +The B<-encoding> argument can be used to specify the character set for XHTML. It +defaults to iso-8859-1 if not specified. + +The B<-dtd> argument can be used to specify a public DTD identifier string. For +example: + + -dtd => '-//W3C//DTD HTML 4.01 Transitional//EN') + +Alternatively, it can take public and system DTD identifiers as an array: + + -dtd => [ + '-//W3C//DTD HTML 4.01 Transitional//EN', + 'http://www.w3.org/TR/html4/loose.dtd' + ] + +For the public DTD identifier to be considered, it must be valid. Otherwise it +will be replaced by the default DTD. If the public DTD contains 'XHTML', CGI.pm +will emit XML. + +The B<-declare_xml> argument, when used in conjunction with XHTML, will put a + declaration at the top of the HTML header. The sole purpose of this +declaration is to declare the character set encoding. In the absence of +-declare_xml, the output HTML will contain a tag that specifies the +encoding, allowing the HTML to pass most validators. The default for -declare_xml +is false. + +You can place other arbitrary HTML elements to the section with the +B<-head> tag. For example, to place a element in the head section, use +this: + + print start_html( + -head => Link({ + -rel => 'shortcut icon', + -href => 'favicon.ico' + }) + ); + +To incorporate multiple HTML elements into the section, just pass an +array reference: + + print start_html( + -head => [ + Link({ + -rel => 'next', + -href => 'http://www.capricorn.com/s2.html' + }), + Link({ + -rel => 'previous', + -href => 'http://www.capricorn.com/s1.html' + }) + ] + ); + +And here's how to create an HTTP-EQUIV tag: + + print start_html( + -head => meta({ + -http_equiv => 'Content-Type', + -content => 'text/html' + }) + ); + + +JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, B<-onMouseOver>, +B<-onMouseOut> and B<-onUnload> parameters are used to add JavaScript calls to +your pages. B<-script> should point to a block of text containing JavaScript +function definitions. This block will be placed within a