home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_mlb.zip / CGI.pm < prev    next >
Text File  |  1997-11-25  |  154KB  |  5,109 lines
  1. package CGI;
  2. require 5.001;
  3.  
  4. # See the bottom of this file for the POD documentation.  Search for the
  5. # string '=head'.
  6.  
  7. # You can run this file through either pod2man or pod2html to produce pretty
  8. # documentation in manual or html file format (these utilities are part of the
  9. # Perl 5 distribution).
  10.  
  11. # Copyright 1995-1997 Lincoln D. Stein.  All rights reserved.
  12. # It may be used and modified freely, but I do request that this copyright
  13. # notice remain attached to the file.  You may modify this module as you 
  14. # wish, but if you redistribute a modified version, please attach a note
  15. # listing the modifications you have made.
  16.  
  17. # The most recent version and complete docs are available at:
  18. #   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
  19. #   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
  20.  
  21. # Set this to 1 to enable copious autoloader debugging messages
  22. $AUTOLOAD_DEBUG=0;
  23.  
  24. # Set this to 1 to enable NPH scripts
  25. # or: 
  26. #    1) use CGI qw(:nph)
  27. #    2) $CGI::nph(1)
  28. #    3) print header(-nph=>1)
  29. $NPH=0;
  30.  
  31. # Set this to 1 to make the temporary files created
  32. # during file uploads safe from prying eyes
  33. # or do...
  34. #    1) use CGI qw(:private_tempfiles)
  35. #    2) $CGI::private_tempfiles(1);
  36. $PRIVATE_TEMPFILES=0;
  37.  
  38. $CGI::revision = '$Id: CGI.pm,v 2.36 1997/5/10 8:22 lstein Exp $';
  39. $CGI::VERSION='2.36';
  40.  
  41. # OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG
  42. # $OS = 'UNIX';
  43. # $OS = 'MACINTOSH';
  44. # $OS = 'WINDOWS';
  45. # $OS = 'VMS';
  46. # $OS = 'OS2';
  47.  
  48. # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
  49. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
  50. # $TempFile::TMPDIRECTORY = '/usr/tmp';
  51.  
  52. # ------------------ START OF THE LIBRARY ------------
  53.  
  54. # FIGURE OUT THE OS WE'RE RUNNING UNDER
  55. # Some systems support the $^O variable.  If not
  56. # available then require() the Config library
  57. unless ($OS) {
  58.     unless ($OS = $^O) {
  59.     require Config;
  60.     $OS = $Config::Config{'osname'};
  61.     }
  62. }
  63. if ($OS=~/Win/i) {
  64.     $OS = 'WINDOWS';
  65. } elsif ($OS=~/vms/i) {
  66.     $OS = 'VMS';
  67. } elsif ($OS=~/Mac/i) {
  68.     $OS = 'MACINTOSH';
  69. } elsif ($OS=~/os2/i) {
  70.     $OS = 'OS2';
  71. } else {
  72.     $OS = 'UNIX';
  73. }
  74.  
  75. # Some OS logic.  Binary mode enabled on DOS, NT and VMS
  76. $needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
  77.  
  78. # This is the default class for the CGI object to use when all else fails.
  79. $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
  80. # This is where to look for autoloaded routines.
  81. $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
  82.  
  83. # The path separator is a slash, backslash or semicolon, depending
  84. # on the paltform.
  85. $SL = {
  86.     UNIX=>'/',
  87.     OS2=>'\\',
  88.     WINDOWS=>'\\',
  89.     MACINTOSH=>':',
  90.     VMS=>'\\'
  91.     }->{$OS};
  92.  
  93. # Turn on NPH scripts by default when running under IIS server!
  94. $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
  95.  
  96. # Turn on special checking for Doug MacEachern's modperl
  97. if (defined($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) {
  98.     $NPH++;
  99.     $| = 1;
  100.     $SEQNO = 1;
  101. }
  102.  
  103. # This is really "\r\n", but the meaning of \n is different
  104. # in MacPerl, so we resort to octal here.
  105. $CRLF = "\015\012";
  106.  
  107. if ($needs_binmode) {
  108.     $CGI::DefaultClass->binmode(main::STDOUT);
  109.     $CGI::DefaultClass->binmode(main::STDIN);
  110.     $CGI::DefaultClass->binmode(main::STDERR);
  111. }
  112.  
  113. # Cute feature, but it broke when the overload mechanism changed...
  114. # %OVERLOAD = ('""'=>'as_string');
  115.  
  116. %EXPORT_TAGS = (
  117.           ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
  118.              tt i b blockquote pre img a address cite samp dfn html head
  119.              base body link nextid title meta kbd start_html end_html
  120.              input Select option/],
  121.           ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont style span/],
  122.           ':netscape'=>[qw/blink frameset frame script font fontsize center/],
  123.           ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group 
  124.                submit reset defaults radio_group popup_menu button autoEscape
  125.                scrolling_list image_button start_form end_form startform endform
  126.                start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
  127.           ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
  128.                raw_cookie request_method query_string accept user_agent remote_host 
  129.                remote_addr referer server_name server_software server_port server_protocol
  130.                virtual_host remote_ident auth_type http use_named_parameters
  131.                remote_user user_name header redirect import_names put/],
  132.           ':ssl' => [qw/https/],
  133.           ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
  134.           ':html' => [qw/:html2 :html3 :netscape/],
  135.           ':standard' => [qw/:html2 :form :cgi/],
  136.           ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
  137.      );
  138.  
  139. # to import symbols into caller
  140. sub import {
  141.     my $self = shift;
  142.     my ($callpack, $callfile, $callline) = caller;
  143.     foreach (@_) {
  144.     $NPH++, next if $_ eq ':nph';
  145.     $PRIVATE_TEMPFILES++, next if $_ eq ':private_tempfiles';
  146.     foreach (&expand_tags($_)) {
  147.         tr/a-zA-Z0-9_//cd;  # don't allow weird function names
  148.         $EXPORT{$_}++;
  149.     }
  150.     }
  151.     # To allow overriding, search through the packages
  152.     # Till we find one in which the correct subroutine is defined.
  153.     my @packages = ($self,@{"$self\:\:ISA"});
  154.     foreach $sym (keys %EXPORT) {
  155.     my $pck;
  156.     my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
  157.     foreach $pck (@packages) {
  158.         if (defined(&{"$pck\:\:$sym"})) {
  159.         $def = $pck;
  160.         last;
  161.         }
  162.     }
  163.     *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
  164.     }
  165. }
  166.  
  167. sub expand_tags {
  168.     my($tag) = @_;
  169.     my(@r);
  170.     return ($tag) unless $EXPORT_TAGS{$tag};
  171.     foreach (@{$EXPORT_TAGS{$tag}}) {
  172.     push(@r,&expand_tags($_));
  173.     }
  174.     return @r;
  175. }
  176.  
  177. #### Method: new
  178. # The new routine.  This will check the current environment
  179. # for an existing query string, and initialize itself, if so.
  180. ####
  181. sub new {
  182.     my($class,$initializer) = @_;
  183.     my $self = {};
  184.     bless $self,ref $class || $class || $DefaultClass;
  185.     $CGI::DefaultClass->_reset_globals() if $MOD_PERL;
  186.     $initializer = to_filehandle($initializer) if $initializer;
  187.     $self->init($initializer);
  188.     return $self;
  189. }
  190.  
  191. # We provide a DESTROY method so that the autoloader
  192. # doesn't bother trying to find it.
  193. sub DESTROY { }
  194.  
  195. #### Method: param
  196. # Returns the value(s)of a named parameter.
  197. # If invoked in a list context, returns the
  198. # entire list.  Otherwise returns the first
  199. # member of the list.
  200. # If name is not provided, return a list of all
  201. # the known parameters names available.
  202. # If more than one argument is provided, the
  203. # second and subsequent arguments are used to
  204. # set the value of the parameter.
  205. ####
  206. sub param {
  207.     my($self,@p) = self_or_default(@_);
  208.     return $self->all_parameters unless @p;
  209.     my($name,$value,@other);
  210.  
  211.     # For compatibility between old calling style and use_named_parameters() style, 
  212.     # we have to special case for a single parameter present.
  213.     if (@p > 1) {
  214.     ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
  215.     my(@values);
  216.  
  217.     if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
  218.         @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
  219.     } else {
  220.         foreach ($value,@other) {
  221.         push(@values,$_) if defined($_);
  222.         }
  223.     }
  224.     # If values is provided, then we set it.
  225.     if (@values) {
  226.         $self->add_parameter($name);
  227.         $self->{$name}=[@values];
  228.     }
  229.     } else {
  230.     $name = $p[0];
  231.     }
  232.  
  233.     return () unless defined($name) && $self->{$name};
  234.     return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
  235. }
  236.  
  237. #### Method: delete
  238. # Deletes the named parameter entirely.
  239. ####
  240. sub delete {
  241.     my($self,$name) = self_or_default(@_);
  242.     delete $self->{$name};
  243.     delete $self->{'.fieldnames'}->{$name};
  244.     @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
  245.     return wantarray ? () : undef;
  246. }
  247.  
  248. sub self_or_default {
  249.     return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
  250.     unless (defined($_[0]) && 
  251.         ref($_[0]) &&
  252.         (ref($_[0]) eq 'CGI' ||
  253.          eval "\$_[0]->isaCGI()")) { # optimize for the common case
  254.     $CGI::DefaultClass->_reset_globals() 
  255.         if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request();
  256.     $Q = $CGI::DefaultClass->new unless defined($Q);
  257.     unshift(@_,$Q);
  258.     }
  259.     return @_;
  260. }
  261.  
  262. sub _new_request {
  263.     return undef unless (defined(Apache->seqno()) or eval { require Apache });
  264.     if (Apache->seqno() != $SEQNO) {
  265.     $SEQNO = Apache->seqno();
  266.     return 1;
  267.     } else {
  268.     return undef;
  269.     }
  270. }
  271.  
  272. sub _reset_globals {
  273.     undef $Q;
  274.     undef @QUERY_PARAM;
  275. }
  276.  
  277. sub self_or_CGI {
  278.     local $^W=0;                # prevent a warning
  279.     if (defined($_[0]) &&
  280.     (substr(ref($_[0]),0,3) eq 'CGI' 
  281.      || eval "\$_[0]->isaCGI()")) {
  282.     return @_;
  283.     } else {
  284.     return ($DefaultClass,@_);
  285.     }
  286. }
  287.  
  288. sub isaCGI {
  289.     return 1;
  290. }
  291.  
  292. #### Method: import_names
  293. # Import all parameters into the given namespace.
  294. # Assumes namespace 'Q' if not specified
  295. ####
  296. sub import_names {
  297.     my($self,$namespace) = self_or_default(@_);
  298.     $namespace = 'Q' unless defined($namespace);
  299.     die "Can't import names into 'main'\n"
  300.     if $namespace eq 'main';
  301.     my($param,@value,$var);
  302.     foreach $param ($self->param) {
  303.     # protect against silly names
  304.     ($var = $param)=~tr/a-zA-Z0-9_/_/c;
  305.     $var = "${namespace}::$var";
  306.     @value = $self->param($param);
  307.     @{$var} = @value;
  308.     ${$var} = $value[0];
  309.     }
  310. }
  311.  
  312. #### Method: use_named_parameters
  313. # Force CGI.pm to use named parameter-style method calls
  314. # rather than positional parameters.  The same effect
  315. # will happen automatically if the first parameter
  316. # begins with a -.
  317. sub use_named_parameters {
  318.     my($self,$use_named) = self_or_default(@_);
  319.     return $self->{'.named'} unless defined ($use_named);
  320.  
  321.     # stupidity to avoid annoying warnings
  322.     return $self->{'.named'}=$use_named;
  323. }
  324.  
  325. ########################################
  326. # THESE METHODS ARE MORE OR LESS PRIVATE
  327. # GO TO THE __DATA__ SECTION TO SEE MORE
  328. # PUBLIC METHODS
  329. ########################################
  330.  
  331. # Initialize the query object from the environment.
  332. # If a parameter list is found, this object will be set
  333. # to an associative array in which parameter names are keys
  334. # and the values are stored as lists
  335. # If a keyword list is found, this method creates a bogus
  336. # parameter list with the single parameter 'keywords'.
  337.  
  338. sub init {
  339.     my($self,$initializer) = @_;
  340.     my($query_string,@lines);
  341.     my($meth) = '';
  342.  
  343.     # if we get called more than once, we want to initialize
  344.     # ourselves from the original query (which may be gone
  345.     # if it was read from STDIN originally.)
  346.     if (defined(@QUERY_PARAM) && !defined($initializer)) {
  347.  
  348.     foreach (@QUERY_PARAM) {
  349.         $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
  350.     }
  351.     return;
  352.     }
  353.  
  354.     $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
  355.  
  356.     # If initializer is defined, then read parameters
  357.     # from it.
  358.   METHOD: {
  359.       if (defined($initializer)) {
  360.  
  361.       if (ref($initializer) && ref($initializer) eq 'HASH') {
  362.           foreach (keys %$initializer) {
  363.           $self->param('-name'=>$_,'-value'=>$initializer->{$_});
  364.           }
  365.           last METHOD;
  366.       }
  367.       
  368.       $initializer = $$initializer if ref($initializer);
  369.       if (defined(fileno($initializer))) {
  370.           while (<$initializer>) {
  371.           chomp;
  372.           last if /^=/;
  373.           push(@lines,$_);
  374.           }
  375.           # massage back into standard format
  376.           if ("@lines" =~ /=/) {
  377.           $query_string=join("&",@lines);
  378.           } else {
  379.           $query_string=join("+",@lines);
  380.           }
  381.           last METHOD;
  382.       }
  383.       $query_string = $initializer;
  384.       last METHOD;
  385.       }
  386.       # If method is GET or HEAD, fetch the query from
  387.       # the environment.
  388.       if ($meth=~/^(GET|HEAD)$/) {
  389.     $query_string = $ENV{'QUERY_STRING'};
  390.     last METHOD;
  391.     }
  392.     
  393.       # If the method is POST, fetch the query from standard
  394.       # input.
  395.       if ($meth eq 'POST') {
  396.  
  397.       if (defined($ENV{'CONTENT_TYPE'}) 
  398.           && 
  399.           $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
  400.           my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
  401.           $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
  402.  
  403.       } else {
  404.  
  405.           $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
  406.           if $ENV{'CONTENT_LENGTH'} > 0;
  407.  
  408.       }
  409.       # Some people want to have their cake and eat it too!
  410.       # Uncomment this line to have the contents of the query string
  411.       # APPENDED to the POST data.
  412.       # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};
  413.       last METHOD;
  414.       }
  415.       
  416.       # If neither is set, assume we're being debugged offline.
  417.       # Check the command line and then the standard input for data.
  418.       # We use the shellwords package in order to behave the way that
  419.       # UN*X programmers expect.
  420.       $query_string = &read_from_cmdline;
  421.   }
  422.     
  423.     # We now have the query string in hand.  We do slightly
  424.     # different things for keyword lists and parameter lists.
  425.     if ($query_string) {
  426.     if ($query_string =~ /=/) {
  427.         $self->parse_params($query_string);
  428.     } else {
  429.         $self->add_parameter('keywords');
  430.         $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
  431.     }
  432.     }
  433.  
  434.     # Special case.  Erase everything if there is a field named
  435.     # .defaults.
  436.     if ($self->param('.defaults')) {
  437.     undef %{$self};
  438.     }
  439.  
  440.     # Associative array containing our defined fieldnames
  441.     $self->{'.fieldnames'} = {};
  442.     foreach ($self->param('.cgifields')) {
  443.     $self->{'.fieldnames'}->{$_}++;
  444.     }
  445.     
  446.     # Clear out our default submission button flag if present
  447.     $self->delete('.submit');
  448.     $self->delete('.cgifields');
  449.     $self->save_request unless $initializer;
  450.  
  451. }
  452.  
  453.  
  454. # FUNCTIONS TO OVERRIDE:
  455.  
  456. # Turn a string into a filehandle
  457. sub to_filehandle {
  458.     my $string = shift;
  459.     if ($string && !ref($string)) {
  460.     my($package) = caller(1);
  461.     my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string"; 
  462.     return $tmp if defined(fileno($tmp));
  463.     }
  464.     return $string;
  465. }
  466.  
  467. # Create a new multipart buffer
  468. sub new_MultipartBuffer {
  469.     my($self,$boundary,$length,$filehandle) = @_;
  470.     return MultipartBuffer->new($self,$boundary,$length,$filehandle);
  471. }
  472.  
  473. # Read data from a file handle
  474. sub read_from_client {
  475.     my($self, $fh, $buff, $len, $offset) = @_;
  476.     local $^W=0;                # prevent a warning
  477.     return read($fh, $$buff, $len, $offset);
  478. }
  479.  
  480. # put a filehandle into binary mode (DOS)
  481. sub binmode {
  482.     binmode($_[1]);
  483. }
  484.  
  485. # send output to the browser
  486. sub put {
  487.     my($self,@p) = self_or_default(@_);
  488.     $self->print(@p);
  489. }
  490.  
  491. # print to standard output (for overriding in mod_perl)
  492. sub print {
  493.     shift;
  494.     CORE::print(@_);
  495. }
  496.  
  497. # unescape URL-encoded data
  498. sub unescape {
  499.     my($todecode) = @_;
  500.     $todecode =~ tr/+/ /;       # pluses become spaces
  501.     $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
  502.     return $todecode;
  503. }
  504.  
  505. # URL-encode data
  506. sub escape {
  507.     my($toencode) = @_;
  508.     $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
  509.     return $toencode;
  510. }
  511.  
  512. sub save_request {
  513.     my($self) = @_;
  514.     # We're going to play with the package globals now so that if we get called
  515.     # again, we initialize ourselves in exactly the same way.  This allows
  516.     # us to have several of these objects.
  517.     @QUERY_PARAM = $self->param; # save list of parameters
  518.     foreach (@QUERY_PARAM) {
  519.     $QUERY_PARAM{$_}=$self->{$_};
  520.     }
  521. }
  522.  
  523. sub parse_keywordlist {
  524.     my($self,$tosplit) = @_;
  525.     $tosplit = &unescape($tosplit); # unescape the keywords
  526.     $tosplit=~tr/+/ /;          # pluses to spaces
  527.     my(@keywords) = split(/\s+/,$tosplit);
  528.     return @keywords;
  529. }
  530.  
  531. sub parse_params {
  532.     my($self,$tosplit) = @_;
  533.     my(@pairs) = split('&',$tosplit);
  534.     my($param,$value);
  535.     foreach (@pairs) {
  536.     ($param,$value) = split('=');
  537.     $param = &unescape($param);
  538.     $value = &unescape($value);
  539.     $self->add_parameter($param);
  540.     push (@{$self->{$param}},$value);
  541.     }
  542. }
  543.  
  544. sub add_parameter {
  545.     my($self,$param)=@_;
  546.     push (@{$self->{'.parameters'}},$param) 
  547.     unless defined($self->{$param});
  548. }
  549.  
  550. sub all_parameters {
  551.     my $self = shift;
  552.     return () unless defined($self) && $self->{'.parameters'};
  553.     return () unless @{$self->{'.parameters'}};
  554.     return @{$self->{'.parameters'}};
  555. }
  556.  
  557. #### Method as_string
  558. #
  559. # synonym for "dump"
  560. ####
  561. sub as_string {
  562.     &dump(@_);
  563. }
  564.  
  565. sub AUTOLOAD {
  566.     print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
  567.     my($func) = $AUTOLOAD;
  568.     my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
  569.     $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
  570.                 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
  571.  
  572.     my($sub) = \%{"$pack\:\:SUBS"};
  573.     unless (%$sub) {
  574.     my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
  575.     eval "package $pack; $$auto";
  576.     die $@ if $@;
  577.     }
  578.     my($code) = $sub->{$func_name};
  579.  
  580.     $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
  581.     if (!$code) {
  582.     if ($EXPORT{':any'} || 
  583.         $EXPORT{$func_name} || 
  584.         (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
  585.         && $EXPORT_OK{$func_name}) {
  586.         $code = $sub->{'HTML_FUNC'};
  587.         $code=~s/func_name/$func_name/mg;
  588.     }
  589.     }
  590.     die "Undefined subroutine $AUTOLOAD\n" unless $code;
  591.     eval "package $pack; $code";
  592.     if ($@) {
  593.     $@ =~ s/ at .*\n//;
  594.     die $@;
  595.     }
  596.     goto &{"$pack\:\:$func_name"};
  597. }
  598.  
  599. # PRIVATE SUBROUTINE
  600. # Smart rearrangement of parameters to allow named parameter
  601. # calling.  We do the rearangement if:
  602. # 1. The first parameter begins with a -
  603. # 2. The use_named_parameters() method returns true
  604. sub rearrange {
  605.     my($self,$order,@param) = @_;
  606.     return () unless @param;
  607.     
  608.     return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-')
  609.     || $self->use_named_parameters;
  610.  
  611.     my $i;
  612.     for ($i=0;$i<@param;$i+=2) {
  613.     $param[$i]=~s/^\-//;     # get rid of initial - if present
  614.     $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
  615.     }
  616.     
  617.     my(%param) = @param;                # convert into associative array
  618.     my(@return_array);
  619.     
  620.     my($key)='';
  621.     foreach $key (@$order) {
  622.     my($value);
  623.     # this is an awful hack to fix spurious warnings when the
  624.     # -w switch is set.
  625.     if (ref($key) && ref($key) eq 'ARRAY') {
  626.         foreach (@$key) {
  627.         last if defined($value);
  628.         $value = $param{$_};
  629.         delete $param{$_};
  630.         }
  631.     } else {
  632.         $value = $param{$key};
  633.         delete $param{$key};
  634.     }
  635.     push(@return_array,$value);
  636.     }
  637.     push (@return_array,$self->make_attributes(\%param)) if %param;
  638.     return (@return_array);
  639. }
  640.  
  641. ###############################################################################
  642. ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
  643. ###############################################################################
  644. $AUTOLOADED_ROUTINES = '';      # get rid of -w warning
  645. $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
  646.  
  647. %SUBS = (
  648.  
  649. 'URL_ENCODED'=> <<'END_OF_FUNC',
  650. sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
  651. END_OF_FUNC
  652.  
  653. 'MULTIPART' => <<'END_OF_FUNC',
  654. sub MULTIPART {  'multipart/form-data'; }
  655. END_OF_FUNC
  656.  
  657. 'HTML_FUNC' => <<'END_OF_FUNC',
  658. sub func_name { 
  659.  
  660.     # handle various cases in which we're called
  661.     # most of this bizarre stuff is to avoid -w errors
  662.     shift if $_[0] && 
  663.     (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) ||
  664.         (ref($_[0]) &&
  665.          (substr(ref($_[0]),0,3) eq 'CGI' ||
  666.           eval "\$_[0]->isaCGI()"));
  667.  
  668.     my($attr) = '';
  669.     if (ref($_[0]) && ref($_[0]) eq 'HASH') {
  670.     my(@attr) = CGI::make_attributes('',shift);
  671.     $attr = " @attr" if @attr;
  672.     }
  673.     my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E");
  674.     return $tag unless @_;
  675.     if (ref($_[0]) eq 'ARRAY') {
  676.     my(@r);
  677.     foreach (@{$_[0]}) {
  678.         push(@r,"$tag$_$untag");
  679.     }
  680.     return "@r";
  681.     } else {
  682.     return "$tag@_$untag";
  683.     }
  684. }
  685. END_OF_FUNC
  686.  
  687. #### Method: keywords
  688. # Keywords acts a bit differently.  Calling it in a list context
  689. # returns the list of keywords.  
  690. # Calling it in a scalar context gives you the size of the list.
  691. ####
  692. 'keywords' => <<'END_OF_FUNC',
  693. sub keywords {
  694.     my($self,@values) = self_or_default(@_);
  695.     # If values is provided, then we set it.
  696.     $self->{'keywords'}=[@values] if @values;
  697.     my(@result) = @{$self->{'keywords'}};
  698.     @result;
  699. }
  700. END_OF_FUNC
  701.  
  702. # These are some tie() interfaces for compatibility
  703. # with Steve Brenner's cgi-lib.pl routines
  704. 'ReadParse' => <<'END_OF_FUNC',
  705. sub ReadParse {
  706.     local(*in);
  707.     if (@_) {
  708.     *in = $_[0];
  709.     } else {
  710.     my $pkg = caller();
  711.     *in=*{"${pkg}::in"};
  712.     }
  713.     tie(%in,CGI);
  714. }
  715. END_OF_FUNC
  716.  
  717. 'PrintHeader' => <<'END_OF_FUNC',
  718. sub PrintHeader {
  719.     my($self) = self_or_default(@_);
  720.     return $self->header();
  721. }
  722. END_OF_FUNC
  723.  
  724. 'HtmlTop' => <<'END_OF_FUNC',
  725. sub HtmlTop {
  726.     my($self,@p) = self_or_default(@_);
  727.     return $self->start_html(@p);
  728. }
  729. END_OF_FUNC
  730.  
  731. 'HtmlBot' => <<'END_OF_FUNC',
  732. sub HtmlBot {
  733.     my($self,@p) = self_or_default(@_);
  734.     return $self->end_html(@p);
  735. }
  736. END_OF_FUNC
  737.  
  738. 'SplitParam' => <<'END_OF_FUNC',
  739. sub SplitParam {
  740.     my ($param) = @_;
  741.     my (@params) = split ("\0", $param);
  742.     return (wantarray ? @params : $params[0]);
  743. }
  744. END_OF_FUNC
  745.  
  746. 'MethGet' => <<'END_OF_FUNC',
  747. sub MethGet {
  748.     return request_method() eq 'GET';
  749. }
  750. END_OF_FUNC
  751.  
  752. 'MethPost' => <<'END_OF_FUNC',
  753. sub MethPost {
  754.     return request_method() eq 'POST';
  755. }
  756. END_OF_FUNC
  757.  
  758. 'TIEHASH' => <<'END_OF_FUNC',
  759. sub TIEHASH { 
  760.     return new CGI;
  761. }
  762. END_OF_FUNC
  763.  
  764. 'STORE' => <<'END_OF_FUNC',
  765. sub STORE {
  766.     $_[0]->param($_[1],split("\0",$_[2]));
  767. }
  768. END_OF_FUNC
  769.  
  770. 'FETCH' => <<'END_OF_FUNC',
  771. sub FETCH {
  772.     return $_[0] if $_[1] eq 'CGI';
  773.     return undef unless defined $_[0]->param($_[1]);
  774.     return join("\0",$_[0]->param($_[1]));
  775. }
  776. END_OF_FUNC
  777.  
  778. 'FIRSTKEY' => <<'END_OF_FUNC',
  779. sub FIRSTKEY {
  780.     $_[0]->{'.iterator'}=0;
  781.     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
  782. }
  783. END_OF_FUNC
  784.  
  785. 'NEXTKEY' => <<'END_OF_FUNC',
  786. sub NEXTKEY {
  787.     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
  788. }
  789. END_OF_FUNC
  790.  
  791. 'EXISTS' => <<'END_OF_FUNC',
  792. sub EXISTS {
  793.     exists $_[0]->{$_[1]};
  794. }
  795. END_OF_FUNC
  796.  
  797. 'DELETE' => <<'END_OF_FUNC',
  798. sub DELETE {
  799.     $_[0]->delete($_[1]);
  800. }
  801. END_OF_FUNC
  802.  
  803. 'CLEAR' => <<'END_OF_FUNC',
  804. sub CLEAR {
  805.     %{$_[0]}=();
  806. }
  807. ####
  808. END_OF_FUNC
  809.  
  810. ####
  811. # Append a new value to an existing query
  812. ####
  813. 'append' => <<'EOF',
  814. sub append {
  815.     my($self,@p) = @_;
  816.     my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
  817.     my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
  818.     if (@values) {
  819.     $self->add_parameter($name);
  820.     push(@{$self->{$name}},@values);
  821.     }
  822.     return $self->param($name);
  823. }
  824. EOF
  825.  
  826. #### Method: delete_all
  827. # Delete all parameters
  828. ####
  829. 'delete_all' => <<'EOF',
  830. sub delete_all {
  831.     my($self) = self_or_default(@_);
  832.     undef %{$self};
  833. }
  834. EOF
  835.  
  836. #### Method: autoescape
  837. # If you want to turn off the autoescaping features,
  838. # call this method with undef as the argument
  839. 'autoEscape' => <<'END_OF_FUNC',
  840. sub autoEscape {
  841.     my($self,$escape) = self_or_default(@_);
  842.     $self->{'dontescape'}=!$escape;
  843. }
  844. END_OF_FUNC
  845.  
  846.  
  847. #### Method: version
  848. # Return the current version
  849. ####
  850. 'version' => <<'END_OF_FUNC',
  851. sub version {
  852.     return $VERSION;
  853. }
  854. END_OF_FUNC
  855.  
  856. 'make_attributes' => <<'END_OF_FUNC',
  857. sub make_attributes {
  858.     my($self,$attr) = @_;
  859.     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
  860.     my(@att);
  861.     foreach (keys %{$attr}) {
  862.     my($key) = $_;
  863.     $key=~s/^\-//;     # get rid of initial - if present
  864.     $key=~tr/a-z/A-Z/; # parameters are upper case
  865.     push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
  866.     }
  867.     return @att;
  868. }
  869. END_OF_FUNC
  870.  
  871. #### Method: dump
  872. # Returns a string in which all the known parameter/value 
  873. # pairs are represented as nested lists, mainly for the purposes 
  874. # of debugging.
  875. ####
  876. 'dump' => <<'END_OF_FUNC',
  877. sub dump {
  878.     my($self) = self_or_default(@_);
  879.     my($param,$value,@result);
  880.     return '<UL></UL>' unless $self->param;
  881.     push(@result,"<UL>");
  882.     foreach $param ($self->param) {
  883.     my($name)=$self->escapeHTML($param);
  884.     push(@result,"<LI><STRONG>$param</STRONG>");
  885.     push(@result,"<UL>");
  886.     foreach $value ($self->param($param)) {
  887.         $value = $self->escapeHTML($value);
  888.         push(@result,"<LI>$value");
  889.     }
  890.     push(@result,"</UL>");
  891.     }
  892.     push(@result,"</UL>\n");
  893.     return join("\n",@result);
  894. }
  895. END_OF_FUNC
  896.  
  897.  
  898. #### Method: save
  899. # Write values out to a filehandle in such a way that they can
  900. # be reinitialized by the filehandle form of the new() method
  901. ####
  902. 'save' => <<'END_OF_FUNC',
  903. sub save {
  904.     my($self,$filehandle) = self_or_default(@_);
  905.     my($param);
  906.     my($package) = caller;
  907. # Check that this still works!
  908. #    $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
  909.     $filehandle = to_filehandle($filehandle);
  910.     foreach $param ($self->param) {
  911.     my($escaped_param) = &escape($param);
  912.     my($value);
  913.     foreach $value ($self->param($param)) {
  914.         print $filehandle "$escaped_param=",escape($value),"\n";
  915.     }
  916.     }
  917.     print $filehandle "=\n";    # end of record
  918. }
  919. END_OF_FUNC
  920.  
  921.  
  922. #### Method: header
  923. # Return a Content-Type: style header
  924. #
  925. ####
  926. 'header' => <<'END_OF_FUNC',
  927. sub header {
  928.     my($self,@p) = self_or_default(@_);
  929.     my(@header);
  930.  
  931.     my($type,$status,$cookie,$target,$expires,$nph,@other) = 
  932.     $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
  933.  
  934.     # rearrange() was designed for the HTML portion, so we
  935.     # need to fix it up a little.
  936.     foreach (@other) {
  937.     next unless my($header,$value) = /([^\s=]+)=(.+)/;
  938.     substr($header,1,1000)=~tr/A-Z/a-z/;
  939.     ($value)=$value=~/^"(.*)"$/;
  940.     $_ = "$header: $value";
  941.     }
  942.  
  943.     $type = $type || 'text/html';
  944.  
  945.     push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH;
  946.     push(@header,"Status: $status") if $status;
  947.     push(@header,"Window-target: $target") if $target;
  948.     # push all the cookies -- there may be several
  949.     if ($cookie) {
  950.     my(@cookie) = ref($cookie) ? @{$cookie} : $cookie;
  951.     foreach (@cookie) {
  952.         push(@header,"Set-cookie: $_");
  953.     }
  954.     }
  955.     # if the user indicates an expiration time, then we need
  956.     # both an Expires and a Date header (so that the browser is
  957.     # uses OUR clock)
  958.     push(@header,"Expires: " . &date(&expire_calc($expires),'http'))
  959.     if $expires;
  960.     push(@header,"Date: " . &date(&expire_calc(0),'http')) if $expires || $cookie;
  961.     push(@header,"Pragma: no-cache") if $self->cache();
  962.     push(@header,@other);
  963.     push(@header,"Content-type: $type");
  964.  
  965.     my $header = join($CRLF,@header);
  966.     return $header . "${CRLF}${CRLF}";
  967. }
  968. END_OF_FUNC
  969.  
  970.  
  971. #### Method: cache
  972. # Control whether header() will produce the no-cache
  973. # Pragma directive.
  974. ####
  975. 'cache' => <<'END_OF_FUNC',
  976. sub cache {
  977.     my($self,$new_value) = self_or_default(@_);
  978.     $new_value = '' unless $new_value;
  979.     if ($new_value ne '') {
  980.     $self->{'cache'} = $new_value;
  981.     }
  982.     return $self->{'cache'};
  983. }
  984. END_OF_FUNC
  985.  
  986.  
  987. #### Method: redirect
  988. # Return a Location: style header
  989. #
  990. ####
  991. 'redirect' => <<'END_OF_FUNC',
  992. sub redirect {
  993.     my($self,@p) = self_or_default(@_);
  994.     my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
  995.     $url = $url || $self->self_url;
  996.     my(@o);
  997.     foreach (@other) { push(@o,split("=")); }
  998.     if($MOD_PERL or exists $self->{'.req'}) {
  999.     my $r = $self->{'.req'} || Apache->request;
  1000.     $r->header_out(Location => $url);
  1001.     $r->err_header_out(Location => $url);
  1002.     $r->status(302);
  1003.     return;
  1004.     }
  1005.     push(@o,
  1006.      '-Status'=>'302 Found',
  1007.      '-Location'=>$url,
  1008.      '-URI'=>$url,
  1009.      '-nph'=>($nph||$NPH));
  1010.     push(@o,'-Target'=>$target) if $target;
  1011.     push(@o,'-Cookie'=>$cookie) if $cookie;
  1012.     return $self->header(@o);
  1013. }
  1014. END_OF_FUNC
  1015.  
  1016.  
  1017. #### Method: start_html
  1018. # Canned HTML header
  1019. #
  1020. # Parameters:
  1021. # $title -> (optional) The title for this HTML document (-title)
  1022. # $author -> (optional) e-mail address of the author (-author)
  1023. # $base -> (optional) if set to true, will enter the BASE address of this document
  1024. #          for resolving relative references (-base) 
  1025. # $xbase -> (optional) alternative base at some remote location (-xbase)
  1026. # $target -> (optional) target window to load all links into (-target)
  1027. # $script -> (option) Javascript code (-script)
  1028. # $no_script -> (option) Javascript <noscript> tag (-noscript)
  1029. # $meta -> (optional) Meta information tags
  1030. # $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag
  1031. #           (a scalar or array ref)
  1032. # $style -> (optional) reference to an external style sheet
  1033. # @other -> (optional) any other named parameters you'd like to incorporate into
  1034. #           the <BODY> tag.
  1035. ####
  1036. 'start_html' => <<'END_OF_FUNC',
  1037. sub start_html {
  1038.     my($self,@p) = &self_or_default(@_);
  1039.     my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,@other) = 
  1040.     $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE],@p);
  1041.  
  1042.     # strangely enough, the title needs to be escaped as HTML
  1043.     # while the author needs to be escaped as a URL
  1044.     $title = $self->escapeHTML($title || 'Untitled Document');
  1045.     $author = $self->escapeHTML($author);
  1046.     my(@result);
  1047.     push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
  1048.     push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
  1049.     push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author;
  1050.  
  1051.     if ($base || $xbase || $target) {
  1052.     my $href = $xbase || $self->url();
  1053.     my $t = $target ? qq/ TARGET="$target"/ : '';
  1054.     push(@result,qq/<BASE HREF="$href"$t>/);
  1055.     }
  1056.  
  1057.     if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
  1058.     foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
  1059.     }
  1060.  
  1061.     push(@result,ref($head) ? @$head : $head) if $head;
  1062.  
  1063.     # handle various types of -style parameters
  1064.     if ($style) {
  1065.     if (ref($style)) {
  1066.         my($src,$code,@other) =
  1067.         $self->rearrange([SRC,CODE],
  1068.                  '-foo'=>'bar',    # a trick to allow the '-' to be omitted
  1069.                  ref($style) eq 'ARRAY' ? @$style : %$style);
  1070.         push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src;
  1071.         push(@result,style($code)) if $code;
  1072.     } else {
  1073.         push(@result,style($style))
  1074.     }
  1075.     }
  1076.  
  1077.     # handle -script parameter
  1078.     if ($script) {
  1079.     my($src,$code,$language);
  1080.     if (ref($script)) { # script is a hash
  1081.         ($src,$code,$language) =
  1082.         $self->rearrange([SRC,CODE,LANGUAGE],
  1083.                  '-foo'=>'bar',    # a trick to allow the '-' to be omitted
  1084.                  ref($style) eq 'ARRAY' ? @$script : %$script);
  1085.     
  1086.     } else {
  1087.         ($src,$code,$language) = ('',$script,'JavaScript');
  1088.     }
  1089.     my(@satts);
  1090.     push(@satts,'src'=>$src) if $src;
  1091.     push(@satts,'language'=>$language || 'JavaScript');
  1092.     $code = "<!-- Hide script\n$code\n// End script hiding -->"
  1093.         if $code && $language=~/javascript/i;
  1094.     $code = "<!-- Hide script\n$code\n\# End script hiding -->"
  1095.         if $code && $language=~/perl/i;
  1096.     push(@result,script({@satts},$code));
  1097.     }
  1098.  
  1099.     # handle -noscript parameter
  1100.     push(@result,<<END) if $noscript;
  1101. <NOSCRIPT>
  1102. $noscript
  1103. </NOSCRIPT>
  1104. END
  1105.     ;
  1106.     my($other) = @other ? " @other" : '';
  1107.     push(@result,"</HEAD><BODY$other>");
  1108.     return join("\n",@result);
  1109. }
  1110. END_OF_FUNC
  1111.  
  1112.  
  1113. #### Method: end_html
  1114. # End an HTML document.
  1115. # Trivial method for completeness.  Just returns "</BODY>"
  1116. ####
  1117. 'end_html' => <<'END_OF_FUNC',
  1118. sub end_html {
  1119.     return "</BODY></HTML>";
  1120. }
  1121. END_OF_FUNC
  1122.  
  1123.  
  1124. ################################
  1125. # METHODS USED IN BUILDING FORMS
  1126. ################################
  1127.  
  1128. #### Method: isindex
  1129. # Just prints out the isindex tag.
  1130. # Parameters:
  1131. #  $action -> optional URL of script to run
  1132. # Returns:
  1133. #   A string containing a <ISINDEX> tag
  1134. 'isindex' => <<'END_OF_FUNC',
  1135. sub isindex {
  1136.     my($self,@p) = self_or_default(@_);
  1137.     my($action,@other) = $self->rearrange([ACTION],@p);
  1138.     $action = qq/ACTION="$action"/ if $action;
  1139.     my($other) = @other ? " @other" : '';
  1140.     return "<ISINDEX $action$other>";
  1141. }
  1142. END_OF_FUNC
  1143.  
  1144.  
  1145. #### Method: startform
  1146. # Start a form
  1147. # Parameters:
  1148. #   $method -> optional submission method to use (GET or POST)
  1149. #   $action -> optional URL of script to run
  1150. #   $enctype ->encoding to use (URL_ENCODED or MULTIPART)
  1151. 'startform' => <<'END_OF_FUNC',
  1152. sub startform {
  1153.     my($self,@p) = self_or_default(@_);
  1154.  
  1155.     my($method,$action,$enctype,@other) = 
  1156.     $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
  1157.  
  1158.     $method = $method || 'POST';
  1159.     $enctype = $enctype || &URL_ENCODED;
  1160.     $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
  1161.     'ACTION="'.$self->script_name.'"' : '';
  1162.     my($other) = @other ? " @other" : '';
  1163.     $self->{'.parametersToAdd'}={};
  1164.     return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
  1165. }
  1166. END_OF_FUNC
  1167.  
  1168.  
  1169. #### Method: start_form
  1170. # synonym for startform
  1171. 'start_form' => <<'END_OF_FUNC',
  1172. sub start_form {
  1173.     &startform;
  1174. }
  1175. END_OF_FUNC
  1176.  
  1177.  
  1178. #### Method: start_multipart_form
  1179. # synonym for startform
  1180. 'start_multipart_form' => <<'END_OF_FUNC',
  1181. sub start_multipart_form {
  1182.     my($self,@p) = self_or_default(@_);
  1183.     if ($self->use_named_parameters || 
  1184.     (defined($param[0]) && substr($param[0],0,1) eq '-')) {
  1185.     my(%p) = @p;
  1186.     $p{'-enctype'}=&MULTIPART;
  1187.     return $self->startform(%p);
  1188.     } else {
  1189.     my($method,$action,@other) = 
  1190.         $self->rearrange([METHOD,ACTION],@p);
  1191.     return $self->startform($method,$action,&MULTIPART,@other);
  1192.     }
  1193. }
  1194. END_OF_FUNC
  1195.  
  1196.  
  1197. #### Method: endform
  1198. # End a form
  1199. 'endform' => <<'END_OF_FUNC',
  1200. sub endform {
  1201.     my($self,@p) = self_or_default(@_);    
  1202.     return ($self->get_fields,"</FORM>");
  1203. }
  1204. END_OF_FUNC
  1205.  
  1206.  
  1207. #### Method: end_form
  1208. # synonym for endform
  1209. 'end_form' => <<'END_OF_FUNC',
  1210. sub end_form {
  1211.     &endform;
  1212. }
  1213. END_OF_FUNC
  1214.  
  1215.  
  1216. #### Method: textfield
  1217. # Parameters:
  1218. #   $name -> Name of the text field
  1219. #   $default -> Optional default value of the field if not
  1220. #                already defined.
  1221. #   $size ->  Optional width of field in characaters.
  1222. #   $maxlength -> Optional maximum number of characters.
  1223. # Returns:
  1224. #   A string containing a <INPUT TYPE="text"> field
  1225. #
  1226. 'textfield' => <<'END_OF_FUNC',
  1227. sub textfield {
  1228.     my($self,@p) = self_or_default(@_);
  1229.     my($name,$default,$size,$maxlength,$override,@other) = 
  1230.     $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
  1231.  
  1232.     my $current = $override ? $default : 
  1233.     (defined($self->param($name)) ? $self->param($name) : $default);
  1234.  
  1235.     $current = defined($current) ? $self->escapeHTML($current) : '';
  1236.     $name = defined($name) ? $self->escapeHTML($name) : '';
  1237.     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
  1238.     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
  1239.     my($other) = @other ? " @other" : '';    
  1240.     return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/;
  1241. }
  1242. END_OF_FUNC
  1243.  
  1244.  
  1245. #### Method: filefield
  1246. # Parameters:
  1247. #   $name -> Name of the file upload field
  1248. #   $size ->  Optional width of field in characaters.
  1249. #   $maxlength -> Optional maximum number of characters.
  1250. # Returns:
  1251. #   A string containing a <INPUT TYPE="text"> field
  1252. #
  1253. 'filefield' => <<'END_OF_FUNC',
  1254. sub filefield {
  1255.     my($self,@p) = self_or_default(@_);
  1256.  
  1257.     my($name,$default,$size,$maxlength,$override,@other) = 
  1258.     $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
  1259.  
  1260.     $current = $override ? $default :
  1261.     (defined($self->param($name)) ? $self->param($name) : $default);
  1262.  
  1263.     $name = defined($name) ? $self->escapeHTML($name) : '';
  1264.     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
  1265.     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
  1266.     $current = defined($current) ? $self->escapeHTML($current) : '';
  1267.     $other = ' ' . join(" ",@other);
  1268.     return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/;
  1269. }
  1270. END_OF_FUNC
  1271.  
  1272.  
  1273. #### Method: password
  1274. # Create a "secret password" entry field
  1275. # Parameters:
  1276. #   $name -> Name of the field
  1277. #   $default -> Optional default value of the field if not
  1278. #                already defined.
  1279. #   $size ->  Optional width of field in characters.
  1280. #   $maxlength -> Optional maximum characters that can be entered.
  1281. # Returns:
  1282. #   A string containing a <INPUT TYPE="password"> field
  1283. #
  1284. 'password_field' => <<'END_OF_FUNC',
  1285. sub password_field {
  1286.     my ($self,@p) = self_or_default(@_);
  1287.  
  1288.     my($name,$default,$size,$maxlength,$override,@other) = 
  1289.     $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
  1290.  
  1291.     my($current) =  $override ? $default :
  1292.     (defined($self->param($name)) ? $self->param($name) : $default);
  1293.  
  1294.     $name = defined($name) ? $self->escapeHTML($name) : '';
  1295.     $current = defined($current) ? $self->escapeHTML($current) : '';
  1296.     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
  1297.     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
  1298.     my($other) = @other ? " @other" : '';
  1299.     return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/;
  1300. }
  1301. END_OF_FUNC
  1302.  
  1303.  
  1304. #### Method: textarea
  1305. # Parameters:
  1306. #   $name -> Name of the text field
  1307. #   $default -> Optional default value of the field if not
  1308. #                already defined.
  1309. #   $rows ->  Optional number of rows in text area
  1310. #   $columns -> Optional number of columns in text area
  1311. # Returns:
  1312. #   A string containing a <TEXTAREA></TEXTAREA> tag
  1313. #
  1314. 'textarea' => <<'END_OF_FUNC',
  1315. sub textarea {
  1316.     my($self,@p) = self_or_default(@_);
  1317.     
  1318.     my($name,$default,$rows,$cols,$override,@other) =
  1319.     $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
  1320.  
  1321.     my($current)= $override ? $default :
  1322.     (defined($self->param($name)) ? $self->param($name) : $default);
  1323.  
  1324.     $name = defined($name) ? $self->escapeHTML($name) : '';
  1325.     $current = defined($current) ? $self->escapeHTML($current) : '';
  1326.     my($r) = $rows ? " ROWS=$rows" : '';
  1327.     my($c) = $cols ? " COLS=$cols" : '';
  1328.     my($other) = @other ? " @other" : '';
  1329.     return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
  1330. }
  1331. END_OF_FUNC
  1332.  
  1333.  
  1334. #### Method: button
  1335. # Create a javascript button.
  1336. # Parameters:
  1337. #   $name ->  (optional) Name for the button. (-name)
  1338. #   $value -> (optional) Value of the button when selected (and visible name) (-value)
  1339. #   $onclick -> (optional) Text of the JavaScript to run when the button is
  1340. #                clicked.
  1341. # Returns:
  1342. #   A string containing a <INPUT TYPE="button"> tag
  1343. ####
  1344. 'button' => <<'END_OF_FUNC',
  1345. sub button {
  1346.     my($self,@p) = self_or_default(@_);
  1347.  
  1348.     my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
  1349.                              [ONCLICK,SCRIPT]],@p);
  1350.  
  1351.     $label=$self->escapeHTML($label);
  1352.     $value=$self->escapeHTML($value);
  1353.     $script=$self->escapeHTML($script);
  1354.  
  1355.     my($name) = '';
  1356.     $name = qq/ NAME="$label"/ if $label;
  1357.     $value = $value || $label;
  1358.     my($val) = '';
  1359.     $val = qq/ VALUE="$value"/ if $value;
  1360.     $script = qq/ ONCLICK="$script"/ if $script;
  1361.     my($other) = @other ? " @other" : '';
  1362.     return qq/<INPUT TYPE="button"$name$val$script$other>/;
  1363. }
  1364. END_OF_FUNC
  1365.  
  1366.  
  1367. #### Method: submit
  1368. # Create a "submit query" button.
  1369. # Parameters:
  1370. #   $name ->  (optional) Name for the button.
  1371. #   $value -> (optional) Value of the button when selected (also doubles as label).
  1372. #   $label -> (optional) Label printed on the button(also doubles as the value).
  1373. # Returns:
  1374. #   A string containing a <INPUT TYPE="submit"> tag
  1375. ####
  1376. 'submit' => <<'END_OF_FUNC',
  1377. sub submit {
  1378.     my($self,@p) = self_or_default(@_);
  1379.  
  1380.     my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
  1381.  
  1382.     $label=$self->escapeHTML($label);
  1383.     $value=$self->escapeHTML($value);
  1384.  
  1385.     my($name) = ' NAME=".submit"';
  1386.     $name = qq/ NAME="$label"/ if $label;
  1387.     $value = $value || $label;
  1388.     my($val) = '';
  1389.     $val = qq/ VALUE="$value"/ if defined($value);
  1390.     my($other) = @other ? " @other" : '';
  1391.     return qq/<INPUT TYPE="submit"$name$val$other>/;
  1392. }
  1393. END_OF_FUNC
  1394.  
  1395.  
  1396. #### Method: reset
  1397. # Create a "reset" button.
  1398. # Parameters:
  1399. #   $name -> (optional) Name for the button.
  1400. # Returns:
  1401. #   A string containing a <INPUT TYPE="reset"> tag
  1402. ####
  1403. 'reset' => <<'END_OF_FUNC',
  1404. sub reset {
  1405.     my($self,@p) = self_or_default(@_);
  1406.     my($label,@other) = $self->rearrange([NAME],@p);
  1407.     $label=$self->escapeHTML($label);
  1408.     my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
  1409.     my($other) = @other ? " @other" : '';
  1410.     return qq/<INPUT TYPE="reset"$value$other>/;
  1411. }
  1412. END_OF_FUNC
  1413.  
  1414.  
  1415. #### Method: defaults
  1416. # Create a "defaults" button.
  1417. # Parameters:
  1418. #   $name -> (optional) Name for the button.
  1419. # Returns:
  1420. #   A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
  1421. #
  1422. # Note: this button has a special meaning to the initialization script,
  1423. # and tells it to ERASE the current query string so that your defaults
  1424. # are used again!
  1425. ####
  1426. 'defaults' => <<'END_OF_FUNC',
  1427. sub defaults {
  1428.     my($self,@p) = self_or_default(@_);
  1429.  
  1430.     my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
  1431.  
  1432.     $label=$self->escapeHTML($label);
  1433.     $label = $label || "Defaults";
  1434.     my($value) = qq/ VALUE="$label"/;
  1435.     my($other) = @other ? " @other" : '';
  1436.     return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
  1437. }
  1438. END_OF_FUNC
  1439.  
  1440.  
  1441. #### Method: checkbox
  1442. # Create a checkbox that is not logically linked to any others.
  1443. # The field value is "on" when the button is checked.
  1444. # Parameters:
  1445. #   $name -> Name of the checkbox
  1446. #   $checked -> (optional) turned on by default if true
  1447. #   $value -> (optional) value of the checkbox, 'on' by default
  1448. #   $label -> (optional) a user-readable label printed next to the box.
  1449. #             Otherwise the checkbox name is used.
  1450. # Returns:
  1451. #   A string containing a <INPUT TYPE="checkbox"> field
  1452. ####
  1453. 'checkbox' => <<'END_OF_FUNC',
  1454. sub checkbox {
  1455.     my($self,@p) = self_or_default(@_);
  1456.  
  1457.     my($name,$checked,$value,$label,$override,@other) = 
  1458.     $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
  1459.     
  1460.     if (!$override && defined($self->param($name))) {
  1461.     $value = $self->param($name) unless defined $value;
  1462.     $checked = $self->param($name) eq $value ? ' CHECKED' : '';
  1463.     } else {
  1464.     $checked = $checked ? ' CHECKED' : '';
  1465.     $value = defined $value ? $value : 'on';
  1466.     }
  1467.     my($the_label) = defined $label ? $label : $name;
  1468.     $name = $self->escapeHTML($name);
  1469.     $value = $self->escapeHTML($value);
  1470.     $the_label = $self->escapeHTML($the_label);
  1471.     my($other) = @other ? " @other" : '';
  1472.     $self->register_parameter($name);
  1473.     return <<END;
  1474. <INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
  1475. END
  1476. }
  1477. END_OF_FUNC
  1478.  
  1479.  
  1480. #### Method: checkbox_group
  1481. # Create a list of logically-linked checkboxes.
  1482. # Parameters:
  1483. #   $name -> Common name for all the check boxes
  1484. #   $values -> A pointer to a regular array containing the
  1485. #             values for each checkbox in the group.
  1486. #   $defaults -> (optional)
  1487. #             1. If a pointer to a regular array of checkbox values,
  1488. #             then this will be used to decide which
  1489. #             checkboxes to turn on by default.
  1490. #             2. If a scalar, will be assumed to hold the
  1491. #             value of a single checkbox in the group to turn on. 
  1492. #   $linebreak -> (optional) Set to true to place linebreaks
  1493. #             between the buttons.
  1494. #   $labels -> (optional)
  1495. #             A pointer to an associative array of labels to print next to each checkbox
  1496. #             in the form $label{'value'}="Long explanatory label".
  1497. #             Otherwise the provided values are used as the labels.
  1498. # Returns:
  1499. #   An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
  1500. ####
  1501. 'checkbox_group' => <<'END_OF_FUNC',
  1502. sub checkbox_group {
  1503.     my($self,@p) = self_or_default(@_);
  1504.  
  1505.     my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
  1506.        $rowheaders,$colheaders,$override,$nolabels,@other) =
  1507.     $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
  1508.               LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
  1509.               ROWHEADERS,COLHEADERS,
  1510.               [OVERRIDE,FORCE],NOLABELS],@p);
  1511.  
  1512.     my($checked,$break,$result,$label);
  1513.  
  1514.     my(%checked) = $self->previous_or_default($name,$defaults,$override);
  1515.  
  1516.     $break = $linebreak ? "<BR>" : '';
  1517.     $name=$self->escapeHTML($name);
  1518.  
  1519.     # Create the elements
  1520.     my(@elements);
  1521.     my(@values) = $values ? @$values : $self->param($name);
  1522.     my($other) = @other ? " @other" : '';
  1523.     foreach (@values) {
  1524.     $checked = $checked{$_} ? ' CHECKED' : '';
  1525.     $label = '';
  1526.     unless (defined($nolabels) && $nolabels) {
  1527.         $label = $_;
  1528.         $label = $labels->{$_} if defined($labels) && $labels->{$_};
  1529.         $label = $self->escapeHTML($label);
  1530.     }
  1531.     $_ = $self->escapeHTML($_);
  1532.     push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/);
  1533.     }
  1534.     $self->register_parameter($name);
  1535.     return wantarray ? @elements : join('',@elements) unless $columns;
  1536.     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
  1537. }
  1538. END_OF_FUNC
  1539.  
  1540.  
  1541. # Escape HTML -- used internally
  1542. 'escapeHTML' => <<'END_OF_FUNC',
  1543. sub escapeHTML {
  1544.     my($self,$toencode) = @_;
  1545.     return undef unless defined($toencode);
  1546.     return $toencode if $self->{'dontescape'};
  1547.     $toencode=~s/&/&/g;
  1548.     $toencode=~s/\"/"/g;
  1549.     $toencode=~s/>/>/g;
  1550.     $toencode=~s/</</g;
  1551.     return $toencode;
  1552. }
  1553. END_OF_FUNC
  1554.  
  1555.  
  1556. # Internal procedure - don't use
  1557. '_tableize' => <<'END_OF_FUNC',
  1558. sub _tableize {
  1559.     my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
  1560.     my($result);
  1561.  
  1562.     $rows = int(0.99 + @elements/$columns) unless $rows;
  1563.     # rearrange into a pretty table
  1564.     $result = "<TABLE>";
  1565.     my($row,$column);
  1566.     unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
  1567.     $result .= "<TR>" if @{$colheaders};
  1568.     foreach (@{$colheaders}) {
  1569.     $result .= "<TH>$_</TH>";
  1570.     }
  1571.     for ($row=0;$row<$rows;$row++) {
  1572.     $result .= "<TR>";
  1573.     $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
  1574.     for ($column=0;$column<$columns;$column++) {
  1575.         $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>";
  1576.     }
  1577.     $result .= "</TR>";
  1578.     }
  1579.     $result .= "</TABLE>";
  1580.     return $result;
  1581. }
  1582. END_OF_FUNC
  1583.  
  1584.  
  1585. #### Method: radio_group
  1586. # Create a list of logically-linked radio buttons.
  1587. # Parameters:
  1588. #   $name -> Common name for all the buttons.
  1589. #   $values -> A pointer to a regular array containing the
  1590. #             values for each button in the group.
  1591. #   $default -> (optional) Value of the button to turn on by default.  Pass '-'
  1592. #               to turn _nothing_ on.
  1593. #   $linebreak -> (optional) Set to true to place linebreaks
  1594. #             between the buttons.
  1595. #   $labels -> (optional)
  1596. #             A pointer to an associative array of labels to print next to each checkbox
  1597. #             in the form $label{'value'}="Long explanatory label".
  1598. #             Otherwise the provided values are used as the labels.
  1599. # Returns:
  1600. #   An ARRAY containing a series of <INPUT TYPE="radio"> fields
  1601. ####
  1602. 'radio_group' => <<'END_OF_FUNC',
  1603. sub radio_group {
  1604.     my($self,@p) = self_or_default(@_);
  1605.  
  1606.     my($name,$values,$default,$linebreak,$labels,
  1607.        $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
  1608.     $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
  1609.               ROWS,[COLUMNS,COLS],
  1610.               ROWHEADERS,COLHEADERS,
  1611.               [OVERRIDE,FORCE],NOLABELS],@p);
  1612.     my($result,$checked);
  1613.  
  1614.     if (!$override && defined($self->param($name))) {
  1615.     $checked = $self->param($name);
  1616.     } else {
  1617.     $checked = $default;
  1618.     }
  1619.     # If no check array is specified, check the first by default
  1620.     $checked = $values->[0] unless $checked;
  1621.     $name=$self->escapeHTML($name);
  1622.  
  1623.     my(@elements);
  1624.     my(@values) = $values ? @$values : $self->param($name);
  1625.     my($other) = @other ? " @other" : '';
  1626.     foreach (@values) {
  1627.     my($checkit) = $checked eq $_ ? ' CHECKED' : '';
  1628.     my($break) = $linebreak ? '<BR>' : '';
  1629.     my($label)='';
  1630.     unless (defined($nolabels) && $nolabels) {
  1631.         $label = $_;
  1632.         $label = $labels->{$_} if defined($labels) && $labels->{$_};
  1633.         $label = $self->escapeHTML($label);
  1634.     }
  1635.     $_=$self->escapeHTML($_);
  1636.     push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/);
  1637.     }
  1638.     $self->register_parameter($name);
  1639.     return wantarray ? @elements : join('',@elements) unless $columns;
  1640.     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
  1641. }
  1642. END_OF_FUNC
  1643.  
  1644.  
  1645. #### Method: popup_menu
  1646. # Create a popup menu.
  1647. # Parameters:
  1648. #   $name -> Name for all the menu
  1649. #   $values -> A pointer to a regular array containing the
  1650. #             text of each menu item.
  1651. #   $default -> (optional) Default item to display
  1652. #   $labels -> (optional)
  1653. #             A pointer to an associative array of labels to print next to each checkbox
  1654. #             in the form $label{'value'}="Long explanatory label".
  1655. #             Otherwise the provided values are used as the labels.
  1656. # Returns:
  1657. #   A string containing the definition of a popup menu.
  1658. ####
  1659. 'popup_menu' => <<'END_OF_FUNC',
  1660. sub popup_menu {
  1661.     my($self,@p) = self_or_default(@_);
  1662.  
  1663.     my($name,$values,$default,$labels,$override,@other) =
  1664.     $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
  1665.     my($result,$selected);
  1666.  
  1667.     if (!$override && defined($self->param($name))) {
  1668.     $selected = $self->param($name);
  1669.     } else {
  1670.     $selected = $default;
  1671.     }
  1672.     $name=$self->escapeHTML($name);
  1673.     my($other) = @other ? " @other" : '';
  1674.  
  1675.     my(@values) = $values ? @$values : $self->param($name);
  1676.     $result = qq/<SELECT NAME="$name"$other>\n/;
  1677.     foreach (@values) {
  1678.     my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
  1679.     my($label) = $_;
  1680.     $label = $labels->{$_} if defined($labels) && $labels->{$_};
  1681.     my($value) = $self->escapeHTML($_);
  1682.     $label=$self->escapeHTML($label);
  1683.     $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
  1684.     }
  1685.  
  1686.     $result .= "</SELECT>\n";
  1687.     return $result;
  1688. }
  1689. END_OF_FUNC
  1690.  
  1691.  
  1692. #### Method: scrolling_list
  1693. # Create a scrolling list.
  1694. # Parameters:
  1695. #   $name -> name for the list
  1696. #   $values -> A pointer to a regular array containing the
  1697. #             values for each option line in the list.
  1698. #   $defaults -> (optional)
  1699. #             1. If a pointer to a regular array of options,
  1700. #             then this will be used to decide which
  1701. #             lines to turn on by default.
  1702. #             2. Otherwise holds the value of the single line to turn on.
  1703. #   $size -> (optional) Size of the list.
  1704. #   $multiple -> (optional) If set, allow multiple selections.
  1705. #   $labels -> (optional)
  1706. #             A pointer to an associative array of labels to print next to each checkbox
  1707. #             in the form $label{'value'}="Long explanatory label".
  1708. #             Otherwise the provided values are used as the labels.
  1709. # Returns:
  1710. #   A string containing the definition of a scrolling list.
  1711. ####
  1712. 'scrolling_list' => <<'END_OF_FUNC',
  1713. sub scrolling_list {
  1714.     my($self,@p) = self_or_default(@_);
  1715.     my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
  1716.     = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
  1717.                 SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
  1718.  
  1719.     my($result);
  1720.     my(@values) = $values ? @$values : $self->param($name);
  1721.     $size = $size || scalar(@values);
  1722.  
  1723.     my(%selected) = $self->previous_or_default($name,$defaults,$override);
  1724.     my($is_multiple) = $multiple ? ' MULTIPLE' : '';
  1725.     my($has_size) = $size ? " SIZE=$size" : '';
  1726.     my($other) = @other ? " @other" : '';
  1727.  
  1728.     $name=$self->escapeHTML($name);
  1729.     $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
  1730.     foreach (@values) {
  1731.     my($selectit) = $selected{$_} ? 'SELECTED' : '';
  1732.     my($label) = $_;
  1733.     $label = $labels->{$_} if defined($labels) && $labels->{$_};
  1734.     $label=$self->escapeHTML($label);
  1735.     my($value)=$self->escapeHTML($_);
  1736.     $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
  1737.     }
  1738.     $result .= "</SELECT>\n";
  1739.     $self->register_parameter($name);
  1740.     return $result;
  1741. }
  1742. END_OF_FUNC
  1743.  
  1744.  
  1745. #### Method: hidden
  1746. # Parameters:
  1747. #   $name -> Name of the hidden field
  1748. #   @default -> (optional) Initial values of field (may be an array)
  1749. #      or
  1750. #   $default->[initial values of field]
  1751. # Returns:
  1752. #   A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
  1753. ####
  1754. 'hidden' => <<'END_OF_FUNC',
  1755. sub hidden {
  1756.     my($self,@p) = self_or_default(@_);
  1757.  
  1758.     # this is the one place where we departed from our standard
  1759.     # calling scheme, so we have to special-case (darn)
  1760.     my(@result,@value);
  1761.     my($name,$default,$override,@other) = 
  1762.     $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
  1763.  
  1764.     my $do_override = 0;
  1765.     if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
  1766.     @value = ref($default) ? @{$default} : $default;
  1767.     $do_override = $override;
  1768.     } else {
  1769.     foreach ($default,$override,@other) {
  1770.         push(@value,$_) if defined($_);
  1771.     }
  1772.     }
  1773.  
  1774.     # use previous values if override is not set
  1775.     my @prev = $self->param($name);
  1776.     @value = @prev if !$do_override && @prev;
  1777.  
  1778.     $name=$self->escapeHTML($name);
  1779.     foreach (@value) {
  1780.     $_=$self->escapeHTML($_);
  1781.     push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
  1782.     }
  1783.     return wantarray ? @result : join('',@result);
  1784. }
  1785. END_OF_FUNC
  1786.  
  1787.  
  1788. #### Method: image_button
  1789. # Parameters:
  1790. #   $name -> Name of the button
  1791. #   $src ->  URL of the image source
  1792. #   $align -> Alignment style (TOP, BOTTOM or MIDDLE)
  1793. # Returns:
  1794. #   A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
  1795. ####
  1796. 'image_button' => <<'END_OF_FUNC',
  1797. sub image_button {
  1798.     my($self,@p) = self_or_default(@_);
  1799.  
  1800.     my($name,$src,$alignment,@other) =
  1801.     $self->rearrange([NAME,SRC,ALIGN],@p);
  1802.  
  1803.     my($align) = $alignment ? " ALIGN=\U$alignment" : '';
  1804.     my($other) = @other ? " @other" : '';
  1805.     $name=$self->escapeHTML($name);
  1806.     return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
  1807. }
  1808. END_OF_FUNC
  1809.  
  1810.  
  1811. #### Method: self_url
  1812. # Returns a URL containing the current script and all its
  1813. # param/value pairs arranged as a query.  You can use this
  1814. # to create a link that, when selected, will reinvoke the
  1815. # script with all its state information preserved.
  1816. ####
  1817. 'self_url' => <<'END_OF_FUNC',
  1818. sub self_url {
  1819.     my($self) = self_or_default(@_);
  1820.     my($query_string) = $self->query_string;
  1821.     my $protocol = $self->protocol();
  1822.     my $name = "$protocol://" . $self->server_name;
  1823.     $name .= ":" . $self->server_port
  1824.     unless $self->server_port == 80;
  1825.     $name .= $self->script_name;
  1826.     $name .= $self->path_info if $self->path_info;
  1827.     return $name unless $query_string;
  1828.     return "$name?$query_string";
  1829. }
  1830. END_OF_FUNC
  1831.  
  1832.  
  1833. # This is provided as a synonym to self_url() for people unfortunate
  1834. # enough to have incorporated it into their programs already!
  1835. 'state' => <<'END_OF_FUNC',
  1836. sub state {
  1837.     &self_url;
  1838. }
  1839. END_OF_FUNC
  1840.  
  1841.  
  1842. #### Method: url
  1843. # Like self_url, but doesn't return the query string part of
  1844. # the URL.
  1845. ####
  1846. 'url' => <<'END_OF_FUNC',
  1847. sub url {
  1848.     my($self) = self_or_default(@_);
  1849.     my $protocol = $self->protocol();
  1850.     my $name = "$protocol://" . $self->server_name;
  1851.     $name .= ":" . $self->server_port
  1852.     unless $self->server_port == 80;
  1853.     $name .= $self->script_name;
  1854.     return $name;
  1855. }
  1856.  
  1857. END_OF_FUNC
  1858.  
  1859. #### Method: cookie
  1860. # Set or read a cookie from the specified name.
  1861. # Cookie can then be passed to header().
  1862. # Usual rules apply to the stickiness of -value.
  1863. #  Parameters:
  1864. #   -name -> name for this cookie (optional)
  1865. #   -value -> value of this cookie (scalar, array or hash) 
  1866. #   -path -> paths for which this cookie is valid (optional)
  1867. #   -domain -> internet domain in which this cookie is valid (optional)
  1868. #   -secure -> if true, cookie only passed through secure channel (optional)
  1869. #   -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
  1870. ####
  1871. 'cookie' => <<'END_OF_FUNC',
  1872. # temporary, for debugging.
  1873. sub cookie {
  1874.     my($self,@p) = self_or_default(@_);
  1875.     my($name,$value,$path,$domain,$secure,$expires) =
  1876.     $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
  1877.  
  1878.  
  1879.     # if no value is supplied, then we retrieve the
  1880.     # value of the cookie, if any.  For efficiency, we cache the parsed
  1881.     # cookie in our state variables.
  1882.     unless (defined($value)) {
  1883.     unless ($self->{'.cookies'}) {
  1884.         my(@pairs) = split("; ",$self->raw_cookie);
  1885.         foreach (@pairs) {
  1886.         my($key,$value) = split("=");
  1887.         my(@values) = map unescape($_),split('&',$value);
  1888.         $self->{'.cookies'}->{unescape($key)} = [@values];
  1889.         }
  1890.     }
  1891.  
  1892.     # If no name is supplied, then retrieve the names of all our cookies.
  1893.     return () unless $self->{'.cookies'};
  1894.     return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]
  1895.         if defined($name) && $name ne '';
  1896.     return keys %{$self->{'.cookies'}};
  1897.     }
  1898.     my(@values);
  1899.  
  1900.     # Pull out our parameters.
  1901.     if (ref($value)) {
  1902.     if (ref($value) eq 'ARRAY') {
  1903.         @values = @$value;
  1904.     } elsif (ref($value) eq 'HASH') {
  1905.         @values = %$value;
  1906.     }
  1907.     } else {
  1908.     @values = ($value);
  1909.     }
  1910.     @values = map escape($_),@values;
  1911.  
  1912.     # I.E. requires the path to be present.
  1913.     ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
  1914.  
  1915.     my(@constant_values);
  1916.     push(@constant_values,"domain=$domain") if $domain;
  1917.     push(@constant_values,"path=$path") if $path;
  1918.     push(@constant_values,"expires=".&date(&expire_calc($expires),'cookie'))
  1919.     if $expires;
  1920.     push(@constant_values,'secure') if $secure;
  1921.  
  1922.     my($key) = &escape($name);
  1923.     my($cookie) = join("=",$key,join("&",@values));
  1924.     return join("; ",$cookie,@constant_values);
  1925. }
  1926. END_OF_FUNC
  1927.  
  1928.  
  1929. # This internal routine creates an expires time exactly some number of
  1930. # hours from the current time.  It incorporates modifications from 
  1931. # Fisher Mark.
  1932. 'expire_calc' => <<'END_OF_FUNC',
  1933. sub expire_calc {
  1934.     my($time) = @_;
  1935.     my(%mult) = ('s'=>1,
  1936.                  'm'=>60,
  1937.                  'h'=>60*60,
  1938.                  'd'=>60*60*24,
  1939.                  'M'=>60*60*24*30,
  1940.                  'y'=>60*60*24*365);
  1941.     # format for time can be in any of the forms...
  1942.     # "now" -- expire immediately
  1943.     # "+180s" -- in 180 seconds
  1944.     # "+2m" -- in 2 minutes
  1945.     # "+12h" -- in 12 hours
  1946.     # "+1d"  -- in 1 day
  1947.     # "+3M"  -- in 3 months
  1948.     # "+2y"  -- in 2 years
  1949.     # "-3m"  -- 3 minutes ago(!)
  1950.     # If you don't supply one of these forms, we assume you are
  1951.     # specifying the date yourself
  1952.     my($offset);
  1953.     if (!$time || ($time eq 'now')) {
  1954.         $offset = 0;
  1955.     } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) {
  1956.         $offset = ($mult{$2} || 1)*$1;
  1957.     } else {
  1958.         return $time;
  1959.     }
  1960.     return (time+$offset);
  1961. }
  1962. END_OF_FUNC
  1963.  
  1964. # This internal routine creates date strings suitable for use in
  1965. # cookies and HTTP headers.  (They differ, unfortunately.)
  1966. # Thanks to Fisher Mark for this.
  1967. 'date' => <<'END_OF_FUNC',
  1968. sub date {
  1969.     my($time,$format) = @_;
  1970.     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
  1971.     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
  1972.  
  1973.     # pass through preformatted dates for the sake of expire_calc()
  1974.     if ("$time" =~ m/^[^0-9]/o) {
  1975.         return $time;
  1976.     }
  1977.  
  1978.     # make HTTP/cookie date string from GMT'ed time
  1979.     # (cookies use '-' as date separator, HTTP uses ' ')
  1980.     my($sc) = ' ';
  1981.     $sc = '-' if $format eq "cookie";
  1982.     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
  1983.     $year += 1900;
  1984.     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
  1985.                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
  1986. }
  1987. END_OF_FUNC
  1988.  
  1989. ###############################################
  1990. # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
  1991. ###############################################
  1992.  
  1993. #### Method: path_info
  1994. # Return the extra virtual path information provided
  1995. # after the URL (if any)
  1996. ####
  1997. 'path_info' => <<'END_OF_FUNC',
  1998. sub path_info {
  1999.     return $ENV{'PATH_INFO'};
  2000. }
  2001. END_OF_FUNC
  2002.  
  2003.  
  2004. #### Method: request_method
  2005. # Returns 'POST', 'GET', 'PUT' or 'HEAD'
  2006. ####
  2007. 'request_method' => <<'END_OF_FUNC',
  2008. sub request_method {
  2009.     return $ENV{'REQUEST_METHOD'};
  2010. }
  2011. END_OF_FUNC
  2012.  
  2013. #### Method: path_translated
  2014. # Return the physical path information provided
  2015. # by the URL (if any)
  2016. ####
  2017. 'path_translated' => <<'END_OF_FUNC',
  2018. sub path_translated {
  2019.     return $ENV{'PATH_TRANSLATED'};
  2020. }
  2021. END_OF_FUNC
  2022.  
  2023.  
  2024. #### Method: query_string
  2025. # Synthesize a query string from our current
  2026. # parameters
  2027. ####
  2028. 'query_string' => <<'END_OF_FUNC',
  2029. sub query_string {
  2030.     my($self) = self_or_default(@_);
  2031.     my($param,$value,@pairs);
  2032.     foreach $param ($self->param) {
  2033.     my($eparam) = &escape($param);
  2034.     foreach $value ($self->param($param)) {
  2035.         $value = &escape($value);
  2036.         push(@pairs,"$eparam=$value");
  2037.     }
  2038.     }
  2039.     return join("&",@pairs);
  2040. }
  2041. END_OF_FUNC
  2042.  
  2043.  
  2044. #### Method: accept
  2045. # Without parameters, returns an array of the
  2046. # MIME types the browser accepts.
  2047. # With a single parameter equal to a MIME
  2048. # type, will return undef if the browser won't
  2049. # accept it, 1 if the browser accepts it but
  2050. # doesn't give a preference, or a floating point
  2051. # value between 0.0 and 1.0 if the browser
  2052. # declares a quantitative score for it.
  2053. # This handles MIME type globs correctly.
  2054. ####
  2055. 'accept' => <<'END_OF_FUNC',
  2056. sub accept {
  2057.     my($self,$search) = self_or_CGI(@_);
  2058.     my(%prefs,$type,$pref,$pat);
  2059.     
  2060.     my(@accept) = split(',',$self->http('accept'));
  2061.  
  2062.     foreach (@accept) {
  2063.     ($pref) = /q=(\d\.\d+|\d+)/;
  2064.     ($type) = m#(\S+/[^;]+)#;
  2065.     next unless $type;
  2066.     $prefs{$type}=$pref || 1;
  2067.     }
  2068.  
  2069.     return keys %prefs unless $search;
  2070.     
  2071.     # if a search type is provided, we may need to
  2072.     # perform a pattern matching operation.
  2073.     # The MIME types use a glob mechanism, which
  2074.     # is easily translated into a perl pattern match
  2075.  
  2076.     # First return the preference for directly supported
  2077.     # types:
  2078.     return $prefs{$search} if $prefs{$search};
  2079.  
  2080.     # Didn't get it, so try pattern matching.
  2081.     foreach (keys %prefs) {
  2082.     next unless /\*/;       # not a pattern match
  2083.     ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
  2084.     $pat =~ s/\*/.*/g; # turn it into a pattern
  2085.     return $prefs{$_} if $search=~/$pat/;
  2086.     }
  2087. }
  2088. END_OF_FUNC
  2089.  
  2090.  
  2091. #### Method: user_agent
  2092. # If called with no parameters, returns the user agent.
  2093. # If called with one parameter, does a pattern match (case
  2094. # insensitive) on the user agent.
  2095. ####
  2096. 'user_agent' => <<'END_OF_FUNC',
  2097. sub user_agent {
  2098.     my($self,$match)=self_or_CGI(@_);
  2099.     return $self->http('user_agent') unless $match;
  2100.     return $self->http('user_agent') =~ /$match/i;
  2101. }
  2102. END_OF_FUNC
  2103.  
  2104.  
  2105. #### Method: cookie
  2106. # Returns the magic cookie for the session.
  2107. # To set the magic cookie for new transations,
  2108. # try print $q->header('-Set-cookie'=>'my cookie')
  2109. ####
  2110. 'raw_cookie' => <<'END_OF_FUNC',
  2111. sub raw_cookie {
  2112.     my($self) = self_or_CGI(@_);
  2113.     return $self->http('cookie') || $ENV{'COOKIE'} || '';
  2114. }
  2115. END_OF_FUNC
  2116.  
  2117. #### Method: virtual_host
  2118. # Return the name of the virtual_host, which
  2119. # is not always the same as the server
  2120. ######
  2121. 'virtual_host' => <<'END_OF_FUNC',
  2122. sub virtual_host {
  2123.     return http('host') || server_name();
  2124. }
  2125. END_OF_FUNC
  2126.  
  2127. #### Method: remote_host
  2128. # Return the name of the remote host, or its IP
  2129. # address if unavailable.  If this variable isn't
  2130. # defined, it returns "localhost" for debugging
  2131. # purposes.
  2132. ####
  2133. 'remote_host' => <<'END_OF_FUNC',
  2134. sub remote_host {
  2135.     return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} 
  2136.     || 'localhost';
  2137. }
  2138. END_OF_FUNC
  2139.  
  2140.  
  2141. #### Method: remote_addr
  2142. # Return the IP addr of the remote host.
  2143. ####
  2144. 'remote_addr' => <<'END_OF_FUNC',
  2145. sub remote_addr {
  2146.     return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
  2147. }
  2148. END_OF_FUNC
  2149.  
  2150.  
  2151. #### Method: script_name
  2152. # Return the partial URL to this script for
  2153. # self-referencing scripts.  Also see
  2154. # self_url(), which returns a URL with all state information
  2155. # preserved.
  2156. ####
  2157. 'script_name' => <<'END_OF_FUNC',
  2158. sub script_name {
  2159.     return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'};
  2160.     # These are for debugging
  2161.     return "/$0" unless $0=~/^\//;
  2162.     return $0;
  2163. }
  2164. END_OF_FUNC
  2165.  
  2166.  
  2167. #### Method: referer
  2168. # Return the HTTP_REFERER: useful for generating
  2169. # a GO BACK button.
  2170. ####
  2171. 'referer' => <<'END_OF_FUNC',
  2172. sub referer {
  2173.     my($self) = self_or_CGI(@_);
  2174.     return $self->http('referer');
  2175. }
  2176. END_OF_FUNC
  2177.  
  2178.  
  2179. #### Method: server_name
  2180. # Return the name of the server
  2181. ####
  2182. 'server_name' => <<'END_OF_FUNC',
  2183. sub server_name {
  2184.     return $ENV{'SERVER_NAME'} || 'localhost';
  2185. }
  2186. END_OF_FUNC
  2187.  
  2188. #### Method: server_software
  2189. # Return the name of the server software
  2190. ####
  2191. 'server_software' => <<'END_OF_FUNC',
  2192. sub server_software {
  2193.     return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
  2194. }
  2195. END_OF_FUNC
  2196.  
  2197. #### Method: server_port
  2198. # Return the tcp/ip port the server is running on
  2199. ####
  2200. 'server_port' => <<'END_OF_FUNC',
  2201. sub server_port {
  2202.     return $ENV{'SERVER_PORT'} || 80; # for debugging
  2203. }
  2204. END_OF_FUNC
  2205.  
  2206. #### Method: server_protocol
  2207. # Return the protocol (usually HTTP/1.0)
  2208. ####
  2209. 'server_protocol' => <<'END_OF_FUNC',
  2210. sub server_protocol {
  2211.     return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
  2212. }
  2213. END_OF_FUNC
  2214.  
  2215. #### Method: http
  2216. # Return the value of an HTTP variable, or
  2217. # the list of variables if none provided
  2218. ####
  2219. 'http' => <<'END_OF_FUNC',
  2220. sub http {
  2221.     my ($self,$parameter) = self_or_CGI(@_);
  2222.     return $ENV{$parameter} if $parameter=~/^HTTP/;
  2223.     return $ENV{"HTTP_\U$parameter\E"} if $parameter;
  2224.     my(@p);
  2225.     foreach (keys %ENV) {
  2226.     push(@p,$_) if /^HTTP/;
  2227.     }
  2228.     return @p;
  2229. }
  2230. END_OF_FUNC
  2231.  
  2232. #### Method: https
  2233. # Return the value of HTTPS
  2234. ####
  2235. 'https' => <<'END_OF_FUNC',
  2236. sub https {
  2237.     local($^W)=0;
  2238.     my ($self,$parameter) = self_or_CGI(@_);
  2239.     return $ENV{HTTPS} unless $parameter;
  2240.     return $ENV{$parameter} if $parameter=~/^HTTPS/;
  2241.     return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
  2242.     my(@p);
  2243.     foreach (keys %ENV) {
  2244.     push(@p,$_) if /^HTTPS/;
  2245.     }
  2246.     return @p;
  2247. }
  2248. END_OF_FUNC
  2249.  
  2250. #### Method: protocol
  2251. # Return the protocol (http or https currently)
  2252. ####
  2253. 'protocol' => <<'END_OF_FUNC',
  2254. sub protocol {
  2255.     local($^W)=0;
  2256.     my $self = shift;
  2257.     return 'https' if $self->https() eq 'ON'; 
  2258.     return 'https' if $self->server_port == 443;
  2259.     my $prot = $self->server_protocol;
  2260.     my($protocol,$version) = split('/',$prot);
  2261.     return "\L$protocol\E";
  2262. }
  2263. END_OF_FUNC
  2264.  
  2265. #### Method: remote_ident
  2266. # Return the identity of the remote user
  2267. # (but only if his host is running identd)
  2268. ####
  2269. 'remote_ident' => <<'END_OF_FUNC',
  2270. sub remote_ident {
  2271.     return $ENV{'REMOTE_IDENT'};
  2272. }
  2273. END_OF_FUNC
  2274.  
  2275.  
  2276. #### Method: auth_type
  2277. # Return the type of use verification/authorization in use, if any.
  2278. ####
  2279. 'auth_type' => <<'END_OF_FUNC',
  2280. sub auth_type {
  2281.     return $ENV{'AUTH_TYPE'};
  2282. }
  2283. END_OF_FUNC
  2284.  
  2285.  
  2286. #### Method: remote_user
  2287. # Return the authorization name used for user
  2288. # verification.
  2289. ####
  2290. 'remote_user' => <<'END_OF_FUNC',
  2291. sub remote_user {
  2292.     return $ENV{'REMOTE_USER'};
  2293. }
  2294. END_OF_FUNC
  2295.  
  2296.  
  2297. #### Method: user_name
  2298. # Try to return the remote user's name by hook or by
  2299. # crook
  2300. ####
  2301. 'user_name' => <<'END_OF_FUNC',
  2302. sub user_name {
  2303.     my ($self) = self_or_CGI(@_);
  2304.     return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
  2305. }
  2306. END_OF_FUNC
  2307.  
  2308. #### Method: nph
  2309. # Set or return the NPH global flag
  2310. ####
  2311. 'nph' => <<'END_OF_FUNC',
  2312. sub nph {
  2313.     my ($self,$param) = self_or_CGI(@_);
  2314.     $CGI::NPH = $param if defined($param);
  2315.     return $CGI::NPH;
  2316. }
  2317. END_OF_FUNC
  2318.  
  2319. #### Method: private_tempfiles
  2320. # Set or return the private_tempfiles global flag
  2321. ####
  2322. 'private_tempfiles' => <<'END_OF_FUNC',
  2323. sub private_tempfiles {
  2324.     my ($self,$param) = self_or_CGI(@_);
  2325.     $CGI::$PRIVATE_TEMPFILES = $param if defined($param);
  2326.     return $CGI::PRIVATE_TEMPFILES;
  2327. }
  2328. END_OF_FUNC
  2329.  
  2330. # -------------- really private subroutines -----------------
  2331. 'previous_or_default' => <<'END_OF_FUNC',
  2332. sub previous_or_default {
  2333.     my($self,$name,$defaults,$override) = @_;
  2334.     my(%selected);
  2335.  
  2336.     if (!$override && ($self->{'.fieldnames'}->{$name} || 
  2337.                defined($self->param($name)) ) ) {
  2338.     grep($selected{$_}++,$self->param($name));
  2339.     } elsif (defined($defaults) && ref($defaults) && 
  2340.          (ref($defaults) eq 'ARRAY')) {
  2341.     grep($selected{$_}++,@{$defaults});
  2342.     } else {
  2343.     $selected{$defaults}++ if defined($defaults);
  2344.     }
  2345.  
  2346.     return %selected;
  2347. }
  2348. END_OF_FUNC
  2349.  
  2350. 'register_parameter' => <<'END_OF_FUNC',
  2351. sub register_parameter {
  2352.     my($self,$param) = @_;
  2353.     $self->{'.parametersToAdd'}->{$param}++;
  2354. }
  2355. END_OF_FUNC
  2356.  
  2357. 'get_fields' => <<'END_OF_FUNC',
  2358. sub get_fields {
  2359.     my($self) = @_;
  2360.     return $self->hidden('-name'=>'.cgifields',
  2361.              '-values'=>[keys %{$self->{'.parametersToAdd'}}],
  2362.              '-override'=>1);
  2363. }
  2364. END_OF_FUNC
  2365.  
  2366. 'read_from_cmdline' => <<'END_OF_FUNC',
  2367. sub read_from_cmdline {
  2368.     require "shellwords.pl";
  2369.     my($input,@words);
  2370.     my($query_string);
  2371.     if (@ARGV) {
  2372.     $input = join(" ",@ARGV);
  2373.     } else {
  2374.     print STDERR "(offline mode: enter name=value pairs on standard input)\n";
  2375.     chomp(@lines = <>); # remove newlines
  2376.     $input = join(" ",@lines);
  2377.     }
  2378.  
  2379.     # minimal handling of escape characters
  2380.     $input=~s/\\=/%3D/g;
  2381.     $input=~s/\\&/%26/g;
  2382.     
  2383.     @words = &shellwords($input);
  2384.     if ("@words"=~/=/) {
  2385.     $query_string = join('&',@words);
  2386.     } else {
  2387.     $query_string = join('+',@words);
  2388.     }
  2389.     return $query_string;
  2390. }
  2391. END_OF_FUNC
  2392.  
  2393. #####
  2394. # subroutine: read_multipart
  2395. #
  2396. # Read multipart data and store it into our parameters.
  2397. # An interesting feature is that if any of the parts is a file, we
  2398. # create a temporary file and open up a filehandle on it so that the
  2399. # caller can read from it if necessary.
  2400. #####
  2401. 'read_multipart' => <<'END_OF_FUNC',
  2402. sub read_multipart {
  2403.     my($self,$boundary,$length) = @_;
  2404.     my($buffer) = $self->new_MultipartBuffer($boundary,$length);
  2405.     return unless $buffer;
  2406.     my(%header,$body);
  2407.     while (!$buffer->eof) {
  2408.     %header = $buffer->readHeader;
  2409.     die "Malformed multipart POST\n" unless %header;
  2410.  
  2411.     # In beta1 it was "Content-disposition".  In beta2 it's "Content-Disposition"
  2412.     # Sheesh.
  2413.     my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition';
  2414.     my($param)= $header{$key}=~/ name="([^\"]*)"/;
  2415.  
  2416.     # possible bug: our regular expression expects the filename= part to fall
  2417.     # at the end of the line.  Netscape doesn't escape quotation marks in file names!!!
  2418.     my($filename) = $header{$key}=~/ filename="(.*)"$/;
  2419.  
  2420.     # add this parameter to our list
  2421.     $self->add_parameter($param);
  2422.  
  2423.     # If no filename specified, then just read the data and assign it
  2424.     # to our parameter list.
  2425.     unless ($filename) {
  2426.         my($value) = $buffer->readBody;
  2427.         push(@{$self->{$param}},$value);
  2428.         next;
  2429.     }
  2430.  
  2431.     # If we get here, then we are dealing with a potentially large
  2432.     # uploaded form.  Save the data to a temporary file, then open
  2433.     # the file for reading.
  2434.     my($tmpfile) = new TempFile;
  2435.     my $tmp = $tmpfile->as_string;
  2436.     
  2437.     # Now create a new filehandle in the caller's namespace.
  2438.     # The name of this filehandle just happens to be identical
  2439.     # to the original filename (NOT the name of the temporary
  2440.     # file, which is hidden!)
  2441.     my($filehandle);
  2442.     if ($filename=~/^[a-zA-Z_]/) {
  2443.         my($frame,$cp)=(1);
  2444.         do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()");
  2445.         $filehandle = "$cp\:\:$filename";
  2446.     } else {
  2447.         $filehandle = "\:\:$filename";
  2448.     }
  2449.  
  2450.         # potential security problem -- this type of line can clobber 
  2451.     # tempfile, and can be abused by malicious users.
  2452.     # open ($filehandle,">$tmp") || die "CGI open of $tmpfile: $!\n";
  2453.  
  2454.     # This technique causes open to fail if file already exists.
  2455.     unless (defined(&O_RDWR)) {
  2456.         require Fcntl;
  2457.         import Fcntl qw/O_RDWR O_CREAT O_EXCL/;
  2458.     }
  2459.     sysopen($filehandle,$tmp,&O_RDWR|&O_CREAT|&O_EXCL) || die "CGI open of $tmp: $!\n";
  2460.     unlink($tmp) if $PRIVATE_TEMPFILES;
  2461.  
  2462.     $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
  2463.     chmod 0600,$tmp;    # only the owner can tamper with it
  2464.     my $data;
  2465.     while (defined($data = $buffer->read)) {
  2466.         print $filehandle $data;
  2467.     }
  2468.  
  2469.     seek($filehandle,0,0); #rewind file
  2470.     push(@{$self->{$param}},$filename);
  2471.  
  2472.     # Under Unix, it would be safe to let the temporary file
  2473.     # be deleted immediately.  However, I fear that other operating
  2474.     # systems are not so forgiving.  Therefore we save a reference
  2475.     # to the temporary file in the CGI object so that the file
  2476.     # isn't unlinked until the CGI object itself goes out of
  2477.     # scope.  This is a bit hacky, but it has the interesting side
  2478.     # effect that one can access the name of the tmpfile by
  2479.     # asking for $query->{$query->param('foo')}, where 'foo'
  2480.     # is the name of the file upload field.
  2481.     $self->{'.tmpfiles'}->{$filename}= {
  2482.         name=>($PRIVATE_TEMPFILES ? '' : $tmpfile),
  2483.         info=>{%header}
  2484.     }
  2485.     }
  2486. }
  2487. END_OF_FUNC
  2488.  
  2489. 'tmpFileName' => <<'END_OF_FUNC',
  2490. sub tmpFileName {
  2491.     my($self,$filename) = self_or_default(@_);
  2492.     return $self->{'.tmpfiles'}->{$filename}->{name} ?
  2493.     $self->{'.tmpfiles'}->{$filename}->{name}->as_string
  2494.         : '';
  2495. }
  2496. END_OF_FUNC
  2497.  
  2498. 'uploadInfo' => <<'END_OF_FUNC'
  2499. sub uploadInfo {
  2500.     my($self,$filename) = self_or_default(@_);
  2501.     return $self->{'.tmpfiles'}->{$filename}->{info};
  2502. }
  2503. END_OF_FUNC
  2504.  
  2505. );
  2506. END_OF_AUTOLOAD
  2507. ;
  2508.  
  2509. # Globals and stubs for other packages that we use
  2510. package MultipartBuffer;
  2511.  
  2512. # how many bytes to read at a time.  We use
  2513. # a 5K buffer by default.
  2514. $FILLUNIT = 1024 * 5;
  2515. $TIMEOUT = 10*60;       # 10 minute timeout
  2516. $SPIN_LOOP_MAX = 1000;  # bug fix for some Netscape servers
  2517. $CRLF=$CGI::CRLF;
  2518.  
  2519. #reuse the autoload function
  2520. *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
  2521.  
  2522. ###############################################################################
  2523. ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
  2524. ###############################################################################
  2525. $AUTOLOADED_ROUTINES = '';      # prevent -w error
  2526. $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
  2527. %SUBS =  (
  2528.  
  2529. 'new' => <<'END_OF_FUNC',
  2530. sub new {
  2531.     my($package,$interface,$boundary,$length,$filehandle) = @_;
  2532.     my $IN;
  2533.     if ($filehandle) {
  2534.     my($package) = caller;
  2535.     # force into caller's package if necessary
  2536.     $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; 
  2537.     }
  2538.     $IN = "main::STDIN" unless $IN;
  2539.  
  2540.     $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
  2541.     
  2542.     # If the user types garbage into the file upload field,
  2543.     # then Netscape passes NOTHING to the server (not good).
  2544.     # We may hang on this read in that case. So we implement
  2545.     # a read timeout.  If nothing is ready to read
  2546.     # by then, we return.
  2547.  
  2548.     # Netscape seems to be a little bit unreliable
  2549.     # about providing boundary strings.
  2550.     if ($boundary) {
  2551.  
  2552.     # Under the MIME spec, the boundary consists of the 
  2553.     # characters "--" PLUS the Boundary string
  2554.     $boundary = "--$boundary";
  2555.     # Read the topmost (boundary) line plus the CRLF
  2556.     my($null) = '';
  2557.     $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
  2558.     } else { # otherwise we find it ourselves
  2559.     my($old);
  2560.     ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
  2561.     $boundary = <$IN>;      # BUG: This won't work correctly under mod_perl
  2562.     $length -= length($boundary);
  2563.     chomp($boundary);               # remove the CRLF
  2564.     $/ = $old;                      # restore old line separator
  2565.     }
  2566.  
  2567.     my $self = {LENGTH=>$length,
  2568.         BOUNDARY=>$boundary,
  2569.         IN=>$IN,
  2570.         INTERFACE=>$interface,
  2571.         BUFFER=>'',
  2572.         };
  2573.  
  2574.     $FILLUNIT = length($boundary)
  2575.     if length($boundary) > $FILLUNIT;
  2576.  
  2577.     return bless $self,ref $package || $package;
  2578. }
  2579. END_OF_FUNC
  2580.  
  2581. 'readHeader' => <<'END_OF_FUNC',
  2582. sub readHeader {
  2583.     my($self) = @_;
  2584.     my($end);
  2585.     my($ok) = 0;
  2586.     my($bad) = 0;
  2587.     do {
  2588.     $self->fillBuffer($FILLUNIT);
  2589.     $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
  2590.     $ok++ if $self->{BUFFER} eq '';
  2591.     $bad++ if !$ok && $self->{LENGTH} <= 0;
  2592.     $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; 
  2593.     } until $ok || $bad;
  2594.     return () if $bad;
  2595.  
  2596.     my($header) = substr($self->{BUFFER},0,$end+2);
  2597.     substr($self->{BUFFER},0,$end+4) = '';
  2598.     my %return;
  2599.     while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
  2600.     $return{$1}=$2;
  2601.     }
  2602.     return %return;
  2603. }
  2604. END_OF_FUNC
  2605.  
  2606. # This reads and returns the body as a single scalar value.
  2607. 'readBody' => <<'END_OF_FUNC',
  2608. sub readBody {
  2609.     my($self) = @_;
  2610.     my($data);
  2611.     my($returnval)='';
  2612.     while (defined($data = $self->read)) {
  2613.     $returnval .= $data;
  2614.     }
  2615.     return $returnval;
  2616. }
  2617. END_OF_FUNC
  2618.  
  2619. # This will read $bytes or until the boundary is hit, whichever happens
  2620. # first.  After the boundary is hit, we return undef.  The next read will
  2621. # skip over the boundary and begin reading again;
  2622. 'read' => <<'END_OF_FUNC',
  2623. sub read {
  2624.     my($self,$bytes) = @_;
  2625.  
  2626.     # default number of bytes to read
  2627.     $bytes = $bytes || $FILLUNIT;       
  2628.  
  2629.     # Fill up our internal buffer in such a way that the boundary
  2630.     # is never split between reads.
  2631.     $self->fillBuffer($bytes);
  2632.  
  2633.     # Find the boundary in the buffer (it may not be there).
  2634.     my $start = index($self->{BUFFER},$self->{BOUNDARY});
  2635.     # protect against malformed multipart POST operations
  2636.     die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
  2637.  
  2638.     # If the boundary begins the data, then skip past it
  2639.     # and return undef.  The +2 here is a fiendish plot to
  2640.     # remove the CR/LF pair at the end of the boundary.
  2641.     if ($start == 0) {
  2642.  
  2643.     # clear us out completely if we've hit the last boundary.
  2644.     if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
  2645.         $self->{BUFFER}='';
  2646.         $self->{LENGTH}=0;
  2647.         return undef;
  2648.     }
  2649.  
  2650.     # just remove the boundary.
  2651.     substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
  2652.     return undef;
  2653.     }
  2654.  
  2655.     my $bytesToReturn;    
  2656.     if ($start > 0) {           # read up to the boundary
  2657.     $bytesToReturn = $start > $bytes ? $bytes : $start;
  2658.     } else {    # read the requested number of bytes
  2659.     # leave enough bytes in the buffer to allow us to read
  2660.     # the boundary.  Thanks to Kevin Hendrick for finding
  2661.     # this one.
  2662.     $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
  2663.     }
  2664.  
  2665.     my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
  2666.     substr($self->{BUFFER},0,$bytesToReturn)='';
  2667.     
  2668.     # If we hit the boundary, remove the CRLF from the end.
  2669.     return ($start > 0) ? substr($returnval,0,-2) : $returnval;
  2670. }
  2671. END_OF_FUNC
  2672.  
  2673.  
  2674. # This fills up our internal buffer in such a way that the
  2675. # boundary is never split between reads
  2676. 'fillBuffer' => <<'END_OF_FUNC',
  2677. sub fillBuffer {
  2678.     my($self,$bytes) = @_;
  2679.     return unless $self->{LENGTH};
  2680.  
  2681.     my($boundaryLength) = length($self->{BOUNDARY});
  2682.     my($bufferLength) = length($self->{BUFFER});
  2683.     my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
  2684.     $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
  2685.  
  2686.     # Try to read some data.  We may hang here if the browser is screwed up.  
  2687.     my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
  2688.                              \$self->{BUFFER},
  2689.                              $bytesToRead,
  2690.                              $bufferLength);
  2691.  
  2692.     # An apparent bug in the Apache server causes the read()
  2693.     # to return zero bytes repeatedly without blocking if the
  2694.     # remote user aborts during a file transfer.  I don't know how
  2695.     # they manage this, but the workaround is to abort if we get
  2696.     # more than SPIN_LOOP_MAX consecutive zero reads.
  2697.     if ($bytesRead == 0) {
  2698.     die  "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
  2699.         if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
  2700.     } else {
  2701.     $self->{ZERO_LOOP_COUNTER}=0;
  2702.     }
  2703.  
  2704.     $self->{LENGTH} -= $bytesRead;
  2705. }
  2706. END_OF_FUNC
  2707.  
  2708.  
  2709. # Return true when we've finished reading
  2710. 'eof' => <<'END_OF_FUNC'
  2711. sub eof {
  2712.     my($self) = @_;
  2713.     return 1 if (length($self->{BUFFER}) == 0)
  2714.          && ($self->{LENGTH} <= 0);
  2715.     undef;
  2716. }
  2717. END_OF_FUNC
  2718.  
  2719. );
  2720. END_OF_AUTOLOAD
  2721.  
  2722. ####################################################################################
  2723. ################################## TEMPORARY FILES #################################
  2724. ####################################################################################
  2725. package TempFile;
  2726.  
  2727. $SL = $CGI::SL;
  2728. unless ($TMPDIRECTORY) {
  2729.     @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items");
  2730.     foreach (@TEMP) {
  2731.     do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
  2732.     }
  2733. }
  2734.  
  2735. $TMPDIRECTORY  = "." unless $TMPDIRECTORY;
  2736. $SEQUENCE="CGItemp${$}0000";
  2737.  
  2738. # cute feature, but overload implementation broke it
  2739. # %OVERLOAD = ('""'=>'as_string');
  2740. *TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
  2741.  
  2742. ###############################################################################
  2743. ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
  2744. ###############################################################################
  2745. $AUTOLOADED_ROUTINES = '';      # prevent -w error
  2746. $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
  2747. %SUBS = (
  2748.  
  2749. 'new' => <<'END_OF_FUNC',
  2750. sub new {
  2751.     my($package) = @_;
  2752.     $SEQUENCE++;
  2753.     my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}";
  2754.     return bless \$directory;
  2755. }
  2756. END_OF_FUNC
  2757.  
  2758. 'DESTROY' => <<'END_OF_FUNC',
  2759. sub DESTROY {
  2760.     my($self) = @_;
  2761.     unlink $$self;              # get rid of the file
  2762. }
  2763. END_OF_FUNC
  2764.  
  2765. 'as_string' => <<'END_OF_FUNC'
  2766. sub as_string {
  2767.     my($self) = @_;
  2768.     return $$self;
  2769. }
  2770. END_OF_FUNC
  2771.  
  2772. );
  2773. END_OF_AUTOLOAD
  2774.  
  2775. package CGI;
  2776.  
  2777. # We get a whole bunch of warnings about "possibly uninitialized variables"
  2778. # when running with the -w switch.  Touch them all once to get rid of the
  2779. # warnings.  This is ugly and I hate it.
  2780. if ($^W) {
  2781.     $CGI::CGI = '';
  2782.     $CGI::CGI=<<EOF;
  2783.     $CGI::VERSION;
  2784.     $MultipartBuffer::SPIN_LOOP_MAX;
  2785.     $MultipartBuffer::CRLF;
  2786.     $MultipartBuffer::TIMEOUT;
  2787.     $MultipartBuffer::FILLUNIT;
  2788.     $TempFile::SEQUENCE;
  2789. EOF
  2790.     ;
  2791. }
  2792.  
  2793. $revision;
  2794.  
  2795. __END__
  2796.  
  2797. =head1 NAME
  2798.  
  2799. CGI - Simple Common Gateway Interface Class
  2800.  
  2801. =head1 SYNOPSIS
  2802.  
  2803.   use CGI;
  2804.   # the rest is too complicated for a synopsis; keep reading
  2805.  
  2806. =head1 ABSTRACT
  2807.  
  2808. This perl library uses perl5 objects to make it easy to create
  2809. Web fill-out forms and parse their contents.  This package
  2810. defines CGI objects, entities that contain the values of the
  2811. current query string and other state variables.
  2812. Using a CGI object's methods, you can examine keywords and parameters
  2813. passed to your script, and create forms whose initial values
  2814. are taken from the current query (thereby preserving state
  2815. information).
  2816.  
  2817. The current version of CGI.pm is available at
  2818.  
  2819.   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
  2820.   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
  2821.  
  2822. =head1 INSTALLATION
  2823.  
  2824. CGI is a part of the base Perl installation.  However, you may need
  2825. to install a newer version someday.  Therefore:
  2826.  
  2827. To install this package, just change to the directory in which this
  2828. file is found and type the following:
  2829.  
  2830.     perl Makefile.PL
  2831.     make
  2832.     make install
  2833.  
  2834. This will copy CGI.pm to your perl library directory for use by all
  2835. perl scripts.  You probably must be root to do this.   Now you can
  2836. load the CGI routines in your Perl scripts with the line:
  2837.  
  2838.     use CGI;
  2839.  
  2840. If you don't have sufficient privileges to install CGI.pm in the Perl
  2841. library directory, you can put CGI.pm into some convenient spot, such
  2842. as your home directory, or in cgi-bin itself and prefix all Perl
  2843. scripts that call it with something along the lines of the following
  2844. preamble:
  2845.  
  2846.     use lib '/home/davis/lib';
  2847.     use CGI;
  2848.  
  2849. If you are using a version of perl earlier than 5.002 (such as NT perl), use
  2850. this instead:
  2851.  
  2852.     BEGIN {
  2853.         unshift(@INC,'/home/davis/lib');
  2854.     }
  2855.     use CGI;
  2856.  
  2857. The CGI distribution also comes with a cute module called L<CGI::Carp>.
  2858. It redefines the die(), warn(), confess() and croak() error routines
  2859. so that they write nicely formatted error messages into the server's
  2860. error log (or to the output stream of your choice).  This avoids long
  2861. hours of groping through the error and access logs, trying to figure
  2862. out which CGI script is generating  error messages.  If you choose,
  2863. you can even have fatal error messages echoed to the browser to avoid
  2864. the annoying and uninformative "Server Error" message.
  2865.  
  2866. =head1 DESCRIPTION
  2867.  
  2868. =head2 CREATING A NEW QUERY OBJECT:
  2869.  
  2870.      $query = new CGI;
  2871.  
  2872. This will parse the input (from both POST and GET methods) and store
  2873. it into a perl5 object called $query.  
  2874.  
  2875. =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
  2876.  
  2877.      $query = new CGI(INPUTFILE);
  2878.  
  2879. If you provide a file handle to the new() method, it
  2880. will read parameters from the file (or STDIN, or whatever).  The
  2881. file can be in any of the forms describing below under debugging
  2882. (i.e. a series of newline delimited TAG=VALUE pairs will work).
  2883. Conveniently, this type of file is created by the save() method
  2884. (see below).  Multiple records can be saved and restored.
  2885.  
  2886. Perl purists will be pleased to know that this syntax accepts
  2887. references to file handles, or even references to filehandle globs,
  2888. which is the "official" way to pass a filehandle:
  2889.  
  2890.     $query = new CGI(\*STDIN);
  2891.  
  2892. You can also initialize the query object from an associative array
  2893. reference:
  2894.  
  2895.     $query = new CGI( {'dinosaur'=>'barney',
  2896.                'song'=>'I love you',
  2897.                'friends'=>[qw/Jessica George Nancy/]}
  2898.             );
  2899.  
  2900. or from a properly formatted, URL-escaped query string:
  2901.  
  2902.     $query = new CGI('dinosaur=barney&color=purple');
  2903.  
  2904. To create an empty query, initialize it from an empty string or hash:
  2905.  
  2906.     $empty_query = new CGI("");
  2907.          -or-
  2908.     $empty_query = new CGI({});
  2909.  
  2910. =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
  2911.  
  2912.      @keywords = $query->keywords
  2913.  
  2914. If the script was invoked as the result of an <ISINDEX> search, the
  2915. parsed keywords can be obtained as an array using the keywords() method.
  2916.  
  2917. =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
  2918.  
  2919.      @names = $query->param
  2920.  
  2921. If the script was invoked with a parameter list
  2922. (e.g. "name1=value1&name2=value2&name3=value3"), the param()
  2923. method will return the parameter names as a list.  If the
  2924. script was invoked as an <ISINDEX> script, there will be a
  2925. single parameter named 'keywords'.
  2926.  
  2927. NOTE: As of version 1.5, the array of parameter names returned will
  2928. be in the same order as they were submitted by the browser.
  2929. Usually this order is the same as the order in which the 
  2930. parameters are defined in the form (however, this isn't part
  2931. of the spec, and so isn't guaranteed).
  2932.  
  2933. =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
  2934.  
  2935.     @values = $query->param('foo');
  2936.  
  2937.           -or-
  2938.  
  2939.     $value = $query->param('foo');
  2940.  
  2941. Pass the param() method a single argument to fetch the value of the
  2942. named parameter. If the parameter is multivalued (e.g. from multiple
  2943. selections in a scrolling list), you can ask to receive an array.  Otherwise
  2944. the method will return a single value.
  2945.  
  2946. =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
  2947.  
  2948.     $query->param('foo','an','array','of','values');
  2949.  
  2950. This sets the value for the named parameter 'foo' to an array of
  2951. values.  This is one way to change the value of a field AFTER
  2952. the script has been invoked once before.  (Another way is with
  2953. the -override parameter accepted by all methods that generate
  2954. form elements.)
  2955.  
  2956. param() also recognizes a named parameter style of calling described
  2957. in more detail later:
  2958.  
  2959.     $query->param(-name=>'foo',-values=>['an','array','of','values']);
  2960.  
  2961.                   -or-
  2962.  
  2963.     $query->param(-name=>'foo',-value=>'the value');
  2964.  
  2965. =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
  2966.  
  2967.    $query->append(-name=>;'foo',-values=>['yet','more','values']);
  2968.  
  2969. This adds a value or list of values to the named parameter.  The
  2970. values are appended to the end of the parameter if it already exists.
  2971. Otherwise the parameter is created.  Note that this method only
  2972. recognizes the named argument calling syntax.
  2973.  
  2974. =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
  2975.  
  2976.    $query->import_names('R');
  2977.  
  2978. This creates a series of variables in the 'R' namespace.  For example,
  2979. $R::foo, @R:foo.  For keyword lists, a variable @R::keywords will appear.
  2980. If no namespace is given, this method will assume 'Q'.
  2981. WARNING:  don't import anything into 'main'; this is a major security
  2982. risk!!!!
  2983.  
  2984. In older versions, this method was called B<import()>.  As of version 2.20, 
  2985. this name has been removed completely to avoid conflict with the built-in
  2986. Perl module B<import> operator.
  2987.  
  2988. =head2 DELETING A PARAMETER COMPLETELY:
  2989.  
  2990.     $query->delete('foo');
  2991.  
  2992. This completely clears a parameter.  It sometimes useful for
  2993. resetting parameters that you don't want passed down between
  2994. script invocations.
  2995.  
  2996. =head2 DELETING ALL PARAMETERS:
  2997.  
  2998. $query->delete_all();
  2999.  
  3000. This clears the CGI object completely.  It might be useful to ensure
  3001. that all the defaults are taken when you create a fill-out form.
  3002.  
  3003. =head2 SAVING THE STATE OF THE FORM TO A FILE:
  3004.  
  3005.     $query->save(FILEHANDLE)
  3006.  
  3007. This will write the current state of the form to the provided
  3008. filehandle.  You can read it back in by providing a filehandle
  3009. to the new() method.  Note that the filehandle can be a file, a pipe,
  3010. or whatever!
  3011.  
  3012. The format of the saved file is:
  3013.  
  3014.     NAME1=VALUE1
  3015.     NAME1=VALUE1'
  3016.     NAME2=VALUE2
  3017.     NAME3=VALUE3
  3018.     =
  3019.  
  3020. Both name and value are URL escaped.  Multi-valued CGI parameters are
  3021. represented as repeated names.  A session record is delimited by a
  3022. single = symbol.  You can write out multiple records and read them
  3023. back in with several calls to B<new>.  You can do this across several
  3024. sessions by opening the file in append mode, allowing you to create
  3025. primitive guest books, or to keep a history of users' queries.  Here's
  3026. a short example of creating multiple session records:
  3027.  
  3028.    use CGI;
  3029.  
  3030.    open (OUT,">>test.out") || die;
  3031.    $records = 5;
  3032.    foreach (0..$records) {
  3033.        my $q = new CGI;
  3034.        $q->param(-name=>'counter',-value=>$_);
  3035.        $q->save(OUT);
  3036.    }
  3037.    close OUT;
  3038.  
  3039.    # reopen for reading
  3040.    open (IN,"test.out") || die;
  3041.    while (!eof(IN)) {
  3042.        my $q = new CGI(IN);
  3043.        print $q->param('counter'),"\n";
  3044.    }
  3045.  
  3046. The file format used for save/restore is identical to that used by the
  3047. Whitehead Genome Center's data exchange format "Boulderio", and can be
  3048. manipulated and even databased using Boulderio utilities.  See
  3049.     
  3050.   http://www.genome.wi.mit.edu/genome_software/other/boulder.html
  3051.  
  3052. for further details.
  3053.  
  3054. =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
  3055.  
  3056.     $myself = $query->self_url;
  3057.     print "<A HREF=$myself>I'm talking to myself.</A>";
  3058.  
  3059. self_url() will return a URL, that, when selected, will reinvoke
  3060. this script with all its state information intact.  This is most
  3061. useful when you want to jump around within the document using
  3062. internal anchors but you don't want to disrupt the current contents
  3063. of the form(s).  Something like this will do the trick.
  3064.  
  3065.      $myself = $query->self_url;
  3066.      print "<A HREF=$myself#table1>See table 1</A>";
  3067.      print "<A HREF=$myself#table2>See table 2</A>";
  3068.      print "<A HREF=$myself#yourself>See for yourself</A>";
  3069.  
  3070. If you don't want to get the whole query string, call
  3071. the method url() to return just the URL for the script:
  3072.  
  3073.     $myself = $query->url;
  3074.     print "<A HREF=$myself>No query string in this baby!</A>\n";
  3075.  
  3076. You can also retrieve the unprocessed query string with query_string():
  3077.  
  3078.     $the_string = $query->query_string;
  3079.  
  3080. =head2 COMPATIBILITY WITH CGI-LIB.PL
  3081.  
  3082. To make it easier to port existing programs that use cgi-lib.pl
  3083. the compatibility routine "ReadParse" is provided.  Porting is
  3084. simple:
  3085.  
  3086. OLD VERSION
  3087.     require "cgi-lib.pl";
  3088.     &ReadParse;
  3089.     print "The value of the antique is $in{antique}.\n";
  3090.  
  3091. NEW VERSION
  3092.     use CGI;
  3093.     CGI::ReadParse
  3094.     print "The value of the antique is $in{antique}.\n";
  3095.  
  3096. CGI.pm's ReadParse() routine creates a tied variable named %in,
  3097. which can be accessed to obtain the query variables.  Like
  3098. ReadParse, you can also provide your own variable.  Infrequently
  3099. used features of ReadParse, such as the creation of @in and $in 
  3100. variables, are not supported.
  3101.  
  3102. Once you use ReadParse, you can retrieve the query object itself
  3103. this way:
  3104.  
  3105.     $q = $in{CGI};
  3106.     print $q->textfield(-name=>'wow',
  3107.             -value=>'does this really work?');
  3108.  
  3109. This allows you to start using the more interesting features
  3110. of CGI.pm without rewriting your old scripts from scratch.
  3111.  
  3112. =head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
  3113.  
  3114. In versions of CGI.pm prior to 2.0, it could get difficult to remember
  3115. the proper order of arguments in CGI function calls that accepted five
  3116. or six different arguments.  As of 2.0, there's a better way to pass
  3117. arguments to the various CGI functions.  In this style, you pass a
  3118. series of name=>argument pairs, like this:
  3119.  
  3120.    $field = $query->radio_group(-name=>'OS',
  3121.                 -values=>[Unix,Windows,Macintosh],
  3122.                 -default=>'Unix');
  3123.  
  3124. The advantages of this style are that you don't have to remember the
  3125. exact order of the arguments, and if you leave out a parameter, in
  3126. most cases it will default to some reasonable value.  If you provide
  3127. a parameter that the method doesn't recognize, it will usually do
  3128. something useful with it, such as incorporating it into the HTML form
  3129. tag.  For example if Netscape decides next week to add a new
  3130. JUSTIFICATION parameter to the text field tags, you can start using
  3131. the feature without waiting for a new version of CGI.pm:
  3132.  
  3133.    $field = $query->textfield(-name=>'State',
  3134.                   -default=>'gaseous',
  3135.                   -justification=>'RIGHT');
  3136.  
  3137. This will result in an HTML tag that looks like this:
  3138.  
  3139.     <INPUT TYPE="textfield" NAME="State" VALUE="gaseous"
  3140.            JUSTIFICATION="RIGHT">
  3141.  
  3142. Parameter names are case insensitive: you can use -name, or -Name or
  3143. -NAME.  You don't have to use the hyphen if you don't want to.  After
  3144. creating a CGI object, call the B<use_named_parameters()> method with
  3145. a nonzero value.  This will tell CGI.pm that you intend to use named
  3146. parameters exclusively:
  3147.  
  3148.    $query = new CGI;
  3149.    $query->use_named_parameters(1);
  3150.    $field = $query->radio_group('name'=>'OS',
  3151.                 'values'=>['Unix','Windows','Macintosh'],
  3152.                 'default'=>'Unix');
  3153.  
  3154. Actually, CGI.pm only looks for a hyphen in the first parameter.  So
  3155. you can leave it off subsequent parameters if you like.  Something to
  3156. be wary of is the potential that a string constant like "values" will
  3157. collide with a keyword (and in fact it does!) While Perl usually
  3158. figures out when you're referring to a function and when you're
  3159. referring to a string, you probably should put quotation marks around
  3160. all string constants just to play it safe.
  3161.  
  3162. =head2 CREATING THE HTTP HEADER:
  3163.  
  3164.     print $query->header;
  3165.  
  3166.          -or-
  3167.  
  3168.     print $query->header('image/gif');
  3169.  
  3170.          -or-
  3171.  
  3172.     print $query->header('text/html','204 No response');
  3173.  
  3174.          -or-
  3175.  
  3176.     print $query->header(-type=>'image/gif',
  3177.                  -nph=>1,
  3178.                  -status=>'402 Payment required',
  3179.                  -expires=>'+3d',
  3180.                  -cookie=>$cookie,
  3181.                  -Cost=>'$2.00');
  3182.  
  3183. header() returns the Content-type: header.  You can provide your own
  3184. MIME type if you choose, otherwise it defaults to text/html.  An
  3185. optional second parameter specifies the status code and a human-readable
  3186. message.  For example, you can specify 204, "No response" to create a
  3187. script that tells the browser to do nothing at all.  If you want to
  3188. add additional fields to the header, just tack them on to the end:
  3189.  
  3190.     print $query->header('text/html','200 OK','Content-Length: 3002');
  3191.  
  3192. The last example shows the named argument style for passing arguments
  3193. to the CGI methods using named parameters.  Recognized parameters are
  3194. B<-type>, B<-status>, B<-expires>, and B<-cookie>.  Any other 
  3195. parameters will be stripped of their initial hyphens and turned into
  3196. header fields, allowing you to specify any HTTP header you desire.
  3197.  
  3198. Most browsers will not cache the output from CGI scripts.  Every time
  3199. the browser reloads the page, the script is invoked anew.  You can
  3200. change this behavior with the B<-expires> parameter.  When you specify
  3201. an absolute or relative expiration interval with this parameter, some
  3202. browsers and proxy servers will cache the script's output until the
  3203. indicated expiration date.  The following forms are all valid for the
  3204. -expires field:
  3205.  
  3206.     +30s                              30 seconds from now
  3207.     +10m                              ten minutes from now
  3208.     +1h                               one hour from now
  3209.     -1d                               yesterday (i.e. "ASAP!")
  3210.     now                               immediately
  3211.     +3M                               in three months
  3212.     +10y                              in ten years time
  3213.     Thursday, 25-Apr-96 00:40:33 GMT  at the indicated time & date
  3214.  
  3215. (CGI::expires() is the static function call used internally that turns
  3216. relative time intervals into HTTP dates.  You can call it directly if
  3217. you wish.)
  3218.  
  3219. The B<-cookie> parameter generates a header that tells the browser to provide
  3220. a "magic cookie" during all subsequent transactions with your script.
  3221. Netscape cookies have a special format that includes interesting attributes
  3222. such as expiration time.  Use the cookie() method to create and retrieve
  3223. session cookies.
  3224.  
  3225. The B<-nph> parameter, if set to a true value, will issue the correct
  3226. headers to work with a NPH (no-parse-header) script.  This is important
  3227. to use with certain servers, such as Microsoft Internet Explorer, which
  3228. expect all their scripts to be NPH.
  3229.  
  3230. =head2 GENERATING A REDIRECTION INSTRUCTION
  3231.  
  3232.    print $query->redirect('http://somewhere.else/in/movie/land');
  3233.  
  3234. redirects the browser elsewhere.  If you use redirection like this,
  3235. you should B<not> print out a header as well.  As of version 2.0, we
  3236. produce both the unofficial Location: header and the official URI:
  3237. header.  This should satisfy most servers and browsers.
  3238.  
  3239. One hint I can offer is that relative links may not work correctly
  3240. when you generate a redirection to another document on your site.
  3241. This is due to a well-intentioned optimization that some servers use.
  3242. The solution to this is to use the full URL (including the http: part)
  3243. of the document you are redirecting to.
  3244.  
  3245. You can use named parameters:
  3246.  
  3247.     print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
  3248.                -nph=>1);
  3249.  
  3250. The B<-nph> parameter, if set to a true value, will issue the correct
  3251. headers to work with a NPH (no-parse-header) script.  This is important
  3252. to use with certain servers, such as Microsoft Internet Explorer, which
  3253. expect all their scripts to be NPH.
  3254.  
  3255.  
  3256. =head2 CREATING THE HTML HEADER:
  3257.  
  3258.    print $query->start_html(-title=>'Secrets of the Pyramids',
  3259.                 -author=>'fred@capricorn.org',
  3260.                 -base=>'true',
  3261.                 -target=>'_blank',
  3262.                 -meta=>{'keywords'=>'pharaoh secret mummy',
  3263.                     'copyright'=>'copyright 1996 King Tut'},
  3264.                 -style=>{'src'=>'/styles/style1.css'},
  3265.                 -BGCOLOR=>'blue');
  3266.  
  3267.    -or-
  3268.  
  3269.    print $query->start_html('Secrets of the Pyramids',
  3270.                 'fred@capricorn.org','true',
  3271.                 'BGCOLOR="blue"');
  3272.  
  3273. This will return a canned HTML header and the opening <BODY> tag.  
  3274. All parameters are optional.   In the named parameter form, recognized
  3275. parameters are -title, -author, -base, -xbase and -target (see below for the
  3276. explanation).  Any additional parameters you provide, such as the
  3277. Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag.
  3278.  
  3279. The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
  3280. different from the current location, as in
  3281.  
  3282.     -xbase=>"http://home.mcom.com/"
  3283.  
  3284. All relative links will be interpreted relative to this tag.
  3285.  
  3286. The argument B<-target> allows you to provide a default target frame
  3287. for all the links and fill-out forms on the page.  See the Netscape
  3288. documentation on frames for details of how to manipulate this.
  3289.  
  3290.     -target=>"answer_window"
  3291.  
  3292. All relative links will be interpreted relative to this tag.
  3293. You add arbitrary meta information to the header with the B<-meta>
  3294. argument.  This argument expects a reference to an associative array
  3295. containing name/value pairs of meta information.  These will be turned
  3296. into a series of header <META> tags that look something like this:
  3297.  
  3298.     <META NAME="keywords" CONTENT="pharaoh secret mummy">
  3299.     <META NAME="description" CONTENT="copyright 1996 King Tut">
  3300.  
  3301. There is no support for the HTTP-EQUIV type of <META> tag.  This is
  3302. because you can modify the HTTP header directly with the B<header()>
  3303. method.  For example, if you want to send the Refresh: header, do it
  3304. in the header() method:
  3305.  
  3306.     print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
  3307.  
  3308. The B<-style> tag is used to incorporate cascading stylesheets into
  3309. your code.  See the section on CASCADING STYLESHEETS for more information.
  3310.  
  3311. You can place other arbitrary HTML elements to the <HEAD> section with the
  3312. B<-head> tag.  For example, to place the rarely-used <LINK> element in the
  3313. head section, use this:
  3314.  
  3315.     print $q->header(-head=>link({-rel=>'next',
  3316.                   -href=>'http://www.capricorn.com/s2.html'}));
  3317.  
  3318. To incorporate multiple HTML elements into the <HEAD> section, just pass an
  3319. array reference:
  3320.  
  3321.     print $q->header(-head=>[ link({-rel=>'next',
  3322.                     -href=>'http://www.capricorn.com/s2.html'}),
  3323.                   link({-rel=>'previous',
  3324.                     -href=>'http://www.capricorn.com/s1.html'})
  3325.                  ]
  3326.              );
  3327.  
  3328.  
  3329. JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad> and B<-onUnload> parameters
  3330. are used to add Netscape JavaScript calls to your pages.  B<-script>
  3331. should point to a block of text containing JavaScript function
  3332. definitions.  This block will be placed within a <SCRIPT> block inside
  3333. the HTML (not HTTP) header.  The block is placed in the header in
  3334. order to give your page a fighting chance of having all its JavaScript
  3335. functions in place even if the user presses the stop button before the
  3336. page has loaded completely.  CGI.pm attempts to format the script in
  3337. such a way that JavaScript-naive browsers will not choke on the code:
  3338. unfortunately there are some browsers, such as Chimera for Unix, that
  3339. get confused by it nevertheless.
  3340.  
  3341. The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
  3342. code to execute when the page is respectively opened and closed by the
  3343. browser.  Usually these parameters are calls to functions defined in the
  3344. B<-script> field:
  3345.  
  3346.       $query = new CGI;
  3347.       print $query->header;
  3348.       $JSCRIPT=<<END;
  3349.       // Ask a silly question
  3350.       function riddle_me_this() {
  3351.      var r = prompt("What walks on four legs in the morning, " +
  3352.                "two legs in the afternoon, " +
  3353.                "and three legs in the evening?");
  3354.      response(r);
  3355.       }
  3356.       // Get a silly answer
  3357.       function response(answer) {
  3358.      if (answer == "man")
  3359.         alert("Right you are!");
  3360.      else
  3361.         alert("Wrong!  Guess again.");
  3362.       }
  3363.       END
  3364.       print $query->start_html(-title=>'The Riddle of the Sphinx',
  3365.                    -script=>$JSCRIPT);
  3366.  
  3367. Use the B<-noScript> parameter to pass some HTML text that will be displayed on 
  3368. browsers that do not have JavaScript (or browsers where JavaScript is turned
  3369. off).
  3370.  
  3371. Netscape 3.0 recognizes several attributes of the <SCRIPT> tag,
  3372. including LANGUAGE and SRC.  The latter is particularly interesting,
  3373. as it allows you to keep the JavaScript code in a file or CGI script
  3374. rather than cluttering up each page with the source.  To use these
  3375. attributes pass a HASH reference in the B<-script> parameter containing
  3376. one or more of -language, -src, or -code:
  3377.  
  3378.     print $q->start_html(-title=>'The Riddle of the Sphinx',
  3379.              -script=>{-language=>'JAVASCRIPT',
  3380.                                    -src=>'/javascript/sphinx.js'}
  3381.              );
  3382.  
  3383.     print $q->(-title=>'The Riddle of the Sphinx',
  3384.            -script=>{-language=>'PERLSCRIPT'},
  3385.              -code=>'print "hello world!\n;"'
  3386.            );
  3387.  
  3388.  
  3389. See
  3390.  
  3391.    http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
  3392.  
  3393. for more information about JavaScript.
  3394.  
  3395. The old-style positional parameters are as follows:
  3396.  
  3397. =over 4
  3398.  
  3399. =item B<Parameters:>
  3400.  
  3401. =item 1.
  3402.  
  3403. The title
  3404.  
  3405. =item 2.
  3406.  
  3407. The author's e-mail address (will create a <LINK REV="MADE"> tag if present
  3408.  
  3409. =item 3.
  3410.  
  3411. A 'true' flag if you want to include a <BASE> tag in the header.  This
  3412. helps resolve relative addresses to absolute ones when the document is moved, 
  3413. but makes the document hierarchy non-portable.  Use with care!
  3414.  
  3415. =item 4, 5, 6...
  3416.  
  3417. Any other parameters you want to include in the <BODY> tag.  This is a good
  3418. place to put Netscape extensions, such as colors and wallpaper patterns.
  3419.  
  3420. =back
  3421.  
  3422. =head2 ENDING THE HTML DOCUMENT:
  3423.  
  3424.     print $query->end_html
  3425.  
  3426. This ends an HTML document by printing the </BODY></HTML> tags.
  3427.  
  3428. =head1 CREATING FORMS
  3429.  
  3430. I<General note>  The various form-creating methods all return strings
  3431. to the caller, containing the tag or tags that will create the requested
  3432. form element.  You are responsible for actually printing out these strings.
  3433. It's set up this way so that you can place formatting tags
  3434. around the form elements.
  3435.  
  3436. I<Another note> The default values that you specify for the forms are only
  3437. used the B<first> time the script is invoked (when there is no query
  3438. string).  On subsequent invocations of the script (when there is a query
  3439. string), the former values are used even if they are blank.  
  3440.  
  3441. If you want to change the value of a field from its previous value, you have two
  3442. choices:
  3443.  
  3444. (1) call the param() method to set it.
  3445.  
  3446. (2) use the -override (alias -force) parameter (a new feature in version 2.15).
  3447. This forces the default value to be used, regardless of the previous value:
  3448.  
  3449.    print $query->textfield(-name=>'field_name',
  3450.                -default=>'starting value',
  3451.                -override=>1,
  3452.                -size=>50,
  3453.                -maxlength=>80);
  3454.  
  3455. I<Yet another note> By default, the text and labels of form elements are
  3456. escaped according to HTML rules.  This means that you can safely use
  3457. "<CLICK ME>" as the label for a button.  However, it also interferes with
  3458. your ability to incorporate special HTML character sequences, such as Á,
  3459. into your fields.  If you wish to turn off automatic escaping, call the
  3460. autoEscape() method with a false value immediately after creating the CGI object:
  3461.  
  3462.    $query = new CGI;
  3463.    $query->autoEscape(undef);
  3464.                  
  3465.  
  3466. =head2 CREATING AN ISINDEX TAG
  3467.  
  3468.    print $query->isindex(-action=>$action);
  3469.  
  3470.      -or-
  3471.  
  3472.    print $query->isindex($action);
  3473.  
  3474. Prints out an <ISINDEX> tag.  Not very exciting.  The parameter
  3475. -action specifies the URL of the script to process the query.  The
  3476. default is to process the query with the current script.
  3477.  
  3478. =head2 STARTING AND ENDING A FORM
  3479.  
  3480.     print $query->startform(-method=>$method,
  3481.                 -action=>$action,
  3482.                 -encoding=>$encoding);
  3483.       <... various form stuff ...>
  3484.     print $query->endform;
  3485.  
  3486.     -or-
  3487.  
  3488.     print $query->startform($method,$action,$encoding);
  3489.       <... various form stuff ...>
  3490.     print $query->endform;
  3491.  
  3492. startform() will return a <FORM> tag with the optional method,
  3493. action and form encoding that you specify.  The defaults are:
  3494.     
  3495.     method: POST
  3496.     action: this script
  3497.     encoding: application/x-www-form-urlencoded
  3498.  
  3499. endform() returns the closing </FORM> tag.  
  3500.  
  3501. Startform()'s encoding method tells the browser how to package the various
  3502. fields of the form before sending the form to the server.  Two
  3503. values are possible:
  3504.  
  3505. =over 4
  3506.  
  3507. =item B<application/x-www-form-urlencoded>
  3508.  
  3509. This is the older type of encoding used by all browsers prior to
  3510. Netscape 2.0.  It is compatible with many CGI scripts and is
  3511. suitable for short fields containing text data.  For your
  3512. convenience, CGI.pm stores the name of this encoding
  3513. type in B<$CGI::URL_ENCODED>.
  3514.  
  3515. =item B<multipart/form-data>
  3516.  
  3517. This is the newer type of encoding introduced by Netscape 2.0.
  3518. It is suitable for forms that contain very large fields or that
  3519. are intended for transferring binary data.  Most importantly,
  3520. it enables the "file upload" feature of Netscape 2.0 forms.  For
  3521. your convenience, CGI.pm stores the name of this encoding type
  3522. in B<$CGI::MULTIPART>
  3523.  
  3524. Forms that use this type of encoding are not easily interpreted
  3525. by CGI scripts unless they use CGI.pm or another library designed
  3526. to handle them.
  3527.  
  3528. =back
  3529.  
  3530. For compatibility, the startform() method uses the older form of
  3531. encoding by default.  If you want to use the newer form of encoding
  3532. by default, you can call B<start_multipart_form()> instead of
  3533. B<startform()>.
  3534.  
  3535. JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
  3536. for use with JavaScript.  The -name parameter gives the
  3537. form a name so that it can be identified and manipulated by
  3538. JavaScript functions.  -onSubmit should point to a JavaScript
  3539. function that will be executed just before the form is submitted to your
  3540. server.  You can use this opportunity to check the contents of the form 
  3541. for consistency and completeness.  If you find something wrong, you
  3542. can put up an alert box or maybe fix things up yourself.  You can 
  3543. abort the submission by returning false from this function.  
  3544.  
  3545. Usually the bulk of JavaScript functions are defined in a <SCRIPT>
  3546. block in the HTML header and -onSubmit points to one of these function
  3547. call.  See start_html() for details.
  3548.  
  3549. =head2 CREATING A TEXT FIELD
  3550.  
  3551.     print $query->textfield(-name=>'field_name',
  3552.                 -default=>'starting value',
  3553.                 -size=>50,
  3554.                 -maxlength=>80);
  3555.     -or-
  3556.  
  3557.     print $query->textfield('field_name','starting value',50,80);
  3558.  
  3559. textfield() will return a text input field.  
  3560.  
  3561. =over 4
  3562.  
  3563. =item B<Parameters>
  3564.  
  3565. =item 1.
  3566.  
  3567. The first parameter is the required name for the field (-name).  
  3568.  
  3569. =item 2.
  3570.  
  3571. The optional second parameter is the default starting value for the field
  3572. contents (-default).  
  3573.  
  3574. =item 3.
  3575.  
  3576. The optional third parameter is the size of the field in
  3577.       characters (-size).
  3578.  
  3579. =item 4.
  3580.  
  3581. The optional fourth parameter is the maximum number of characters the
  3582.       field will accept (-maxlength).
  3583.  
  3584. =back
  3585.  
  3586. As with all these methods, the field will be initialized with its 
  3587. previous contents from earlier invocations of the script.
  3588. When the form is processed, the value of the text field can be
  3589. retrieved with:
  3590.  
  3591.        $value = $query->param('foo');
  3592.  
  3593. If you want to reset it from its initial value after the script has been
  3594. called once, you can do so like this:
  3595.  
  3596.        $query->param('foo',"I'm taking over this value!");
  3597.  
  3598. NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
  3599. value, you can force its current value by using the -override (alias -force)
  3600. parameter:
  3601.  
  3602.     print $query->textfield(-name=>'field_name',
  3603.                 -default=>'starting value',
  3604.                 -override=>1,
  3605.                 -size=>50,
  3606.                 -maxlength=>80);
  3607.  
  3608. JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur>
  3609. and B<-onSelect> parameters to register JavaScript event handlers.
  3610. The onChange handler will be called whenever the user changes the
  3611. contents of the text field.  You can do text validation if you like.
  3612. onFocus and onBlur are called respectively when the insertion point
  3613. moves into and out of the text field.  onSelect is called when the
  3614. user changes the portion of the text that is selected.
  3615.  
  3616. =head2 CREATING A BIG TEXT FIELD
  3617.  
  3618.    print $query->textarea(-name=>'foo',
  3619.               -default=>'starting value',
  3620.               -rows=>10,
  3621.               -columns=>50);
  3622.  
  3623.     -or
  3624.  
  3625.    print $query->textarea('foo','starting value',10,50);
  3626.  
  3627. textarea() is just like textfield, but it allows you to specify
  3628. rows and columns for a multiline text entry box.  You can provide
  3629. a starting value for the field, which can be long and contain
  3630. multiple lines.
  3631.  
  3632. JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
  3633. and B<-onSelect> parameters are recognized.  See textfield().
  3634.  
  3635. =head2 CREATING A PASSWORD FIELD
  3636.  
  3637.    print $query->password_field(-name=>'secret',
  3638.                 -value=>'starting value',
  3639.                 -size=>50,
  3640.                 -maxlength=>80);
  3641.     -or-
  3642.  
  3643.    print $query->password_field('secret','starting value',50,80);
  3644.  
  3645. password_field() is identical to textfield(), except that its contents 
  3646. will be starred out on the web page.
  3647.  
  3648. JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
  3649. and B<-onSelect> parameters are recognized.  See textfield().
  3650.  
  3651. =head2 CREATING A FILE UPLOAD FIELD
  3652.  
  3653.     print $query->filefield(-name=>'uploaded_file',
  3654.                 -default=>'starting value',
  3655.                 -size=>50,
  3656.                 -maxlength=>80);
  3657.     -or-
  3658.  
  3659.     print $query->filefield('uploaded_file','starting value',50,80);
  3660.  
  3661. filefield() will return a file upload field for Netscape 2.0 browsers.
  3662. In order to take full advantage of this I<you must use the new 
  3663. multipart encoding scheme> for the form.  You can do this either
  3664. by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
  3665. or by calling the new method B<start_multipart_form()> instead of
  3666. vanilla B<startform()>.
  3667.  
  3668. =over 4
  3669.  
  3670. =item B<Parameters>
  3671.  
  3672. =item 1.
  3673.  
  3674. The first parameter is the required name for the field (-name).  
  3675.  
  3676. =item 2.
  3677.  
  3678. The optional second parameter is the starting value for the field contents
  3679. to be used as the default file name (-default).
  3680.  
  3681. The beta2 version of Netscape 2.0 currently doesn't pay any attention
  3682. to this field, and so the starting value will always be blank.  Worse,
  3683. the field loses its "sticky" behavior and forgets its previous
  3684. contents.  The starting value field is called for in the HTML
  3685. specification, however, and possibly later versions of Netscape will
  3686. honor it.
  3687.  
  3688. =item 3.
  3689.  
  3690. The optional third parameter is the size of the field in
  3691. characters (-size).
  3692.  
  3693. =item 4.
  3694.  
  3695. The optional fourth parameter is the maximum number of characters the
  3696. field will accept (-maxlength).
  3697.  
  3698. =back
  3699.  
  3700. When the form is processed, you can retrieve the entered filename
  3701. by calling param().
  3702.  
  3703.        $filename = $query->param('uploaded_file');
  3704.  
  3705. In Netscape Gold, the filename that gets returned is the full local filename
  3706. on the B<remote user's> machine.  If the remote user is on a Unix
  3707. machine, the filename will follow Unix conventions:
  3708.  
  3709.     /path/to/the/file
  3710.  
  3711. On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
  3712.  
  3713.     C:\PATH\TO\THE\FILE.MSW
  3714.  
  3715. On a Macintosh machine, the filename will follow Mac conventions:
  3716.  
  3717.     HD 40:Desktop Folder:Sort Through:Reminders
  3718.  
  3719. The filename returned is also a file handle.  You can read the contents
  3720. of the file using standard Perl file reading calls:
  3721.  
  3722.     # Read a text file and print it out
  3723.     while (<$filename>) {
  3724.        print;
  3725.     }
  3726.  
  3727.     # Copy a binary file to somewhere safe
  3728.     open (OUTFILE,">>/usr/local/web/users/feedback");
  3729.     while ($bytesread=read($filename,$buffer,1024)) {
  3730.        print OUTFILE $buffer;
  3731.     }
  3732.  
  3733. When a file is uploaded the browser usually sends along some
  3734. information along with it in the format of headers.  The information
  3735. usually includes the MIME content type.  Future browsers may send
  3736. other information as well (such as modification date and size). To
  3737. retrieve this information, call uploadInfo().  It returns a reference to
  3738. an associative array containing all the document headers.
  3739.  
  3740.        $filename = $query->param('uploaded_file');
  3741.        $type = $query->uploadInfo($filename)->{'Content-Type'};
  3742.        unless ($type eq 'text/html') {
  3743.       die "HTML FILES ONLY!";
  3744.        }
  3745.  
  3746. If you are using a machine that recognizes "text" and "binary" data
  3747. modes, be sure to understand when and how to use them (see the Camel book).  
  3748. Otherwise you may find that binary files are corrupted during file uploads.
  3749.  
  3750. JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
  3751. and B<-onSelect> parameters are recognized.  See textfield()
  3752. for details. 
  3753.  
  3754. =head2 CREATING A POPUP MENU
  3755.  
  3756.    print $query->popup_menu('menu_name',
  3757.                 ['eenie','meenie','minie'],
  3758.                 'meenie');
  3759.  
  3760.       -or-
  3761.  
  3762.    %labels = ('eenie'=>'your first choice',
  3763.           'meenie'=>'your second choice',
  3764.           'minie'=>'your third choice');
  3765.    print $query->popup_menu('menu_name',
  3766.                 ['eenie','meenie','minie'],
  3767.                 'meenie',\%labels);
  3768.  
  3769.     -or (named parameter style)-
  3770.  
  3771.    print $query->popup_menu(-name=>'menu_name',
  3772.                 -values=>['eenie','meenie','minie'],
  3773.                 -default=>'meenie',
  3774.                 -labels=>\%labels);
  3775.  
  3776. popup_menu() creates a menu.
  3777.  
  3778. =over 4
  3779.  
  3780. =item 1.
  3781.  
  3782. The required first argument is the menu's name (-name).
  3783.  
  3784. =item 2.
  3785.  
  3786. The required second argument (-values) is an array B<reference>
  3787. containing the list of menu items in the menu.  You can pass the
  3788. method an anonymous array, as shown in the example, or a reference to
  3789. a named array, such as "\@foo".
  3790.  
  3791. =item 3.
  3792.  
  3793. The optional third parameter (-default) is the name of the default
  3794. menu choice.  If not specified, the first item will be the default.
  3795. The values of the previous choice will be maintained across queries.
  3796.  
  3797. =item 4.
  3798.  
  3799. The optional fourth parameter (-labels) is provided for people who
  3800. want to use different values for the user-visible label inside the
  3801. popup menu nd the value returned to your script.  It's a pointer to an
  3802. associative array relating menu values to user-visible labels.  If you
  3803. leave this parameter blank, the menu values will be displayed by
  3804. default.  (You can also leave a label undefined if you want to).
  3805.  
  3806. =back
  3807.  
  3808. When the form is processed, the selected value of the popup menu can
  3809. be retrieved using:
  3810.  
  3811.       $popup_menu_value = $query->param('menu_name');
  3812.  
  3813. JAVASCRIPTING: popup_menu() recognizes the following event handlers:
  3814. B<-onChange>, B<-onFocus>, and B<-onBlur>.  See the textfield()
  3815. section for details on when these handlers are called.
  3816.  
  3817. =head2 CREATING A SCROLLING LIST
  3818.  
  3819.    print $query->scrolling_list('list_name',
  3820.                 ['eenie','meenie','minie','moe'],
  3821.                 ['eenie','moe'],5,'true');
  3822.       -or-
  3823.  
  3824.    print $query->scrolling_list('list_name',
  3825.                 ['eenie','meenie','minie','moe'],
  3826.                 ['eenie','moe'],5,'true',
  3827.                 \%labels);
  3828.  
  3829.     -or-
  3830.  
  3831.    print $query->scrolling_list(-name=>'list_name',
  3832.                 -values=>['eenie','meenie','minie','moe'],
  3833.                 -default=>['eenie','moe'],
  3834.                 -size=>5,
  3835.                 -multiple=>'true',
  3836.                 -labels=>\%labels);
  3837.  
  3838. scrolling_list() creates a scrolling list.  
  3839.  
  3840. =over 4
  3841.  
  3842. =item B<Parameters:>
  3843.  
  3844. =item 1.
  3845.  
  3846. The first and second arguments are the list name (-name) and values
  3847. (-values).  As in the popup menu, the second argument should be an
  3848. array reference.
  3849.  
  3850. =item 2.
  3851.  
  3852. The optional third argument (-default) can be either a reference to a
  3853. list containing the values to be selected by default, or can be a
  3854. single value to select.  If this argument is missing or undefined,
  3855. then nothing is selected when the list first appears.  In the named
  3856. parameter version, you can use the synonym "-defaults" for this
  3857. parameter.
  3858.  
  3859. =item 3.
  3860.  
  3861. The optional fourth argument is the size of the list (-size).
  3862.  
  3863. =item 4.
  3864.  
  3865. The optional fifth argument can be set to true to allow multiple
  3866. simultaneous selections (-multiple).  Otherwise only one selection
  3867. will be allowed at a time.
  3868.  
  3869. =item 5.
  3870.  
  3871. The optional sixth argument is a pointer to an associative array
  3872. containing long user-visible labels for the list items (-labels).
  3873. If not provided, the values will be displayed.
  3874.  
  3875. When this form is processed, all selected list items will be returned as
  3876. a list under the parameter name 'list_name'.  The values of the
  3877. selected items can be retrieved with:
  3878.  
  3879.       @selected = $query->param('list_name');
  3880.  
  3881. =back
  3882.  
  3883. JAVASCRIPTING: scrolling_list() recognizes the following event handlers:
  3884. B<-onChange>, B<-onFocus>, and B<-onBlur>.  See textfield() for
  3885. the description of when these handlers are called.
  3886.  
  3887. =head2 CREATING A GROUP OF RELATED CHECKBOXES
  3888.  
  3889.    print $query->checkbox_group(-name=>'group_name',
  3890.                 -values=>['eenie','meenie','minie','moe'],
  3891.                 -default=>['eenie','moe'],
  3892.                 -linebreak=>'true',
  3893.                 -labels=>\%labels);
  3894.  
  3895.    print $query->checkbox_group('group_name',
  3896.                 ['eenie','meenie','minie','moe'],
  3897.                 ['eenie','moe'],'true',\%labels);
  3898.  
  3899.    HTML3-COMPATIBLE BROWSERS ONLY:
  3900.  
  3901.    print $query->checkbox_group(-name=>'group_name',
  3902.                 -values=>['eenie','meenie','minie','moe'],
  3903.                 -rows=2,-columns=>2);
  3904.     
  3905.  
  3906. checkbox_group() creates a list of checkboxes that are related
  3907. by the same name.
  3908.  
  3909. =over 4
  3910.  
  3911. =item B<Parameters:>
  3912.  
  3913. =item 1.
  3914.  
  3915. The first and second arguments are the checkbox name and values,
  3916. respectively (-name and -values).  As in the popup menu, the second
  3917. argument should be an array reference.  These values are used for the
  3918. user-readable labels printed next to the checkboxes as well as for the
  3919. values passed to your script in the query string.
  3920.  
  3921. =item 2.
  3922.  
  3923. The optional third argument (-default) can be either a reference to a
  3924. list containing the values to be checked by default, or can be a
  3925. single value to checked.  If this argument is missing or undefined,
  3926. then nothing is selected when the list first appears.
  3927.  
  3928. =item 3.
  3929.  
  3930. The optional fourth argument (-linebreak) can be set to true to place
  3931. line breaks between the checkboxes so that they appear as a vertical
  3932. list.  Otherwise, they will be strung together on a horizontal line.
  3933.  
  3934. =item 4.
  3935.  
  3936. The optional fifth argument is a pointer to an associative array
  3937. relating the checkbox values to the user-visible labels that will
  3938. be printed next to them (-labels).  If not provided, the values will
  3939. be used as the default.
  3940.  
  3941. =item 5.
  3942.  
  3943. B<HTML3-compatible browsers> (such as Netscape) can take advantage 
  3944. of the optional 
  3945. parameters B<-rows>, and B<-columns>.  These parameters cause
  3946. checkbox_group() to return an HTML3 compatible table containing
  3947. the checkbox group formatted with the specified number of rows
  3948. and columns.  You can provide just the -columns parameter if you
  3949. wish; checkbox_group will calculate the correct number of rows
  3950. for you.
  3951.  
  3952. To include row and column headings in the returned table, you
  3953. can use the B<-rowheader> and B<-colheader> parameters.  Both
  3954. of these accept a pointer to an array of headings to use.
  3955. The headings are just decorative.  They don't reorganize the
  3956. interpretation of the checkboxes -- they're still a single named
  3957. unit.
  3958.  
  3959. =back
  3960.  
  3961. When the form is processed, all checked boxes will be returned as
  3962. a list under the parameter name 'group_name'.  The values of the
  3963. "on" checkboxes can be retrieved with:
  3964.  
  3965.       @turned_on = $query->param('group_name');
  3966.  
  3967. The value returned by checkbox_group() is actually an array of button
  3968. elements.  You can capture them and use them within tables, lists,
  3969. or in other creative ways:
  3970.  
  3971.     @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
  3972.     &use_in_creative_way(@h);
  3973.  
  3974. JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
  3975. parameter.  This specifies a JavaScript code fragment or
  3976. function call to be executed every time the user clicks on
  3977. any of the buttons in the group.  You can retrieve the identity
  3978. of the particular button clicked on using the "this" variable.
  3979.  
  3980. =head2 CREATING A STANDALONE CHECKBOX
  3981.  
  3982.     print $query->checkbox(-name=>'checkbox_name',
  3983.                -checked=>'checked',
  3984.                -value=>'ON',
  3985.                -label=>'CLICK ME');
  3986.  
  3987.     -or-
  3988.  
  3989.     print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
  3990.  
  3991. checkbox() is used to create an isolated checkbox that isn't logically
  3992. related to any others.
  3993.  
  3994. =over 4
  3995.  
  3996. =item B<Parameters:>
  3997.  
  3998. =item 1.
  3999.  
  4000. The first parameter is the required name for the checkbox (-name).  It
  4001. will also be used for the user-readable label printed next to the
  4002. checkbox.
  4003.  
  4004. =item 2.
  4005.  
  4006. The optional second parameter (-checked) specifies that the checkbox
  4007. is turned on by default.  Synonyms are -selected and -on.
  4008.  
  4009. =item 3.
  4010.  
  4011. The optional third parameter (-value) specifies the value of the
  4012. checkbox when it is checked.  If not provided, the word "on" is
  4013. assumed.
  4014.  
  4015. =item 4.
  4016.  
  4017. The optional fourth parameter (-label) is the user-readable label to
  4018. be attached to the checkbox.  If not provided, the checkbox name is
  4019. used.
  4020.  
  4021. =back
  4022.  
  4023. The value of the checkbox can be retrieved using:
  4024.  
  4025.     $turned_on = $query->param('checkbox_name');
  4026.  
  4027. JAVASCRIPTING: checkbox() recognizes the B<-onClick>
  4028. parameter.  See checkbox_group() for further details.
  4029.  
  4030. =head2 CREATING A RADIO BUTTON GROUP
  4031.  
  4032.    print $query->radio_group(-name=>'group_name',
  4033.                  -values=>['eenie','meenie','minie'],
  4034.                  -default=>'meenie',
  4035.                  -linebreak=>'true',
  4036.                  -labels=>\%labels);
  4037.  
  4038.     -or-
  4039.  
  4040.    print $query->radio_group('group_name',['eenie','meenie','minie'],
  4041.                       'meenie','true',\%labels);
  4042.  
  4043.  
  4044.    HTML3-COMPATIBLE BROWSERS ONLY:
  4045.  
  4046.    print $query->radio_group(-name=>'group_name',
  4047.                  -values=>['eenie','meenie','minie','moe'],
  4048.                  -rows=2,-columns=>2);
  4049.  
  4050. radio_group() creates a set of logically-related radio buttons
  4051. (turning one member of the group on turns the others off)
  4052.  
  4053. =over 4
  4054.  
  4055. =item B<Parameters:>
  4056.  
  4057. =item 1.
  4058.  
  4059. The first argument is the name of the group and is required (-name).
  4060.  
  4061. =item 2.
  4062.  
  4063. The second argument (-values) is the list of values for the radio
  4064. buttons.  The values and the labels that appear on the page are
  4065. identical.  Pass an array I<reference> in the second argument, either
  4066. using an anonymous array, as shown, or by referencing a named array as
  4067. in "\@foo".
  4068.  
  4069. =item 3.
  4070.  
  4071. The optional third parameter (-default) is the name of the default
  4072. button to turn on. If not specified, the first item will be the
  4073. default.  You can provide a nonexistent button name, such as "-" to
  4074. start up with no buttons selected.
  4075.  
  4076. =item 4.
  4077.  
  4078. The optional fourth parameter (-linebreak) can be set to 'true' to put
  4079. line breaks between the buttons, creating a vertical list.
  4080.  
  4081. =item 5.
  4082.  
  4083. The optional fifth parameter (-labels) is a pointer to an associative
  4084. array relating the radio button values to user-visible labels to be
  4085. used in the display.  If not provided, the values themselves are
  4086. displayed.
  4087.  
  4088. =item 6.
  4089.  
  4090. B<HTML3-compatible browsers> (such as Netscape) can take advantage 
  4091. of the optional 
  4092. parameters B<-rows>, and B<-columns>.  These parameters cause
  4093. radio_group() to return an HTML3 compatible table containing
  4094. the radio group formatted with the specified number of rows
  4095. and columns.  You can provide just the -columns parameter if you
  4096. wish; radio_group will calculate the correct number of rows
  4097. for you.
  4098.  
  4099. To include row and column headings in the returned table, you
  4100. can use the B<-rowheader> and B<-colheader> parameters.  Both
  4101. of these accept a pointer to an array of headings to use.
  4102. The headings are just decorative.  They don't reorganize the
  4103. interpetation of the radio buttons -- they're still a single named
  4104. unit.
  4105.  
  4106. =back
  4107.  
  4108. When the form is processed, the selected radio button can
  4109. be retrieved using:
  4110.  
  4111.       $which_radio_button = $query->param('group_name');
  4112.  
  4113. The value returned by radio_group() is actually an array of button
  4114. elements.  You can capture them and use them within tables, lists,
  4115. or in other creative ways:
  4116.  
  4117.     @h = $query->radio_group(-name=>'group_name',-values=>\@values);
  4118.     &use_in_creative_way(@h);
  4119.  
  4120. =head2 CREATING A SUBMIT BUTTON 
  4121.  
  4122.    print $query->submit(-name=>'button_name',
  4123.             -value=>'value');
  4124.  
  4125.     -or-
  4126.  
  4127.    print $query->submit('button_name','value');
  4128.  
  4129. submit() will create the query submission button.  Every form
  4130. should have one of these.
  4131.  
  4132. =over 4
  4133.  
  4134. =item B<Parameters:>
  4135.  
  4136. =item 1.
  4137.  
  4138. The first argument (-name) is optional.  You can give the button a
  4139. name if you have several submission buttons in your form and you want
  4140. to distinguish between them.  The name will also be used as the
  4141. user-visible label.  Be aware that a few older browsers don't deal with this correctly and
  4142. B<never> send back a value from a button.
  4143.  
  4144. =item 2.
  4145.  
  4146. The second argument (-value) is also optional.  This gives the button
  4147. a value that will be passed to your script in the query string.
  4148.  
  4149. =back
  4150.  
  4151. You can figure out which button was pressed by using different
  4152. values for each one:
  4153.  
  4154.      $which_one = $query->param('button_name');
  4155.  
  4156. JAVASCRIPTING: radio_group() recognizes the B<-onClick>
  4157. parameter.  See checkbox_group() for further details.
  4158.  
  4159. =head2 CREATING A RESET BUTTON
  4160.  
  4161.    print $query->reset
  4162.  
  4163. reset() creates the "reset" button.  Note that it restores the
  4164. form to its value from the last time the script was called, 
  4165. NOT necessarily to the defaults.
  4166.  
  4167. =head2 CREATING A DEFAULT BUTTON
  4168.  
  4169.    print $query->defaults('button_label')
  4170.  
  4171. defaults() creates a button that, when invoked, will cause the
  4172. form to be completely reset to its defaults, wiping out all the
  4173. changes the user ever made.
  4174.  
  4175. =head2 CREATING A HIDDEN FIELD
  4176.  
  4177.     print $query->hidden(-name=>'hidden_name',
  4178.                  -default=>['value1','value2'...]);
  4179.  
  4180.         -or-
  4181.  
  4182.     print $query->hidden('hidden_name','value1','value2'...);
  4183.  
  4184. hidden() produces a text field that can't be seen by the user.  It
  4185. is useful for passing state variable information from one invocation
  4186. of the script to the next.
  4187.  
  4188. =over 4
  4189.  
  4190. =item B<Parameters:>
  4191.  
  4192. =item 1.
  4193.  
  4194. The first argument is required and specifies the name of this
  4195. field (-name).
  4196.  
  4197. =item 2.  
  4198.  
  4199. The second argument is also required and specifies its value
  4200. (-default).  In the named parameter style of calling, you can provide
  4201. a single value here or a reference to a whole list
  4202.  
  4203. =back
  4204.  
  4205. Fetch the value of a hidden field this way:
  4206.  
  4207.      $hidden_value = $query->param('hidden_name');
  4208.  
  4209. Note, that just like all the other form elements, the value of a
  4210. hidden field is "sticky".  If you want to replace a hidden field with
  4211. some other values after the script has been called once you'll have to
  4212. do it manually:
  4213.  
  4214.      $query->param('hidden_name','new','values','here');
  4215.  
  4216. =head2 CREATING A CLICKABLE IMAGE BUTTON
  4217.  
  4218.      print $query->image_button(-name=>'button_name',
  4219.                 -src=>'/source/URL',
  4220.                 -align=>'MIDDLE');      
  4221.  
  4222.     -or-
  4223.  
  4224.      print $query->image_button('button_name','/source/URL','MIDDLE');
  4225.  
  4226. image_button() produces a clickable image.  When it's clicked on the
  4227. position of the click is returned to your script as "button_name.x"
  4228. and "button_name.y", where "button_name" is the name you've assigned
  4229. to it.
  4230.  
  4231. JAVASCRIPTING: image_button() recognizes the B<-onClick>
  4232. parameter.  See checkbox_group() for further details.
  4233.  
  4234. =over 4
  4235.  
  4236. =item B<Parameters:>
  4237.  
  4238. =item 1.
  4239.  
  4240. The first argument (-name) is required and specifies the name of this
  4241. field.
  4242.  
  4243. =item 2.
  4244.  
  4245. The second argument (-src) is also required and specifies the URL
  4246.  
  4247. =item 3.
  4248. The third option (-align, optional) is an alignment type, and may be
  4249. TOP, BOTTOM or MIDDLE
  4250.  
  4251. =back
  4252.  
  4253. Fetch the value of the button this way:
  4254.      $x = $query->param('button_name.x');
  4255.      $y = $query->param('button_name.y');
  4256.  
  4257. =head2 CREATING A JAVASCRIPT ACTION BUTTON
  4258.  
  4259.      print $query->button(-name=>'button_name',
  4260.               -value=>'user visible label',
  4261.               -onClick=>"do_something()");
  4262.  
  4263.     -or-
  4264.  
  4265.      print $query->button('button_name',"do_something()");
  4266.  
  4267. button() produces a button that is compatible with Netscape 2.0's
  4268. JavaScript.  When it's pressed the fragment of JavaScript code
  4269. pointed to by the B<-onClick> parameter will be executed.  On
  4270. non-Netscape browsers this form element will probably not even
  4271. display.
  4272.  
  4273. =head1 NETSCAPE COOKIES
  4274.  
  4275. Netscape browsers versions 1.1 and higher support a so-called
  4276. "cookie" designed to help maintain state within a browser session.
  4277. CGI.pm has several methods that support cookies.
  4278.  
  4279. A cookie is a name=value pair much like the named parameters in a CGI
  4280. query string.  CGI scripts create one or more cookies and send
  4281. them to the browser in the HTTP header.  The browser maintains a list
  4282. of cookies that belong to a particular Web server, and returns them
  4283. to the CGI script during subsequent interactions.
  4284.  
  4285. In addition to the required name=value pair, each cookie has several
  4286. optional attributes:
  4287.  
  4288. =over 4
  4289.  
  4290. =item 1. an expiration time
  4291.  
  4292. This is a time/date string (in a special GMT format) that indicates
  4293. when a cookie expires.  The cookie will be saved and returned to your
  4294. script until this expiration date is reached if the user exits
  4295. Netscape and restarts it.  If an expiration date isn't specified, the cookie
  4296. will remain active until the user quits Netscape.
  4297.  
  4298. =item 2. a domain
  4299.  
  4300. This is a partial or complete domain name for which the cookie is 
  4301. valid.  The browser will return the cookie to any host that matches
  4302. the partial domain name.  For example, if you specify a domain name
  4303. of ".capricorn.com", then Netscape will return the cookie to
  4304. Web servers running on any of the machines "www.capricorn.com", 
  4305. "www2.capricorn.com", "feckless.capricorn.com", etc.  Domain names
  4306. must contain at least two periods to prevent attempts to match
  4307. on top level domains like ".edu".  If no domain is specified, then
  4308. the browser will only return the cookie to servers on the host the
  4309. cookie originated from.
  4310.  
  4311. =item 3. a path
  4312.  
  4313. If you provide a cookie path attribute, the browser will check it
  4314. against your script's URL before returning the cookie.  For example,
  4315. if you specify the path "/cgi-bin", then the cookie will be returned
  4316. to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
  4317. and "/cgi-bin/customer_service/complain.pl", but not to the script
  4318. "/cgi-private/site_admin.pl".  By default, path is set to "/", which
  4319. causes the cookie to be sent to any CGI script on your site.
  4320.  
  4321. =item 4. a "secure" flag
  4322.  
  4323. If the "secure" attribute is set, the cookie will only be sent to your
  4324. script if the CGI request is occurring on a secure channel, such as SSL.
  4325.  
  4326. =back
  4327.  
  4328. The interface to Netscape cookies is the B<cookie()> method:
  4329.  
  4330.     $cookie = $query->cookie(-name=>'sessionID',
  4331.                  -value=>'xyzzy',
  4332.                  -expires=>'+1h',
  4333.                  -path=>'/cgi-bin/database',
  4334.                  -domain=>'.capricorn.org',
  4335.                  -secure=>1);
  4336.     print $query->header(-cookie=>$cookie);
  4337.  
  4338. B<cookie()> creates a new cookie.  Its parameters include:
  4339.  
  4340. =over 4
  4341.  
  4342. =item B<-name>
  4343.  
  4344. The name of the cookie (required).  This can be any string at all.
  4345. Although Netscape limits its cookie names to non-whitespace
  4346. alphanumeric characters, CGI.pm removes this restriction by escaping
  4347. and unescaping cookies behind the scenes.
  4348.  
  4349. =item B<-value>
  4350.  
  4351. The value of the cookie.  This can be any scalar value,
  4352. array reference, or even associative array reference.  For example,
  4353. you can store an entire associative array into a cookie this way:
  4354.  
  4355.     $cookie=$query->cookie(-name=>'family information',
  4356.                    -value=>\%childrens_ages);
  4357.  
  4358. =item B<-path>
  4359.  
  4360. The optional partial path for which this cookie will be valid, as described
  4361. above.
  4362.  
  4363. =item B<-domain>
  4364.  
  4365. The optional partial domain for which this cookie will be valid, as described
  4366. above.
  4367.  
  4368. =item B<-expires>
  4369.  
  4370. The optional expiration date for this cookie.  The format is as described 
  4371. in the section on the B<header()> method:
  4372.  
  4373.     "+1h"  one hour from now
  4374.  
  4375. =item B<-secure>
  4376.  
  4377. If set to true, this cookie will only be used within a secure
  4378. SSL session.
  4379.  
  4380. =back
  4381.  
  4382. The cookie created by cookie() must be incorporated into the HTTP
  4383. header within the string returned by the header() method:
  4384.  
  4385.     print $query->header(-cookie=>$my_cookie);
  4386.  
  4387. To create multiple cookies, give header() an array reference:
  4388.  
  4389.     $cookie1 = $query->cookie(-name=>'riddle_name',
  4390.                   -value=>"The Sphynx's Question");
  4391.     $cookie2 = $query->cookie(-name=>'answers',
  4392.                   -value=>\%answers);
  4393.     print $query->header(-cookie=>[$cookie1,$cookie2]);
  4394.  
  4395. To retrieve a cookie, request it by name by calling cookie()
  4396. method without the B<-value> parameter:
  4397.  
  4398.     use CGI;
  4399.     $query = new CGI;
  4400.     %answers = $query->cookie(-name=>'answers');
  4401.     # $query->cookie('answers') will work too!
  4402.  
  4403. The cookie and CGI namespaces are separate.  If you have a parameter
  4404. named 'answers' and a cookie named 'answers', the values retrieved by
  4405. param() and cookie() are independent of each other.  However, it's
  4406. simple to turn a CGI parameter into a cookie, and vice-versa:
  4407.  
  4408.    # turn a CGI parameter into a cookie
  4409.    $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
  4410.    # vice-versa
  4411.    $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
  4412.  
  4413. See the B<cookie.cgi> example script for some ideas on how to use
  4414. cookies effectively.
  4415.  
  4416. B<NOTE:> There appear to be some (undocumented) restrictions on
  4417. Netscape cookies.  In Netscape 2.01, at least, I haven't been able to
  4418. set more than three cookies at a time.  There may also be limits on
  4419. the length of cookies.  If you need to store a lot of information,
  4420. it's probably better to create a unique session ID, store it in a
  4421. cookie, and use the session ID to locate an external file/database
  4422. saved on the server's side of the connection.
  4423.  
  4424. =head1 WORKING WITH NETSCAPE FRAMES
  4425.  
  4426. It's possible for CGI.pm scripts to write into several browser
  4427. panels and windows using Netscape's frame mechanism.  
  4428. There are three techniques for defining new frames programmatically:
  4429.  
  4430. =over 4
  4431.  
  4432. =item 1. Create a <Frameset> document
  4433.  
  4434. After writing out the HTTP header, instead of creating a standard
  4435. HTML document using the start_html() call, create a <FRAMESET> 
  4436. document that defines the frames on the page.  Specify your script(s)
  4437. (with appropriate parameters) as the SRC for each of the frames.
  4438.  
  4439. There is no specific support for creating <FRAMESET> sections 
  4440. in CGI.pm, but the HTML is very simple to write.  See the frame
  4441. documentation in Netscape's home pages for details 
  4442.  
  4443.   http://home.netscape.com/assist/net_sites/frames.html
  4444.  
  4445. =item 2. Specify the destination for the document in the HTTP header
  4446.  
  4447. You may provide a B<-target> parameter to the header() method:
  4448.    
  4449.     print $q->header(-target=>'ResultsWindow');
  4450.  
  4451. This will tell Netscape to load the output of your script into the
  4452. frame named "ResultsWindow".  If a frame of that name doesn't
  4453. already exist, Netscape will pop up a new window and load your
  4454. script's document into that.  There are a number of magic names
  4455. that you can use for targets.  See the frame documents on Netscape's
  4456. home pages for details.
  4457.  
  4458. =item 3. Specify the destination for the document in the <FORM> tag
  4459.  
  4460. You can specify the frame to load in the FORM tag itself.  With
  4461. CGI.pm it looks like this:
  4462.  
  4463.     print $q->startform(-target=>'ResultsWindow');
  4464.  
  4465. When your script is reinvoked by the form, its output will be loaded
  4466. into the frame named "ResultsWindow".  If one doesn't already exist
  4467. a new window will be created.
  4468.  
  4469. =back
  4470.  
  4471. The script "frameset.cgi" in the examples directory shows one way to
  4472. create pages in which the fill-out form and the response live in
  4473. side-by-side frames.
  4474.  
  4475. =head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
  4476.  
  4477. CGI.pm has limited support for HTML3's cascading style sheets (css).
  4478. To incorporate a stylesheet into your document, pass the
  4479. start_html() method a B<-style> parameter.  The value of this
  4480. parameter may be a scalar, in which case it is incorporated directly
  4481. into a <STYLE> section, or it may be a hash reference.  In the latter
  4482. case you should provide the hash with one or more of B<-src> or
  4483. B<-code>.  B<-src> points to a URL where an externally-defined
  4484. stylesheet can be found.  B<-code> points to a scalar value to be
  4485. incorporated into a <STYLE> section.  Style definitions in B<-code>
  4486. override similarly-named ones in B<-src>, hence the name "cascading."
  4487.  
  4488. To refer to a style within the body of your document, add the
  4489. B<-class> parameter to any HTML element:
  4490.  
  4491.     print h1({-class=>'Fancy'},'Welcome to the Party');
  4492.  
  4493. Or define styles on the fly with the B<-style> parameter:
  4494.  
  4495.     print h1({-style=>'Color: red;'},'Welcome to Hell');
  4496.  
  4497. You may also use the new B<span()> element to apply a style to a
  4498. section of text:
  4499.  
  4500.     print span({-style=>'Color: red;'},
  4501.            h1('Welcome to Hell'),
  4502.            "Where did that handbasket get to?"
  4503.            );
  4504.  
  4505. Note that you must import the ":html3" definitions to have the
  4506. B<span()> method available.  Here's a quick and dirty example of using
  4507. CSS's.  See the CSS specification at
  4508. http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
  4509.  
  4510.     use CGI qw/:standard :html3/;
  4511.  
  4512.     #here's a stylesheet incorporated directly into the page
  4513.     $newStyle=<<END;
  4514.     <!-- 
  4515.     P.Tip {
  4516.     margin-right: 50pt;
  4517.     margin-left: 50pt;
  4518.         color: red;
  4519.     }
  4520.     P.Alert {
  4521.     font-size: 30pt;
  4522.         font-family: sans-serif;
  4523.       color: red;
  4524.     }
  4525.     -->
  4526.     END
  4527.     print header();
  4528.     print start_html( -title=>'CGI with Style',
  4529.               -style=>{-src=>'http://www.capricorn.com/style/st1.css',
  4530.                        -code=>$newStyle}
  4531.                  );
  4532.     print h1('CGI with Style'),
  4533.           p({-class=>'Tip'},
  4534.         "Better read the cascading style sheet spec before playing with this!"),
  4535.           span({-style=>'color: magenta'},
  4536.            "Look Mom, no hands!",
  4537.            p(),
  4538.            "Whooo wee!"
  4539.            );
  4540.     print end_html;
  4541.  
  4542. =head1 DEBUGGING
  4543.  
  4544. If you are running the script
  4545. from the command line or in the perl debugger, you can pass the script
  4546. a list of keywords or parameter=value pairs on the command line or 
  4547. from standard input (you don't have to worry about tricking your
  4548. script into reading from environment variables).
  4549. You can pass keywords like this:
  4550.  
  4551.     your_script.pl keyword1 keyword2 keyword3
  4552.  
  4553. or this:
  4554.  
  4555.    your_script.pl keyword1+keyword2+keyword3
  4556.  
  4557. or this:
  4558.  
  4559.     your_script.pl name1=value1 name2=value2
  4560.  
  4561. or this:
  4562.  
  4563.     your_script.pl name1=value1&name2=value2
  4564.  
  4565. or even as newline-delimited parameters on standard input.
  4566.  
  4567. When debugging, you can use quotes and backslashes to escape 
  4568. characters in the familiar shell manner, letting you place
  4569. spaces and other funny characters in your parameter=value
  4570. pairs:
  4571.  
  4572.    your_script.pl "name1='I am a long value'" "name2=two\ words"
  4573.  
  4574. =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
  4575.  
  4576. The dump() method produces a string consisting of all the query's
  4577. name/value pairs formatted nicely as a nested list.  This is useful
  4578. for debugging purposes:
  4579.  
  4580.     print $query->dump
  4581.     
  4582.  
  4583. Produces something that looks like:
  4584.  
  4585.     <UL>
  4586.     <LI>name1
  4587.     <UL>
  4588.     <LI>value1
  4589.     <LI>value2
  4590.     </UL>
  4591.     <LI>name2
  4592.     <UL>
  4593.     <LI>value1
  4594.     </UL>
  4595.     </UL>
  4596.  
  4597. You can pass a value of 'true' to dump() in order to get it to
  4598. print the results out as plain text, suitable for incorporating
  4599. into a <PRE> section.
  4600.  
  4601. As a shortcut, as of version 1.56 you can interpolate the entire CGI
  4602. object into a string and it will be replaced with the a nice HTML dump
  4603. shown above:
  4604.  
  4605.     $query=new CGI;
  4606.     print "<H2>Current Values</H2> $query\n";
  4607.  
  4608. =head1 FETCHING ENVIRONMENT VARIABLES
  4609.  
  4610. Some of the more useful environment variables can be fetched
  4611. through this interface.  The methods are as follows:
  4612.  
  4613. =over 4
  4614.  
  4615. =item B<accept()>
  4616.  
  4617. Return a list of MIME types that the remote browser
  4618. accepts. If you give this method a single argument
  4619. corresponding to a MIME type, as in
  4620. $query->accept('text/html'), it will return a
  4621. floating point value corresponding to the browser's
  4622. preference for this type from 0.0 (don't want) to 1.0.
  4623. Glob types (e.g. text/*) in the browser's accept list
  4624. are handled correctly.
  4625.  
  4626. =item B<raw_cookie()>
  4627.  
  4628. Returns the HTTP_COOKIE variable, an HTTP extension
  4629. implemented by Netscape browsers version 1.1
  4630. and higher.  Cookies have a special format, and this 
  4631. method call just returns the raw form (?cookie dough).
  4632. See cookie() for ways of setting and retrieving
  4633. cooked cookies.
  4634.  
  4635. =item B<user_agent()>
  4636.  
  4637. Returns the HTTP_USER_AGENT variable.  If you give
  4638. this method a single argument, it will attempt to
  4639. pattern match on it, allowing you to do something
  4640. like $query->user_agent(netscape);
  4641.  
  4642. =item B<path_info()>
  4643.  
  4644. Returns additional path information from the script URL.
  4645. E.G. fetching /cgi-bin/your_script/additional/stuff will
  4646. result in $query->path_info() returning
  4647. "additional/stuff".
  4648.  
  4649. NOTE: The Microsoft Internet Information Server
  4650. is broken with respect to additional path information.  If
  4651. you use the Perl DLL library, the IIS server will attempt to
  4652. execute the additional path information as a Perl script.
  4653. If you use the ordinary file associations mapping, the
  4654. path information will be present in the environment, 
  4655. but incorrect.  The best thing to do is to avoid using additional
  4656. path information in CGI scripts destined for use with IIS.
  4657.  
  4658. =item B<path_translated()>
  4659.  
  4660. As per path_info() but returns the additional
  4661. path information translated into a physical path, e.g.
  4662. "/usr/local/etc/httpd/htdocs/additional/stuff".
  4663.  
  4664. The Microsoft IIS is broken with respect to the translated
  4665. path as well.
  4666.  
  4667. =item B<remote_host()>
  4668.  
  4669. Returns either the remote host name or IP address.
  4670. if the former is unavailable.
  4671.  
  4672. =item B<script_name()>
  4673. Return the script name as a partial URL, for self-refering
  4674. scripts.
  4675.  
  4676. =item B<referer()>
  4677.  
  4678. Return the URL of the page the browser was viewing
  4679. prior to fetching your script.  Not available for all
  4680. browsers.
  4681.  
  4682. =item B<auth_type ()>
  4683.  
  4684. Return the authorization/verification method in use for this
  4685. script, if any.
  4686.  
  4687. =item B<server_name ()>
  4688.  
  4689. Returns the name of the server, usually the machine's host
  4690. name.
  4691.  
  4692. =item B<virtual_host ()>
  4693.  
  4694. When using virtual hosts, returns the name of the host that
  4695. the browser attempted to contact
  4696.  
  4697. =item B<server_software ()>
  4698.  
  4699. Returns the server software and version number.
  4700.  
  4701. =item B<remote_user ()>
  4702.  
  4703. Return the authorization/verification name used for user
  4704. verification, if this script is protected.
  4705.  
  4706. =item B<user_name ()>
  4707.  
  4708. Attempt to obtain the remote user's name, using a variety
  4709. of different techniques.  This only works with older browsers
  4710. such as Mosaic.  Netscape does not reliably report the user
  4711. name!
  4712.  
  4713. =item B<request_method()>
  4714.  
  4715. Returns the method used to access your script, usually
  4716. one of 'POST', 'GET' or 'HEAD'.
  4717.  
  4718. =back
  4719.  
  4720. =head1 CREATING HTML ELEMENTS
  4721.  
  4722. In addition to its shortcuts for creating form elements, CGI.pm
  4723. defines general HTML shortcut methods as well.  HTML shortcuts are
  4724. named after a single HTML element and return a fragment of HTML text
  4725. that you can then print or manipulate as you like.
  4726.  
  4727. This example shows how to use the HTML methods:
  4728.  
  4729.     $q = new CGI;
  4730.     print $q->blockquote(
  4731.                  "Many years ago on the island of",
  4732.                  $q->a({href=>"http://crete.org/"},"Crete"),
  4733.                  "there lived a minotaur named",
  4734.                  $q->strong("Fred."),
  4735.                 ),
  4736.            $q->hr;
  4737.  
  4738. This results in the following HTML code (extra newlines have been
  4739. added for readability):
  4740.  
  4741.     <blockquote>
  4742.     Many years ago on the island of
  4743.     <a HREF="http://crete.org/">Crete</a> there lived
  4744.     a minotaur named <strong>Fred.</strong> 
  4745.     </blockquote>
  4746.     <hr>
  4747.  
  4748. If you find the syntax for calling the HTML shortcuts awkward, you can
  4749. import them into your namespace and dispense with the object syntax
  4750. completely (see the next section for more details):
  4751.  
  4752.     use CGI shortcuts;      # IMPORT HTML SHORTCUTS
  4753.     print blockquote(
  4754.              "Many years ago on the island of",
  4755.              a({href=>"http://crete.org/"},"Crete"),
  4756.              "there lived a minotaur named",
  4757.              strong("Fred."),
  4758.              ),
  4759.            hr;
  4760.  
  4761. =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
  4762.  
  4763. The HTML methods will accept zero, one or multiple arguments.  If you
  4764. provide no arguments, you get a single tag:
  4765.  
  4766.     print hr;  
  4767.     #  gives "<hr>"
  4768.  
  4769. If you provide one or more string arguments, they are concatenated
  4770. together with spaces and placed between opening and closing tags:
  4771.  
  4772.     print h1("Chapter","1"); 
  4773.     # gives "<h1>Chapter 1</h1>"
  4774.  
  4775. If the first argument is an associative array reference, then the keys
  4776. and values of the associative array become the HTML tag's attributes:
  4777.  
  4778.     print a({href=>'fred.html',target=>'_new'},
  4779.         "Open a new frame");
  4780.     # gives <a href="fred.html",target="_new">Open a new frame</a>
  4781.  
  4782. You are free to use CGI.pm-style dashes in front of the attribute
  4783. names if you prefer:
  4784.  
  4785.     print img {-src=>'fred.gif',-align=>'LEFT'};
  4786.     # gives <img ALIGN="LEFT" SRC="fred.gif">
  4787.  
  4788. =head2 Generating new HTML tags
  4789.  
  4790. Since no mere mortal can keep up with Netscape and Microsoft as they
  4791. battle it out for control of HTML, the code that generates HTML tags
  4792. is general and extensible.  You can create new HTML tags freely just
  4793. by referring to them on the import line:
  4794.  
  4795.     use CGI shortcuts,winkin,blinkin,nod;
  4796.  
  4797. Now, in addition to the standard CGI shortcuts, you've created HTML
  4798. tags named "winkin", "blinkin" and "nod".  You can use them like this:
  4799.  
  4800.     print blinkin {color=>'blue',rate=>'fast'},"Yahoo!";
  4801.     # <blinkin COLOR="blue" RATE="fast">Yahoo!</blinkin>
  4802.  
  4803. =head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE
  4804.  
  4805. As a convenience, you can import most of the CGI method calls directly
  4806. into your name space.  The syntax for doing this is:
  4807.  
  4808.     use CGI <list of methods>;
  4809.  
  4810. The listed methods will be imported into the current package; you can
  4811. call them directly without creating a CGI object first.  This example
  4812. shows how to import the B<param()> and B<header()>
  4813. methods, and then use them directly:
  4814.  
  4815.     use CGI param,header;
  4816.     print header('text/plain');
  4817.     $zipcode = param('zipcode');
  4818.  
  4819. You can import groups of methods by referring to a number of special
  4820. names:
  4821.  
  4822. =over 4
  4823.  
  4824. =item B<cgi>
  4825.  
  4826. Import all CGI-handling methods, such as B<param()>, B<path_info()>
  4827. and the like.
  4828.  
  4829. =item B<form>
  4830.  
  4831. Import all fill-out form generating methods, such as B<textfield()>.
  4832.  
  4833. =item B<html2>
  4834.  
  4835. Import all methods that generate HTML 2.0 standard elements.
  4836.  
  4837. =item B<html3>
  4838.  
  4839. Import all methods that generate HTML 3.0 proposed elements (such as
  4840. <table>, <super> and <sub>).
  4841.  
  4842. =item B<netscape>
  4843.  
  4844. Import all methods that generate Netscape-specific HTML extensions.
  4845.  
  4846. =item B<shortcuts>
  4847.  
  4848. Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
  4849. 'netscape')...
  4850.  
  4851. =item B<standard>
  4852.  
  4853. Import "standard" features, 'html2', 'form' and 'cgi'.
  4854.  
  4855. =item B<all>
  4856.  
  4857. Import all the available methods.  For the full list, see the CGI.pm
  4858. code, where the variable %TAGS is defined.
  4859.  
  4860. =back
  4861.  
  4862. Note that in the interests of execution speed CGI.pm does B<not> use
  4863. the standard L<Exporter> syntax for specifying load symbols.  This may
  4864. change in the future.
  4865.  
  4866. If you import any of the state-maintaining CGI or form-generating
  4867. methods, a default CGI object will be created and initialized
  4868. automatically the first time you use any of the methods that require
  4869. one to be present.  This includes B<param()>, B<textfield()>,
  4870. B<submit()> and the like.  (If you need direct access to the CGI
  4871. object, you can find it in the global variable B<$CGI::Q>).  By
  4872. importing CGI.pm methods, you can create visually elegant scripts:
  4873.  
  4874.    use CGI standard,html2;
  4875.    print 
  4876.        header,
  4877.        start_html('Simple Script'),
  4878.        h1('Simple Script'),
  4879.        start_form,
  4880.        "What's your name? ",textfield('name'),p,
  4881.        "What's the combination?",
  4882.        checkbox_group(-name=>'words',
  4883.               -values=>['eenie','meenie','minie','moe'],
  4884.               -defaults=>['eenie','moe']),p,
  4885.        "What's your favorite color?",
  4886.        popup_menu(-name=>'color',
  4887.           -values=>['red','green','blue','chartreuse']),p,
  4888.        submit,
  4889.        end_form,
  4890.        hr,"\n";
  4891.  
  4892.     if (param) {
  4893.        print 
  4894.        "Your name is ",em(param('name')),p,
  4895.        "The keywords are: ",em(join(", ",param('words'))),p,
  4896.        "Your favorite color is ",em(param('color')),".\n";
  4897.     }
  4898.     print end_html;
  4899.  
  4900. =head1 USING NPH SCRIPTS
  4901.  
  4902. NPH, or "no-parsed-header", scripts bypass the server completely by
  4903. sending the complete HTTP header directly to the browser.  This has
  4904. slight performance benefits, but is of most use for taking advantage
  4905. of HTTP extensions that are not directly supported by your server,
  4906. such as server push and PICS headers.
  4907.  
  4908. Servers use a variety of conventions for designating CGI scripts as
  4909. NPH.  Many Unix servers look at the beginning of the script's name for
  4910. the prefix "nph-".  The Macintosh WebSTAR server and Microsoft's
  4911. Internet Information Server, in contrast, try to decide whether a
  4912. program is an NPH script by examining the first line of script output.
  4913.  
  4914.  
  4915. CGI.pm supports NPH scripts with a special NPH mode.  When in this
  4916. mode, CGI.pm will output the necessary extra header information when
  4917. the header() and redirect() methods are
  4918. called.
  4919.  
  4920. The Microsoft Internet Information Server requires NPH mode.  As of version
  4921. 2.30, CGI.pm will automatically detect when the script is running under IIS
  4922. and put itself into this mode.  You do not need to do this manually, although
  4923. it won't hurt anything if you do.
  4924.  
  4925. There are a number of ways to put CGI.pm into NPH mode:
  4926.  
  4927. =over 4
  4928.  
  4929. =item In the B<use> statement
  4930. Simply add ":nph" to the list of symbols to be imported into your script:
  4931.  
  4932.       use CGI qw(:standard :nph)
  4933.  
  4934. =item By calling the B<nph()> method:
  4935.  
  4936. Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
  4937.  
  4938.       CGI->nph(1)
  4939.  
  4940. =item By using B<-nph> parameters in the B<header()> and B<redirect()>  statements:
  4941.  
  4942.       print $q->header(-nph=>1);
  4943.  
  4944. =back
  4945.  
  4946. =head1 AUTHOR INFORMATION
  4947.  
  4948. Copyright 1995,1996, Lincoln D. Stein.  All rights reserved.  It may
  4949. be used and modified freely, but I do request that this copyright
  4950. notice remain attached to the file.  You may modify this module as you
  4951. wish, but if you redistribute a modified version, please attach a note
  4952. listing the modifications you have made.
  4953.  
  4954. Address bug reports and comments to:
  4955. lstein@genome.wi.mit.edu
  4956.  
  4957. =head1 CREDITS
  4958.  
  4959. Thanks very much to:
  4960.  
  4961. =over 4
  4962.  
  4963. =item Matt Heffron (heffron@falstaff.css.beckman.com)
  4964.  
  4965. =item James Taylor (james.taylor@srs.gov)
  4966.  
  4967. =item Scott Anguish <sanguish@digifix.com>
  4968.  
  4969. =item Mike Jewell (mlj3u@virginia.edu)
  4970.  
  4971. =item Timothy Shimmin (tes@kbs.citri.edu.au)
  4972.  
  4973. =item Joergen Haegg (jh@axis.se)
  4974.  
  4975. =item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
  4976.  
  4977. =item Richard Resnick (applepi1@aol.com)
  4978.  
  4979. =item Craig Bishop (csb@barwonwater.vic.gov.au)
  4980.  
  4981. =item Tony Curtis (tc@vcpc.univie.ac.at)
  4982.  
  4983. =item Tim Bunce (Tim.Bunce@ig.co.uk)
  4984.  
  4985. =item Tom Christiansen (tchrist@convex.com)
  4986.  
  4987. =item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
  4988.  
  4989. =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
  4990.  
  4991. =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
  4992.  
  4993. =item Stephen Dahmen (joyfire@inxpress.net)
  4994.  
  4995. =item Ed Jordan (ed@fidalgo.net)
  4996.  
  4997. =item David Alan Pisoni (david@cnation.com)
  4998.  
  4999. =item ...and many many more...
  5000.  
  5001. for suggestions and bug fixes.
  5002.  
  5003. =back
  5004.  
  5005. =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
  5006.  
  5007.  
  5008.     #!/usr/local/bin/perl
  5009.      
  5010.     use CGI;
  5011.  
  5012.     $query = new CGI;
  5013.  
  5014.     print $query->header;
  5015.     print $query->start_html("Example CGI.pm Form");
  5016.     print "<H1> Example CGI.pm Form</H1>\n";
  5017.     &print_prompt($query);
  5018.     &do_work($query);
  5019.     &print_tail;
  5020.     print $query->end_html;
  5021.  
  5022.     sub print_prompt {
  5023.        my($query) = @_;
  5024.  
  5025.        print $query->startform;
  5026.        print "<EM>What's your name?</EM><BR>";
  5027.        print $query->textfield('name');
  5028.        print $query->checkbox('Not my real name');
  5029.  
  5030.        print "<P><EM>Where can you find English Sparrows?</EM><BR>";
  5031.        print $query->checkbox_group(
  5032.                  -name=>'Sparrow locations',
  5033.                  -values=>[England,France,Spain,Asia,Hoboken],
  5034.                  -linebreak=>'yes',
  5035.                  -defaults=>[England,Asia]);
  5036.  
  5037.        print "<P><EM>How far can they fly?</EM><BR>",
  5038.         $query->radio_group(
  5039.             -name=>'how far',
  5040.             -values=>['10 ft','1 mile','10 miles','real far'],
  5041.             -default=>'1 mile');
  5042.  
  5043.        print "<P><EM>What's your favorite color?</EM>  ";
  5044.        print $query->popup_menu(-name=>'Color',
  5045.                     -values=>['black','brown','red','yellow'],
  5046.                     -default=>'red');
  5047.  
  5048.        print $query->hidden('Reference','Monty Python and the Holy Grail');
  5049.  
  5050.        print "<P><EM>What have you got there?</EM><BR>";
  5051.        print $query->scrolling_list(
  5052.              -name=>'possessions',
  5053.              -values=>['A Coconut','A Grail','An Icon',
  5054.                    'A Sword','A Ticket'],
  5055.              -size=>5,
  5056.              -multiple=>'true');
  5057.  
  5058.        print "<P><EM>Any parting comments?</EM><BR>";
  5059.        print $query->textarea(-name=>'Comments',
  5060.                   -rows=>10,
  5061.                   -columns=>50);
  5062.  
  5063.        print "<P>",$query->reset;
  5064.        print $query->submit('Action','Shout');
  5065.        print $query->submit('Action','Scream');
  5066.        print $query->endform;
  5067.        print "<HR>\n";
  5068.     }
  5069.  
  5070.     sub do_work {
  5071.        my($query) = @_;
  5072.        my(@values,$key);
  5073.  
  5074.        print "<H2>Here are the current settings in this form</H2>";
  5075.  
  5076.        foreach $key ($query->param) {
  5077.           print "<STRONG>$key</STRONG> -> ";
  5078.           @values = $query->param($key);
  5079.           print join(", ",@values),"<BR>\n";
  5080.       }
  5081.     }
  5082.  
  5083.     sub print_tail {
  5084.        print <<END;
  5085.     <HR>
  5086.     <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
  5087.     <A HREF="/">Home Page</A>
  5088.     END
  5089.     }
  5090.  
  5091. =head1 BUGS
  5092.  
  5093. This module has grown large and monolithic.  Furthermore it's doing many
  5094. things, such as handling URLs, parsing CGI input, writing HTML, etc., that
  5095. are also done in the LWP modules. It should be discarded in favor of
  5096. the CGI::* modules, but somehow I continue to work on it.
  5097.  
  5098. Note that the code is truly contorted in order to avoid spurious
  5099. warnings when programs are run with the B<-w> switch.
  5100.  
  5101. =head1 SEE ALSO
  5102.  
  5103. L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
  5104. L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
  5105. L<CGI::Push>, L<CGI::Fast>
  5106.  
  5107. =cut
  5108.  
  5109.