summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/CGI.pm4885
-rw-r--r--lib/CGI/Apache.pm90
-rw-r--r--lib/CGI/Carp.pm242
-rw-r--r--lib/CGI/Fast.pm173
-rw-r--r--lib/CGI/Push.pm239
-rw-r--r--lib/CGI/Switch.pm78
-rw-r--r--lib/ExtUtils/typemap2
-rw-r--r--lib/Pod/Html.pm1472
-rw-r--r--lib/Term/Cap.pm7
-rw-r--r--lib/Text/ParseWords.pm2
-rw-r--r--lib/chat2.inter495
-rw-r--r--lib/chat2.pl368
-rw-r--r--lib/constant.pm162
13 files changed, 7349 insertions, 866 deletions
diff --git a/lib/CGI.pm b/lib/CGI.pm
new file mode 100644
index 0000000000..3ddd4d999b
--- /dev/null
+++ b/lib/CGI.pm
@@ -0,0 +1,4885 @@
+package CGI;
+require 5.001;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995-1997 Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
+# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+
+# Set this to 1 to enable copious autoloader debugging messages
+$AUTOLOAD_DEBUG=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;
+
+$CGI::revision = '$Id: CGI.pm,v 2.32 1997/3/19 10:10 lstein Exp $';
+$CGI::VERSION='2.32';
+
+# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG
+# $OS = 'UNIX';
+# $OS = 'MACINTOSH';
+# $OS = 'WINDOWS';
+# $OS = 'VMS';
+# $OS = 'OS2';
+
+# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
+# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
+# $TempFile::TMPDIRECTORY = '/usr/tmp';
+
+# ------------------ START OF THE LIBRARY ------------
+
+# 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=~/Win/i) {
+ $OS = 'WINDOWS';
+} elsif ($OS=~/vms/i) {
+ $OS = 'VMS';
+} elsif ($OS=~/Mac/i) {
+ $OS = 'MACINTOSH';
+} elsif ($OS=~/os2/i) {
+ $OS = 'OS2';
+} else {
+ $OS = 'UNIX';
+}
+
+# Some OS logic. Binary mode enabled on DOS, NT and VMS
+$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
+
+# This is the default class for the CGI object to use when all else fails.
+$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
+# This is where to look for autoloaded routines.
+$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
+
+# The path separator is a slash, backslash or semicolon, depending
+# on the paltform.
+$SL = {
+ UNIX=>'/',
+ OS2=>'\\',
+ WINDOWS=>'\\',
+ MACINTOSH=>':',
+ VMS=>'\\'
+ }->{$OS};
+
+# Turn on NPH scripts by default when running under IIS server!
+$NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+
+# Turn on special checking for Doug MacEachern's modperl
+if ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/) {
+ $NPH++;
+ $| = 1;
+ $SEQNO = 1;
+}
+
+# This is really "\r\n", but the meaning of \n is different
+# in MacPerl, so we resort to octal here.
+$CRLF = "\015\012";
+
+if ($needs_binmode) {
+ $CGI::DefaultClass->binmode(main::STDOUT);
+ $CGI::DefaultClass->binmode(main::STDIN);
+ $CGI::DefaultClass->binmode(main::STDERR);
+}
+
+# Cute feature, but it broke when the overload mechanism changed...
+# %OVERLOAD = ('""'=>'as_string');
+
+%EXPORT_TAGS = (
+ ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
+ tt 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/],
+ ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/],
+ ':netscape'=>[qw/blink frameset frame script font fontsize center/],
+ ':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 startform endform
+ start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
+ ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
+ raw_cookie request_method query_string accept user_agent remote_host
+ remote_addr referer server_name server_software server_port server_protocol
+ virtual_host remote_ident auth_type http
+ remote_user user_name header redirect import_names put/],
+ ':ssl' => [qw/https/],
+ ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
+ ':html' => [qw/:html2 :html3 :netscape/],
+ ':standard' => [qw/:html2 :form :cgi/],
+ ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
+ );
+
+# to import symbols into caller
+sub import {
+ my $self = shift;
+ my ($callpack, $callfile, $callline) = caller;
+ foreach (@_) {
+ $NPH++, next if $_ eq ':nph';
+ foreach (&expand_tags($_)) {
+ tr/a-zA-Z0-9_//cd; # don't allow weird function names
+ $EXPORT{$_}++;
+ }
+ }
+ # To allow overriding, search through the packages
+ # Till we find one in which the correct subroutine is defined.
+ my @packages = ($self,@{"$self\:\:ISA"});
+ foreach $sym (keys %EXPORT) {
+ my $pck;
+ my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
+ foreach $pck (@packages) {
+ if (defined(&{"$pck\:\:$sym"})) {
+ $def = $pck;
+ last;
+ }
+ }
+ *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
+ }
+}
+
+sub expand_tags {
+ my($tag) = @_;
+ my(@r);
+ return ($tag) unless $EXPORT_TAGS{$tag};
+ foreach (@{$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;
+ $CGI::DefaultClass->_reset_globals() if $MOD_PERL;
+ $initializer = to_filehandle($initializer) if $initializer;
+ $self->init($initializer);
+ return $self;
+}
+
+# We provide a DESTROY method so that the autoloader
+# doesn't bother trying to find it.
+sub DESTROY { }
+
+#### Method: 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.
+####
+sub param {
+ my($self,@p) = self_or_default(@_);
+ return $self->all_parameters unless @p;
+ 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) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
+ my(@values);
+
+ if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
+ @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
+ } else {
+ foreach ($value,@other) {
+ push(@values,$_) if defined($_);
+ }
+ }
+ # If values is provided, then we set it.
+ if (@values) {
+ $self->add_parameter($name);
+ $self->{$name}=[@values];
+ }
+ } else {
+ $name = $p[0];
+ }
+
+ return () unless defined($name) && $self->{$name};
+ return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
+}
+
+#### Method: delete
+# Deletes the named parameter entirely.
+####
+sub delete {
+ my($self,$name) = self_or_default(@_);
+ delete $self->{$name};
+ delete $self->{'.fieldnames'}->{$name};
+ @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
+ return wantarray ? () : undef;
+}
+
+sub self_or_default {
+ return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
+ unless (defined($_[0]) &&
+ ref($_[0]) &&
+ (ref($_[0]) eq 'CGI' ||
+ eval "\$_[0]->isaCGI()")) { # optimize for the common case
+ $CGI::DefaultClass->_reset_globals()
+ if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request();
+ $Q = $CGI::DefaultClass->new unless defined($Q);
+ unshift(@_,$Q);
+ }
+ return @_;
+}
+
+sub _new_request {
+ return undef unless (defined(Apache->seqno()) or eval { require Apache });
+ if (Apache->seqno() != $SEQNO) {
+ $SEQNO = Apache->seqno();
+ return 1;
+ } else {
+ return undef;
+ }
+}
+
+sub _reset_globals {
+ undef $Q;
+ undef @QUERY_PARAM;
+}
+
+sub self_or_CGI {
+ local $^W=0; # prevent a warning
+ if (defined($_[0]) &&
+ (substr(ref($_[0]),0,3) eq 'CGI'
+ || eval "\$_[0]->isaCGI()")) {
+ return @_;
+ } else {
+ return ($DefaultClass,@_);
+ }
+}
+
+sub isaCGI {
+ return 1;
+}
+
+#### Method: import_names
+# Import all parameters into the given namespace.
+# Assumes namespace 'Q' if not specified
+####
+sub import_names {
+ my($self,$namespace) = self_or_default(@_);
+ $namespace = 'Q' unless defined($namespace);
+ die "Can't import names into 'main'\n"
+ if $namespace eq 'main';
+ my($param,@value,$var);
+ foreach $param ($self->param) {
+ # protect against silly names
+ ($var = $param)=~tr/a-zA-Z0-9_/_/c;
+ $var = "${namespace}::$var";
+ @value = $self->param($param);
+ @{$var} = @value;
+ ${$var} = $value[0];
+ }
+}
+
+#### Method: use_named_parameters
+# Force CGI.pm to use named parameter-style method calls
+# rather than positional parameters. The same effect
+# will happen automatically if the first parameter
+# begins with a -.
+sub use_named_parameters {
+ my($self,$use_named) = self_or_default(@_);
+ return $self->{'.named'} unless defined ($use_named);
+
+ # stupidity to avoid annoying warnings
+ return $self->{'.named'}=$use_named;
+}
+
+########################################
+# 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 an associative array 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,$initializer) = @_;
+ my($query_string,@lines);
+ my($meth) = '';
+
+ # 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 (defined(@QUERY_PARAM) && !defined($initializer)) {
+
+ foreach (@QUERY_PARAM) {
+ $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
+ }
+ return;
+ }
+
+ $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
+
+ # If initializer is defined, then read parameters
+ # from it.
+ METHOD: {
+ if (defined($initializer)) {
+
+ if (ref($initializer) && ref($initializer) eq 'HASH') {
+ foreach (keys %$initializer) {
+ $self->param('-name'=>$_,'-value'=>$initializer->{$_});
+ }
+ last METHOD;
+ }
+
+ $initializer = $$initializer if ref($initializer);
+ if (defined(fileno($initializer))) {
+ while (<$initializer>) {
+ chomp;
+ last if /^=/;
+ push(@lines,$_);
+ }
+ # massage back into standard format
+ if ("@lines" =~ /=/) {
+ $query_string=join("&",@lines);
+ } else {
+ $query_string=join("+",@lines);
+ }
+ last METHOD;
+ }
+ $query_string = $initializer;
+ last METHOD;
+ }
+ # If method is GET or HEAD, fetch the query from
+ # the environment.
+ if ($meth=~/^(GET|HEAD)$/) {
+ $query_string = $ENV{'QUERY_STRING'};
+ last METHOD;
+ }
+
+ # If the method is POST, fetch the query from standard
+ # input.
+ if ($meth eq 'POST') {
+
+ if (defined($ENV{'CONTENT_TYPE'})
+ &&
+ $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
+ my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
+ $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
+
+ } else {
+
+ $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
+ if $ENV{'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 .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};
+ last METHOD;
+ }
+
+ # If neither is set, 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.
+ $query_string = &read_from_cmdline;
+ }
+
+ # We now have the query string in hand. We do slightly
+ # different things for keyword lists and parameter lists.
+ if ($query_string) {
+ if ($query_string =~ /=/) {
+ $self->parse_params($query_string);
+ } else {
+ $self->add_parameter('keywords');
+ $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
+ }
+ }
+
+ # Special case. Erase everything if there is a field named
+ # .defaults.
+ if ($self->param('.defaults')) {
+ undef %{$self};
+ }
+
+ # Associative array containing our defined fieldnames
+ $self->{'.fieldnames'} = {};
+ foreach ($self->param('.cgifields')) {
+ $self->{'.fieldnames'}->{$_}++;
+ }
+
+ # Clear out our default submission button flag if present
+ $self->delete('.submit');
+ $self->delete('.cgifields');
+ $self->save_request unless $initializer;
+
+}
+
+
+# FUNCTIONS TO OVERRIDE:
+
+# Turn a string into a filehandle
+sub to_filehandle {
+ my $string = shift;
+ if ($string && !ref($string)) {
+ my($package) = caller(1);
+ my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string";
+ return $tmp if defined(fileno($tmp));
+ }
+ return $string;
+}
+
+# Create a new multipart buffer
+sub new_MultipartBuffer {
+ my($self,$boundary,$length,$filehandle) = @_;
+ return MultipartBuffer->new($self,$boundary,$length,$filehandle);
+}
+
+# Read data from a file handle
+sub read_from_client {
+ my($self, $fh, $buff, $len, $offset) = @_;
+ local $^W=0; # prevent a warning
+ return read($fh, $$buff, $len, $offset);
+}
+
+# put a filehandle into binary mode (DOS)
+sub binmode {
+ binmode($_[1]);
+}
+
+# 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(@_);
+}
+
+# unescape URL-encoded data
+sub unescape {
+ my($todecode) = @_;
+ $todecode =~ tr/+/ /; # pluses become spaces
+ $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
+ return $todecode;
+}
+
+# URL-encode data
+sub escape {
+ my($toencode) = @_;
+ $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
+ return $toencode;
+}
+
+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
+ foreach (@QUERY_PARAM) {
+ $QUERY_PARAM{$_}=$self->{$_};
+ }
+}
+
+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 parse_params {
+ my($self,$tosplit) = @_;
+ my(@pairs) = split('&',$tosplit);
+ my($param,$value);
+ foreach (@pairs) {
+ ($param,$value) = split('=');
+ $param = &unescape($param);
+ $value = &unescape($value);
+ $self->add_parameter($param);
+ push (@{$self->{$param}},$value);
+ }
+}
+
+sub add_parameter {
+ my($self,$param)=@_;
+ push (@{$self->{'.parameters'}},$param)
+ unless defined($self->{$param});
+}
+
+sub all_parameters {
+ my $self = shift;
+ return () unless defined($self) && $self->{'.parameters'};
+ return () unless @{$self->{'.parameters'}};
+ return @{$self->{'.parameters'}};
+}
+
+
+
+#### Method as_string
+#
+# synonym for "dump"
+####
+sub as_string {
+ &dump(@_);
+}
+
+sub AUTOLOAD {
+ print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
+ my($func) = $AUTOLOAD;
+ my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
+ $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
+ unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
+
+ my($sub) = \%{"$pack\:\:SUBS"};
+ unless (%$sub) {
+ my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
+ eval "package $pack; $$auto";
+ die $@ if $@;
+ }
+ my($code) = $sub->{$func_name};
+
+ $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
+ if (!$code) {
+ if ($EXPORT{':any'} ||
+ $EXPORT{$func_name} ||
+ (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
+ && $EXPORT_OK{$func_name}) {
+ $code = $sub->{'HTML_FUNC'};
+ $code=~s/func_name/$func_name/mg;
+ }
+ }
+ die "Undefined subroutine $AUTOLOAD\n" unless $code;
+ eval "package $pack; $code";
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ die $@;
+ }
+ goto &{"$pack\:\:$func_name"};
+}
+
+# PRIVATE SUBROUTINE
+# Smart rearrangement of parameters to allow named parameter
+# calling. We do the rearangement if:
+# 1. The first parameter begins with a -
+# 2. The use_named_parameters() method returns true
+sub rearrange {
+ my($self,$order,@param) = @_;
+ return () unless @param;
+
+ return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-')
+ || $self->use_named_parameters;
+
+ my $i;
+ for ($i=0;$i<@param;$i+=2) {
+ $param[$i]=~s/^\-//; # get rid of initial - if present
+ $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
+ }
+
+ my(%param) = @param; # convert into associative array
+ my(@return_array);
+
+ my($key)='';
+ foreach $key (@$order) {
+ my($value);
+ # this is an awful hack to fix spurious warnings when the
+ # -w switch is set.
+ if (ref($key) && ref($key) eq 'ARRAY') {
+ foreach (@$key) {
+ last if defined($value);
+ $value = $param{$_};
+ delete $param{$_};
+ }
+ } else {
+ $value = $param{$key};
+ delete $param{$key};
+ }
+ push(@return_array,$value);
+ }
+ push (@return_array,$self->make_attributes(\%param)) if %param;
+ return (@return_array);
+}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+
+%SUBS = (
+
+'URL_ENCODED'=> <<'END_OF_FUNC',
+sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
+END_OF_FUNC
+
+'MULTIPART' => <<'END_OF_FUNC',
+sub MULTIPART { 'multipart/form-data'; }
+END_OF_FUNC
+
+'HTML_FUNC' => <<'END_OF_FUNC',
+sub func_name {
+
+ # handle various cases in which we're called
+ # most of this bizarre stuff is to avoid -w errors
+ shift if $_[0] &&
+ (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) ||
+ (ref($_[0]) &&
+ (substr(ref($_[0]),0,3) eq 'CGI' ||
+ eval "\$_[0]->isaCGI()"));
+
+ my($attr) = '';
+ if (ref($_[0]) && ref($_[0]) eq 'HASH') {
+ my(@attr) = CGI::make_attributes('',shift);
+ $attr = " @attr" if @attr;
+ }
+ my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E");
+ return $tag unless @_;
+ if (ref($_[0]) eq 'ARRAY') {
+ my(@r);
+ foreach (@{$_[0]}) {
+ push(@r,"$tag$_$untag");
+ }
+ return "@r";
+ } else {
+ return "$tag@_$untag";
+ }
+}
+END_OF_FUNC
+
+#### 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.
+####
+'keywords' => <<'END_OF_FUNC',
+sub keywords {
+ my($self,@values) = self_or_default(@_);
+ # If values is provided, then we set it.
+ $self->{'keywords'}=[@values] if @values;
+ my(@result) = @{$self->{'keywords'}};
+ @result;
+}
+END_OF_FUNC
+
+# These are some tie() interfaces for compatibility
+# with Steve Brenner's cgi-lib.pl routines
+'ReadParse' => <<'END_OF_FUNC',
+sub ReadParse {
+ local(*in);
+ if (@_) {
+ *in = $_[0];
+ } else {
+ my $pkg = caller();
+ *in=*{"${pkg}::in"};
+ }
+ tie(%in,CGI);
+}
+END_OF_FUNC
+
+'PrintHeader' => <<'END_OF_FUNC',
+sub PrintHeader {
+ my($self) = self_or_default(@_);
+ return $self->header();
+}
+END_OF_FUNC
+
+'HtmlTop' => <<'END_OF_FUNC',
+sub HtmlTop {
+ my($self,@p) = self_or_default(@_);
+ return $self->start_html(@p);
+}
+END_OF_FUNC
+
+'HtmlBot' => <<'END_OF_FUNC',
+sub HtmlBot {
+ my($self,@p) = self_or_default(@_);
+ return $self->end_html(@p);
+}
+END_OF_FUNC
+
+'SplitParam' => <<'END_OF_FUNC',
+sub SplitParam {
+ my ($param) = @_;
+ my (@params) = split ("\0", $param);
+ return (wantarray ? @params : $params[0]);
+}
+END_OF_FUNC
+
+'MethGet' => <<'END_OF_FUNC',
+sub MethGet {
+ return request_method() eq 'GET';
+}
+END_OF_FUNC
+
+'MethPost' => <<'END_OF_FUNC',
+sub MethPost {
+ return request_method() eq 'POST';
+}
+END_OF_FUNC
+
+'TIEHASH' => <<'END_OF_FUNC',
+sub TIEHASH {
+ return new CGI;
+}
+END_OF_FUNC
+
+'STORE' => <<'END_OF_FUNC',
+sub STORE {
+ $_[0]->param($_[1],split("\0",$_[2]));
+}
+END_OF_FUNC
+
+'FETCH' => <<'END_OF_FUNC',
+sub FETCH {
+ return $_[0] if $_[1] eq 'CGI';
+ return undef unless defined $_[0]->param($_[1]);
+ return join("\0",$_[0]->param($_[1]));
+}
+END_OF_FUNC
+
+'FIRSTKEY' => <<'END_OF_FUNC',
+sub FIRSTKEY {
+ $_[0]->{'.iterator'}=0;
+ $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
+}
+END_OF_FUNC
+
+'NEXTKEY' => <<'END_OF_FUNC',
+sub NEXTKEY {
+ $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
+}
+END_OF_FUNC
+
+'EXISTS' => <<'END_OF_FUNC',
+sub EXISTS {
+ exists $_[0]->{$_[1]};
+}
+END_OF_FUNC
+
+'DELETE' => <<'END_OF_FUNC',
+sub DELETE {
+ $_[0]->delete($_[1]);
+}
+END_OF_FUNC
+
+'CLEAR' => <<'END_OF_FUNC',
+sub CLEAR {
+ %{$_[0]}=();
+}
+####
+END_OF_FUNC
+
+####
+# Append a new value to an existing query
+####
+'append' => <<'EOF',
+sub append {
+ my($self,@p) = @_;
+ my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
+ my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
+ if (@values) {
+ $self->add_parameter($name);
+ push(@{$self->{$name}},@values);
+ }
+ return $self->param($name);
+}
+EOF
+
+#### Method: delete_all
+# Delete all parameters
+####
+'delete_all' => <<'EOF',
+sub delete_all {
+ my($self) = self_or_default(@_);
+ undef %{$self};
+}
+EOF
+
+#### Method: autoescape
+# If you want to turn off the autoescaping features,
+# call this method with undef as the argument
+'autoEscape' => <<'END_OF_FUNC',
+sub autoEscape {
+ my($self,$escape) = self_or_default(@_);
+ $self->{'dontescape'}=!$escape;
+}
+END_OF_FUNC
+
+
+#### Method: version
+# Return the current version
+####
+'version' => <<'END_OF_FUNC',
+sub version {
+ return $VERSION;
+}
+END_OF_FUNC
+
+'make_attributes' => <<'END_OF_FUNC',
+sub make_attributes {
+ my($self,$attr) = @_;
+ return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
+ my(@att);
+ foreach (keys %{$attr}) {
+ my($key) = $_;
+ $key=~s/^\-//; # get rid of initial - if present
+ $key=~tr/a-z/A-Z/; # parameters are upper case
+ push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
+ }
+ return @att;
+}
+END_OF_FUNC
+
+#### Method: dump
+# Returns a string in which all the known parameter/value
+# pairs are represented as nested lists, mainly for the purposes
+# of debugging.
+####
+'dump' => <<'END_OF_FUNC',
+sub dump {
+ my($self) = self_or_default(@_);
+ my($param,$value,@result);
+ return '<UL></UL>' unless $self->param;
+ push(@result,"<UL>");
+ foreach $param ($self->param) {
+ my($name)=$self->escapeHTML($param);
+ push(@result,"<LI><STRONG>$param</STRONG>");
+ push(@result,"<UL>");
+ foreach $value ($self->param($param)) {
+ $value = $self->escapeHTML($value);
+ push(@result,"<LI>$value");
+ }
+ push(@result,"</UL>");
+ }
+ push(@result,"</UL>\n");
+ return join("\n",@result);
+}
+END_OF_FUNC
+
+
+#### 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
+####
+'save' => <<'END_OF_FUNC',
+sub save {
+ my($self,$filehandle) = self_or_default(@_);
+ my($param);
+ my($package) = caller;
+# Check that this still works!
+# $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
+ $filehandle = to_filehandle($filehandle);
+ foreach $param ($self->param) {
+ my($escaped_param) = &escape($param);
+ my($value);
+ foreach $value ($self->param($param)) {
+ print $filehandle "$escaped_param=",escape($value),"\n";
+ }
+ }
+ print $filehandle "=\n"; # end of record
+}
+END_OF_FUNC
+
+
+#### Method: header
+# Return a Content-Type: style header
+#
+####
+'header' => <<'END_OF_FUNC',
+sub header {
+ my($self,@p) = self_or_default(@_);
+ my(@header);
+
+ my($type,$status,$cookie,$target,$expires,$nph,@other) =
+ $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ foreach (@other) {
+ next unless my($header,$value) = /([^\s=]+)=(.+)/;
+ substr($header,1,1000)=~tr/A-Z/a-z/;
+ ($value)=$value=~/^"(.*)"$/;
+ $_ = "$header: $value";
+ }
+
+ $type = $type || 'text/html';
+
+ push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH;
+ push(@header,"Status: $status") if $status;
+ push(@header,"Window-target: $target") if $target;
+ # push all the cookies -- there may be several
+ if ($cookie) {
+ my(@cookie) = ref($cookie) ? @{$cookie} : $cookie;
+ foreach (@cookie) {
+ push(@header,"Set-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)) if $expires;
+ push(@header,"Date: " . &expires(0)) if $expires;
+ push(@header,"Pragma: no-cache") if $self->cache();
+ push(@header,@other);
+ push(@header,"Content-type: $type");
+
+ my $header = join($CRLF,@header);
+ return $header . "${CRLF}${CRLF}";
+}
+END_OF_FUNC
+
+
+#### Method: cache
+# Control whether header() will produce the no-cache
+# Pragma directive.
+####
+'cache' => <<'END_OF_FUNC',
+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'};
+}
+END_OF_FUNC
+
+
+#### Method: redirect
+# Return a Location: style header
+#
+####
+'redirect' => <<'END_OF_FUNC',
+sub redirect {
+ my($self,@p) = self_or_default(@_);
+ my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
+ $url = $url || $self->self_url;
+ my(@o);
+ foreach (@other) { push(@o,split("=")); }
+ push(@o,
+ '-Status'=>'302 Found',
+ '-Location'=>$url,
+ '-URI'=>$url,
+ '-nph'=>($nph||$NPH));
+ push(@o,'-Target'=>$target) if $target;
+ push(@o,'-Cookie'=>$cookie) if $cookie;
+ return $self->header(@o);
+}
+END_OF_FUNC
+
+
+#### 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)
+# $meta -> (optional) Meta information tags
+# @other -> (optional) any other named parameters you'd like to incorporate into
+# the <BODY> tag.
+####
+'start_html' => <<'END_OF_FUNC',
+sub start_html {
+ my($self,@p) = &self_or_default(@_);
+ my($title,$author,$base,$xbase,$script,$target,$meta,@other) =
+ $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,TARGET,META],@p);
+
+ # strangely enough, the title needs to be escaped as HTML
+ # while the author needs to be escaped as a URL
+ $title = $self->escapeHTML($title || 'Untitled Document');
+ $author = $self->escapeHTML($author);
+ my(@result);
+ push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
+ push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
+ push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author;
+
+ if ($base || $xbase || $target) {
+ my $href = $xbase || $self->url();
+ my $t = $target ? qq/ TARGET="$target"/ : '';
+ push(@result,qq/<BASE HREF="$href"$t>/);
+ }
+
+ if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
+ foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
+ }
+ push(@result,<<END) if $script;
+<SCRIPT>
+<!-- Hide script from HTML-compliant browsers
+$script
+// End script hiding. -->
+</SCRIPT>
+END
+ ;
+ my($other) = @other ? " @other" : '';
+ push(@result,"</HEAD><BODY$other>");
+ return join("\n",@result);
+}
+END_OF_FUNC
+
+
+#### Method: end_html
+# End an HTML document.
+# Trivial method for completeness. Just returns "</BODY>"
+####
+'end_html' => <<'END_OF_FUNC',
+sub end_html {
+ return "</BODY></HTML>";
+}
+END_OF_FUNC
+
+
+################################
+# METHODS USED IN BUILDING FORMS
+################################
+
+#### Method: isindex
+# Just prints out the isindex tag.
+# Parameters:
+# $action -> optional URL of script to run
+# Returns:
+# A string containing a <ISINDEX> tag
+'isindex' => <<'END_OF_FUNC',
+sub isindex {
+ my($self,@p) = self_or_default(@_);
+ my($action,@other) = $self->rearrange([ACTION],@p);
+ $action = qq/ACTION="$action"/ if $action;
+ my($other) = @other ? " @other" : '';
+ return "<ISINDEX $action$other>";
+}
+END_OF_FUNC
+
+
+#### Method: startform
+# 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)
+'startform' => <<'END_OF_FUNC',
+sub startform {
+ my($self,@p) = self_or_default(@_);
+
+ my($method,$action,$enctype,@other) =
+ $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
+
+ $method = $method || 'POST';
+ $enctype = $enctype || &URL_ENCODED;
+ $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
+ 'ACTION="'.$self->script_name.'"' : '';
+ my($other) = @other ? " @other" : '';
+ $self->{'.parametersToAdd'}={};
+ return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
+}
+END_OF_FUNC
+
+
+#### Method: start_form
+# synonym for startform
+'start_form' => <<'END_OF_FUNC',
+sub start_form {
+ &startform;
+}
+END_OF_FUNC
+
+
+#### Method: start_multipart_form
+# synonym for startform
+'start_multipart_form' => <<'END_OF_FUNC',
+sub start_multipart_form {
+ my($self,@p) = self_or_default(@_);
+ if ($self->use_named_parameters ||
+ (defined($param[0]) && substr($param[0],0,1) eq '-')) {
+ my(%p) = @p;
+ $p{'-enctype'}=&MULTIPART;
+ return $self->startform(%p);
+ } else {
+ my($method,$action,@other) =
+ $self->rearrange([METHOD,ACTION],@p);
+ return $self->startform($method,$action,&MULTIPART,@other);
+ }
+}
+END_OF_FUNC
+
+
+#### Method: endform
+# End a form
+'endform' => <<'END_OF_FUNC',
+sub endform {
+ my($self,@p) = self_or_default(@_);
+ return ($self->get_fields,"</FORM>");
+}
+END_OF_FUNC
+
+
+#### Method: end_form
+# synonym for endform
+'end_form' => <<'END_OF_FUNC',
+sub end_form {
+ &endform;
+}
+END_OF_FUNC
+
+
+#### Method: textfield
+# Parameters:
+# $name -> Name of the text field
+# $default -> Optional default value of the field if not
+# already defined.
+# $size -> Optional width of field in characaters.
+# $maxlength -> Optional maximum number of characters.
+# Returns:
+# A string containing a <INPUT TYPE="text"> field
+#
+'textfield' => <<'END_OF_FUNC',
+sub textfield {
+ my($self,@p) = self_or_default(@_);
+ my($name,$default,$size,$maxlength,$override,@other) =
+ $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+
+ my $current = $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ my($s) = defined($size) ? qq/ SIZE=$size/ : '';
+ my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: filefield
+# Parameters:
+# $name -> Name of the file upload field
+# $size -> Optional width of field in characaters.
+# $maxlength -> Optional maximum number of characters.
+# Returns:
+# A string containing a <INPUT TYPE="text"> field
+#
+'filefield' => <<'END_OF_FUNC',
+sub filefield {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$default,$size,$maxlength,$override,@other) =
+ $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+
+ $current = $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ my($s) = defined($size) ? qq/ SIZE=$size/ : '';
+ my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ $other = ' ' . join(" ",@other);
+ return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: password
+# Create a "secret password" entry field
+# Parameters:
+# $name -> Name of the field
+# $default -> Optional default value of the field if not
+# already defined.
+# $size -> Optional width of field in characters.
+# $maxlength -> Optional maximum characters that can be entered.
+# Returns:
+# A string containing a <INPUT TYPE="password"> field
+#
+'password_field' => <<'END_OF_FUNC',
+sub password_field {
+ my ($self,@p) = self_or_default(@_);
+
+ my($name,$default,$size,$maxlength,$override,@other) =
+ $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+
+ my($current) = $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ my($s) = defined($size) ? qq/ SIZE=$size/ : '';
+ my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: textarea
+# Parameters:
+# $name -> Name of the text field
+# $default -> Optional default value of the field if not
+# already defined.
+# $rows -> Optional number of rows in text area
+# $columns -> Optional number of columns in text area
+# Returns:
+# A string containing a <TEXTAREA></TEXTAREA> tag
+#
+'textarea' => <<'END_OF_FUNC',
+sub textarea {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$default,$rows,$cols,$override,@other) =
+ $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
+
+ my($current)= $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ my($r) = $rows ? " ROWS=$rows" : '';
+ my($c) = $cols ? " COLS=$cols" : '';
+ my($other) = @other ? " @other" : '';
+ return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
+}
+END_OF_FUNC
+
+
+#### Method: button
+# Create a javascript button.
+# Parameters:
+# $name -> (optional) Name for the button. (-name)
+# $value -> (optional) Value of the button when selected (and visible name) (-value)
+# $onclick -> (optional) Text of the JavaScript to run when the button is
+# clicked.
+# Returns:
+# A string containing a <INPUT TYPE="button"> tag
+####
+'button' => <<'END_OF_FUNC',
+sub button {
+ my($self,@p) = self_or_default(@_);
+
+ my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
+ [ONCLICK,SCRIPT]],@p);
+
+ $label=$self->escapeHTML($label);
+ $value=$self->escapeHTML($value);
+ $script=$self->escapeHTML($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" : '';
+ return qq/<INPUT TYPE="button"$name$val$script$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: submit
+# Create a "submit query" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# $value -> (optional) Value of the button when selected (also doubles as label).
+# $label -> (optional) Label printed on the button(also doubles as the value).
+# Returns:
+# A string containing a <INPUT TYPE="submit"> tag
+####
+'submit' => <<'END_OF_FUNC',
+sub submit {
+ my($self,@p) = self_or_default(@_);
+
+ my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
+
+ $label=$self->escapeHTML($label);
+ $value=$self->escapeHTML($value);
+
+ my($name) = ' NAME=".submit"';
+ $name = qq/ NAME="$label"/ if $label;
+ $value = $value || $label;
+ my($val) = '';
+ $val = qq/ VALUE="$value"/ if defined($value);
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="submit"$name$val$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: reset
+# Create a "reset" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# Returns:
+# A string containing a <INPUT TYPE="reset"> tag
+####
+'reset' => <<'END_OF_FUNC',
+sub reset {
+ my($self,@p) = self_or_default(@_);
+ my($label,@other) = $self->rearrange([NAME],@p);
+ $label=$self->escapeHTML($label);
+ my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="reset"$value$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: defaults
+# Create a "defaults" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# Returns:
+# A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
+#
+# Note: this button has a special meaning to the initialization script,
+# and tells it to ERASE the current query string so that your defaults
+# are used again!
+####
+'defaults' => <<'END_OF_FUNC',
+sub defaults {
+ my($self,@p) = self_or_default(@_);
+
+ my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
+
+ $label=$self->escapeHTML($label);
+ $label = $label || "Defaults";
+ my($value) = qq/ VALUE="$label"/;
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: checkbox
+# Create a checkbox that is not logically linked to any others.
+# The field value is "on" when the button is checked.
+# Parameters:
+# $name -> Name of the checkbox
+# $checked -> (optional) turned on by default if true
+# $value -> (optional) value of the checkbox, 'on' by default
+# $label -> (optional) a user-readable label printed next to the box.
+# Otherwise the checkbox name is used.
+# Returns:
+# A string containing a <INPUT TYPE="checkbox"> field
+####
+'checkbox' => <<'END_OF_FUNC',
+sub checkbox {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$checked,$value,$label,$override,@other) =
+ $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
+
+ if (!$override && defined($self->param($name))) {
+ $value = $self->param($name) unless defined $value;
+ $checked = $self->param($name) eq $value ? ' CHECKED' : '';
+ } else {
+ $checked = $checked ? ' CHECKED' : '';
+ $value = defined $value ? $value : 'on';
+ }
+ my($the_label) = defined $label ? $label : $name;
+ $name = $self->escapeHTML($name);
+ $value = $self->escapeHTML($value);
+ $the_label = $self->escapeHTML($the_label);
+ my($other) = @other ? " @other" : '';
+ $self->register_parameter($name);
+ return <<END;
+<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
+END
+}
+END_OF_FUNC
+
+
+#### 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 an associative array 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 <INPUT TYPE="checkbox"> fields
+####
+'checkbox_group' => <<'END_OF_FUNC',
+sub checkbox_group {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
+ $rowheaders,$colheaders,$override,$nolabels,@other) =
+ $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
+ ROWHEADERS,COLHEADERS,
+ [OVERRIDE,FORCE],NOLABELS],@p);
+
+ my($checked,$break,$result,$label);
+
+ my(%checked) = $self->previous_or_default($name,$defaults,$override);
+
+ $break = $linebreak ? "<BR>" : '';
+ $name=$self->escapeHTML($name);
+
+ # Create the elements
+ my(@elements);
+ my(@values) = $values ? @$values : $self->param($name);
+ my($other) = @other ? " @other" : '';
+ foreach (@values) {
+ $checked = $checked{$_} ? ' CHECKED' : '';
+ $label = '';
+ unless (defined($nolabels) && $nolabels) {
+ $label = $_;
+ $label = $labels->{$_} if defined($labels) && $labels->{$_};
+ $label = $self->escapeHTML($label);
+ }
+ $_ = $self->escapeHTML($_);
+ push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/);
+ }
+ $self->register_parameter($name);
+ return wantarray ? @elements : join('',@elements) unless $columns;
+ return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
+}
+END_OF_FUNC
+
+
+# Escape HTML -- used internally
+'escapeHTML' => <<'END_OF_FUNC',
+sub escapeHTML {
+ my($self,$toencode) = @_;
+ return undef unless defined($toencode);
+ return $toencode if $self->{'dontescape'};
+ $toencode=~s/&/&amp;/g;
+ $toencode=~s/\"/&quot;/g;
+ $toencode=~s/>/&gt;/g;
+ $toencode=~s/</&lt;/g;
+ return $toencode;
+}
+END_OF_FUNC
+
+
+# Internal procedure - don't use
+'_tableize' => <<'END_OF_FUNC',
+sub _tableize {
+ my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
+ my($result);
+
+ $rows = int(0.99 + @elements/$columns) unless $rows;
+ # rearrange into a pretty table
+ $result = "<TABLE>";
+ my($row,$column);
+ unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
+ $result .= "<TR>" if @{$colheaders};
+ foreach (@{$colheaders}) {
+ $result .= "<TH>$_</TH>";
+ }
+ for ($row=0;$row<$rows;$row++) {
+ $result .= "<TR>";
+ $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
+ for ($column=0;$column<$columns;$column++) {
+ $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>";
+ }
+ $result .= "</TR>";
+ }
+ $result .= "</TABLE>";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### 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 an associative array 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 <INPUT TYPE="radio"> fields
+####
+'radio_group' => <<'END_OF_FUNC',
+sub radio_group {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$values,$default,$linebreak,$labels,
+ $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
+ $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
+ ROWS,[COLUMNS,COLS],
+ ROWHEADERS,COLHEADERS,
+ [OVERRIDE,FORCE],NOLABELS],@p);
+ my($result,$checked);
+
+ if (!$override && defined($self->param($name))) {
+ $checked = $self->param($name);
+ } else {
+ $checked = $default;
+ }
+ # If no check array is specified, check the first by default
+ $checked = $values->[0] unless $checked;
+ $name=$self->escapeHTML($name);
+
+ my(@elements);
+ my(@values) = $values ? @$values : $self->param($name);
+ my($other) = @other ? " @other" : '';
+ foreach (@values) {
+ my($checkit) = $checked eq $_ ? ' CHECKED' : '';
+ my($break) = $linebreak ? '<BR>' : '';
+ my($label)='';
+ unless (defined($nolabels) && $nolabels) {
+ $label = $_;
+ $label = $labels->{$_} if defined($labels) && $labels->{$_};
+ $label = $self->escapeHTML($label);
+ }
+ $_=$self->escapeHTML($_);
+ push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/);
+ }
+ $self->register_parameter($name);
+ return wantarray ? @elements : join('',@elements) unless $columns;
+ return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
+}
+END_OF_FUNC
+
+
+#### 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 an associative array 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.
+####
+'popup_menu' => <<'END_OF_FUNC',
+sub popup_menu {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$values,$default,$labels,$override,@other) =
+ $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
+ my($result,$selected);
+
+ if (!$override && defined($self->param($name))) {
+ $selected = $self->param($name);
+ } else {
+ $selected = $default;
+ }
+ $name=$self->escapeHTML($name);
+ my($other) = @other ? " @other" : '';
+
+ my(@values) = $values ? @$values : $self->param($name);
+ $result = qq/<SELECT NAME="$name"$other>\n/;
+ foreach (@values) {
+ my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && $labels->{$_};
+ my($value) = $self->escapeHTML($_);
+ $label=$self->escapeHTML($label);
+ $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
+ }
+
+ $result .= "</SELECT>\n";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### 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 an associative array 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.
+####
+'scrolling_list' => <<'END_OF_FUNC',
+sub scrolling_list {
+ my($self,@p) = self_or_default(@_);
+ my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
+ = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
+
+ my($result);
+ my(@values) = $values ? @$values : $self->param($name);
+ $size = $size || scalar(@values);
+
+ my(%selected) = $self->previous_or_default($name,$defaults,$override);
+ my($is_multiple) = $multiple ? ' MULTIPLE' : '';
+ my($has_size) = $size ? " SIZE=$size" : '';
+ my($other) = @other ? " @other" : '';
+
+ $name=$self->escapeHTML($name);
+ $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
+ foreach (@values) {
+ my($selectit) = $selected{$_} ? 'SELECTED' : '';
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && $labels->{$_};
+ $label=$self->escapeHTML($label);
+ my($value)=$self->escapeHTML($_);
+ $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
+ }
+ $result .= "</SELECT>\n";
+ $self->register_parameter($name);
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: hidden
+# Parameters:
+# $name -> Name of the hidden field
+# @default -> (optional) Initial values of field (may be an array)
+# or
+# $default->[initial values of field]
+# Returns:
+# A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
+####
+'hidden' => <<'END_OF_FUNC',
+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) =
+ $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
+
+ my $do_override = 0;
+ if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
+ @value = ref($default) ? @{$default} : $default;
+ $do_override = $override;
+ } else {
+ foreach ($default,$override,@other) {
+ push(@value,$_) if defined($_);
+ }
+ }
+
+ # use previous values if override is not set
+ my @prev = $self->param($name);
+ @value = @prev if !$do_override && @prev;
+
+ $name=$self->escapeHTML($name);
+ foreach (@value) {
+ $_=$self->escapeHTML($_);
+ push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
+ }
+ return wantarray ? @result : join('',@result);
+}
+END_OF_FUNC
+
+
+#### Method: image_button
+# Parameters:
+# $name -> Name of the button
+# $src -> URL of the image source
+# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
+# Returns:
+# A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
+####
+'image_button' => <<'END_OF_FUNC',
+sub image_button {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$src,$alignment,@other) =
+ $self->rearrange([NAME,SRC,ALIGN],@p);
+
+ my($align) = $alignment ? " ALIGN=\U$alignment" : '';
+ my($other) = @other ? " @other" : '';
+ $name=$self->escapeHTML($name);
+ return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
+}
+END_OF_FUNC
+
+
+#### 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.
+####
+'self_url' => <<'END_OF_FUNC',
+sub self_url {
+ my($self) = self_or_default(@_);
+ my($query_string) = $self->query_string;
+ my $protocol = $self->protocol();
+ my $name = "$protocol://" . $self->server_name;
+ $name .= ":" . $self->server_port
+ unless $self->server_port == 80;
+ $name .= $self->script_name;
+ $name .= $self->path_info if $self->path_info;
+ return $name unless $query_string;
+ return "$name?$query_string";
+}
+END_OF_FUNC
+
+
+# This is provided as a synonym to self_url() for people unfortunate
+# enough to have incorporated it into their programs already!
+'state' => <<'END_OF_FUNC',
+sub state {
+ &self_url;
+}
+END_OF_FUNC
+
+
+#### Method: url
+# Like self_url, but doesn't return the query string part of
+# the URL.
+####
+'url' => <<'END_OF_FUNC',
+sub url {
+ my($self) = self_or_default(@_);
+ my $protocol = $self->protocol();
+ my $name = "$protocol://" . $self->server_name;
+ $name .= ":" . $self->server_port
+ unless $self->server_port == 80;
+ $name .= $self->script_name;
+ return $name;
+}
+
+END_OF_FUNC
+
+#### 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-YY HH:MM:SS GMT (optional)
+####
+'cookie' => <<'END_OF_FUNC',
+# temporary, for debugging.
+sub cookie {
+ my($self,@p) = self_or_default(@_);
+ my($name,$value,$path,$domain,$secure,$expires) =
+ $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
+
+
+ # if no value is supplied, then we retrieve the
+ # value of the cookie, if any. For efficiency, we cache the parsed
+ # cookie in our state variables.
+ unless (defined($value)) {
+ unless ($self->{'.cookies'}) {
+ my(@pairs) = split("; ",$self->raw_cookie);
+ foreach (@pairs) {
+ my($key,$value) = split("=");
+ my(@values) = map unescape($_),split('&',$value);
+ $self->{'.cookies'}->{unescape($key)} = [@values];
+ }
+ }
+
+ # If no name is supplied, then retrieve the names of all our cookies.
+ return () unless $self->{'.cookies'};
+ return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]
+ if defined($name) && $name ne '';
+ return keys %{$self->{'.cookies'}};
+ }
+ my(@values);
+
+ # Pull out our parameters.
+ if (ref($value)) {
+ if (ref($value) eq 'ARRAY') {
+ @values = @$value;
+ } elsif (ref($value) eq 'HASH') {
+ @values = %$value;
+ }
+ } else {
+ @values = ($value);
+ }
+ @values = map escape($_),@values;
+
+ # I.E. requires the path to be present.
+ ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
+
+ my(@constant_values);
+ push(@constant_values,"domain=$domain") if $domain;
+ push(@constant_values,"path=$path") if $path;
+ push(@constant_values,"expires=".&expires($expires)) if $expires;
+ push(@constant_values,'secure') if $secure;
+
+ my($key) = &escape($name);
+ my($cookie) = join("=",$key,join("&",@values));
+ return join("; ",$cookie,@constant_values);
+}
+END_OF_FUNC
+
+
+# This internal routine creates an expires string exactly some number of
+# hours from the current time in GMT. This is the format
+# required by Netscape cookies, and I think it works for the HTTP
+# Expires: header as well.
+'expires' => <<'END_OF_FUNC',
+sub expires {
+ my($time) = @_;
+ my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
+ my(@WDAY) = qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/;
+ my(%mult) = ('s'=>1,
+ 'm'=>60,
+ 'h'=>60*60,
+ 'd'=>60*60*24,
+ 'M'=>60*60*24*30,
+ 'y'=>60*60*24*365);
+ # format for time can be in any of the forms...
+ # "now" -- expire immediately
+ # "+180s" -- in 180 seconds
+ # "+2m" -- in 2 minutes
+ # "+12h" -- in 12 hours
+ # "+1d" -- in 1 day
+ # "+3M" -- in 3 months
+ # "+2y" -- in 2 years
+ # "-3m" -- 3 minutes ago(!)
+ # If you don't supply one of these forms, we assume you are
+ # specifying the date yourself
+ my($offset);
+ if (!$time || ($time eq 'now')) {
+ $offset = 0;
+ } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) {
+ $offset = ($mult{$2} || 1)*$1;
+ } else {
+ return $time;
+ }
+ my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime(time+$offset);
+ $year += 1900 unless $year < 100;
+ return sprintf("%s, %02d-%s-%02d %02d:%02d:%02d GMT",
+ $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
+}
+END_OF_FUNC
+
+
+###############################################
+# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
+###############################################
+
+#### Method: path_info
+# Return the extra virtual path information provided
+# after the URL (if any)
+####
+'path_info' => <<'END_OF_FUNC',
+sub path_info {
+ return $ENV{'PATH_INFO'};
+}
+END_OF_FUNC
+
+
+#### Method: request_method
+# Returns 'POST', 'GET', 'PUT' or 'HEAD'
+####
+'request_method' => <<'END_OF_FUNC',
+sub request_method {
+ return $ENV{'REQUEST_METHOD'};
+}
+END_OF_FUNC
+
+#### Method: path_translated
+# Return the physical path information provided
+# by the URL (if any)
+####
+'path_translated' => <<'END_OF_FUNC',
+sub path_translated {
+ return $ENV{'PATH_TRANSLATED'};
+}
+END_OF_FUNC
+
+
+#### Method: query_string
+# Synthesize a query string from our current
+# parameters
+####
+'query_string' => <<'END_OF_FUNC',
+sub query_string {
+ my($self) = self_or_default(@_);
+ my($param,$value,@pairs);
+ foreach $param ($self->param) {
+ my($eparam) = &escape($param);
+ foreach $value ($self->param($param)) {
+ $value = &escape($value);
+ push(@pairs,"$eparam=$value");
+ }
+ }
+ return join("&",@pairs);
+}
+END_OF_FUNC
+
+
+#### 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.
+####
+'accept' => <<'END_OF_FUNC',
+sub accept {
+ my($self,$search) = self_or_CGI(@_);
+ my(%prefs,$type,$pref,$pat);
+
+ my(@accept) = split(',',$self->http('accept'));
+
+ foreach (@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.
+ foreach (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/;
+ }
+}
+END_OF_FUNC
+
+
+#### 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.
+####
+'user_agent' => <<'END_OF_FUNC',
+sub user_agent {
+ my($self,$match)=self_or_CGI(@_);
+ return $self->http('user_agent') unless $match;
+ return $self->http('user_agent') =~ /$match/i;
+}
+END_OF_FUNC
+
+
+#### Method: cookie
+# Returns the magic cookie for the session.
+# To set the magic cookie for new transations,
+# try print $q->header('-Set-cookie'=>'my cookie')
+####
+'raw_cookie' => <<'END_OF_FUNC',
+sub raw_cookie {
+ my($self) = self_or_CGI(@_);
+ return $self->http('cookie') || $ENV{'COOKIE'} || '';
+}
+END_OF_FUNC
+
+#### Method: virtual_host
+# Return the name of the virtual_host, which
+# is not always the same as the server
+######
+'virtual_host' => <<'END_OF_FUNC',
+sub virtual_host {
+ return http('host') || server_name();
+}
+END_OF_FUNC
+
+#### 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.
+####
+'remote_host' => <<'END_OF_FUNC',
+sub remote_host {
+ return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
+ || 'localhost';
+}
+END_OF_FUNC
+
+
+#### Method: remote_addr
+# Return the IP addr of the remote host.
+####
+'remote_addr' => <<'END_OF_FUNC',
+sub remote_addr {
+ return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
+}
+END_OF_FUNC
+
+
+#### 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.
+####
+'script_name' => <<'END_OF_FUNC',
+sub script_name {
+ return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'};
+ # These are for debugging
+ return "/$0" unless $0=~/^\//;
+ return $0;
+}
+END_OF_FUNC
+
+
+#### Method: referer
+# Return the HTTP_REFERER: useful for generating
+# a GO BACK button.
+####
+'referer' => <<'END_OF_FUNC',
+sub referer {
+ my($self) = self_or_CGI(@_);
+ return $self->http('referer');
+}
+END_OF_FUNC
+
+
+#### Method: server_name
+# Return the name of the server
+####
+'server_name' => <<'END_OF_FUNC',
+sub server_name {
+ return $ENV{'SERVER_NAME'} || 'localhost';
+}
+END_OF_FUNC
+
+#### Method: server_software
+# Return the name of the server software
+####
+'server_software' => <<'END_OF_FUNC',
+sub server_software {
+ return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
+}
+END_OF_FUNC
+
+#### Method: server_port
+# Return the tcp/ip port the server is running on
+####
+'server_port' => <<'END_OF_FUNC',
+sub server_port {
+ return $ENV{'SERVER_PORT'} || 80; # for debugging
+}
+END_OF_FUNC
+
+#### Method: server_protocol
+# Return the protocol (usually HTTP/1.0)
+####
+'server_protocol' => <<'END_OF_FUNC',
+sub server_protocol {
+ return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
+}
+END_OF_FUNC
+
+#### Method: http
+# Return the value of an HTTP variable, or
+# the list of variables if none provided
+####
+'http' => <<'END_OF_FUNC',
+sub http {
+ my ($self,$parameter) = self_or_CGI(@_);
+ return $ENV{$parameter} if $parameter=~/^HTTP/;
+ return $ENV{"HTTP_\U$parameter\E"} if $parameter;
+ my(@p);
+ foreach (keys %ENV) {
+ push(@p,$_) if /^HTTP/;
+ }
+ return @p;
+}
+END_OF_FUNC
+
+#### Method: https
+# Return the value of HTTPS
+####
+'https' => <<'END_OF_FUNC',
+sub https {
+ local($^W)=0;
+ my ($self,$parameter) = self_or_CGI(@_);
+ return $ENV{HTTPS} unless $parameter;
+ return $ENV{$parameter} if $parameter=~/^HTTPS/;
+ return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
+ my(@p);
+ foreach (keys %ENV) {
+ push(@p,$_) if /^HTTPS/;
+ }
+ return @p;
+}
+END_OF_FUNC
+
+#### Method: protocol
+# Return the protocol (http or https currently)
+####
+'protocol' => <<'END_OF_FUNC',
+sub protocol {
+ local($^W)=0;
+ my $self = shift;
+ return 'https' if $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";
+}
+END_OF_FUNC
+
+#### Method: remote_ident
+# Return the identity of the remote user
+# (but only if his host is running identd)
+####
+'remote_ident' => <<'END_OF_FUNC',
+sub remote_ident {
+ return $ENV{'REMOTE_IDENT'};
+}
+END_OF_FUNC
+
+
+#### Method: auth_type
+# Return the type of use verification/authorization in use, if any.
+####
+'auth_type' => <<'END_OF_FUNC',
+sub auth_type {
+ return $ENV{'AUTH_TYPE'};
+}
+END_OF_FUNC
+
+
+#### Method: remote_user
+# Return the authorization name used for user
+# verification.
+####
+'remote_user' => <<'END_OF_FUNC',
+sub remote_user {
+ return $ENV{'REMOTE_USER'};
+}
+END_OF_FUNC
+
+
+#### Method: user_name
+# Try to return the remote user's name by hook or by
+# crook
+####
+'user_name' => <<'END_OF_FUNC',
+sub user_name {
+ my ($self) = self_or_CGI(@_);
+ return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
+}
+END_OF_FUNC
+
+#### Method: nph
+# Set or return the NPH global flag
+####
+'nph' => <<'END_OF_FUNC',
+sub nph {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::nph = $param if defined($param);
+ return $CGI::nph;
+}
+END_OF_FUNC
+
+# -------------- really private subroutines -----------------
+'previous_or_default' => <<'END_OF_FUNC',
+sub previous_or_default {
+ my($self,$name,$defaults,$override) = @_;
+ my(%selected);
+
+ if (!$override && ($self->{'.fieldnames'}->{$name} ||
+ defined($self->param($name)) ) ) {
+ grep($selected{$_}++,$self->param($name));
+ } elsif (defined($defaults) && ref($defaults) &&
+ (ref($defaults) eq 'ARRAY')) {
+ grep($selected{$_}++,@{$defaults});
+ } else {
+ $selected{$defaults}++ if defined($defaults);
+ }
+
+ return %selected;
+}
+END_OF_FUNC
+
+'register_parameter' => <<'END_OF_FUNC',
+sub register_parameter {
+ my($self,$param) = @_;
+ $self->{'.parametersToAdd'}->{$param}++;
+}
+END_OF_FUNC
+
+'get_fields' => <<'END_OF_FUNC',
+sub get_fields {
+ my($self) = @_;
+ return $self->hidden('-name'=>'.cgifields',
+ '-values'=>[keys %{$self->{'.parametersToAdd'}}],
+ '-override'=>1);
+}
+END_OF_FUNC
+
+'read_from_cmdline' => <<'END_OF_FUNC',
+sub read_from_cmdline {
+ require "shellwords.pl";
+ my($input,@words);
+ my($query_string);
+ if (@ARGV) {
+ $input = join(" ",@ARGV);
+ } else {
+ print STDERR "(offline mode: enter name=value pairs on standard input)\n";
+ chomp(@lines = <>); # remove newlines
+ $input = join(" ",@lines);
+ }
+
+ # minimal handling of escape characters
+ $input=~s/\\=/%3D/g;
+ $input=~s/\\&/%26/g;
+
+ @words = &shellwords($input);
+ if ("@words"=~/=/) {
+ $query_string = join('&',@words);
+ } else {
+ $query_string = join('+',@words);
+ }
+ return $query_string;
+}
+END_OF_FUNC
+
+#####
+# 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.
+#####
+'read_multipart' => <<'END_OF_FUNC',
+sub read_multipart {
+ my($self,$boundary,$length) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
+ return unless $buffer;
+ my(%header,$body);
+ while (!$buffer->eof) {
+ %header = $buffer->readHeader;
+
+ # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition"
+ # Sheesh.
+ my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition';
+ my($param)= $header{$key}=~/ name="([^\"]*)"/;
+
+ # possible bug: our regular expression expects the filename= part to fall
+ # at the end of the line. Netscape doesn't escape quotation marks in file names!!!
+ my($filename) = $header{$key}=~/ filename="(.*)"$/;
+
+ # 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.
+ unless ($filename) {
+ my($value) = $buffer->readBody;
+ push(@{$self->{$param}},$value);
+ next;
+ }
+
+ # 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.
+ my($tmpfile) = new TempFile;
+ my $tmp = $tmpfile->as_string;
+
+ open (OUT,">$tmp") || die "CGI open of $tmpfile: $!\n";
+ $CGI::DefaultClass->binmode(OUT) if $CGI::needs_binmode;
+ chmod 0666,$tmp; # make sure anyone can delete it.
+ my $data;
+ while ($data = $buffer->read) {
+ print OUT $data;
+ }
+ close OUT;
+
+ # Now create a new filehandle in the caller's namespace.
+ # The name of this filehandle just happens to be identical
+ # to the original filename (NOT the name of the temporary
+ # file, which is hidden!)
+ my($filehandle);
+ if ($filename=~/^[a-zA-Z_]/) {
+ my($frame,$cp)=(1);
+ do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()");
+ $filehandle = "$cp\:\:$filename";
+ } else {
+ $filehandle = "\:\:$filename";
+ }
+
+ open($filehandle,$tmp) || die "CGI open of $tmp: $!\n";
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+
+ push(@{$self->{$param}},$filename);
+
+ # Under Unix, it would be safe to let the temporary file
+ # be deleted immediately. However, I fear that other operating
+ # systems are not so forgiving. Therefore we save a reference
+ # to the temporary file in the CGI object so that the file
+ # isn't unlinked until the CGI object itself goes out of
+ # scope. This is a bit hacky, but it has the interesting side
+ # effect that one can access the name of the tmpfile by
+ # asking for $query->{$query->param('foo')}, where 'foo'
+ # is the name of the file upload field.
+ $self->{'.tmpfiles'}->{$filename}= {
+ name=>$tmpfile,
+ info=>{%header}
+ }
+ }
+}
+END_OF_FUNC
+
+'tmpFileName' => <<'END_OF_FUNC',
+sub tmpFileName {
+ my($self,$filename) = self_or_default(@_);
+ return $self->{'.tmpfiles'}->{$filename}->{name}->as_string;
+}
+END_OF_FUNC
+
+'uploadInfo' => <<'END_OF_FUNC'
+sub uploadInfo {
+ my($self,$filename) = self_or_default(@_);
+ return $self->{'.tmpfiles'}->{$filename}->{info};
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+;
+
+# Globals and stubs for other packages that we use
+package MultipartBuffer;
+
+# how many bytes to read at a time. We use
+# a 5K buffer by default.
+$FILLUNIT = 1024 * 5;
+$TIMEOUT = 10*60; # 10 minute timeout
+$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers
+$CRLF=$CGI::CRLF;
+
+#reuse the autoload function
+*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($package,$interface,$boundary,$length,$filehandle) = @_;
+ my $IN;
+ if ($filehandle) {
+ my($package) = caller;
+ # force into caller's package if necessary
+ $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
+ }
+ $IN = "main::STDIN" unless $IN;
+
+ $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
+
+ # 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.
+ if ($boundary) {
+
+ # Under the MIME spec, the boundary consists of the
+ # characters "--" PLUS the Boundary string
+ $boundary = "--$boundary";
+ # Read the topmost (boundary) line plus the CRLF
+ my($null) = '';
+ $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
+
+ } else { # otherwise we find it ourselves
+ my($old);
+ ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
+ $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
+ $length -= length($boundary);
+ chomp($boundary); # remove the CRLF
+ $/ = $old; # restore old line separator
+ }
+
+ my $self = {LENGTH=>$length,
+ BOUNDARY=>$boundary,
+ IN=>$IN,
+ INTERFACE=>$interface,
+ BUFFER=>'',
+ };
+
+ $FILLUNIT = length($boundary)
+ if length($boundary) > $FILLUNIT;
+
+ return bless $self,ref $package || $package;
+}
+END_OF_FUNC
+
+'readHeader' => <<'END_OF_FUNC',
+sub readHeader {
+ my($self) = @_;
+ my($end);
+ my($ok) = 0;
+ do {
+ $self->fillBuffer($FILLUNIT);
+ $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
+ $ok++ if $self->{BUFFER} eq '';
+ $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
+ } until $ok;
+
+ my($header) = substr($self->{BUFFER},0,$end+2);
+ substr($self->{BUFFER},0,$end+4) = '';
+ my %return;
+ while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
+ $return{$1}=$2;
+ }
+ return %return;
+}
+END_OF_FUNC
+
+# This reads and returns the body as a single scalar value.
+'readBody' => <<'END_OF_FUNC',
+sub readBody {
+ my($self) = @_;
+ my($data);
+ my($returnval)='';
+ while (defined($data = $self->read)) {
+ $returnval .= $data;
+ }
+ return $returnval;
+}
+END_OF_FUNC
+
+# 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;
+'read' => <<'END_OF_FUNC',
+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);
+
+ # Find the boundary in the buffer (it may not be there).
+ my $start = index($self->{BUFFER},$self->{BOUNDARY});
+
+ # If the boundary begins the data, then skip past it
+ # and return undef. The +2 here is a fiendish plot to
+ # remove the CR/LF pair at the end of the boundary.
+ if ($start == 0) {
+
+ # clear us out completely if we've hit the last boundary.
+ if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
+ $self->{BUFFER}='';
+ $self->{LENGTH}=0;
+ return undef;
+ }
+
+ # just remove the boundary.
+ substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
+ return undef;
+ }
+
+ my $bytesToReturn;
+ if ($start > 0) { # read up to the boundary
+ $bytesToReturn = $start > $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($self->{BOUNDARY})+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 ($start > 0) ? substr($returnval,0,-2) : $returnval;
+}
+END_OF_FUNC
+
+
+# This fills up our internal buffer in such a way that the
+# boundary is never split between reads
+'fillBuffer' => <<'END_OF_FUNC',
+sub fillBuffer {
+ my($self,$bytes) = @_;
+ return unless $self->{LENGTH};
+
+ my($boundaryLength) = length($self->{BOUNDARY});
+ my($bufferLength) = length($self->{BUFFER});
+ my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
+ $bytesToRead = $self->{LENGTH} if $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->{IN},
+ \$self->{BUFFER},
+ $bytesToRead,
+ $bufferLength);
+
+ # An apparent bug in the Netscape Commerce 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;
+}
+END_OF_FUNC
+
+
+# Return true when we've finished reading
+'eof' => <<'END_OF_FUNC'
+sub eof {
+ my($self) = @_;
+ return 1 if (length($self->{BUFFER}) == 0)
+ && ($self->{LENGTH} <= 0);
+ undef;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+####################################################################################
+################################## TEMPORARY FILES #################################
+####################################################################################
+package TempFile;
+
+$SL = $CGI::SL;
+unless ($TMPDIRECTORY) {
+ @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items");
+ foreach (@TEMP) {
+ do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
+ }
+}
+
+$TMPDIRECTORY = "." unless $TMPDIRECTORY;
+$SEQUENCE="CGItemp${$}0000";
+
+# cute feature, but overload implementation broke it
+# %OVERLOAD = ('""'=>'as_string');
+*TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($package) = @_;
+ $SEQUENCE++;
+ my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}";
+ return bless \$directory;
+}
+END_OF_FUNC
+
+'DESTROY' => <<'END_OF_FUNC',
+sub DESTROY {
+ my($self) = @_;
+ unlink $$self; # get rid of the file
+}
+END_OF_FUNC
+
+'as_string' => <<'END_OF_FUNC'
+sub as_string {
+ my($self) = @_;
+ return $$self;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+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=<<EOF;
+ $CGI::VERSION;
+ $MultipartBuffer::SPIN_LOOP_MAX;
+ $MultipartBuffer::CRLF;
+ $MultipartBuffer::TIMEOUT;
+ $MultipartBuffer::FILLUNIT;
+ $TempFile::SEQUENCE;
+EOF
+ ;
+}
+
+$revision;
+
+__END__
+
+=head1 NAME
+
+CGI - Simple Common Gateway Interface Class
+
+=head1 ABSTRACT
+
+This perl library uses perl5 objects to make it easy to create
+Web fill-out forms and parse their contents. This package
+defines CGI objects, entities that contain the values of the
+current query string and other state variables.
+Using a CGI object's methods, you can examine keywords and parameters
+passed to your script, and create forms whose initial values
+are taken from the current query (thereby preserving state
+information).
+
+The current version of CGI.pm is available at
+
+ http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
+ ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+
+=head1 INSTALLATION:
+
+To install this package, just change to the directory in which this
+file is found and type the following:
+
+ perl Makefile.PL
+ make
+ make install
+
+This will copy CGI.pm to your perl library directory for use by all
+perl scripts. You probably must be root to do this. Now you can
+load the CGI routines in your Perl scripts with the line:
+
+ use CGI;
+
+If you don't have sufficient privileges to install CGI.pm in the Perl
+library directory, you can put CGI.pm into some convenient spot, such
+as your home directory, or in cgi-bin itself and prefix all Perl
+scripts that call it with something along the lines of the following
+preamble:
+
+ use lib '/home/davis/lib';
+ use CGI;
+
+If you are using a version of perl earlier than 5.002 (such as NT perl), use
+this instead:
+
+ BEGIN {
+ unshift(@INC,'/home/davis/lib');
+ }
+ use CGI;
+
+The CGI distribution also comes with a cute module called L<CGI::Carp>.
+It redefines the die(), warn(), confess() and croak() error routines
+so that they write nicely formatted error messages into the server's
+error log (or to the output stream of your choice). This avoids long
+hours of groping through the error and access logs, trying to figure
+out which CGI script is generating error messages. If you choose,
+you can even have fatal error messages echoed to the browser to avoid
+the annoying and uninformative "Server Error" message.
+
+=head1 DESCRIPTION
+
+=head2 CREATING A NEW QUERY OBJECT:
+
+ $query = new CGI;
+
+This will parse the input (from both POST and GET methods) and store
+it into a perl5 object called $query.
+
+=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
+
+ $query = new CGI(INPUTFILE);
+
+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:
+
+ $query = new CGI(\*STDIN);
+
+You can also initialize the query object from an associative array
+reference:
+
+ $query = new CGI( {'dinosaur'=>'barney',
+ 'song'=>'I love you',
+ 'friends'=>[qw/Jessica George Nancy/]}
+ );
+
+or from a properly formatted, URL-escaped query string:
+
+ $query = new CGI('dinosaur=barney&color=purple');
+
+To create an empty query, initialize it from an empty string or hash:
+
+ $empty_query = new CGI("");
+ -or-
+ $empty_query = new CGI({});
+
+=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
+
+ @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:
+
+ @names = $query->param
+
+If the script was invoked with a parameter list
+(e.g. "name1=value1&name2=value2&name3=value3"), the param()
+method will return the parameter names as a list. If the
+script was invoked as an <ISINDEX> script, there will be a
+single parameter named 'keywords'.
+
+NOTE: As of version 1.5, 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:
+
+ @values = $query->param('foo');
+
+ -or-
+
+ $value = $query->param('foo');
+
+Pass the 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.
+
+=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. (Another way is with
+the -override parameter accepted by all methods that generate
+form elements.)
+
+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'.
+WARNING: don't import anything into 'main'; this is a major security
+risk!!!!
+
+In older versions, this method was called B<import()>. As of version 2.20,
+this name has been removed completely to avoid conflict with the built-in
+Perl module B<import> operator.
+
+=head2 DELETING A PARAMETER COMPLETELY:
+
+ $query->delete('foo');
+
+This completely clears a parameter. It sometimes useful for
+resetting parameters that you don't want passed down between
+script invocations.
+
+=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.
+
+=head2 SAVING THE STATE OF THE FORM 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<new>. 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 CGI;
+
+ open (OUT,">>test.out") || die;
+ $records = 5;
+ foreach (0..$records) {
+ my $q = new CGI;
+ $q->param(-name=>'counter',-value=>$_);
+ $q->save(OUT);
+ }
+ close OUT;
+
+ # reopen for reading
+ open (IN,"test.out") || die;
+ while (!eof(IN)) {
+ my $q = new CGI(IN);
+ 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
+
+ http://www.genome.wi.mit.edu/genome_software/other/boulder.html
+
+for further details.
+
+=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
+
+ $myself = $query->self_url;
+ print "<A HREF=$myself>I'm talking to myself.</A>";
+
+self_url() will return a URL, that, when selected, will reinvoke
+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.
+
+ $myself = $query->self_url;
+ print "<A HREF=$myself#table1>See table 1</A>";
+ print "<A HREF=$myself#table2>See table 2</A>";
+ print "<A HREF=$myself#yourself>See for yourself</A>";
+
+If you don't want to get the whole query string, call
+the method url() to return just the URL for the script:
+
+ $myself = $query->url;
+ print "<A HREF=$myself>No query string in this baby!</A>\n";
+
+You can also retrieve the unprocessed query string with query_string():
+
+ $the_string = $query->query_string;
+
+=head2 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:
+
+ $q = $in{CGI};
+ print $q->textfield(-name=>'wow',
+ -value=>'does this really work?');
+
+This allows you to start using the more interesting features
+of CGI.pm without rewriting your old scripts from scratch.
+
+=head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
+
+In versions of CGI.pm prior to 2.0, it could get difficult to remember
+the proper order of arguments in CGI function calls that accepted five
+or six different arguments. As of 2.0, there's a better way to pass
+arguments to the various CGI functions. In this style, you pass a
+series of name=>argument pairs, like this:
+
+ $field = $query->radio_group(-name=>'OS',
+ -values=>[Unix,Windows,Macintosh],
+ -default=>'Unix');
+
+The advantages of this style are that you don't have to remember the
+exact order of the arguments, and if you leave out a parameter, in
+most cases it will default to some reasonable value. If you provide
+a parameter that the method doesn't recognize, it will usually do
+something useful with it, such as incorporating it into the HTML form
+tag. For example if Netscape decides next week to add a new
+JUSTIFICATION parameter to the text field tags, you can start using
+the feature without waiting for a new version of CGI.pm:
+
+ $field = $query->textfield(-name=>'State',
+ -default=>'gaseous',
+ -justification=>'RIGHT');
+
+This will result in an HTML tag that looks like this:
+
+ <INPUT TYPE="textfield" NAME="State" VALUE="gaseous"
+ JUSTIFICATION="RIGHT">
+
+Parameter names are case insensitive: you can use -name, or -Name or
+-NAME. You don't have to use the hyphen if you don't want to. After
+creating a CGI object, call the B<use_named_parameters()> method with
+a nonzero value. This will tell CGI.pm that you intend to use named
+parameters exclusively:
+
+ $query = new CGI;
+ $query->use_named_parameters(1);
+ $field = $query->radio_group('name'=>'OS',
+ 'values'=>['Unix','Windows','Macintosh'],
+ 'default'=>'Unix');
+
+Actually, CGI.pm only looks for a hyphen in the first parameter. So
+you can leave it off subsequent parameters if you like. Something to
+be wary of is the potential that a string constant like "values" will
+collide with a keyword (and in fact it does!) While Perl usually
+figures out when you're referring to a function and when you're
+referring to a string, you probably should put quotation marks around
+all string constants just to play it safe.
+
+=head2 CREATING THE HTTP HEADER:
+
+ print $query->header;
+
+ -or-
+
+ print $query->header('image/gif');
+
+ -or-
+
+ print $query->header('text/html','204 No response');
+
+ -or-
+
+ print $query->header(-type=>'image/gif',
+ -nph=>1,
+ -status=>'402 Payment required',
+ -expires=>'+3d',
+ -cookie=>$cookie,
+ -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. If you want to
+add additional fields to the header, just tack them on to the end:
+
+ print $query->header('text/html','200 OK','Content-Length: 3002');
+
+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
+parameters will be stripped of their initial hyphens and turned into
+header fields, allowing you to specify any HTTP header you desire.
+
+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-96 00:40:33 GMT at the indicated time & date
+
+(CGI::expires() is the static function call used internally that turns
+relative time intervals into HTTP dates. You can call it directly if
+you wish.)
+
+The B<-cookie> parameter generates a header that tells the browser to provide
+a "magic cookie" during all subsequent transactions with your script.
+Netscape 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, such as Microsoft Internet Explorer, which
+expect all their scripts to be NPH.
+
+=head2 GENERATING A REDIRECTION INSTRUCTION
+
+ print $query->redirect('http://somewhere.else/in/movie/land');
+
+redirects the browser elsewhere. If you use redirection like this,
+you should B<not> print out a header as well. As of version 2.0, we
+produce both the unofficial Location: header and the official URI:
+header. This should satisfy most servers and browsers.
+
+One hint I can offer is that relative links may not work correctly
+when when you generate a redirection to another document on your site.
+This is due to a well-intentioned optimization that some servers use.
+The solution to this is to use the full URL (including the http: part)
+of the document you are redirecting to.
+
+You can use named parameters:
+
+ print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
+ -nph=>1);
+
+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 Internet Explorer, which
+expect all their scripts to be NPH.
+
+
+=head2 CREATING THE HTML HEADER:
+
+ print $query->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'},
+ -BGCOLOR=>'blue');
+
+ -or-
+
+ print $query->start_html('Secrets of the Pyramids',
+ 'fred@capricorn.org','true',
+ 'BGCOLOR="blue"');
+
+This will return a canned HTML header and the opening <BODY> tag.
+All parameters are optional. In the named parameter form, recognized
+parameters are -title, -author, -base, -xbase and -target (see below for the
+explanation). Any additional parameters you provide, such as the
+Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag.
+
+The argument B<-xbase> allows you to provide an HREF for the <BASE> 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. See the Netscape
+documentation on frames for details of how to manipulate this.
+
+ -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 an associative array
+containing name/value pairs of meta information. These will be turned
+into a series of header <META> tags that look something like this:
+
+ <META NAME="keywords" CONTENT="pharaoh secret mummy">
+ <META NAME="description" CONTENT="copyright 1996 King Tut">
+
+There is no support for the HTTP-EQUIV type of <META> tag. This is
+because you can modify the HTTP header directly with the B<header()>
+method.
+
+JAVASCRIPTING: The B<-script>, B<-onLoad> and B<-onUnload> parameters
+are used to add Netscape 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 <SCRIPT> block inside
+the HTML (not HTTP) header. The block is placed in the header in
+order to give your page a fighting chance of having all its JavaScript
+functions in place even if the user presses the stop button before the
+page has loaded completely. CGI.pm attempts to format the script in
+such a way that JavaScript-naive browsers will not choke on the code:
+unfortunately there are some browsers, such as Chimera for Unix, that
+get confused by it nevertheless.
+
+The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
+code to execute when the page is respectively opened and closed by the
+browser. Usually these parameters are calls to functions defined in the
+B<-script> field:
+
+ $query = new CGI;
+ print $query->header;
+ $JSCRIPT=<<END;
+ // Ask a silly question
+ function riddle_me_this() {
+ var r = prompt("What walks on four legs in the morning, " +
+ "two legs in the afternoon, " +
+ "and three legs in the evening?");
+ response(r);
+ }
+ // Get a silly answer
+ function response(answer) {
+ if (answer == "man")
+ alert("Right you are!");
+ else
+ alert("Wrong! Guess again.");
+ }
+ END
+ print $query->start_html(-title=>'The Riddle of the Sphinx',
+ -script=>$JSCRIPT);
+
+See
+
+ http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
+
+for more information about JavaScript.
+
+The old-style positional parameters are as follows:
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The title
+
+=item 2.
+
+The author's e-mail address (will create a <LINK REV="MADE"> tag if present
+
+=item 3.
+
+A 'true' flag if you want to include a <BASE> tag in the header. This
+helps resolve relative addresses to absolute ones when the document is moved,
+but makes the document hierarchy non-portable. Use with care!
+
+=item 4, 5, 6...
+
+Any other parameters you want to include in the <BODY> tag. This is a good
+place to put Netscape extensions, such as colors and wallpaper patterns.
+
+=back
+
+=head2 ENDING THE HTML DOCUMENT:
+
+ print $query->end_html
+
+This ends an HTML document by printing the </BODY></HTML> tags.
+
+=head1 CREATING FORMS:
+
+I<General note> The various form-creating methods all return strings
+to the caller, containing the tag or tags that will create the requested
+form element. You are responsible for actually printing out these strings.
+It's set up this way so that you can place formatting tags
+around the form elements.
+
+I<Another note> The default values that you specify for the forms are only
+used the B<first> time the script is invoked (when there is no query
+string). On subsequent invocations of the script (when there is a query
+string), the former values are used even if they are blank.
+
+If you want to change the value of a field from its previous value, you have two
+choices:
+
+(1) call the param() method to set it.
+
+(2) use the -override (alias -force) parameter (a new feature in version 2.15).
+This forces the default value to be used, regardless of the previous value:
+
+ print $query->textfield(-name=>'field_name',
+ -default=>'starting value',
+ -override=>1,
+ -size=>50,
+ -maxlength=>80);
+
+I<Yet another note> By default, the text and labels of form elements are
+escaped according to HTML rules. This means that you can safely use
+"<CLICK ME>" as the label for a button. However, it also interferes with
+your ability to incorporate special HTML character sequences, such as &Aacute;,
+into your fields. If you wish to turn off automatic escaping, call the
+autoEscape() method with a false value immediately after creating the CGI object:
+
+ $query = new CGI;
+ $query->autoEscape(undef);
+
+
+=head2 CREATING AN ISINDEX TAG
+
+ print $query->isindex(-action=>$action);
+
+ -or-
+
+ print $query->isindex($action);
+
+Prints out an <ISINDEX> tag. Not very exciting. The parameter
+-action specifies the URL of the script to process the query. The
+default is to process the query with the current script.
+
+=head2 STARTING AND ENDING A FORM
+
+ print $query->startform(-method=>$method,
+ -action=>$action,
+ -encoding=>$encoding);
+ <... various form stuff ...>
+ print $query->endform;
+
+ -or-
+
+ print $query->startform($method,$action,$encoding);
+ <... various form stuff ...>
+ print $query->endform;
+
+startform() will return a <FORM> tag with the optional method,
+action and form encoding that you specify. The defaults are:
+
+ method: POST
+ action: this script
+ encoding: application/x-www-form-urlencoded
+
+endform() returns the closing </FORM> tag.
+
+Startform()'s encoding method tells the browser how to package the various
+fields of the form before sending the form to the server. Two
+values are possible:
+
+=over 4
+
+=item B<application/x-www-form-urlencoded>
+
+This is the older type of encoding used by all browsers prior to
+Netscape 2.0. It is compatible with many CGI scripts and is
+suitable for short fields containing text data. For your
+convenience, CGI.pm stores the name of this encoding
+type in B<$CGI::URL_ENCODED>.
+
+=item B<multipart/form-data>
+
+This is the newer type of encoding introduced by Netscape 2.0.
+It is suitable for forms that contain very large fields or that
+are intended for transferring binary data. Most importantly,
+it enables the "file upload" feature of Netscape 2.0 forms. For
+your convenience, CGI.pm stores the name of this encoding type
+in B<$CGI::MULTIPART>
+
+Forms that use this type of encoding are not easily interpreted
+by CGI scripts unless they use CGI.pm or another library designed
+to handle them.
+
+=back
+
+For compatibility, the startform() method uses the older form of
+encoding by default. If you want to use the newer form of encoding
+by default, you can call B<start_multipart_form()> instead of
+B<startform()>.
+
+JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
+for use with JavaScript. The -name parameter gives the
+form a name so that it can be identified and manipulated by
+JavaScript functions. -onSubmit should point to a JavaScript
+function that will be executed just before the form is submitted to your
+server. You can use this opportunity to check the contents of the form
+for consistency and completeness. If you find something wrong, you
+can put up an alert box or maybe fix things up yourself. You can
+abort the submission by returning false from this function.
+
+Usually the bulk of JavaScript functions are defined in a <SCRIPT>
+block in the HTML header and -onSubmit points to one of these function
+call. See start_html() for details.
+
+=head2 CREATING A TEXT FIELD
+
+ print $query->textfield(-name=>'field_name',
+ -default=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print $query->textfield('field_name','starting value',50,80);
+
+textfield() will return a text input field.
+
+=over 4
+
+=item B<Parameters>
+
+=item 1.
+
+The first parameter is the required name for the field (-name).
+
+=item 2.
+
+The optional second parameter is the default starting value for the field
+contents (-default).
+
+=item 3.
+
+The optional third parameter is the size of the field in
+ characters (-size).
+
+=item 4.
+
+The optional fourth parameter is the maximum number of characters the
+ field will accept (-maxlength).
+
+=back
+
+As with all these methods, the field will be initialized with its
+previous contents from earlier invocations of the script.
+When the form is processed, the value of the text field can be
+retrieved with:
+
+ $value = $query->param('foo');
+
+If you want to reset it from its initial value after the script has been
+called once, you can do so like this:
+
+ $query->param('foo',"I'm taking over this value!");
+
+NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
+value, you can force its current value by using the -override (alias -force)
+parameter:
+
+ print $query->textfield(-name=>'field_name',
+ -default=>'starting value',
+ -override=>1,
+ -size=>50,
+ -maxlength=>80);
+
+JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur>
+and B<-onSelect> parameters to register JavaScript event handlers.
+The onChange handler will be called whenever the user changes the
+contents of the text field. You can do text validation if you like.
+onFocus and onBlur are called respectively when the insertion point
+moves into and out of the text field. onSelect is called when the
+user changes the portion of the text that is selected.
+
+=head2 CREATING A BIG TEXT FIELD
+
+ print $query->textarea(-name=>'foo',
+ -default=>'starting value',
+ -rows=>10,
+ -columns=>50);
+
+ -or
+
+ print $query->textarea('foo','starting value',10,50);
+
+textarea() is just like textfield, but it allows you to specify
+rows and columns for a multiline text entry box. You can provide
+a starting value for the field, which can be long and contain
+multiple lines.
+
+JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
+and B<-onSelect> parameters are recognized. See textfield().
+
+=head2 CREATING A PASSWORD FIELD
+
+ print $query->password_field(-name=>'secret',
+ -value=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print $query->password_field('secret','starting value',50,80);
+
+password_field() is identical to textfield(), except that its contents
+will be starred out on the web page.
+
+JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
+and B<-onSelect> parameters are recognized. See textfield().
+
+=head2 CREATING A FILE UPLOAD FIELD
+
+ print $query->filefield(-name=>'uploaded_file',
+ -default=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print $query->filefield('uploaded_file','starting value',50,80);
+
+filefield() will return a file upload field for Netscape 2.0 browsers.
+In order to take full advantage of this I<you must use the new
+multipart encoding scheme> for the form. You can do this either
+by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
+or by calling the new method B<start_multipart_form()> instead of
+vanilla B<startform()>.
+
+=over 4
+
+=item B<Parameters>
+
+=item 1.
+
+The first parameter is the required name for the field (-name).
+
+=item 2.
+
+The optional second parameter is the starting value for the field contents
+to be used as the default file name (-default).
+
+The beta2 version of Netscape 2.0 currently doesn't pay any attention
+to this field, and so the starting value will always be blank. Worse,
+the field loses its "sticky" behavior and forgets its previous
+contents. The starting value field is called for in the HTML
+specification, however, and possibly later versions of Netscape will
+honor it.
+
+=item 3.
+
+The optional third parameter is the size of the field in
+characters (-size).
+
+=item 4.
+
+The optional fourth parameter is the maximum number of characters the
+field will accept (-maxlength).
+
+=back
+
+When the form is processed, you can retrieve the entered filename
+by calling param().
+
+ $filename = $query->param('uploaded_file');
+
+In Netscape Gold, the filename that gets returned is the full local filename
+on the B<remote user's> machine. If the remote user is on a Unix
+machine, the filename will follow Unix conventions:
+
+ /path/to/the/file
+
+On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
+
+ C:\PATH\TO\THE\FILE.MSW
+
+On a Macintosh machine, the filename will follow Mac conventions:
+
+ HD 40:Desktop Folder:Sort Through:Reminders
+
+The filename returned is also a file handle. You can read the contents
+of the file using standard Perl file reading calls:
+
+ # Read a text file and print it out
+ while (<$filename>) {
+ print;
+ }
+
+ # Copy a binary file to somewhere safe
+ open (OUTFILE,">>/usr/local/web/users/feedback");
+ while ($bytesread=read($filename,$buffer,1024)) {
+ print OUTFILE $buffer;
+ }
+
+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. Future browsers may send
+other information as well (such as modification date and size). To
+retrieve this information, call uploadInfo(). It returns a reference to
+an associative array containing all the document headers.
+
+ $filename = $query->param('uploaded_file');
+ $type = $query->uploadInfo($filename)->{'Content-Type'};
+ unless ($type eq 'text/html') {
+ die "HTML FILES ONLY!";
+ }
+
+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.
+
+JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
+and B<-onSelect> parameters are recognized. See textfield()
+for details.
+
+=head2 CREATING A POPUP MENU
+
+ print $query->popup_menu('menu_name',
+ ['eenie','meenie','minie'],
+ 'meenie');
+
+ -or-
+
+ %labels = ('eenie'=>'your first choice',
+ 'meenie'=>'your second choice',
+ 'minie'=>'your third choice');
+ print $query->popup_menu('menu_name',
+ ['eenie','meenie','minie'],
+ 'meenie',\%labels);
+
+ -or (named parameter style)-
+
+ print $query->popup_menu(-name=>'menu_name',
+ -values=>['eenie','meenie','minie'],
+ -default=>'meenie',
+ -labels=>\%labels);
+
+popup_menu() creates a menu.
+
+=over 4
+
+=item 1.
+
+The required first argument is the menu's name (-name).
+
+=item 2.
+
+The required second argument (-values) is an array B<reference>
+containing the list of menu items in the menu. You can pass the
+method an anonymous array, as shown in the example, or a reference to
+a named array, such as "\@foo".
+
+=item 3.
+
+The optional third parameter (-default) is the name of the default
+menu choice. If not specified, the first item will be the default.
+The values of the previous choice will be maintained across queries.
+
+=item 4.
+
+The optional fourth parameter (-labels) is provided for people who
+want to use different values for the user-visible label inside the
+popup menu nd the value returned to your script. It's a pointer to an
+associative array relating menu values to user-visible labels. If you
+leave this parameter blank, the menu values will be displayed by
+default. (You can also leave a label undefined if you want to).
+
+=back
+
+When the form is processed, the selected value of the popup menu can
+be retrieved using:
+
+ $popup_menu_value = $query->param('menu_name');
+
+JAVASCRIPTING: popup_menu() recognizes the following event handlers:
+B<-onChange>, B<-onFocus>, and B<-onBlur>. See the textfield()
+section for details on when these handlers are called.
+
+=head2 CREATING A SCROLLING LIST
+
+ print $query->scrolling_list('list_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],5,'true');
+ -or-
+
+ print $query->scrolling_list('list_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],5,'true',
+ \%labels);
+
+ -or-
+
+ print $query->scrolling_list(-name=>'list_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -default=>['eenie','moe'],
+ -size=>5,
+ -multiple=>'true',
+ -labels=>\%labels);
+
+scrolling_list() creates a scrolling list.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first and second arguments are the list name (-name) and values
+(-values). As in the popup menu, the second argument should be an
+array reference.
+
+=item 2.
+
+The optional third argument (-default) can be either a reference to a
+list containing the values to be selected by default, or can be a
+single value to select. If this argument is missing or undefined,
+then nothing is selected when the list first appears. In the named
+parameter version, you can use the synonym "-defaults" for this
+parameter.
+
+=item 3.
+
+The optional fourth argument is the size of the list (-size).
+
+=item 4.
+
+The optional fifth argument can be set to true to allow multiple
+simultaneous selections (-multiple). Otherwise only one selection
+will be allowed at a time.
+
+=item 5.
+
+The optional sixth argument is a pointer to an associative array
+containing long user-visible labels for the list items (-labels).
+If not provided, the values will be displayed.
+
+When this form is processed, all selected list items will be returned as
+a list under the parameter name 'list_name'. The values of the
+selected items can be retrieved with:
+
+ @selected = $query->param('list_name');
+
+=back
+
+JAVASCRIPTING: scrolling_list() recognizes the following event handlers:
+B<-onChange>, B<-onFocus>, and B<-onBlur>. See textfield() for
+the description of when these handlers are called.
+
+=head2 CREATING A GROUP OF RELATED CHECKBOXES
+
+ print $query->checkbox_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -default=>['eenie','moe'],
+ -linebreak=>'true',
+ -labels=>\%labels);
+
+ print $query->checkbox_group('group_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],'true',\%labels);
+
+ HTML3-COMPATIBLE BROWSERS ONLY:
+
+ print $query->checkbox_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -rows=2,-columns=>2);
+
+
+checkbox_group() creates a list of checkboxes that are related
+by the same name.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first and second arguments are the checkbox name and values,
+respectively (-name and -values). As in the popup menu, the second
+argument should be an array reference. These values are used for the
+user-readable labels printed next to the checkboxes as well as for the
+values passed to your script in the query string.
+
+=item 2.
+
+The optional third argument (-default) can be either a reference to a
+list containing the values to be checked by default, or can be a
+single value to checked. If this argument is missing or undefined,
+then nothing is selected when the list first appears.
+
+=item 3.
+
+The optional fourth argument (-linebreak) can be set to true to place
+line breaks between the checkboxes so that they appear as a vertical
+list. Otherwise, they will be strung together on a horizontal line.
+
+=item 4.
+
+The optional fifth argument is a pointer to an associative array
+relating the checkbox values to the user-visible labels that will will
+be printed next to them (-labels). If not provided, the values will
+be used as the default.
+
+=item 5.
+
+B<HTML3-compatible browsers> (such as Netscape) can take advantage
+of the optional
+parameters B<-rows>, and B<-columns>. These parameters cause
+checkbox_group() to return an HTML3 compatible table containing
+the checkbox group formatted with the specified number of rows
+and columns. You can provide just the -columns parameter if you
+wish; checkbox_group will calculate the correct number of rows
+for you.
+
+To include row and column headings in the returned table, you
+can use the B<-rowheader> and B<-colheader> parameters. Both
+of these accept a pointer to an array of headings to use.
+The headings are just decorative. They don't reorganize the
+interpretation of the checkboxes -- they're still a single named
+unit.
+
+=back
+
+When the form is processed, all checked boxes will be returned as
+a list under the parameter name 'group_name'. The values of the
+"on" checkboxes can be retrieved with:
+
+ @turned_on = $query->param('group_name');
+
+The value returned by checkbox_group() is actually an array of button
+elements. You can capture them and use them within tables, lists,
+or in other creative ways:
+
+ @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
+ &use_in_creative_way(@h);
+
+JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
+parameter. This specifies a JavaScript code fragment or
+function call to be executed every time the user clicks on
+any of the buttons in the group. You can retrieve the identity
+of the particular button clicked on using the "this" variable.
+
+=head2 CREATING A STANDALONE CHECKBOX
+
+ print $query->checkbox(-name=>'checkbox_name',
+ -checked=>'checked',
+ -value=>'ON',
+ -label=>'CLICK ME');
+
+ -or-
+
+ print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
+
+checkbox() is used to create an isolated checkbox that isn't logically
+related to any others.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first parameter is the required name for the checkbox (-name). It
+will also be used for the user-readable label printed next to the
+checkbox.
+
+=item 2.
+
+The optional second parameter (-checked) specifies that the checkbox
+is turned on by default. Synonyms are -selected and -on.
+
+=item 3.
+
+The optional third parameter (-value) specifies the value of the
+checkbox when it is checked. If not provided, the word "on" is
+assumed.
+
+=item 4.
+
+The optional fourth parameter (-label) is the user-readable label to
+be attached to the checkbox. If not provided, the checkbox name is
+used.
+
+=back
+
+The value of the checkbox can be retrieved using:
+
+ $turned_on = $query->param('checkbox_name');
+
+JAVASCRIPTING: checkbox() recognizes the B<-onClick>
+parameter. See checkbox_group() for further details.
+
+=head2 CREATING A RADIO BUTTON GROUP
+
+ print $query->radio_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie'],
+ -default=>'meenie',
+ -linebreak=>'true',
+ -labels=>\%labels);
+
+ -or-
+
+ print $query->radio_group('group_name',['eenie','meenie','minie'],
+ 'meenie','true',\%labels);
+
+
+ HTML3-COMPATIBLE BROWSERS ONLY:
+
+ print $query->radio_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -rows=2,-columns=>2);
+
+radio_group() creates a set of logically-related radio buttons
+(turning one member of the group on turns the others off)
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument is the name of the group and is required (-name).
+
+=item 2.
+
+The second argument (-values) is the list of values for the radio
+buttons. The values and the labels that appear on the page are
+identical. Pass an array I<reference> in the second argument, either
+using an anonymous array, as shown, or by referencing a named array as
+in "\@foo".
+
+=item 3.
+
+The optional third parameter (-default) is the name of the default
+button to turn on. If not specified, the first item will be the
+default. You can provide a nonexistent button name, such as "-" to
+start up with no buttons selected.
+
+=item 4.
+
+The optional fourth parameter (-linebreak) can be set to 'true' to put
+line breaks between the buttons, creating a vertical list.
+
+=item 5.
+
+The optional fifth parameter (-labels) is a pointer to an associative
+array relating the radio button values to user-visible labels to be
+used in the display. If not provided, the values themselves are
+displayed.
+
+=item 6.
+
+B<HTML3-compatible browsers> (such as Netscape) can take advantage
+of the optional
+parameters B<-rows>, and B<-columns>. These parameters cause
+radio_group() to return an HTML3 compatible table containing
+the radio group formatted with the specified number of rows
+and columns. You can provide just the -columns parameter if you
+wish; radio_group will calculate the correct number of rows
+for you.
+
+To include row and column headings in the returned table, you
+can use the B<-rowheader> and B<-colheader> parameters. Both
+of these accept a pointer to an array of headings to use.
+The headings are just decorative. They don't reorganize the
+interpetation of the radio buttons -- they're still a single named
+unit.
+
+=back
+
+When the form is processed, the selected radio button can
+be retrieved using:
+
+ $which_radio_button = $query->param('group_name');
+
+The value returned by radio_group() is actually an array of button
+elements. You can capture them and use them within tables, lists,
+or in other creative ways:
+
+ @h = $query->radio_group(-name=>'group_name',-values=>\@values);
+ &use_in_creative_way(@h);
+
+=head2 CREATING A SUBMIT BUTTON
+
+ print $query->submit(-name=>'button_name',
+ -value=>'value');
+
+ -or-
+
+ print $query->submit('button_name','value');
+
+submit() will create the query submission button. Every form
+should have one of these.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument (-name) is optional. You can give the button a
+name if you have several submission buttons in your form and you want
+to distinguish between them. The name will also be used as the
+user-visible label. Be aware that a few older browsers don't deal with this correctly and
+B<never> send back a value from a button.
+
+=item 2.
+
+The second argument (-value) is also optional. This gives the button
+a value that will be passed to your script in the query string.
+
+=back
+
+You can figure out which button was pressed by using different
+values for each one:
+
+ $which_one = $query->param('button_name');
+
+JAVASCRIPTING: radio_group() recognizes the B<-onClick>
+parameter. See checkbox_group() for further details.
+
+=head2 CREATING A RESET BUTTON
+
+ print $query->reset
+
+reset() creates the "reset" button. Note that it restores the
+form to its value from the last time the script was called,
+NOT necessarily to the defaults.
+
+=head2 CREATING A DEFAULT BUTTON
+
+ print $query->defaults('button_label')
+
+defaults() creates a button that, when invoked, will cause the
+form to be completely reset to its defaults, wiping out all the
+changes the user ever made.
+
+=head2 CREATING A HIDDEN FIELD
+
+ print $query->hidden(-name=>'hidden_name',
+ -default=>['value1','value2'...]);
+
+ -or-
+
+ print $query->hidden('hidden_name','value1','value2'...);
+
+hidden() produces a text field that can't be seen by the user. It
+is useful for passing state variable information from one invocation
+of the script to the next.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument is required and specifies the name of this
+field (-name).
+
+=item 2.
+
+The second argument is also required and specifies its value
+(-default). In the named parameter style of calling, you can provide
+a single value here or a reference to a whole list
+
+=back
+
+Fetch the value of a hidden field this way:
+
+ $hidden_value = $query->param('hidden_name');
+
+Note, that just like all the other form elements, the value of a
+hidden field is "sticky". If you want to replace a hidden field with
+some other values after the script has been called once you'll have to
+do it manually:
+
+ $query->param('hidden_name','new','values','here');
+
+=head2 CREATING A CLICKABLE IMAGE BUTTON
+
+ print $query->image_button(-name=>'button_name',
+ -src=>'/source/URL',
+ -align=>'MIDDLE');
+
+ -or-
+
+ print $query->image_button('button_name','/source/URL','MIDDLE');
+
+image_button() produces a clickable image. When it's clicked on the
+position of the click is returned to your script as "button_name.x"
+and "button_name.y", where "button_name" is the name you've assigned
+to it.
+
+JAVASCRIPTING: image_button() recognizes the B<-onClick>
+parameter. See checkbox_group() for further details.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument (-name) is required and specifies the name of this
+field.
+
+=item 2.
+
+The second argument (-src) is also required and specifies the URL
+
+=item 3.
+The third option (-align, optional) is an alignment type, and may be
+TOP, BOTTOM or MIDDLE
+
+=back
+
+Fetch the value of the button this way:
+ $x = $query->param('button_name.x');
+ $y = $query->param('button_name.y');
+
+=head2 CREATING A JAVASCRIPT ACTION BUTTON
+
+ print $query->button(-name=>'button_name',
+ -value=>'user visible label',
+ -onClick=>"do_something()");
+
+ -or-
+
+ print $query->button('button_name',"do_something()");
+
+button() produces a button that is compatible with Netscape 2.0's
+JavaScript. When it's pressed the fragment of JavaScript code
+pointed to by the B<-onClick> parameter will be executed. On
+non-Netscape browsers this form element will probably not even
+display.
+
+=head1 NETSCAPE COOKIES
+
+Netscape browsers versions 1.1 and higher support a so-called
+"cookie" designed to help maintain state within a browser session.
+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
+Netscape and restarts it. If an expiration date isn't specified, the cookie
+will remain active until the user quits Netscape.
+
+=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 Netscape 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 Netscape cookies is the B<cookie()> method:
+
+ $cookie = $query->cookie(-name=>'sessionID',
+ -value=>'xyzzy',
+ -expires=>'+1h',
+ -path=>'/cgi-bin/database',
+ -domain=>'.capricorn.org',
+ -secure=>1);
+ print $query->header(-cookie=>$cookie);
+
+B<cookie()> 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 Netscape limits its 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 associative array reference. For example,
+you can store an entire associative array into a cookie this way:
+
+ $cookie=$query->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<header()> 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:
+
+ print $query->header(-cookie=>$my_cookie);
+
+To create multiple cookies, give header() an array reference:
+
+ $cookie1 = $query->cookie(-name=>'riddle_name',
+ -value=>"The Sphynx's Question");
+ $cookie2 = $query->cookie(-name=>'answers',
+ -value=>\%answers);
+ print $query->header(-cookie=>[$cookie1,$cookie2]);
+
+To retrieve a cookie, request it by name by calling cookie()
+method without the B<-value> parameter:
+
+ use CGI;
+ $query = new CGI;
+ %answers = $query->cookie(-name=>'answers');
+ # $query->cookie('answers') will work too!
+
+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
+ $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
+ # vice-versa
+ $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
+
+See the B<cookie.cgi> example script for some ideas on how to use
+cookies effectively.
+
+B<NOTE:> There appear to be some (undocumented) restrictions on
+Netscape cookies. In Netscape 2.01, at least, I haven't been able to
+set more than three cookies at a time. There may also be limits on
+the length of cookies. If you need to store a lot of information,
+it's probably better to create a unique session ID, store it in a
+cookie, and use the session ID to locate an external file/database
+saved on the server's side of the connection.
+
+=head1 WORKING WITH NETSCAPE FRAMES
+
+It's possible for CGI.pm scripts to write into several browser
+panels and windows using Netscape's frame mechanism.
+There are three techniques for defining new frames programmatically:
+
+=over 4
+
+=item 1. Create a <Frameset> document
+
+After writing out the HTTP header, instead of creating a standard
+HTML document using the start_html() call, create a <FRAMESET>
+document that defines the frames on the page. Specify your script(s)
+(with appropriate parameters) as the SRC for each of the frames.
+
+There is no specific support for creating <FRAMESET> sections
+in CGI.pm, but the HTML is very simple to write. See the frame
+documentation in Netscape's home pages for details
+
+ http://home.netscape.com/assist/net_sites/frames.html
+
+=item 2. Specify the destination for the document in the HTTP header
+
+You may provide a B<-target> parameter to the header() method:
+
+ print $q->header(-target=>'ResultsWindow');
+
+This will tell Netscape to load the output of your script into the
+frame named "ResultsWindow". If a frame of that name doesn't
+already exist, Netscape will pop up a new window and load your
+script's document into that. There are a number of magic names
+that you can use for targets. See the frame documents on Netscape's
+home pages for details.
+
+=item 3. Specify the destination for the document in the <FORM> tag
+
+You can specify the frame to load in the FORM tag itself. With
+CGI.pm it looks like this:
+
+ print $q->startform(-target=>'ResultsWindow');
+
+When your script is reinvoked by the form, its output will be loaded
+into the frame named "ResultsWindow". If one doesn't already exist
+a new window will be created.
+
+=back
+
+The script "frameset.cgi" in the examples directory shows one way to
+create pages in which the fill-out form and the response live in
+side-by-side frames.
+
+=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
+
+or even as newline-delimited parameters 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"
+
+=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
+
+The dump() method produces a string consisting of all the query's
+name/value pairs formatted nicely as a nested list. This is useful
+for debugging purposes:
+
+ print $query->dump
+
+
+Produces something that looks like:
+
+ <UL>
+ <LI>name1
+ <UL>
+ <LI>value1
+ <LI>value2
+ </UL>
+ <LI>name2
+ <UL>
+ <LI>value1
+ </UL>
+ </UL>
+
+You can pass a value of 'true' to dump() in order to get it to
+print the results out as plain text, suitable for incorporating
+into a <PRE> section.
+
+As a shortcut, as of version 1.56 you can interpolate the entire
+CGI object into a string and it will be replaced with the
+the a nice HTML dump shown above:
+
+ $query=new CGI;
+ print "<H2>Current Values</H2> $query\n";
+
+=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<accept()>
+
+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
+$query->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.
+
+=item B<raw_cookie()>
+
+Returns the HTTP_COOKIE variable, an HTTP extension
+implemented by Netscape browsers version 1.1
+and higher. 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.
+
+=item B<user_agent()>
+
+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 $query->user_agent(netscape);
+
+=item B<path_info()>
+
+Returns additional path information from the script URL.
+E.G. fetching /cgi-bin/your_script/additional/stuff will
+result in $query->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.
+
+=item B<path_translated()>
+
+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<remote_host()>
+
+Returns either the remote host name or IP address.
+if the former is unavailable.
+
+=item B<script_name()>
+Return the script name as a partial URL, for self-refering
+scripts.
+
+=item B<referer()>
+
+Return the URL of the page the browser was viewing
+prior to fetching your script. Not available for all
+browsers.
+
+=item B<auth_type ()>
+
+Return the authorization/verification method in use for this
+script, if any.
+
+=item B<server_name ()>
+
+Returns the name of the server, usually the machine's host
+name.
+
+=item B<virtual_host ()>
+
+When using virtual hosts, returns the name of the host that
+the browser attempted to contact
+
+=item B<server_software ()>
+
+Returns the server software and version number.
+
+=item B<remote_user ()>
+
+Return the authorization/verification name used for user
+verification, if this script is protected.
+
+=item B<user_name ()>
+
+Attempt to obtain the remote user's name, using a variety
+of different techniques. This only works with older browsers
+such as Mosaic. Netscape does not reliably report the user
+name!
+
+=item B<request_method()>
+
+Returns the method used to access your script, usually
+one of 'POST', 'GET' or 'HEAD'.
+
+=back
+
+=head1 CREATING HTML ELEMENTS:
+
+In addition to its shortcuts for creating form elements, CGI.pm
+defines general HTML shortcut methods as well. HTML shortcuts are
+named after a single HTML element and return a fragment of HTML text
+that you can then print or manipulate as you like.
+
+This example shows how to use the HTML methods:
+
+ $q = new CGI;
+ print $q->blockquote(
+ "Many years ago on the island of",
+ $q->a({href=>"http://crete.org/"},"Crete"),
+ "there lived a minotaur named",
+ $q->strong("Fred."),
+ ),
+ $q->hr;
+
+This results in the following HTML code (extra newlines have been
+added for readability):
+
+ <blockquote>
+ Many years ago on the island of
+ <a HREF="http://crete.org/">Crete</a> there lived
+ a minotaur named <strong>Fred.</strong>
+ </blockquote>
+ <hr>
+
+If you find the syntax for calling the HTML shortcuts awkward, you can
+import them into your namespace and dispense with the object syntax
+completely (see the next section for more details):
+
+ use CGI shortcuts; # IMPORT HTML SHORTCUTS
+ print blockquote(
+ "Many years ago on the island of",
+ a({href=>"http://crete.org/"},"Crete"),
+ "there lived a minotaur named",
+ strong("Fred."),
+ ),
+ hr;
+
+=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
+
+The HTML methods will accept zero, one or multiple arguments. If you
+provide no arguments, you get a single tag:
+
+ print hr;
+ # gives "<hr>"
+
+If you provide one or more string arguments, they are concatenated
+together with spaces and placed between opening and closing tags:
+
+ print h1("Chapter","1");
+ # gives "<h1>Chapter 1</h1>"
+
+If the first argument is an associative array reference, then the keys
+and values of the associative array become the HTML tag's attributes:
+
+ print a({href=>'fred.html',target=>'_new'},
+ "Open a new frame");
+ # gives <a href="fred.html",target="_new">Open a new frame</a>
+
+You are free to use CGI.pm-style dashes in front of the attribute
+names if you prefer:
+
+ print img {-src=>'fred.gif',-align=>'LEFT'};
+ # gives <img ALIGN="LEFT" SRC="fred.gif">
+
+=head2 Generating new HTML tags
+
+Since no mere mortal can keep up with Netscape and Microsoft as they
+battle it out for control of HTML, the code that generates HTML tags
+is general and extensible. You can create new HTML tags freely just
+by referring to them on the import line:
+
+ use CGI shortcuts,winkin,blinkin,nod;
+
+Now, in addition to the standard CGI shortcuts, you've created HTML
+tags named "winkin", "blinkin" and "nod". You can use them like this:
+
+ print blinkin {color=>'blue',rate=>'fast'},"Yahoo!";
+ # <blinkin COLOR="blue" RATE="fast">Yahoo!</blinkin>
+
+=head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE
+
+As a convenience, you can import most of the CGI method calls directly
+into your name space. The syntax for doing this is:
+
+ use CGI <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<param()> and B<header()>
+methods, and then use them directly:
+
+ use CGI param,header;
+ print header('text/plain');
+ $zipcode = param('zipcode');
+
+You can import groups of methods by referring to a number of special
+names:
+
+=over 4
+
+=item B<cgi>
+
+Import all CGI-handling methods, such as B<param()>, B<path_info()>
+and the like.
+
+=item B<form>
+
+Import all fill-out form generating methods, such as B<textfield()>.
+
+=item B<html2>
+
+Import all methods that generate HTML 2.0 standard elements.
+
+=item B<html3>
+
+Import all methods that generate HTML 3.0 proposed elements (such as
+<table>, <super> and <sub>).
+
+=item B<netscape>
+
+Import all methods that generate Netscape-specific HTML extensions.
+
+=item B<shortcuts>
+
+Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
+'netscape')...
+
+=item B<standard>
+
+Import "standard" features, 'html2', 'form' and 'cgi'.
+
+=item B<all>
+
+Import all the available methods. For the full list, see the CGI.pm
+code, where the variable %TAGS is defined.
+
+=back
+
+Note that in the interests of execution speed CGI.pm does B<not> use
+the standard L<Exporter> syntax for specifying load symbols. This may
+change in the future.
+
+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<param()>, B<textfield()>,
+B<submit()> and the like. (If you need direct access to the CGI
+object, you can find it in the global variable B<$CGI::Q>). By
+importing CGI.pm methods, you can create visually elegant scripts:
+
+ use CGI standard,html2;
+ print
+ header,
+ start_html('Simple Script'),
+ h1('Simple Script'),
+ start_form,
+ "What's your name? ",textfield('name'),p,
+ "What's the combination?",
+ checkbox_group(-name=>'words',
+ -values=>['eenie','meenie','minie','moe'],
+ -defaults=>['eenie','moe']),p,
+ "What's your favorite color?",
+ popup_menu(-name=>'color',
+ -values=>['red','green','blue','chartreuse']),p,
+ submit,
+ end_form,
+ hr,"\n";
+
+ if (param) {
+ print
+ "Your name is ",em(param('name')),p,
+ "The keywords are: ",em(join(", ",param('words'))),p,
+ "Your favorite color is ",em(param('color')),".\n";
+ }
+ print end_html;
+
+=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.
+
+There are a number of ways to put CGI.pm into NPH mode:
+
+=over 4
+
+=item In the B<use> statement
+Simply add ":nph" to the list of symbols to be imported into your script:
+
+ use CGI qw(:standard :nph)
+
+=item By calling the B<nph()> method:
+
+Call B<nph()> 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<header()> and B<redirect()> statements:
+
+ print $q->header(-nph=&gt;1);
+
+=back
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1995,1996, Lincoln D. Stein. All rights reserved. It may
+be used and modified freely, but I do request that this copyright
+notice remain attached to the file. You may modify this module as you
+wish, but if you redistribute a modified version, please attach a note
+listing the modifications you have made.
+
+Address bug reports and comments to:
+lstein@genome.wi.mit.edu
+
+=head1 CREDITS
+
+Thanks very much to:
+
+=over 4
+
+=item Matt Heffron (heffron@falstaff.css.beckman.com)
+
+=item James Taylor (james.taylor@srs.gov)
+
+=item Scott Anguish <sanguish@digifix.com>
+
+=item Mike Jewell (mlj3u@virginia.edu)
+
+=item Timothy Shimmin (tes@kbs.citri.edu.au)
+
+=item Joergen Haegg (jh@axis.se)
+
+=item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
+
+=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 ...and many many more...
+
+for suggestions and bug fixes.
+
+=back
+
+=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
+
+
+ #!/usr/local/bin/perl
+
+ use CGI;
+
+ $query = new CGI;
+
+ print $query->header;
+ print $query->start_html("Example CGI.pm Form");
+ print "<H1> Example CGI.pm Form</H1>\n";
+ &print_prompt($query);
+ &do_work($query);
+ &print_tail;
+ print $query->end_html;
+
+ sub print_prompt {
+ my($query) = @_;
+
+ print $query->startform;
+ print "<EM>What's your name?</EM><BR>";
+ print $query->textfield('name');
+ print $query->checkbox('Not my real name');
+
+ print "<P><EM>Where can you find English Sparrows?</EM><BR>";
+ print $query->checkbox_group(
+ -name=>'Sparrow locations',
+ -values=>[England,France,Spain,Asia,Hoboken],
+ -linebreak=>'yes',
+ -defaults=>[England,Asia]);
+
+ print "<P><EM>How far can they fly?</EM><BR>",
+ $query->radio_group(
+ -name=>'how far',
+ -values=>['10 ft','1 mile','10 miles','real far'],
+ -default=>'1 mile');
+
+ print "<P><EM>What's your favorite color?</EM> ";
+ print $query->popup_menu(-name=>'Color',
+ -values=>['black','brown','red','yellow'],
+ -default=>'red');
+
+ print $query->hidden('Reference','Monty Python and the Holy Grail');
+
+ print "<P><EM>What have you got there?</EM><BR>";
+ print $query->scrolling_list(
+ -name=>'possessions',
+ -values=>['A Coconut','A Grail','An Icon',
+ 'A Sword','A Ticket'],
+ -size=>5,
+ -multiple=>'true');
+
+ print "<P><EM>Any parting comments?</EM><BR>";
+ print $query->textarea(-name=>'Comments',
+ -rows=>10,
+ -columns=>50);
+
+ print "<P>",$query->reset;
+ print $query->submit('Action','Shout');
+ print $query->submit('Action','Scream');
+ print $query->endform;
+ print "<HR>\n";
+ }
+
+ sub do_work {
+ my($query) = @_;
+ my(@values,$key);
+
+ print "<H2>Here are the current settings in this form</H2>";
+
+ foreach $key ($query->param) {
+ print "<STRONG>$key</STRONG> -> ";
+ @values = $query->param($key);
+ print join(", ",@values),"<BR>\n";
+ }
+ }
+
+ sub print_tail {
+ print <<END;
+ <HR>
+ <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
+ <A HREF="/">Home Page</A>
+ END
+ }
+
+=head1 BUGS
+
+This module has grown large and monolithic. Furthermore it's doing many
+things, such as handling URLs, parsing CGI input, writing HTML, etc., that
+are also done in the LWP modules. It should be discarded in favor of
+the CGI::* modules, but somehow I continue to work on it.
+
+Note that the code is truly contorted in order to avoid spurious
+warnings when programs are run with the B<-w> switch.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
+L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
+L<CGI::Push>, L<CGI::Fast>
+
+=cut
+
diff --git a/lib/CGI/Apache.pm b/lib/CGI/Apache.pm
new file mode 100644
index 0000000000..6666f19b55
--- /dev/null
+++ b/lib/CGI/Apache.pm
@@ -0,0 +1,90 @@
+package CGI::Apache;
+use Apache ();
+use vars qw(@ISA $VERSION);
+require CGI;
+@ISA = qw(CGI);
+
+$VERSION = (qw$Revision: 1.00 $)[1];
+$CGI::DefaultClass = 'CGI::Apache';
+$CGI::Apache::AutoloadClass = 'CGI';
+
+sub new {
+ my($class) = shift;
+ my($r) = Apache->request;
+ %ENV = $r->cgi_env unless defined $ENV{GATEWAY_INTERFACE}; #PerlSetupEnv On
+ my $self = $class->SUPER::new(@_);
+ $self->{'.req'} = $r;
+ $self;
+}
+
+sub header {
+ my ($self,@rest) = CGI::self_or_default(@_);
+ my $r = $self->{'.req'};
+ $r->basic_http_header;
+ return CGI::header($self,@rest);
+}
+
+sub print {
+ my($self,@rest) = CGI::self_or_default(@_);
+ $self->{'.req'}->print(@rest);
+}
+
+sub read_from_client {
+ my($self, $fh, $buff, $len, $offset) = @_;
+ my $r = $self->{'.req'} || Apache->request;
+ return $r->read($$buff, $len, $offset);
+}
+
+sub new_MultipartBuffer {
+ my $self = shift;
+ my $new = CGI::Apache::MultipartBuffer->new($self, @_);
+ $new->{'.req'} = $self->{'.req'} || Apache->request;
+ return $new;
+}
+
+package CGI::Apache::MultipartBuffer;
+use vars qw(@ISA);
+@ISA = qw(MultipartBuffer);
+
+$CGI::Apache::MultipartBuffer::AutoloadClass = 'MultipartBuffer';
+*CGI::Apache::MultipartBuffer::read_from_client =
+ \&CGI::Apache::read_from_client;
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Apache - Make things work with CGI.pm against Perl-Apache API
+
+=head1 SYNOPSIS
+
+ require CGI::Apache;
+
+ my $q = new Apache::CGI;
+
+ $q->print($q->header);
+
+ #do things just like you do with CGI.pm
+
+=head1 DESCRIPTION
+
+When using the Perl-Apache API, your applications are faster, but the
+enviroment is different than CGI.
+This module attempts to set-up that environment as best it can.
+
+=head1 NOTE
+
+This module used to be named Apache::CGI. Sorry for the confusion.
+
+=head1 SEE ALSO
+
+perl(1), Apache(3), CGI(3)
+
+=head1 AUTHOR
+
+Doug MacEachern E<lt>dougm@osf.orgE<gt>, hacked over by Andreas König E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt>
+
+=cut
diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm
new file mode 100644
index 0000000000..4cd79467fd
--- /dev/null
+++ b/lib/CGI/Carp.pm
@@ -0,0 +1,242 @@
+package CGI::Carp;
+
+=head1 NAME
+
+B<CGI::Carp> - 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";
+
+=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
+
+And the standard warn(), die (), croak(), confess() and carp() calls
+will automagically be replaced with functions that write out nicely
+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<carpout()> 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, which should be a
+reference to an open filehandle for writing errors. It should be
+called in a C<BEGIN> 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.
+
+The real STDERR is not closed -- it is moved to SAVEERR. Some
+servers, when dealing with CGI scripts, close their connection to the
+browser when the script closes STDOUT and STDERR. SAVEERR is used 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
+
+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, ask to
+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).
+
+=head1 CHANGE LOG
+
+1.05 carpout() added and minor corrections by Marc Hedlund
+ <hedlund@best.com> on 11/26/95.
+
+1.06 fatalsToBrowser() no longer aborts for fatal errors within
+ eval() statements.
+
+=head1 AUTHORS
+
+Lincoln D. Stein <lstein@genome.wi.mit.edu>. Feel free to redistribute
+this under the Perl Artistic License.
+
+
+=head1 SEE ALSO
+
+Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
+CGI::Response
+
+=cut
+
+require 5.000;
+use Exporter;
+use Carp;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(confess croak carp);
+@EXPORT_OK = qw(carpout fatalsToBrowser);
+
+$main::SIG{__WARN__}=\&CGI::Carp::warn;
+$main::SIG{__DIE__}=\&CGI::Carp::die;
+$CGI::Carp::VERSION = '1.06';
+
+# fancy import routine detects and handles 'errorWrap' specially.
+sub import {
+ my $pkg = shift;
+ my(%routines);
+ grep($routines{$_}++,@_);
+ $WRAP++ if $routines{'fatalsToBrowser'};
+ my($oldlevel) = $Exporter::ExportLevel;
+ $Exporter::ExportLevel = 1;
+ Exporter::import($pkg,keys %routines);
+ $Exporter::ExportLevel = $oldlevel;
+}
+
+# These are the originals
+sub realwarn { warn(@_); }
+sub realdie { die(@_); }
+
+sub id {
+ my $level = shift;
+ my($pack,$file,$line,$sub) = caller($level);
+ my($id) = $file=~m|([^/]+)$|;
+ return ($file,$line,$id);
+}
+
+sub stamp {
+ my $time = scalar(localtime);
+ my $frame = 0;
+ my ($id,$pack,$file);
+ do {
+ $id = $file;
+ ($pack,$file) = caller($frame++);
+ } until !$file;
+ ($id) = $id=~m|([^/]+)$|;
+ return "[$time] $id: ";
+}
+
+sub warn {
+ my $message = shift;
+ my($file,$line,$id) = id(1);
+ $message .= " at $file line $line.\n" unless $message=~/\n$/;
+ my $stamp = stamp;
+ $message=~s/^/$stamp/gm;
+ realwarn $message;
+}
+
+sub die {
+ my $message = shift;
+ my $time = scalar(localtime);
+ my($file,$line,$id) = id(1);
+ return undef if $file=~/^\(eval/;
+ $message .= " at $file line $line.\n" unless $message=~/\n$/;
+ &fatalsToBrowser($message) if $WRAP;
+ my $stamp = stamp;
+ $message=~s/^/$stamp/gm;
+ realdie $message;
+}
+
+# Avoid generating "subroutine redefined" warnings with the following
+# hack:
+{
+ local $^W=0;
+ eval <<EOF;
+sub confess { CGI::Carp::die Carp::longmess \@_; }
+sub croak { CGI::Carp::die Carp::shortmess \@_; }
+sub carp { CGI::Carp::warn Carp::shortmess \@_; }
+EOF
+ ;
+}
+
+# We have to be ready to accept a filehandle as a reference
+# or a string.
+sub carpout {
+ my($in) = @_;
+ $in = $$in if ref($in); # compatability with Marc's method;
+ my($no) = fileno($in);
+ unless (defined($no)) {
+ my($package) = caller;
+ my($handle) = $in=~/[':]/ ? $in : "$package\:\:$in";
+ $no = fileno($handle);
+ }
+ die "Invalid filehandle $in\n" unless $no;
+
+ open(SAVEERR, ">&STDERR");
+ open(STDERR, ">&$no") or
+ ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
+}
+
+# headers
+sub fatalsToBrowser {
+ my($msg) = @_;
+ $msg=~s/>/&gt;/g;
+ $msg=~s/</&lt;/g;
+ print STDOUT "Content-type: text/html\n\n";
+ print STDOUT <<END;
+<H1>Software error:</H1>
+<CODE>$msg</CODE>
+<P>
+Please send mail to this site's webmaster for help.
+END
+}
+
+1;
diff --git a/lib/CGI/Fast.pm b/lib/CGI/Fast.pm
new file mode 100644
index 0000000000..03b54072c9
--- /dev/null
+++ b/lib/CGI/Fast.pm
@@ -0,0 +1,173 @@
+package CGI::Fast;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
+# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+$CGI::Fast::VERSION='1.00a';
+
+use CGI;
+use FCGI;
+@ISA = ('CGI');
+
+# workaround for known bug in libfcgi
+while (($ignore) = each %ENV) { }
+
+# override the initialization behavior so that
+# state is NOT maintained between invocations
+sub save_request {
+ # no-op
+}
+
+# New is slightly different in that it calls FCGI's
+# accept() method.
+sub new {
+ return undef unless FCGI::accept() >= 0;
+ my($self,@param) = @_;
+ return $CGI::Q = $self->SUPER::new(@param);
+}
+
+1;
+
+=head1 NAME
+
+CGI::Fast - CGI Interface for Fast CGI
+
+=head1 SYNOPSIS
+
+ use CGI::Fast qw(:standard);
+ $COUNTER = 0;
+ while (new CGI::Fast) {
+ print header;
+ print start_html("Fast CGI Rocks");
+ print
+ h1("Fast CGI Rocks"),
+ "Invocation number ",b($COUNTER++),
+ " PID ",b($$),".",
+ hr;
+ print end_html;
+ }
+
+=head1 DESCRIPTION
+
+CGI::Fast is a subclass of the CGI object created by
+CGI.pm. It is specialized to work well with the Open Market
+FastCGI standard, which greatly speeds up CGI scripts by
+turning them into persistently running server processes. Scripts
+that perform time-consuming initialization processes, such as
+loading large modules or opening persistent database connections,
+will see large performance improvements.
+
+=head1 OTHER PIECES OF THE PUZZLE
+
+In order to use CGI::Fast you'll need a FastCGI-enabled Web
+server. Open Market's server is FastCGI-savvy. There are also
+freely redistributable FastCGI modules for NCSA httpd 1.5 and Apache.
+FastCGI-enabling modules for Microsoft Internet Information Server and
+Netscape Communications Server have been announced.
+
+In addition, you'll need a version of the Perl interpreter that has
+been linked with the FastCGI I/O library. Precompiled binaries are
+available for several platforms, including DEC Alpha, HP-UX and
+SPARC/Solaris, or you can rebuild Perl from source with patches
+provided in the FastCGI developer's kit. The FastCGI Perl interpreter
+can be used in place of your normal Perl without ill consequences.
+
+You can find FastCGI modules for Apache and NCSA httpd, precompiled
+Perl interpreters, and the FastCGI developer's kit all at URL:
+
+ http://www.fastcgi.com/
+
+=head1 WRITING FASTCGI PERL SCRIPTS
+
+FastCGI scripts are persistent: one or more copies of the script
+are started up when the server initializes, and stay around until
+the server exits or they die a natural death. After performing
+whatever one-time initialization it needs, the script enters a
+loop waiting for incoming connections, processing the request, and
+waiting some more.
+
+A typical FastCGI script will look like this:
+
+ #!/usr/local/bin/perl # must be a FastCGI version of perl!
+ use CGI::Fast;
+ &do_some_initialization();
+ while ($q = new CGI::Fast) {
+ &process_request($q);
+ }
+
+Each time there's a new request, CGI::Fast returns a
+CGI object to your loop. The rest of the time your script
+waits in the call to new(). When the server requests that
+your script be terminated, new() will return undef. You can
+of course exit earlier if you choose. A new version of the
+script will be respawned to take its place (this may be
+necessary in order to avoid Perl memory leaks in long-running
+scripts).
+
+CGI.pm's default CGI object mode also works. Just modify the loop
+this way:
+
+ while (new CGI::Fast) {
+ &process_request;
+ }
+
+Calls to header(), start_form(), etc. will all operate on the
+current request.
+
+=head1 INSTALLING FASTCGI SCRIPTS
+
+See the FastCGI developer's kit documentation for full details. On
+the Apache server, the following line must be added to srm.conf:
+
+ AddType application/x-httpd-fcgi .fcgi
+
+FastCGI scripts must end in the extension .fcgi. For each script you
+install, you must add something like the following to srm.conf:
+
+ AppClass /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
+
+This instructs Apache to launch two copies of file_upload.fcgi at
+startup time.
+
+=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS
+
+Any script that works correctly as a FastCGI script will also work
+correctly when installed as a vanilla CGI script. However it will
+not see any performance benefit.
+
+=head1 CAVEATS
+
+I haven't tested this very much.
+
+=head1 AUTHOR INFORMATION
+
+be used and modified freely, but I do request that this copyright
+notice remain attached to the file. You may modify this module as you
+wish, but if you redistribute a modified version, please attach a note
+listing the modifications you have made.
+
+Address bug reports and comments to:
+lstein@genome.wi.mit.edu
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm
new file mode 100644
index 0000000000..11421a7f23
--- /dev/null
+++ b/lib/CGI/Push.pm
@@ -0,0 +1,239 @@
+package CGI::Push;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
+# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+
+$CGI::Push::VERSION='1.00';
+use CGI;
+@ISA = ('CGI');
+
+# add do_push() to exported tags
+push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push');
+
+sub do_push {
+ my ($self,@p) = CGI::self_or_CGI(@_);
+
+ # unbuffer output
+ $| = 1;
+ srand;
+ my ($random) = rand()*1E16;
+ my ($boundary) = "----------------------------------$random";
+
+ my (@header);
+ my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,@other) =
+ $self->rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p);
+ $type = 'text/html' unless $type;
+ $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
+ $delay = 1 unless defined($delay);
+
+ my(@o);
+ foreach (@other) { push(@o,split("=")); }
+ push(@o,'-Target'=>$target) if defined($target);
+ push(@o,'-Cookie'=>$cookie) if defined($cookie);
+ push(@o,'-Type'=>"multipart/x-mixed-replace; boundary=$boundary");
+ push(@o,'-Server'=>"CGI.pm Push Module");
+ push(@o,'-Status'=>'200 OK');
+ push(@o,'-nph'=>1);
+ print $self->header(@o);
+ print "${boundary}$CGI::CRLF";
+
+ # now we enter a little loop
+ my @contents;
+ while (1) {
+ last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]);
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF";
+ print @contents,"$CGI::CRLF";
+ print "${boundary}$CGI::CRLF";
+ do_sleep($delay) if $delay;
+ }
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF",
+ &$last_page($self,++$COUNTER),
+ "$CGI::CRLF${boundary}$CGI::CRLF"
+ if $last_page && ref($last_page) eq 'CODE';
+}
+
+sub simple_counter {
+ my ($self,$count) = @_;
+ return (
+ CGI->start_html("CGI::Push Default Counter"),
+ CGI->h1("CGI::Push Default Counter"),
+ "This page has been updated ",CGI->strong($count)," times.",
+ CGI->hr(),
+ CGI->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'),
+ CGI->end_html
+ );
+}
+
+sub do_sleep {
+ my $delay = shift;
+ if ( ($delay >= 1) && ($delay!~/\./) ){
+ sleep($delay);
+ } else {
+ select(undef,undef,undef,$delay);
+ }
+}
+
+1;
+
+=head1 NAME
+
+CGI::Push - Simple Interface to Server Push
+
+=head1 SYNOPSIS
+
+ use CGI::Push qw(:standard);
+
+ do_push(-next_page=>\&next_page,
+ -last_page=>\&last_page,
+ -delay=>0.5);
+
+ sub next_page {
+ my($q,$counter) = @_;
+ return undef if $counter >= 10;
+ return start_html('Test'),
+ h1('Visible'),"\n",
+ "This page has been called ", strong($counter)," times",
+ end_html();
+ }
+
+ sub last_page {
+ my($q,$counter) = @_;
+ return start_html('Done'),
+ h1('Finished'),
+ strong($counter),' iterations.',
+ end_html;
+ }
+
+=head1 DESCRIPTION
+
+CGI::Push is a subclass of the CGI object created by CGI.pm. It is
+specialized for server push operations, which allow you to create
+animated pages whose content changes at regular intervals.
+
+You provide CGI::Push with a pointer to a subroutine that will draw
+one page. Every time your subroutine is called, it generates a new
+page. The contents of the page will be transmitted to the browser
+in such a way that it will replace what was there beforehand. The
+technique will work with HTML pages as well as with graphics files,
+allowing you to create animated GIFs.
+
+=head1 USING CGI::Push
+
+CGI::Push adds one new method to the standard CGI suite, do_push().
+When you call this method, you pass it a reference to a subroutine
+that is responsible for drawing each new page, an interval delay, and
+an optional subroutine for drawing the last page. Other optional
+parameters include most of those recognized by the CGI header()
+method.
+
+You may call do_push() in the object oriented manner or not, as you
+prefer:
+
+ use CGI::Push;
+ $q = new CGI::Push;
+ $q->do_push(-next_page=>\&draw_a_page);
+
+ -or-
+
+ use CGI::Push qw(:standard);
+ do_push(-next_page=>\&draw_a_page);
+
+Parameters are as follows:
+
+=over 4
+
+=item -next_page
+
+ do_push(-next_page=>\&my_draw_routine);
+
+This required parameter points to a reference to a subroutine responsible for
+drawing each new page. The subroutine should expect two parameters
+consisting of the CGI object and a counter indicating the number
+of times the subroutine has been called. It should return the
+contents of the page as an B<array> of one or more items to print.
+It can return a false value (or an empty array) in order to abort the
+redrawing loop and print out the final page (if any)
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return undef if $counter > 100;
+ return start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+=item -last_page
+
+This optional parameter points to a reference to the subroutine
+responsible for drawing the last page of the series. It is called
+after the -next_page routine returns a false value. The subroutine
+itself should have exactly the same calling conventions as the
+-next_page routine.
+
+=item -type
+
+This optional parameter indicates the content type of each page. It
+defaults to "text/html". Currently, server push of heterogeneous
+document types is not supported.
+
+=item -delay
+
+This indicates the delay, in seconds, between frames. Smaller delays
+refresh the page faster. Fractional values are allowed.
+
+B<If not specified, -delay will default to 1 second>
+
+=item -cookie, -target, -expires
+
+These have the same meaning as the like-named parameters in
+CGI::header().
+
+=back
+
+=head1 INSTALLING CGI::Push SCRIPTS
+
+Server push scripts B<must> be installed as no-parsed-header (NPH)
+scripts in order to work correctly. On Unix systems, this is most
+often accomplished by prefixing the script's name with "nph-".
+Recognition of NPH scripts happens automatically with WebSTAR and
+Microsoft IIS. Users of other servers should see their documentation
+for help.
+
+=head1 CAVEATS
+
+This is a new module. It hasn't been extensively tested.
+
+=head1 AUTHOR INFORMATION
+
+be used and modified freely, but I do request that this copyright
+notice remain attached to the file. You may modify this module as you
+wish, but if you redistribute a modified version, please attach a note
+listing the modifications you have made.
+
+Address bug reports and comments to:
+lstein@genome.wi.mit.edu
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
+
diff --git a/lib/CGI/Switch.pm b/lib/CGI/Switch.pm
new file mode 100644
index 0000000000..420fff7643
--- /dev/null
+++ b/lib/CGI/Switch.pm
@@ -0,0 +1,78 @@
+package CGI::Switch;
+use Carp;
+use strict;
+use vars qw($VERSION @Pref);
+$VERSION = '0.05';
+@Pref = qw(CGI::Apache CGI); #default
+
+sub import {
+ my($self,@arg) = @_;
+ @Pref = @arg if @arg;
+}
+
+sub new {
+ shift;
+ my($file,$pack);
+ for $pack (@Pref) {
+ ($file = $pack) =~ s|::|/|g;
+ eval { require "$file.pm"; };
+ if ($@) {
+#XXX warn $@;
+ next;
+ } else {
+#XXX warn "Going to try $pack\->new\n";
+ my $obj;
+ eval {$obj = $pack->new(@_)};
+ if ($@) {
+#XXX warn $@;
+ } else {
+ return $obj;
+ }
+ }
+ }
+ Carp::croak "Couldn't load+construct any of @Pref\n";
+}
+
+# there's a trick in Lincoln's package that determines the calling
+# package. The reason is to have a filehandle with the same name as
+# the filename. To tell this trick that we are not the calling
+# package we have to follow this dirty convention. It's a questionable
+# trick imho, but for now I want to have something working
+sub isaCGI { 1 }
+
+1;
+__END__
+
+=head1 NAME
+
+CGI::Switch - Try more than one constructors and return the first object available
+
+=head1 SYNOPSIS
+
+
+ use CGISwitch;
+
+ -or-
+
+ use CGI::Switch This, That, CGI::XA, Foo, Bar, CGI;
+
+ my $q = new CGI::Switch;
+
+=head1 DESCRIPTION
+
+Per default the new() method tries to call new() in the three packages
+Apache::CGI, CGI::XA, and CGI. It returns the first CGI object it
+succeeds with.
+
+The import method allows you to set up the default order of the
+modules to be tested.
+
+=head1 SEE ALSO
+
+perl(1), Apache(3), CGI(3), CGI::XA(3)
+
+=head1 AUTHOR
+
+Andreas König E<lt>a.koenig@mind.deE<gt>
+
+=cut
diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap
index c65b1cf35d..20cc96f0b5 100644
--- a/lib/ExtUtils/typemap
+++ b/lib/ExtUtils/typemap
@@ -203,7 +203,7 @@ T_SYSRET
T_ENUM
sv_setiv($arg, (IV)$var);
T_BOOL
- $arg = $var ? &sv_yes : &sv_no;
+ $arg = boolSV($var);
T_U_INT
sv_setiv($arg, (IV)$var);
T_SHORT
diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm
new file mode 100644
index 0000000000..a00d21057b
--- /dev/null
+++ b/lib/Pod/Html.pm
@@ -0,0 +1,1472 @@
+package Pod::Html;
+
+use Pod::Functions;
+use Getopt::Long; # package for handling command-line parameters
+require Exporter;
+@ISA = Exporter;
+@EXPORT = qw(pod2html htmlify);
+use Cwd;
+
+use Carp;
+
+use strict;
+
+=head1 NAME
+
+Pod::HTML - module to convert pod files to HTML
+
+=head1 SYNOPSIS
+
+ use Pod::HTML;
+ pod2html([options]);
+
+=head1 DESCRIPTION
+
+Converts files from pod format (see L<perlpod>) to HTML format. It
+can automatically generate indexes and cross-references, and it keeps
+a cache of things it knows how to cross-reference.
+
+=head1 ARGUMENTS
+
+Pod::Html takes the following arguments:
+
+=over 4
+
+=item help
+
+ --help
+
+Displays the usage message.
+
+=item htmlroot
+
+ --htmlroot=name
+
+Sets the base URL for the HTML files. When cross-references are made,
+the HTML root is prepended to the URL.
+
+=item infile
+
+ --infile=name
+
+Specify the pod file to convert. Input is taken from STDIN if no
+infile is specified.
+
+=item outfile
+
+ --outfile=name
+
+Specify the HTML file to create. Output goes to STDOUT if no outfile
+is specified.
+
+=item podroot
+
+ --podroot=name
+
+Specify the base directory for finding library pods.
+
+=item podpath
+
+ --podpath=name:...:name
+
+Specify which subdirectories of the podroot contain pod files whose
+HTML converted forms can be linked-to in cross-references.
+
+=item libpods
+
+ --libpods=name:...:name
+
+List of page names (eg, "perlfunc") which contain linkable C<=item>s.
+
+=item netscape
+
+ --netscape
+
+Use Netscape HTML directives when applicable.
+
+=item nonetscape
+
+ --nonetscape
+
+Do not use Netscape HTML directives (default).
+
+=item index
+
+ --index
+
+Generate an index at the top of the HTML file (default behaviour).
+
+=item noindex
+
+ --noindex
+
+Do not generate an index at the top of the HTML file.
+
+
+=item recurse
+
+ --recurse
+
+Recurse into subdirectories specified in podpath (default behaviour).
+
+=item norecurse
+
+ --norecurse
+
+Do not recurse into subdirectories specified in podpath.
+
+=item title
+
+ --title=title
+
+Specify the title of the resulting HTML file.
+
+=item verbose
+
+ --verbose
+
+Display progress messages.
+
+=back
+
+=head1 EXAMPLE
+
+ pod2html("pod2html",
+ "--podpath=lib:ext:pod:vms",
+ "--podroot=/usr/src/perl",
+ "--htmlroot=/perl/nmanual",
+ "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
+ "--recurse",
+ "--infile=foo.pod",
+ "--outfile=/perl/nmanual/foo.html");
+
+=head1 AUTHOR
+
+Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
+
+=head1 BUGS
+
+Has trouble with C<> etc in = commands.
+
+=head1 SEE ALSO
+
+L<perlpod>
+
+=head1 COPYRIGHT
+
+This program is distributed under the Artistic License.
+
+=cut
+
+my $dircache = "pod2html-dircache";
+my $itemcache = "pod2html-itemcache";
+
+my @begin_stack = (); # begin/end stack
+
+my @libpods = (); # files to search for links from C<> directives
+my $htmlroot = "/"; # http-server base directory from which all
+ # relative paths in $podpath stem.
+my $htmlfile = ""; # write to stdout by default
+my $podfile = ""; # read from stdin by default
+my @podpath = (); # list of directories containing library pods.
+my $podroot = "."; # filesystem base directory from which all
+ # relative paths in $podpath stem.
+my $recurse = 1; # recurse on subdirectories in $podpath.
+my $verbose = 0; # not verbose by default
+my $doindex = 1; # non-zero if we should generate an index
+my $listlevel = 0; # current list depth
+my @listitem = (); # stack of HTML commands to use when a =item is
+ # encountered. the top of the stack is the
+ # current list.
+my @listdata = (); # similar to @listitem, but for the text after
+ # an =item
+my @listend = (); # similar to @listitem, but the text to use to
+ # end the list.
+my $ignore = 1; # whether or not to format text. we don't
+ # format text until we hit our first pod
+ # directive.
+
+my %items_named = (); # for the multiples of the same item in perlfunc
+my @items_seen = ();
+my $netscape = 0; # whether or not to use netscape directives.
+my $title; # title to give the pod(s)
+my $top = 1; # true if we are at the top of the doc. used
+ # to prevent the first <HR> directive.
+my $paragraph; # which paragraph we're processing (used
+ # for error messages)
+my %pages = (); # associative array used to find the location
+ # of pages referenced by L<> links.
+my %sections = (); # sections within this page
+my %items = (); # associative array used to find the location
+ # of =item directives referenced by C<> links
+sub init_globals {
+$dircache = "pod2html-dircache";
+$itemcache = "pod2html-itemcache";
+
+@begin_stack = (); # begin/end stack
+
+@libpods = (); # files to search for links from C<> directives
+$htmlroot = "/"; # http-server base directory from which all
+ # relative paths in $podpath stem.
+$htmlfile = ""; # write to stdout by default
+$podfile = ""; # read from stdin by default
+@podpath = (); # list of directories containing library pods.
+$podroot = "."; # filesystem base directory from which all
+ # relative paths in $podpath stem.
+$recurse = 1; # recurse on subdirectories in $podpath.
+$verbose = 0; # not verbose by default
+$doindex = 1; # non-zero if we should generate an index
+$listlevel = 0; # current list depth
+@listitem = (); # stack of HTML commands to use when a =item is
+ # encountered. the top of the stack is the
+ # current list.
+@listdata = (); # similar to @listitem, but for the text after
+ # an =item
+@listend = (); # similar to @listitem, but the text to use to
+ # end the list.
+$ignore = 1; # whether or not to format text. we don't
+ # format text until we hit our first pod
+ # directive.
+
+@items_seen = ();
+%items_named = ();
+$netscape = 0; # whether or not to use netscape directives.
+$title = ''; # title to give the pod(s)
+$top = 1; # true if we are at the top of the doc. used
+ # to prevent the first <HR> directive.
+$paragraph = ''; # which paragraph we're processing (used
+ # for error messages)
+%pages = (); # associative array used to find the location
+ # of pages referenced by L<> links.
+%sections = (); # sections within this page
+%items = (); # associative array used to find the location
+ # of =item directives referenced by C<> links
+
+}
+
+sub pod2html {
+ local(@ARGV) = @_;
+ local($/);
+ local $_;
+
+ init_globals();
+
+ # cache of %pages and %items from last time we ran pod2html
+ my $podpath = '';
+
+ #undef $opt_help if defined $opt_help;
+
+ # parse the command-line parameters
+ parse_command_line();
+
+ # set some variables to their default values if necessary
+ local *POD;
+ unless (@ARGV && $ARGV[0]) {
+ $podfile = "-" unless $podfile; # stdin
+ open(POD, "<$podfile")
+ || die "$0: cannot open $podfile file for input: $!\n";
+ } else {
+ $podfile = $ARGV[0]; # XXX: might be more filenames
+ *POD = *ARGV;
+ }
+ $htmlfile = "-" unless $htmlfile; # stdout
+ $htmlroot = "" if $htmlroot eq "/"; # so we don't get a //
+
+ # read the pod a paragraph at a time
+ warn "Scanning for sections in input file(s)\n" if $verbose;
+ $/ = "";
+ my @poddata = <POD>;
+ close(POD);
+
+ # scan the pod for =head[1-6] directives and build an index
+ my $index = scan_headings(\%sections, @poddata);
+
+ # open the output file
+ open(HTML, ">$htmlfile")
+ || die "$0: cannot open $htmlfile file for output: $!\n";
+
+ # put a title in the HTML file
+ $title = '';
+ TITLE_SEARCH: {
+ for (my $i = 0; $i < @poddata; $i++) {
+ if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
+ for my $para ( @poddata[$i, $i+1] ) {
+ last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+\s*.*)/s;
+ }
+ }
+
+ }
+ }
+ unless ($title) {
+ $podfile =~ /^(.*)(\.[^.\/]+)?$/;
+ $title = ($podfile eq "-" ? 'No Title' : $1);
+ warn "found $title" if $verbose;
+ }
+ if ($title =~ /\.pm/) {
+ warn "$0: no title for $podfile";
+ $title = $podfile;
+ }
+ print HTML <<END_OF_HEAD;
+ <HTML>
+ <HEAD>
+ <TITLE>$title</TITLE>
+ </HEAD>
+
+ <BODY>
+
+END_OF_HEAD
+
+ # load a cache of %pages and %items if possible. $tests will be
+ # non-zero if successful.
+ my $tests = 0;
+ if (-f $dircache && -f $itemcache) {
+ warn "scanning for item cache\n" if $verbose;
+ $tests = find_cache($dircache, $itemcache, $podpath, $podroot);
+ }
+
+ # if we didn't succeed in loading the cache then we must (re)build
+ # %pages and %items.
+ if (!$tests) {
+ warn "scanning directories in pod-path\n" if $verbose;
+ scan_podpath($podroot, $recurse);
+ }
+
+ # scan the pod for =item directives
+ scan_items("", \%items, @poddata);
+
+ # put an index at the top of the file. note, if $doindex is 0 we
+ # still generate an index, but surround it with an html comment.
+ # that way some other program can extract it if desired.
+ $index =~ s/--+/-/g;
+ print HTML "<!-- INDEX BEGIN -->\n";
+ print HTML "<!--\n" unless $doindex;
+ print HTML $index;
+ print HTML "-->\n" unless $doindex;
+ print HTML "<!-- INDEX END -->\n\n";
+ print HTML "<HR>\n" if $doindex;
+
+ # now convert this file
+ warn "Converting input file\n" if $verbose;
+ foreach my $i (0..$#poddata) {
+ $_ = $poddata[$i];
+ $paragraph = $i+1;
+ if (/^(=.*)/s) { # is it a pod directive?
+ $ignore = 0;
+ $_ = $1;
+ if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
+ process_begin($1, $2);
+ } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
+ process_end($1, $2);
+ } elsif (/^=cut/) { # =cut
+ process_cut();
+ } elsif (/^=pod/) { # =pod
+ process_pod();
+ } else {
+ next if @begin_stack && $begin_stack[-1] ne 'html';
+
+ if (/^=(head[1-6])\s+(.*)/s) { # =head[1-6] heading
+ process_head($1, $2);
+ } elsif (/^=item\s*(.*)/sm) { # =item text
+ process_item($1);
+ } elsif (/^=over\s*(.*)/) { # =over N
+ process_over();
+ } elsif (/^=back/) { # =back
+ process_back();
+ } elsif (/^=for\s+(\S+)\s+(.*)/si) {# =for
+ process_for($1,$2);
+ } else {
+ /^=(\S*)\s*/;
+ warn "$0: $podfile: unknown pod directive '$1' in "
+ . "paragraph $paragraph. ignoring.\n";
+ }
+ }
+ $top = 0;
+ }
+ else {
+ next if $ignore;
+ next if @begin_stack && $begin_stack[-1] ne 'html';
+ my $text = $_;
+ process_text(\$text, 1);
+ print HTML "$text\n<P>\n\n";
+ }
+ }
+
+ # finish off any pending directives
+ finish_list();
+ print HTML <<END_OF_TAIL;
+ </BODY>
+
+ </HTML>
+END_OF_TAIL
+
+ # close the html file
+ close(HTML);
+
+ warn "Finished\n" if $verbose;
+}
+
+##############################################################################
+
+my $usage; # see below
+sub usage {
+ my $podfile = shift;
+ warn "$0: $podfile: @_\n" if @_;
+ die $usage;
+}
+
+$usage =<<END_OF_USAGE;
+Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
+ --podpath=<name>:...:<name> --podroot=<name>
+ --libpods=<name>:...:<name> --recurse --verbose --index
+ --netscape --norecurse --noindex
+
+ --flush - flushes the item and directory caches.
+ --help - prints this message.
+ --htmlroot - http-server base directory from which all relative paths
+ in podpath stem (default is /).
+ --index - generate an index at the top of the resulting html
+ (default).
+ --infile - filename for the pod to convert (input taken from stdin
+ by default).
+ --libpods - colon-separated list of pages to search for =item pod
+ directives in as targets of C<> and implicit links (empty
+ by default). note, these are not filenames, but rather
+ page names like those that appear in L<> links.
+ --netscape - will use netscape html directives when applicable.
+ --nonetscape - will not use netscape directives (default).
+ --outfile - filename for the resulting html file (output sent to
+ stdout by default).
+ --podpath - colon-separated list of directories containing library
+ pods. empty by default.
+ --podroot - filesystem base directory from which all relative paths
+ in podpath stem (default is .).
+ --noindex - don't generate an index at the top of the resulting html.
+ --norecurse - don't recurse on those subdirectories listed in podpath.
+ --recurse - recurse on those subdirectories listed in podpath
+ (default behavior).
+ --title - title that will appear in resulting html file.
+ --verbose - self-explanatory
+
+END_OF_USAGE
+
+sub parse_command_line {
+ my ($opt_flush,$opt_help,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose);
+ my $result = GetOptions(
+ 'flush' => \$opt_flush,
+ 'help' => \$opt_help,
+ 'htmlroot=s' => \$opt_htmlroot,
+ 'index!' => \$opt_index,
+ 'infile=s' => \$opt_infile,
+ 'libpods=s' => \$opt_libpods,
+ 'netscape!' => \$opt_netscape,
+ 'outfile=s' => \$opt_outfile,
+ 'podpath=s' => \$opt_podpath,
+ 'podroot=s' => \$opt_podroot,
+ 'norecurse' => \$opt_norecurse,
+ 'recurse!' => \$opt_recurse,
+ 'title=s' => \$opt_title,
+ 'verbose' => \$opt_verbose,
+ );
+ usage("-", "invalid parameters") if not $result;
+
+ usage("-") if defined $opt_help; # see if the user asked for help
+ $opt_help = ""; # just to make -w shut-up.
+
+ $podfile = $opt_infile if defined $opt_infile;
+ $htmlfile = $opt_outfile if defined $opt_outfile;
+
+ @podpath = split(":", $opt_podpath) if defined $opt_podpath;
+ @libpods = split(":", $opt_libpods) if defined $opt_libpods;
+
+ warn "Flushing item and directory caches\n"
+ if $opt_verbose && defined $opt_flush;
+ unlink($dircache, $itemcache) if defined $opt_flush;
+
+ $htmlroot = $opt_htmlroot if defined $opt_htmlroot;
+ $podroot = $opt_podroot if defined $opt_podroot;
+
+ $doindex = $opt_index if defined $opt_index;
+ $recurse = $opt_recurse if defined $opt_recurse;
+ $title = $opt_title if defined $opt_title;
+ $verbose = defined $opt_verbose ? 1 : 0;
+ $netscape = $opt_netscape if defined $opt_netscape;
+}
+
+#
+# find_cache - tries to find if the caches stored in $dircache and $itemcache
+# are valid caches of %pages and %items. if they are valid then it loads
+# them and returns a non-zero value.
+#
+sub find_cache {
+ my($dircache, $itemcache, $podpath, $podroot) = @_;
+ my($tests);
+ local $_;
+
+ $tests = 0;
+
+ open(CACHE, "<$itemcache") ||
+ die "$0: error opening $itemcache for reading: $!\n";
+ $/ = "\n";
+
+ # is it the same podpath?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if (join(":", @podpath) eq $_);
+
+ # is it the same podroot?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if ($podroot eq $_);
+
+ # load the cache if its good
+ if ($tests != 2) {
+ close(CACHE);
+
+ %items = ();
+ return 0;
+ }
+
+ warn "loading item cache\n" if $verbose;
+ while (<CACHE>) {
+ /(.*?) (.*)$/;
+ $items{$1} = $2;
+ }
+ close(CACHE);
+
+ warn "scanning for directory cache\n" if $verbose;
+ open(CACHE, "<$dircache") ||
+ die "$0: error opening $dircache for reading: $!\n";
+ $/ = "\n";
+ $tests = 0;
+
+ # is it the same podpath?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if (join(":", @podpath) eq $_);
+
+ # is it the same podroot?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if ($podroot eq $_);
+
+ # load the cache if its good
+ if ($tests != 2) {
+ close(CACHE);
+
+ %pages = ();
+ %items = ();
+ return 0;
+ }
+
+ warn "loading directory cache\n" if $verbose;
+ while (<CACHE>) {
+ /(.*?) (.*)$/;
+ $pages{$1} = $2;
+ }
+
+ close(CACHE);
+
+ return 1;
+}
+
+#
+# scan_podpath - scans the directories specified in @podpath for directories,
+# .pod files, and .pm files. it also scans the pod files specified in
+# @libpods for =item directives.
+#
+sub scan_podpath {
+ my($podroot, $recurse) = @_;
+ my($pwd, $dir);
+ my($libpod, $dirname, $pod, @files, @poddata);
+
+ # scan each directory listed in @podpath
+ $pwd = getcwd();
+ chdir($podroot)
+ || die "$0: error changing to directory $podroot: $!\n";
+ foreach $dir (@podpath) {
+ scan_dir($dir, $recurse);
+ }
+
+ # scan the pods listed in @libpods for =item directives
+ foreach $libpod (@libpods) {
+ # if the page isn't defined then we won't know where to find it
+ # on the system.
+ next unless defined $pages{$libpod} && $pages{$libpod};
+
+ # if there is a directory then use the .pod and .pm files within it.
+ if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+ # find all the .pod and .pm files within the directory
+ $dirname = $1;
+ opendir(DIR, $dirname) ||
+ die "$0: error opening directory $dirname: $!\n";
+ @files = grep(/(\.pod|\.pm)$/ && ! -d $_, readdir(DIR));
+ closedir(DIR);
+
+ # scan each .pod and .pm file for =item directives
+ foreach $pod (@files) {
+ open(POD, "<$dirname/$pod") ||
+ die "$0: error opening $dirname/$pod for input: $!\n";
+ @poddata = <POD>;
+ close(POD);
+
+ scan_items("$dirname/$pod", @poddata);
+ }
+
+ # use the names of files as =item directives too.
+ foreach $pod (@files) {
+ $pod =~ /^(.*)(\.pod|\.pm)$/;
+ $items{$1} = "$dirname/$1.html" if $1;
+ }
+ } elsif ($pages{$libpod} =~ /([^:]*\.pod):/ ||
+ $pages{$libpod} =~ /([^:]*\.pm):/) {
+ # scan the .pod or .pm file for =item directives
+ $pod = $1;
+ open(POD, "<$pod") ||
+ die "$0: error opening $pod for input: $!\n";
+ @poddata = <POD>;
+ close(POD);
+
+ scan_items("$pod", @poddata);
+ } else {
+ warn "$0: shouldn't be here (line ".__LINE__."\n";
+ }
+ }
+ @poddata = (); # clean-up a bit
+
+ chdir($pwd)
+ || die "$0: error changing to directory $pwd: $!\n";
+
+ # cache the item list for later use
+ warn "caching items for later use\n" if $verbose;
+ open(CACHE, ">$itemcache") ||
+ die "$0: error open $itemcache for writing: $!\n";
+
+ print CACHE join(":", @podpath) . "\n$podroot\n";
+ foreach my $key (keys %items) {
+ print CACHE "$key $items{$key}\n";
+ }
+
+ close(CACHE);
+
+ # cache the directory list for later use
+ warn "caching directories for later use\n" if $verbose;
+ open(CACHE, ">$dircache") ||
+ die "$0: error open $dircache for writing: $!\n";
+
+ print CACHE join(":", @podpath) . "\n$podroot\n";
+ foreach my $key (keys %pages) {
+ print CACHE "$key $pages{$key}\n";
+ }
+
+ close(CACHE);
+}
+
+#
+# scan_dir - scans the directory specified in $dir for subdirectories, .pod
+# files, and .pm files. notes those that it finds. this information will
+# be used later in order to figure out where the pages specified in L<>
+# links are on the filesystem.
+#
+sub scan_dir {
+ my($dir, $recurse) = @_;
+ my($t, @subdirs, @pods, $pod, $dirname, @dirs);
+ local $_;
+
+ @subdirs = ();
+ @pods = ();
+
+ opendir(DIR, $dir) ||
+ die "$0: error opening directory $dir: $!\n";
+ while (defined($_ = readdir(DIR))) {
+ if (-d "$dir/$_" && $_ ne "." && $_ ne "..") { # directory
+ $pages{$_} = "" unless defined $pages{$_};
+ $pages{$_} .= "$dir/$_:";
+ push(@subdirs, $_);
+ } elsif (/\.pod$/) { # .pod
+ s/\.pod$//;
+ $pages{$_} = "" unless defined $pages{$_};
+ $pages{$_} .= "$dir/$_.pod:";
+ push(@pods, "$dir/$_.pod");
+ } elsif (/\.pm$/) { # .pm
+ s/\.pm$//;
+ $pages{$_} = "" unless defined $pages{$_};
+ $pages{$_} .= "$dir/$_.pm:";
+ push(@pods, "$dir/$_.pm");
+ }
+ }
+ closedir(DIR);
+
+ # recurse on the subdirectories if necessary
+ if ($recurse) {
+ foreach my $subdir (@subdirs) {
+ scan_dir("$dir/$subdir", $recurse);
+ }
+ }
+}
+
+#
+# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
+# build an index.
+#
+sub scan_headings {
+ my($sections, @data) = @_;
+ my($tag, $which_head, $title, $listdepth, $index);
+
+ $listdepth = 0;
+ $index = "";
+
+ # scan for =head directives, note their name, and build an index
+ # pointing to each of them.
+ foreach my $line (@data) {
+ if ($line =~ /^\s*=(head)([1-6])\s+(.*)/) {
+ ($tag,$which_head, $title) = ($1,$2,$3);
+ chomp($title);
+ $$sections{htmlify(0,$title)} = 1;
+
+ if ($which_head > $listdepth) {
+ $index .= "\n" . ("\t" x $listdepth) . "<UL>\n";
+ } elsif ($which_head < $listdepth) {
+ $listdepth--;
+ $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
+ }
+ $listdepth = $which_head;
+
+ $index .= "\n" . ("\t" x $listdepth) . "<LI>" .
+ "<A HREF=\"#" . htmlify(0,$title) . "\">$title</A>";
+ }
+ }
+
+ # finish off the lists
+ while ($listdepth--) {
+ $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
+ }
+
+ # get rid of bogus lists
+ $index =~ s,\t*<UL>\s*</UL>\n,,g;
+
+ return $index;
+}
+
+#
+# scan_items - scans the pod specified by $pod for =item directives. we
+# will use this information later on in resolving C<> links.
+#
+sub scan_items {
+ my($pod, @poddata) = @_;
+ my($i, $item);
+ local $_;
+
+ $pod =~ s/\.pod$//;
+ $pod .= ".html" if $pod;
+
+ foreach $i (0..$#poddata) {
+ $_ = $poddata[$i];
+
+ # remove any formatting instructions
+ s,[A-Z]<([^<>]*)>,$1,g;
+
+ # figure out what kind of item it is and get the first word of
+ # it's name.
+ if (/^=item\s+(\w*)\s*.*$/s) {
+ if ($1 eq "*") { # bullet list
+ /\A=item\s+\*\s*(.*?)\s*\Z/s;
+ $item = $1;
+ } elsif ($1 =~ /^[0-9]+/) { # numbered list
+ /\A=item\s+[0-9]+\.?(.*?)\s*\Z/s;
+ $item = $1;
+ } else {
+# /\A=item\s+(.*?)\s*\Z/s;
+ /\A=item\s+(\w*)/s;
+ $item = $1;
+ }
+
+ $items{$item} = "$pod" if $item;
+ }
+ }
+}
+
+#
+# process_head - convert a pod head[1-6] tag and convert it to HTML format.
+#
+sub process_head {
+ my($tag, $heading) = @_;
+ my $firstword;
+
+ # figure out the level of the =head
+ $tag =~ /head([1-6])/;
+ my $level = $1;
+
+ # can't have a heading full of spaces and speechmarks and so on
+ $firstword = $heading; $firstword =~ s/\s*(\w+)\s.*/$1/;
+
+ print HTML "<P>\n" unless $listlevel;
+ print HTML "<HR>\n" unless $listlevel || $top;
+ print HTML "<H$level>"; # unless $listlevel;
+ #print HTML "<H$level>" unless $listlevel;
+ my $convert = $heading; process_text(\$convert);
+ print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>";
+ print HTML "</H$level>"; # unless $listlevel;
+ print HTML "\n";
+}
+
+#
+# process_item - convert a pod item tag and convert it to HTML format.
+#
+sub process_item {
+ my $text = $_[0];
+ my($i, $quote, $name);
+
+ my $need_preamble = 0;
+ my $this_entry;
+
+
+ # lots of documents start a list without doing an =over. this is
+ # bad! but, the proper thing to do seems to be to just assume
+ # they did do an =over. so warn them once and then continue.
+ warn "$0: $podfile: unexpected =item directive in paragraph $paragraph. ignoring.\n"
+ unless $listlevel;
+ process_over() unless $listlevel;
+
+ return unless $listlevel;
+
+ # remove formatting instructions from the text
+ 1 while $text =~ s/[A-Z]<([^<>]*)>/$1/g;
+ pre_escape(\$text);
+
+ $need_preamble = $items_seen[$listlevel]++ == 0;
+
+ # check if this is the first =item after an =over
+ $i = $listlevel - 1;
+ my $need_new = $listlevel >= @listitem;
+
+ if ($text =~ /\A\*/) { # bullet
+
+ if ($need_preamble) {
+ push(@listend, "</UL>");
+ print HTML "<UL>\n";
+ }
+
+ print HTML "<LI><STRONG>";
+ $text =~ /\A\*\s*(.*)\Z/s;
+ print HTML "<A NAME=\"item_" . htmlify(1,$1) . "\">" if $1 && !$items_named{$1}++;
+ $quote = 1;
+ #print HTML process_puretext($1, \$quote);
+ print HTML $1;
+ print HTML "</A>" if $1;
+ print HTML "</STRONG>";
+
+ } elsif ($text =~ /\A[0-9#]+/) { # numbered list
+
+ if ($need_preamble) {
+ push(@listend, "</OL>");
+ print HTML "<OL>\n";
+ }
+
+ print HTML "<LI><STRONG>";
+ $text =~ /\A[0-9]+\.?(.*)\Z/s;
+ print HTML "<A NAME=\"item_" . htmlify(0,$1) . "\">" if $1;
+ $quote = 1;
+ #print HTML process_puretext($1, \$quote);
+ print HTML $1 if $1;
+ print HTML "</A>" if $1;
+ print HTML "</STRONG>";
+
+ } else { # all others
+
+ if ($need_preamble) {
+ push(@listend, '</DL>');
+ print HTML "<DL>\n";
+ }
+
+ print HTML "<DT><STRONG>";
+ print HTML "<A NAME=\"item_" . htmlify(1,$text) . "\">"
+ if $text && !$items_named{($text =~ /(\S+)/)[0]}++;
+ # preceding craziness so that the duplicate leading bits in
+ # perlfunc work to find just the first one. otherwise
+ # open etc would have many names
+ $quote = 1;
+ #print HTML process_puretext($text, \$quote);
+ print HTML $text;
+ print HTML "</A>" if $text;
+ print HTML "</STRONG>";
+
+ print HTML '<DD>';
+ }
+
+ print HTML "\n";
+}
+
+#
+# process_over - process a pod over tag and start a corresponding HTML
+# list.
+#
+sub process_over {
+ # start a new list
+ $listlevel++;
+}
+
+#
+# process_back - process a pod back tag and convert it to HTML format.
+#
+sub process_back {
+ warn "$0: $podfile: unexpected =back directive in paragraph $paragraph. ignorning.\n"
+ unless $listlevel;
+ return unless $listlevel;
+
+ # close off the list. note, I check to see if $listend[$listlevel] is
+ # defined because an =item directive may have never appeared and thus
+ # $listend[$listlevel] may have never been initialized.
+ $listlevel--;
+ print HTML $listend[$listlevel] if defined $listend[$listlevel];
+ print HTML "\n";
+
+ # don't need the corresponding perl code anymore
+ pop(@listitem);
+ pop(@listdata);
+ pop(@listend);
+
+ pop(@items_seen);
+}
+
+#
+# process_cut - process a pod cut tag, thus stop ignoring pod directives.
+#
+sub process_cut {
+ $ignore = 1;
+}
+
+#
+# process_pod - process a pod pod tag, thus ignore pod directives until we see a
+# corresponding cut.
+#
+sub process_pod {
+ # no need to set $ignore to 0 cause the main loop did it
+}
+
+#
+# process_for - process a =for pod tag. if it's for html, split
+# it out verbatim, otherwise ignore it.
+#
+sub process_for {
+ my($whom, $text) = @_;
+ if ( $whom =~ /^(pod2)?html$/i) {
+ print HTML $text;
+ }
+}
+
+#
+# process_begin - process a =begin pod tag. this pushes
+# whom we're beginning on the begin stack. if there's a
+# begin stack, we only print if it us.
+#
+sub process_begin {
+ my($whom, $text) = @_;
+ $whom = lc($whom);
+ push (@begin_stack, $whom);
+ if ( $whom =~ /^(pod2)?html$/) {
+ print HTML $text if $text;
+ }
+}
+
+#
+# process_end - process a =end pod tag. pop the
+# begin stack. die if we're mismatched.
+#
+sub process_end {
+ my($whom, $text) = @_;
+ $whom = lc($whom);
+ if ($begin_stack[-1] ne $whom ) {
+ die "Unmatched begin/end at chunk $paragraph\n"
+ }
+ pop @begin_stack;
+}
+
+#
+# process_text - handles plaintext that appears in the input pod file.
+# there may be pod commands embedded within the text so those must be
+# converted to html commands.
+#
+sub process_text {
+ my($text, $escapeQuotes) = @_;
+ my($result, $rest, $s1, $s2, $s3, $s4, $match, $bf);
+ my($podcommand, $params, $tag, $quote);
+
+ return if $ignore;
+
+ $quote = 0; # status of double-quote conversion
+ $result = "";
+ $rest = $$text;
+
+ if ($rest =~ /^\s+/) { # preformatted text, no pod directives
+ $rest =~ s/\n+\Z//;
+
+ $rest =~ s/&/&amp;/g;
+ $rest =~ s/</&lt;/g;
+ $rest =~ s/>/&gt;/g;
+ $rest =~ s/"/&quot;/g;
+
+ # try and create links for all occurrences of perl.* within
+ # the preformatted text.
+ $rest =~ s{
+ (\s*)(perl\w+)
+ }{
+ if (defined $pages{$2}) { # is a link
+ qq($1<A HREF="$htmlroot/$pages{$2}">$2</A>);
+ } else {
+ "$1$2";
+ }
+ }xeg;
+ $rest =~ s/(<A HREF=)([^>:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g;
+
+ my $urls = '(' . join ('|', qw{
+ http
+ telnet
+ mailto
+ news
+ gopher
+ file
+ wais
+ ftp
+ } )
+ . ')';
+
+ my $ltrs = '\w';
+ my $gunk = '/#~:.?+=&%@!\-';
+ my $punc = '.:?\-';
+ my $any = "${ltrs}${gunk}${punc}";
+
+ $rest =~ s{
+ \b # start at word boundary
+ ( # begin $1 {
+ $urls : # need resource and a colon
+ [$any] +? # followed by on or more
+ # of any valid character, but
+ # be conservative and take only
+ # what you need to....
+ ) # end $1 }
+ (?= # look-ahead non-consumptive assertion
+ [$punc]* # either 0 or more puntuation
+ [^$any] # followed by a non-url char
+ | # or else
+ $ # then end of the string
+ )
+ }{<A HREF="$1">$1</A>}igox;
+
+ $result = "<PRE>" # text should be as it is (verbatim)
+ . "$rest\n"
+ . "</PRE>\n";
+ } else { # formatted text
+ # parse through the string, stopping each time we find a
+ # pod-escape. once the string has been throughly processed
+ # we can output it.
+ while ($rest) {
+ # check to see if there are any possible pod directives in
+ # the remaining part of the text.
+ if ($rest =~ m/[BCEIFLSZ]</) {
+ warn "\$rest\t= $rest\n" unless
+ $rest =~ /\A
+ ([^<]*?)
+ ([BCEIFLSZ]?)
+ <
+ (.*)\Z/xs;
+
+ $s1 = $1; # pure text
+ $s2 = $2; # the type of pod-escape that follows
+ $s3 = '<'; # '<'
+ $s4 = $3; # the rest of the string
+ } else {
+ $s1 = $rest;
+ $s2 = "";
+ $s3 = "";
+ $s4 = "";
+ }
+
+ if ($s3 eq '<' && $s2) { # a pod-escape
+ $result .= ($escapeQuotes ? process_puretext($s1, \$quote) : $s1);
+ $podcommand = "$s2<";
+ $rest = $s4;
+
+ # find the matching '>'
+ $match = 1;
+ $bf = 0;
+ while ($match && !$bf) {
+ $bf = 1;
+ if ($rest =~ /\A([^<>]*[BCEIFLSZ]<)(.*)\Z/s) {
+ $bf = 0;
+ $match++;
+ $podcommand .= $1;
+ $rest = $2;
+ } elsif ($rest =~ /\A([^>]*>)(.*)\Z/s) {
+ $bf = 0;
+ $match--;
+ $podcommand .= $1;
+ $rest = $2;
+ }
+ }
+
+ if ($match != 0) {
+ warn <<WARN;
+$0: $podfile: cannot find matching > for $s2 in paragraph $paragraph.
+WARN
+ $result .= substr $podcommand, 0, 2;
+ $rest = substr($podcommand, 2) . $rest;
+ next;
+ }
+
+ # pull out the parameters to the pod-escape
+ $podcommand =~ /^([BCFEILSZ]?)<(.*)>$/s;
+ $tag = $1;
+ $params = $2;
+
+ # process the text within the pod-escape so that any escapes
+ # which must occur do.
+ process_text(\$params, 0) unless $tag eq 'L';
+
+ $s1 = $params;
+ if (!$tag || $tag eq " ") { # <> : no tag
+ $s1 = "&lt;$params&gt;";
+ } elsif ($tag eq "L") { # L<> : link
+ $s1 = process_L($params);
+ } elsif ($tag eq "I" || # I<> : italicize text
+ $tag eq "B" || # B<> : bold text
+ $tag eq "F") { # F<> : file specification
+ $s1 = process_BFI($tag, $params);
+ } elsif ($tag eq "C") { # C<> : literal code
+ $s1 = process_C($params, 1);
+ } elsif ($tag eq "E") { # E<> : escape
+ $s1 = process_E($params);
+ } elsif ($tag eq "Z") { # Z<> : zero-width character
+ $s1 = process_Z($params);
+ } elsif ($tag eq "S") { # S<> : non-breaking space
+ $s1 = process_S($params);
+ } elsif ($tag eq "X") { # S<> : non-breaking space
+ $s1 = process_X($params);
+ } else {
+ warn "$0: $podfile: unhandled tag '$tag' in paragraph $paragraph\n";
+ }
+
+ $result .= "$s1";
+ } else {
+ # for pure text we must deal with implicit links and
+ # double-quotes among other things.
+ $result .= ($escapeQuotes ? process_puretext("$s1$s2$s3", \$quote) : "$s1$s2$s3");
+ $rest = $s4;
+ }
+ }
+ }
+ $$text = $result;
+}
+
+sub html_escape {
+ my $rest = $_[0];
+ $rest =~ s/&/&amp;/g;
+ $rest =~ s/</&lt;/g;
+ $rest =~ s/>/&gt;/g;
+ $rest =~ s/"/&quot;/g;
+ return $rest;
+}
+
+#
+# process_puretext - process pure text (without pod-escapes) converting
+# double-quotes and handling implicit C<> links.
+#
+sub process_puretext {
+ my($text, $quote) = @_;
+ my(@words, $result, $rest, $lead, $trail);
+
+ # convert double-quotes to single-quotes
+ $text =~ s/\A([^"]*)"/$1''/s if $$quote;
+ while ($text =~ s/\A([^"]*)["]([^"]*)["]/$1``$2''/sg) {}
+
+ $$quote = ($text =~ m/"/ ? 1 : 0);
+ $text =~ s/\A([^"]*)"/$1``/s if $$quote;
+
+ # keep track of leading and trailing white-space
+ $lead = ($text =~ /\A(\s*)/s ? $1 : "");
+ $trail = ($text =~ /(\s*)\Z/s ? $1 : "");
+
+ # collapse all white space into a single space
+ $text =~ s/\s+/ /g;
+ @words = split(" ", $text);
+
+ # process each word individually
+ foreach my $word (@words) {
+ # see if we can infer a link
+ if ($word =~ /^\w+\(/) {
+ # has parenthesis so should have been a C<> ref
+ $word = process_C($word);
+# $word =~ /^[^()]*]\(/;
+# if (defined $items{$1} && $items{$1}) {
+# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$1}#item_"
+# . htmlify(0,$word)
+# . "\">$word</A></CODE>";
+# } elsif (defined $items{$word} && $items{$word}) {
+# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$word}#item_"
+# . htmlify(0,$word)
+# . "\">$word</A></CODE>";
+# } else {
+# $word = "\n<CODE><A HREF=\"#item_"
+# . htmlify(0,$word)
+# . "\">$word</A></CODE>";
+# }
+ } elsif ($word =~ /^[\$\@%&*]+\w+$/) {
+ # perl variables, should be a C<> ref
+ $word = process_C($word, 1);
+ } elsif ($word =~ m,^\w+://\w,) {
+ # looks like a URL
+ $word = qq(<A HREF="$word">$word</A>);
+ } elsif ($word =~ /[\w.-]+\@\w+\.\w/) {
+ # looks like an e-mail address
+ $word = qq(<A HREF="MAILTO:$word">$word</A>);
+ } elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) { # all uppercase?
+ $word = html_escape($word) if $word =~ /[&<>]/;
+ $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape;
+ } else {
+ $word = html_escape($word) if $word =~ /[&<>]/;
+ }
+ }
+
+ # build a new string based upon our conversion
+ $result = "";
+ $rest = join(" ", @words);
+ while (length($rest) > 75) {
+ if ( $rest =~ m/^(.{0,75})\s(.*?)$/o ||
+ $rest =~ m/^(\S*)\s(.*?)$/o) {
+
+ $result .= "$1\n";
+ $rest = $2;
+ } else {
+ $result .= "$rest\n";
+ $rest = "";
+ }
+ }
+ $result .= $rest if $rest;
+
+ # restore the leading and trailing white-space
+ $result = "$lead$result$trail";
+
+ return $result;
+}
+
+#
+# pre_escape - convert & in text to $amp;
+#
+sub pre_escape {
+ my($str) = @_;
+
+ $$str =~ s,&,&amp;,g;
+}
+
+#
+# process_L - convert a pod L<> directive to a corresponding HTML link.
+# most of the links made are inferred rather than known about directly
+# (i.e it's not known whether the =head\d section exists in the target file,
+# or whether a .pod file exists in the case of split files). however, the
+# guessing usually works.
+#
+# Unlike the other directives, this should be called with an unprocessed
+# string, else tags in the link won't be matched.
+#
+sub process_L {
+ my($str) = @_;
+ my($s1, $s2, $linktext, $page, $section, $link); # work strings
+
+ $str =~ s/\n/ /g; # undo word-wrapped tags
+ $s1 = $str;
+ for ($s1) {
+ # a :: acts like a /
+ s,::,/,;
+
+ # make sure sections start with a /
+ s,^",/",g;
+ s,^,/,g if (!m,/, && / /);
+
+ # check if there's a section specified
+ if (m,^(.*?)/"?(.*?)"?$,) { # yes
+ ($page, $section) = ($1, $2);
+ } else { # no
+ ($page, $section) = ($str, "");
+ }
+
+ # check if we know that this is a section in this page
+ if (!defined $pages{$page} && defined $sections{$page}) {
+ $section = $page;
+ $page = "";
+ }
+ }
+
+ if ($page eq "") {
+ $link = "#" . htmlify(0,$section);
+ $linktext = $section;
+ } elsif (!defined $pages{$page}) {
+ warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n";
+ $link = "";
+ $linktext = $page;
+ } else {
+ $linktext = ($section ? "$section" : "the $page manpage");
+ $section = htmlify(0,$section) if $section ne "";
+
+ # if there is a directory by the name of the page, then assume that an
+ # appropriate section will exist in the subdirectory
+ if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+ $link = "$htmlroot/$1/$section.html";
+
+ # since there is no directory by the name of the page, the section will
+ # have to exist within a .html of the same name. thus, make sure there
+ # is a .pod or .pm that might become that .html
+ } else {
+ $section = "#$section";
+ # check if there is a .pod with the page name
+ if ($pages{$page} =~ /([^:]*)\.pod:/) {
+ $link = "$htmlroot/$1.html$section";
+ } elsif ($pages{$page} =~ /([^:]*)\.pm:/) {
+ $link = "$htmlroot/$1.html$section";
+ } else {
+ warn "$0: $podfile: cannot resolve L$str in paragraph $paragraph: ".
+ "no .pod or .pm found\n";
+ $link = "";
+ $linktext = $section;
+ }
+ }
+ }
+
+ process_text(\$linktext, 0);
+ if ($link) {
+ $s1 = "<A HREF=\"$link\">$linktext</A>";
+ } else {
+ $s1 = "<EM>$linktext</EM>";
+ }
+ return $s1;
+}
+
+#
+# process_BFI - process any of the B<>, F<>, or I<> pod-escapes and
+# convert them to corresponding HTML directives.
+#
+sub process_BFI {
+ my($tag, $str) = @_;
+ my($s1); # work string
+ my(%repltext) = ( 'B' => 'STRONG',
+ 'F' => 'EM',
+ 'I' => 'EM');
+
+ # extract the modified text and convert to HTML
+ $s1 = "<$repltext{$tag}>$str</$repltext{$tag}>";
+ return $s1;
+}
+
+#
+# process_C - process the C<> pod-escape.
+#
+sub process_C {
+ my($str, $doref) = @_;
+ my($s1, $s2);
+
+ $s1 = $str;
+ $s1 =~ s/\([^()]*\)//g; # delete parentheses
+ $str = $s2 = $s1;
+ $s1 =~ s/\W//g; # delete bogus characters
+
+ # if there was a pod file that we found earlier with an appropriate
+ # =item directive, then create a link to that page.
+ if ($doref && defined $items{$s1}) {
+ $s1 = ($items{$s1} ?
+ "<A HREF=\"$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) . "\">$str</A>" :
+ "<A HREF=\"#item_" . htmlify(0,$s2) . "\">$str</A>");
+ $s1 =~ s,(perl\w+/(\S+)\.html)#item_\2\b,$1,;
+ confess "s1 has space: $s1" if $s1 =~ /HREF="[^"]*\s[^"]*"/;
+ } else {
+ $s1 = "<CODE>$str</CODE>";
+ # warn "$0: $podfile: cannot resolve C<$str> in paragraph $paragraph\n" if $verbose
+ }
+
+
+ return $s1;
+}
+
+#
+# process_E - process the E<> pod directive which seems to escape a character.
+#
+sub process_E {
+ my($str) = @_;
+
+ for ($str) {
+ s,([^/].*),\&$1\;,g;
+ }
+
+ return $str;
+}
+
+#
+# process_Z - process the Z<> pod directive which really just amounts to
+# ignoring it. this allows someone to start a paragraph with an =
+#
+sub process_Z {
+ my($str) = @_;
+
+ # there is no equivalent in HTML for this so just ignore it.
+ $str = "";
+ return $str;
+}
+
+#
+# process_S - process the S<> pod directive which means to convert all
+# spaces in the string to non-breaking spaces (in HTML-eze).
+#
+sub process_S {
+ my($str) = @_;
+
+ # convert all spaces in the text to non-breaking spaces in HTML.
+ $str =~ s/ /&nbsp;/g;
+ return $str;
+}
+
+#
+# process_X - this is supposed to make an index entry. we'll just
+# ignore it.
+#
+sub process_X {
+ return '';
+}
+
+
+#
+# finish_list - finish off any pending HTML lists. this should be called
+# after the entire pod file has been read and converted.
+#
+sub finish_list {
+ while ($listlevel >= 0) {
+ print HTML "</DL>\n";
+ $listlevel--;
+ }
+}
+
+#
+# htmlify - converts a pod section specification to a suitable section
+# specification for HTML. if first arg is 1, only takes 1st word.
+#
+sub htmlify {
+ my($compact, $heading) = @_;
+
+ if ($compact) {
+ $heading =~ /^(\w+)/;
+ $heading = $1;
+ }
+
+ # $heading = lc($heading);
+ $heading =~ s/[^\w\s]/_/g;
+ $heading =~ s/(\s+)/ /g;
+ $heading =~ s/^\s*(.*?)\s*$/$1/s;
+ $heading =~ s/ /_/g;
+ $heading =~ s/\A(.{32}).*\Z/$1/s;
+ $heading =~ s/\s+\Z//;
+ $heading =~ s/_{2,}/_/g;
+
+ return $heading;
+}
+
+BEGIN {
+}
+
+1;
+
diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm
index 5a73ecfc52..0b3b4aa4ad 100644
--- a/lib/Term/Cap.pm
+++ b/lib/Term/Cap.pm
@@ -185,13 +185,16 @@ sub Tgetent { ## public -- static method
# This is eval'ed inside the while loop for each file
$search = q{
- while ($_ = <TERMCAP>) {
+ while (<TERMCAP>) {
next if /^\\t/ || /^#/;
if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
chomp;
s/^[^:]*:// if $first++;
$state = 0;
- while ($_ =~ s/\\\\$//) { $_ .= <TERMCAP>; chomp; }
+ while ($_ =~ s/\\\\$//) {
+ defined(my $x = <TERMCAP>) or last;
+ $_ .= $x; chomp;
+ }
last;
}
}
diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm
index f2e1514972..ce6f0009fc 100644
--- a/lib/Text/ParseWords.pm
+++ b/lib/Text/ParseWords.pm
@@ -9,6 +9,8 @@ use Carp;
@EXPORT = qw(shellwords quotewords);
@EXPORT_OK = qw(old_shellwords);
+*AUTOLOAD = *AutoLoader::AUTOLOAD;
+
=head1 NAME
Text::ParseWords - parse text into an array of tokens
diff --git a/lib/chat2.inter b/lib/chat2.inter
deleted file mode 100644
index 6934f1cc28..0000000000
--- a/lib/chat2.inter
+++ /dev/null
@@ -1,495 +0,0 @@
-Article 20992 of comp.lang.perl:
-Path: netlabs!news.cerf.net!mvb.saic.com!MathWorks.Com!europa.eng.gtefsd.com!howland.reston.ans.net!cs.utexas.edu!swrinde!ihnp4.ucsd.edu!ames!koriel!male.EBay.Sun.COM!jethro.Corp.Sun.COM!eric
-From: eric.arnold@sun.com (Eric Arnold)
-Newsgroups: comp.lang.perl
-Subject: Re: Need a bidirectional filter for interactive Unix applications
-Date: 15 Apr 94 21:24:03 GMT
-Organization: Sun Microsystems
-Lines: 478
-Sender: news@sun.com
-Message-ID: <ERIC.94Apr15212403@sun.com>
-References: <dgfCo9F2J.Jzw@netcom.com> <1994Apr15.110134.4581@chemabs.uucp>
-NNTP-Posting-Host: animus.corp.sun.com
-X-Newsreader: prn Ver 1.09
-In-reply-to: btf64@cas.org's message of Fri, 15 Apr 1994 11:01:34 GMT
-
-In article <1994Apr15.110134.4581@chemabs.uucp>
- btf64@cas.org (Bernard T. French) writes:
-
->In article <dgfCo9F2J.Jzw@netcom.com> dgf@netcom.com (David Feldman) writes:
->>I need to write a bidirectional filter that would (ideally) sit between a
-..
->>program's stdin & stdout to point to a pty pair known to perl. The perl app-
->>lication would talk to the user's crt/keyboard, translate (application-specific)
->>the input & output streams, and pass these as appropriate to/from the pty pair,
-..
->
-> I'm afraid I can't offer you a perl solution, but err..... there is a
->Tcl solution. There is a Tcl extension called "expect" that is designed to
-
-There *is* an old, established Perl solution: "chat2.pl" which does
-everything (well, basically) "expect" does but you get it in the
-expressive Perl environment. "chat2.pl" is delivered with the Perl
-source.
-
-Randal: "interact()" still hasn't made it into Perl5alpha8
-"chat2.pl", so I've included a version which does.
-
--Eric
-
-
-## chat.pl: chat with a server
-## V2.01.alpha.7 91/06/16
-## Randal L. Schwartz
-
-package chat;
-
-$sockaddr = 'S n a4 x8';
-chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
-$thisproc = pack($sockaddr, 2, 0, $thisaddr);
-
-# *S = symbol for current I/O, gets assigned *chatsymbol....
-$next = "chatsymbol000000"; # next one
-$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
-
-
-## $handle = &chat'open_port("server.address",$port_number);
-## opens a named or numbered TCP server
-
-sub open_port { ## public
- local($server, $port) = @_;
-
- local($serveraddr,$serverproc);
-
- *S = ++$next;
- if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
- $serveraddr = pack('C4', $1, $2, $3, $4);
- } else {
- local(@x) = gethostbyname($server);
- return undef unless @x;
- $serveraddr = $x[4];
- }
- $serverproc = pack($sockaddr, 2, $port, $serveraddr);
- unless (socket(S, 2, 1, 6)) {
- # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
- # but who the heck would change these anyway? (:-)
- ($!) = ($!, close(S)); # close S while saving $!
- return undef;
- }
- unless (bind(S, $thisproc)) {
- ($!) = ($!, close(S)); # close S while saving $!
- return undef;
- }
- unless (connect(S, $serverproc)) {
- ($!) = ($!, close(S)); # close S while saving $!
- return undef;
- }
- select((select(S), $| = 1)[0]);
- $next; # return symbol for switcharound
-}
-
-## ($host, $port, $handle) = &chat'open_listen([$port_number]);
-## opens a TCP port on the current machine, ready to be listened to
-## if $port_number is absent or zero, pick a default port number
-## process must be uid 0 to listen to a low port number
-
-sub open_listen { ## public
-
- *S = ++$next;
- local($thisport) = shift || 0;
- local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
- local(*NS) = "__" . time;
- unless (socket(NS, 2, 1, 6)) {
- # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
- # but who the heck would change these anyway? (:-)
- ($!) = ($!, close(NS));
- return undef;
- }
- unless (bind(NS, $thisproc_local)) {
- ($!) = ($!, close(NS));
- return undef;
- }
- unless (listen(NS, 1)) {
- ($!) = ($!, close(NS));
- return undef;
- }
- select((select(NS), $| = 1)[0]);
- local($family, $port, @myaddr) =
- unpack("S n C C C C x8", getsockname(NS));
- $S{"needs_accept"} = *NS; # so expect will open it
- (@myaddr, $port, $next); # returning this
-}
-
-## $handle = &chat'open_proc("command","arg1","arg2",...);
-## opens a /bin/sh on a pseudo-tty
-
-sub open_proc { ## public
- local(@cmd) = @_;
-
- *S = ++$next;
- local(*TTY) = "__TTY" . time;
- local($pty,$tty,$pty_handle) = &_getpty(S,TTY);
-
- #local($pty,$tty,$pty_handle) = &getpty(S,TTY);
- #$Tty = $tty;
-
- die "Cannot find a new pty" unless defined $pty;
- local($pid) = fork;
- die "Cannot fork: $!" unless defined $pid;
- unless ($pid) {
- close STDIN; close STDOUT; close STDERR;
- #close($pty_handle);
- setpgrp(0,$$);
- if (open(DEVTTY, "/dev/tty")) {
- ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
- close DEVTTY;
- }
- open(STDIN,"<&TTY");
- open(STDOUT,">&TTY");
- open(STDERR,">&STDOUT");
- die "Oops" unless fileno(STDERR) == 2; # sanity
- close(S);
-
- exec @cmd;
- die "Cannot exec @cmd: $!";
- }
- close(TTY);
- $PID{$next} = $pid;
- $next; # return symbol for switcharound
-
-}
-
-# $S is the read-ahead buffer
-
-## $return = &chat'expect([$handle,] $timeout_time,
-## $pat1, $body1, $pat2, $body2, ... )
-## $handle is from previous &chat'open_*().
-## $timeout_time is the time (either relative to the current time, or
-## absolute, ala time(2)) at which a timeout event occurs.
-## $pat1, $pat2, and so on are regexs which are matched against the input
-## stream. If a match is found, the entire matched string is consumed,
-## and the corresponding body eval string is evaled.
-##
-## Each pat is a regular-expression (probably enclosed in single-quotes
-## in the invocation). ^ and $ will work, respecting the current value of $*.
-## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
-## If pat is 'EOF', the body is executed if the process exits before
-## the other patterns are seen.
-##
-## Pats are scanned in the order given, so later pats can contain
-## general defaults that won't be examined unless the earlier pats
-## have failed.
-##
-## The result of eval'ing body is returned as the result of
-## the invocation. Recursive invocations are not thought
-## through, and may work only accidentally. :-)
-##
-## undef is returned if either a timeout or an eof occurs and no
-## corresponding body has been defined.
-## I/O errors of any sort are treated as eof.
-
-$nextsubname = "expectloop000000"; # used for subroutines
-
-sub expect { ## public
- if ($_[0] =~ /$nextpat/) {
- *S = shift;
- }
- local($endtime) = shift;
-
- local($timeout,$eof) = (1,1);
- local($caller) = caller;
- local($rmask, $nfound, $timeleft, $thisbuf);
- local($cases, $pattern, $action, $subname);
- $endtime += time if $endtime < 600_000_000;
-
- if (defined $S{"needs_accept"}) { # is it a listen socket?
- local(*NS) = $S{"needs_accept"};
- delete $S{"needs_accept"};
- $S{"needs_close"} = *NS;
- unless(accept(S,NS)) {
- ($!) = ($!, close(S), close(NS));
- return undef;
- }
- select((select(S), $| = 1)[0]);
- }
-
- # now see whether we need to create a new sub:
-
- unless ($subname = $expect_subname{$caller,@_}) {
- # nope. make a new one:
- $expect_subname{$caller,@_} = $subname = $nextsubname++;
-
- $cases .= <<"EDQ"; # header is funny to make everything elsif's
-sub $subname {
- LOOP: {
- if (0) { ; }
-EDQ
- while (@_) {
- ($pattern,$action) = splice(@_,0,2);
- if ($pattern =~ /^eof$/i) {
- $cases .= <<"EDQ";
- elsif (\$eof) {
- package $caller;
- $action;
- }
-EDQ
- $eof = 0;
- } elsif ($pattern =~ /^timeout$/i) {
- $cases .= <<"EDQ";
- elsif (\$timeout) {
- package $caller;
- $action;
- }
-EDQ
- $timeout = 0;
- } else {
- $pattern =~ s#/#\\/#g;
- $cases .= <<"EDQ";
- elsif (\$S =~ /$pattern/) {
- \$S = \$';
- package $caller;
- $action;
- }
-EDQ
- }
- }
- $cases .= <<"EDQ" if $eof;
- elsif (\$eof) {
- undef;
- }
-EDQ
- $cases .= <<"EDQ" if $timeout;
- elsif (\$timeout) {
- undef;
- }
-EDQ
- $cases .= <<'ESQ';
- else {
- $rmask = "";
- vec($rmask,fileno(S),1) = 1;
- ($nfound, $rmask) =
- select($rmask, undef, undef, $endtime - time);
- if ($nfound) {
- $nread = sysread(S, $thisbuf, 1024);
- if ($nread > 0) {
- $S .= $thisbuf;
- } else {
- $eof++, redo LOOP; # any error is also eof
- }
- } else {
- $timeout++, redo LOOP; # timeout
- }
- redo LOOP;
- }
- }
-}
-ESQ
- eval $cases; die "$cases:\n$@" if $@;
- }
- $eof = $timeout = 0;
- do $subname();
-}
-
-## &chat'print([$handle,] @data)
-## $handle is from previous &chat'open().
-## like print $handle @data
-
-sub print { ## public
- if ($_[0] =~ /$nextpat/) {
- *S = shift;
- }
- print S @_;
-}
-
-## &chat'close([$handle,])
-## $handle is from previous &chat'open().
-## like close $handle
-
-sub close { ## public
- local($pid);
- if ($_[0] =~ /$nextpat/) {
- $pid = $PID{$_[0]};
- *S = shift;
- } else {
- $pid = $PID{$next};
- }
- close(S);
- waitpid($pid,0);
- if (defined $S{"needs_close"}) { # is it a listen socket?
- local(*NS) = $S{"needs_close"};
- delete $S{"needs_close"};
- close(NS);
- }
-}
-
-## @ready_handles = &chat'select($timeout, @handles)
-## select()'s the handles with a timeout value of $timeout seconds.
-## Returns an array of handles that are ready for I/O.
-## Both user handles and chat handles are supported (but beware of
-## stdio's buffering for user handles).
-
-sub select { ## public
- local($timeout) = shift;
- local(@handles) = @_;
- local(%handlename) = ();
- local(%ready) = ();
- local($caller) = caller;
- local($rmask) = "";
- for (@handles) {
- if (/$nextpat/o) { # one of ours... see if ready
- local(*SYM) = $_;
- if (length($SYM)) {
- $timeout = 0; # we have a winner
- $ready{$_}++;
- }
- $handlename{fileno($_)} = $_;
- } else {
- $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
- }
- }
- for (sort keys %handlename) {
- vec($rmask, $_, 1) = 1;
- }
- select($rmask, undef, undef, $timeout);
- for (sort keys %handlename) {
- $ready{$handlename{$_}}++ if vec($rmask,$_,1);
- }
- sort keys %ready;
-}
-
-# ($pty,$tty) = $chat'_getpty(PTY,TTY):
-# internal procedure to get the next available pty.
-# opens pty on handle PTY, and matching tty on handle TTY.
-# returns undef if can't find a pty.
-
-sub _getpty { ## private
- local($_PTY,$_TTY) = @_;
- $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
- $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
- local($pty,$tty);
- for $bank (112..127) {
- next unless -e sprintf("/dev/pty%c0", $bank);
- for $unit (48..57) {
- $pty = sprintf("/dev/pty%c%c", $bank, $unit);
- open($_PTY,"+>$pty") || next;
- select((select($_PTY), $| = 1)[0]);
- ($tty = $pty) =~ s/pty/tty/;
- open($_TTY,"+>$tty") || next;
- select((select($_TTY), $| = 1)[0]);
- system "stty nl>$tty";
- return ($pty,$tty,$_PTY);
- }
- }
- undef;
-}
-
-
-sub getpty {
- local( $pty_handle, $tty_handle ) = @_;
-
-print "--------in getpty----------\n";
- $pty_handle =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
- $pty_handle =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
-
- #$pty_handle = ++$next_handle;
- chop( @ptys = `ls /dev/pty*` );
-
- for $pty ( @ptys )
- {
- open($pty_handle,"+>$pty") || next;
- select((select($pty_handle), $| = 1)[0]);
- ($tty = $pty) =~ s/pty/tty/;
-
- open($tty_handle,"+>$tty") || next;
- select((select($tty_handle), $| = 1)[0]);
- ($tty = $pty) =~ s/pty/tty/;
-
- return ($pty, $tty, $pty_handle );
- }
- return undef;
-}
-
-
-
-# from: Randal L. Schwartz
-
-# Usage:
-#
-# ($chathandle = &chat'open_proc("/bin/sh")) || die "cannot open shell";
-# system("stty cbreak raw -echo >/dev/tty\n");
-# &chat'interact($chathandle);
-# &chat'close($chathandle);
-# system("stty -cbreak -raw echo >/dev/tty\n");
-
-sub interact
-{
- local( $chathandle ) = @_;
-
- &chat'print($chathandle, "stty sane\n");
- select(STDOUT) ; $| = 1; # unbuffer STDOUT
-
- #print "tty=$Tty,whoami=",`whoami`,"\n";
- #&change_utmp( "", $Tty, "eric", "", time() );
-
- {
- @ready = &chat'select(30, STDIN,$chathandle);
- print "after select, ready=",join(",",@ready),"\n";
- #(warn "[waiting]"), redo unless @ready;
- if (grep($_ eq $chathandle, @ready)) {
- print "checking $chathandle\n";
- last unless $text = &chat'expect($chathandle,0,'[\s\S]+','$&');
- print "$chathandle OK\n";
- print "got=($text)";
- #print $text;
- }
- if (grep($_ eq STDIN, @ready)) {
- print "checking STDIN\n";
- last unless sysread(STDIN,$buf,1024) > 0;
- print "STDIN OK\n";
- &chat'print($chathandle,$buf);
- }
- redo;
- }
- #&change_utmp( $Tty, "$Tty", "", "", 0 );
- print "leaving interact, \$!=$!\n";
-}
-
-## $handle = &chat'open_duphandle(handle);
-## duplicates an input file handle to conform to chat format
-
-sub open_duphandle { ## public
- *S = ++$next;
- open(S,"<&$_[0]");
- $next; # return symbol for switcharound
-}
-
-#Here is an example which uses this routine.
-#
-# # The following lines makes stdin unbuffered
-#
-# $BSD = -f '/vmunix';
-#
-# if ($BSD) {
-# system "stty cbreak </dev/tty >/dev/tty 2>&1";
-# }
-# else {
-# system "stty", '-icanon';
-# system "stty", 'eol', '^A';
-# }
-#
-# require 'mychat2.pl';
-#
-# &chat'open_duphandle(STDIN);
-#
-# print
-# &chat'expect(3,
-# '[A-Z]', '" :-)"',
-# '.', '" :-("',
-# TIMEOUT, '"-o-"',
-# EOF, '"\$\$"'),
-# "\n";
-
-
-1;
-
-
diff --git a/lib/chat2.pl b/lib/chat2.pl
deleted file mode 100644
index 8320270175..0000000000
--- a/lib/chat2.pl
+++ /dev/null
@@ -1,368 +0,0 @@
-# chat.pl: chat with a server
-# Based on: V2.01.alpha.7 91/06/16
-# Randal L. Schwartz (was <merlyn@stonehenge.com>)
-# multihome additions by A.Macpherson@bnr.co.uk
-# allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU>
-
-package chat;
-
-require 'sys/socket.ph';
-
-if( defined( &main'PF_INET ) ){
- $pf_inet = &main'PF_INET;
- $sock_stream = &main'SOCK_STREAM;
- local($name, $aliases, $proto) = getprotobyname( 'tcp' );
- $tcp_proto = $proto;
-}
-else {
- # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
- # but who the heck would change these anyway? (:-)
- $pf_inet = 2;
- $sock_stream = 1;
- $tcp_proto = 6;
-}
-
-
-$sockaddr = 'S n a4 x8';
-chop($thishost = `hostname`);
-
-# *S = symbol for current I/O, gets assigned *chatsymbol....
-$next = "chatsymbol000000"; # next one
-$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
-
-
-## $handle = &chat'open_port("server.address",$port_number);
-## opens a named or numbered TCP server
-
-sub open_port { ## public
- local($server, $port) = @_;
-
- local($serveraddr,$serverproc);
-
- # We may be multi-homed, start with 0, fixup once connexion is made
- $thisaddr = "\0\0\0\0" ;
- $thisproc = pack($sockaddr, 2, 0, $thisaddr);
-
- *S = ++$next;
- if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
- $serveraddr = pack('C4', $1, $2, $3, $4);
- } else {
- local(@x) = gethostbyname($server);
- return undef unless @x;
- $serveraddr = $x[4];
- }
- $serverproc = pack($sockaddr, 2, $port, $serveraddr);
- unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) {
- ($!) = ($!, close(S)); # close S while saving $!
- return undef;
- }
- unless (bind(S, $thisproc)) {
- ($!) = ($!, close(S)); # close S while saving $!
- return undef;
- }
- unless (connect(S, $serverproc)) {
- ($!) = ($!, close(S)); # close S while saving $!
- return undef;
- }
-# We opened with the local address set to ANY, at this stage we know
-# which interface we are using. This is critical if our machine is
-# multi-homed, with IP forwarding off, so fix-up.
- local($fam,$lport);
- ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S));
- $thisproc = pack($sockaddr, 2, 0, $thisaddr);
-# end of post-connect fixup
- select((select(S), $| = 1)[0]);
- $next; # return symbol for switcharound
-}
-
-## ($host, $port, $handle) = &chat'open_listen([$port_number]);
-## opens a TCP port on the current machine, ready to be listened to
-## if $port_number is absent or zero, pick a default port number
-## process must be uid 0 to listen to a low port number
-
-sub open_listen { ## public
-
- *S = ++$next;
- local($thisport) = shift || 0;
- local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
- local(*NS) = "__" . time;
- unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) {
- ($!) = ($!, close(NS));
- return undef;
- }
- unless (bind(NS, $thisproc_local)) {
- ($!) = ($!, close(NS));
- return undef;
- }
- unless (listen(NS, 1)) {
- ($!) = ($!, close(NS));
- return undef;
- }
- select((select(NS), $| = 1)[0]);
- local($family, $port, @myaddr) =
- unpack("S n C C C C x8", getsockname(NS));
- $S{"needs_accept"} = *NS; # so expect will open it
- (@myaddr, $port, $next); # returning this
-}
-
-## $handle = &chat'open_proc("command","arg1","arg2",...);
-## opens a /bin/sh on a pseudo-tty
-
-sub open_proc { ## public
- local(@cmd) = @_;
-
- *S = ++$next;
- local(*TTY) = "__TTY" . time;
- local($pty,$tty) = &_getpty(S,TTY);
- die "Cannot find a new pty" unless defined $pty;
- $pid = fork;
- die "Cannot fork: $!" unless defined $pid;
- unless ($pid) {
- close STDIN; close STDOUT; close STDERR;
- setpgrp(0,$$);
- if (open(DEVTTY, "/dev/tty")) {
- ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
- close DEVTTY;
- }
- open(STDIN,"<&TTY");
- open(STDOUT,">&TTY");
- open(STDERR,">&STDOUT");
- die "Oops" unless fileno(STDERR) == 2; # sanity
- close(S);
- exec @cmd;
- die "Cannot exec @cmd: $!";
- }
- close(TTY);
- $next; # return symbol for switcharound
-}
-
-# $S is the read-ahead buffer
-
-## $return = &chat'expect([$handle,] $timeout_time,
-## $pat1, $body1, $pat2, $body2, ... )
-## $handle is from previous &chat'open_*().
-## $timeout_time is the time (either relative to the current time, or
-## absolute, ala time(2)) at which a timeout event occurs.
-## $pat1, $pat2, and so on are regexs which are matched against the input
-## stream. If a match is found, the entire matched string is consumed,
-## and the corresponding body eval string is evaled.
-##
-## Each pat is a regular-expression (probably enclosed in single-quotes
-## in the invocation). ^ and $ will work, respecting the current value of $*.
-## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
-## If pat is 'EOF', the body is executed if the process exits before
-## the other patterns are seen.
-##
-## Pats are scanned in the order given, so later pats can contain
-## general defaults that won't be examined unless the earlier pats
-## have failed.
-##
-## The result of eval'ing body is returned as the result of
-## the invocation. Recursive invocations are not thought
-## through, and may work only accidentally. :-)
-##
-## undef is returned if either a timeout or an eof occurs and no
-## corresponding body has been defined.
-## I/O errors of any sort are treated as eof.
-
-$nextsubname = "expectloop000000"; # used for subroutines
-
-sub expect { ## public
- if ($_[0] =~ /$nextpat/) {
- *S = shift;
- }
- local($endtime) = shift;
-
- local($timeout,$eof) = (1,1);
- local($caller) = caller;
- local($rmask, $nfound, $timeleft, $thisbuf);
- local($cases, $pattern, $action, $subname);
- $endtime += time if $endtime < 600_000_000;
-
- if (defined $S{"needs_accept"}) { # is it a listen socket?
- local(*NS) = $S{"needs_accept"};
- delete $S{"needs_accept"};
- $S{"needs_close"} = *NS;
- unless(accept(S,NS)) {
- ($!) = ($!, close(S), close(NS));
- return undef;
- }
- select((select(S), $| = 1)[0]);
- }
-
- # now see whether we need to create a new sub:
-
- unless ($subname = $expect_subname{$caller,@_}) {
- # nope. make a new one:
- $expect_subname{$caller,@_} = $subname = $nextsubname++;
-
- $cases .= <<"EDQ"; # header is funny to make everything elsif's
-sub $subname {
- LOOP: {
- if (0) { ; }
-EDQ
- while (@_) {
- ($pattern,$action) = splice(@_,0,2);
- if ($pattern =~ /^eof$/i) {
- $cases .= <<"EDQ";
- elsif (\$eof) {
- package $caller;
- $action;
- }
-EDQ
- $eof = 0;
- } elsif ($pattern =~ /^timeout$/i) {
- $cases .= <<"EDQ";
- elsif (\$timeout) {
- package $caller;
- $action;
- }
-EDQ
- $timeout = 0;
- } else {
- $pattern =~ s#/#\\/#g;
- $cases .= <<"EDQ";
- elsif (\$S =~ /$pattern/) {
- \$S = \$';
- package $caller;
- $action;
- }
-EDQ
- }
- }
- $cases .= <<"EDQ" if $eof;
- elsif (\$eof) {
- undef;
- }
-EDQ
- $cases .= <<"EDQ" if $timeout;
- elsif (\$timeout) {
- undef;
- }
-EDQ
- $cases .= <<'ESQ';
- else {
- $rmask = "";
- vec($rmask,fileno(S),1) = 1;
- ($nfound, $rmask) =
- select($rmask, undef, undef, $endtime - time);
- if ($nfound) {
- $nread = sysread(S, $thisbuf, 1024);
- if ($nread > 0) {
- $S .= $thisbuf;
- } else {
- $eof++, redo LOOP; # any error is also eof
- }
- } else {
- $timeout++, redo LOOP; # timeout
- }
- redo LOOP;
- }
- }
-}
-ESQ
- eval $cases; die "$cases:\n$@" if $@;
- }
- $eof = $timeout = 0;
- &$subname();
-}
-
-## &chat'print([$handle,] @data)
-## $handle is from previous &chat'open().
-## like print $handle @data
-
-sub print { ## public
- if ($_[0] =~ /$nextpat/) {
- *S = shift;
- }
- print S @_;
- if( $chat'debug ){
- print STDERR "printed:";
- print STDERR @_;
- }
-}
-
-## &chat'close([$handle,])
-## $handle is from previous &chat'open().
-## like close $handle
-
-sub close { ## public
- if ($_[0] =~ /$nextpat/) {
- *S = shift;
- }
- close(S);
- if (defined $S{"needs_close"}) { # is it a listen socket?
- local(*NS) = $S{"needs_close"};
- delete $S{"needs_close"};
- close(NS);
- }
-}
-
-## @ready_handles = &chat'select($timeout, @handles)
-## select()'s the handles with a timeout value of $timeout seconds.
-## Returns an array of handles that are ready for I/O.
-## Both user handles and chat handles are supported (but beware of
-## stdio's buffering for user handles).
-
-sub select { ## public
- local($timeout) = shift;
- local(@handles) = @_;
- local(%handlename) = ();
- local(%ready) = ();
- local($caller) = caller;
- local($rmask) = "";
- for (@handles) {
- if (/$nextpat/o) { # one of ours... see if ready
- local(*SYM) = $_;
- if (length($SYM)) {
- $timeout = 0; # we have a winner
- $ready{$_}++;
- }
- $handlename{fileno($_)} = $_;
- } else {
- $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
- }
- }
- for (sort keys %handlename) {
- vec($rmask, $_, 1) = 1;
- }
- select($rmask, undef, undef, $timeout);
- for (sort keys %handlename) {
- $ready{$handlename{$_}}++ if vec($rmask,$_,1);
- }
- sort keys %ready;
-}
-
-# ($pty,$tty) = $chat'_getpty(PTY,TTY):
-# internal procedure to get the next available pty.
-# opens pty on handle PTY, and matching tty on handle TTY.
-# returns undef if can't find a pty.
-# Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik.
-
-sub _getpty { ## private
- local($_PTY,$_TTY) = @_;
- $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
- $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
- local($pty, $tty, $kind);
- if( -e "/dev/pts000" ){ ## mods by Joe Doupnik Dec 1992
- $kind = "pts"; ## SVR4 Streams
- } else {
- $kind = "pty"; ## BSD Clist stuff
- }
- for $bank (112..127) {
- next unless -e sprintf("/dev/$kind%c0", $bank);
- for $unit (48..57) {
- $pty = sprintf("/dev/$kind%c%c", $bank, $unit);
- open($_PTY,"+>$pty") || next;
- select((select($_PTY), $| = 1)[0]);
- ($tty = $pty) =~ s/pty/tty/;
- open($_TTY,"+>$tty") || next;
- select((select($_TTY), $| = 1)[0]);
- system "stty nl>$tty";
- return ($pty,$tty);
- }
- }
- undef;
-}
-
-1;
diff --git a/lib/constant.pm b/lib/constant.pm
new file mode 100644
index 0000000000..4416cf2ade
--- /dev/null
+++ b/lib/constant.pm
@@ -0,0 +1,162 @@
+package constant;
+
+$VERSION = '1.00';
+
+=head1 NAME
+
+constant - Perl pragma to declare constants
+
+=head1 SYNOPSIS
+
+ use constant BUFFER_SIZE => 4096;
+ use constant ONE_YEAR => 365.2425 * 24 * 60 * 60;
+ use constant PI => 4 * atan2 1, 1;
+ use constant DEBUGGING => 0;
+ use constant ORACLE => 'oracle@cs.indiana.edu';
+ use constant USERNAME => scalar getpwuid($<);
+ use constant USERINFO => getpwuid($<);
+
+ sub deg2rad { PI * $_[0] / 180 }
+
+ print "This line does nothing" unless DEBUGGING;
+
+=head1 DESCRIPTION
+
+This will declare a symbol to be a constant with the given scalar
+or list value.
+
+When you declare a constant such as C<PI> using the method shown
+above, each machine your script runs upon can have as many digits
+of accuracy as it can use. Also, your program will be easier to
+read, more likely to be maintained (and maintained correctly), and
+far less likely to send a space probe to the wrong planet because
+nobody noticed the one equation in which you wrote C<3.14195>.
+
+=head1 NOTES
+
+The value or values are evaluated in a list context. You may override
+this with C<scalar> as shown above.
+
+These constants do not directly interpolate into double-quotish
+strings, although you may do so indirectly. (See L<perlref> for
+details about how this works.)
+
+ print "The value of PI is @{[ PI ]}.\n";
+
+List constants are returned as lists, not as arrays.
+
+ $homedir = USERINFO[7]; # WRONG
+ $homedir = (USERINFO)[7]; # Right
+
+The use of all caps for constant names is merely a convention,
+although it is recommended in order to make constants stand out
+and to help avoid collisions with other barewords, keywords, and
+subroutine names. Constant names must begin with a letter.
+
+Constant symbols are package scoped (rather than block scoped, as
+C<use strict> is). That is, you can refer to a constant from package
+Other as C<Other::CONST>.
+
+As with all C<use> directives, defining a constant happens at
+compile time. Thus, it's probably not correct to put a constant
+declaration inside of a conditional statement (like C<if ($foo)
+{ use constant ... }>).
+
+Omitting the value for a symbol gives it the value of C<undef> in
+a scalar context or the empty list, C<()>, in a list context. This
+isn't so nice as it may sound, though, because in this case you
+must either quote the symbol name, or use a big arrow, (C<=E<gt>>),
+with nothing to point to. It is probably best to declare these
+explicitly.
+
+ use constant UNICORNS => ();
+ use constant LOGFILE => undef;
+
+The result from evaluating a list constant in a scalar context is
+not documented, and is B<not> guaranteed to be any particular value
+in the future. In particular, you should not rely upon it being
+the number of elements in the list, especially since it is not
+B<necessarily> that value in the current implementation.
+
+Magical values, tied values, and references can be made into
+constants at compile time, allowing for way cool stuff like this.
+
+ use constant E2BIG => ($! = 7);
+ print E2BIG, "\n"; # something like "Arg list too long"
+ print 0+E2BIG, "\n"; # "7"
+
+=head1 TECHNICAL NOTE
+
+In the current implementation, scalar constants are actually
+inlinable subroutines. As of version 5.004 of Perl, the appropriate
+scalar constant is inserted directly in place of some subroutine
+calls, thereby saving the overhead of a subroutine call. See
+L<perlsub/"Constant Functions"> for details about how and when this
+happens.
+
+=head1 BUGS
+
+In the current version of Perl, list constants are not inlined
+and some symbols may be redefined without generating a warning.
+
+It is not possible to have a subroutine or keyword with the same
+name as a constant. This is probably a Good Thing.
+
+Unlike constants in some languages, these cannot be overridden
+on the command line or via environment variables.
+
+=head1 AUTHOR
+
+Tom Phoenix, E<lt>F<rootbeer@teleport.com>E<gt>, with help from
+many other folks.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1997, Tom Phoenix
+
+This module is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
+=cut
+
+use strict;
+use Carp;
+use vars qw($VERSION);
+
+#=======================================================================
+
+# Some of this stuff didn't work in version 5.003, alas.
+require 5.003_20;
+
+#=======================================================================
+# import() - import symbols into user's namespace
+#
+# What we actually do is define a function in the caller's namespace
+# which returns the value. The function we create will normally
+# be inlined as a constant, thereby avoiding further sub calling
+# overhead.
+#=======================================================================
+sub import {
+ my $class = shift;
+ my $name = shift or return; # Ignore 'use constant;'
+ croak qq{Can't define "$name" as constant} .
+ qq{ (name contains invalid characters or is empty)}
+ unless $name =~ /^[^\W_0-9]\w*$/;
+
+ my $pkg = caller;
+ {
+ no strict 'refs';
+ if (@_ == 1) {
+ my $scalar = $_[0];
+ *{"${pkg}::$name"} = sub () { $scalar };
+ } elsif (@_) {
+ my @list = @_;
+ *{"${pkg}::$name"} = sub () { @list };
+ } else {
+ *{"${pkg}::$name"} = sub () { };
+ }
+ }
+
+}
+
+1;
View Lorry Controller Status