# This is a library of useful perl cgi scripting routines
# that use perl5 objects.

# Version 1.2, 3/9/95, L. Stein

# ABSTRACT:
# This perl library uses perl5 objects to make it easy to create
# Web fill-out forms and parse their contents.  This package
# defines CGI objects, entities that contain the values of the
# current query string and other state variables.
# Using a CGI object's methods, you can examine keywords and parameters
# passed to your script, and create forms whose initial values
# are taken from the current query (thereby preserving state
# information).

# INSTALLATION:
# To use this package, install it in your perl library path and
# add the following to your perl CGI script:
# Use CGI;

# CREATING A NEW QUERY OBJECT:
#
#     $query = new CGI
#
# This will parse the input (from both POST and GET methods) and store
# it into a perl5 object called $query.  

# FETCHING A LIST OF KEYWORDS FROM THE QUERY:
#
#     @keywords = $query->keywords
#
# If the script was invoked as the result of an <ISINDEX> search, the
# parsed keywords can be obtained as an array using the keywords() method.

# FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
#
#     @names = $query->param
#
# If the script was invoked with a parameter list
# (e.g. "name1=value1&name2=value2&name3=value3"), the param()
# method will return the parameter names as a list.  If the
# script was invoked as an <ISINDEX> script, there will be a
# single parameter named 'keywords'.

# FETCHING THE VALUE(S) OF A SINGLE NAMED PARAMETER:
#
#    @values = $query->param('foo');
#              -or-
#    $value = $query->param('foo');
#
# Pass the param() method a single argument to fetch the value of the
# named parameter. If the parameter is multivalued (e.g. from multiple
# selections in a scrolling list), you can ask to receive an array.  Otherwise
# the method will return a single value.

# SETTING THE VALUE(S) OF A NAMED PARAMETER:
#
#    $query->param('foo','an','array','of','values');
#
# This sets the value for the named parameter 'foo' to an array of
# values.  Do this if you want to change the value of a field AFTER
# the script has been invoked before.

# PRINTING THE HTTP HEADER:
#
# header() returns the Content-type: header.
# you can provide your own MIME type if you choose,
# otherwise it defaults to text/html

# CREATING FORMS:
#
# General note.  The various form-creating methods all return strings
# to the caller, containing the tag or tags that will create the requested
# form element.  You are responsible for actually printing out these strings.
# It's set up this way so that you can place formatting tags
# around the form elements.

# Another note: The default values that you specify for the forms are only
# used the _first_ time the script is invoked.  If there are already values
# present in the query string, they are used, even if blank.  If you want
# to change the value of a field from its previous value, call the param()
# method to set it.

# CREATING AN ISINDEX TAG
#
#    print $query->isindex($action);
#
# Prints out an <ISINDEX> tag.  Not very exciting.  The optional
# parameter specifies an ACTION="<URL>" attribute.

# STARTING AND ENDING A FORM
#
#    print $query->startform($method,$action);
#      <... various form stuff ...>
#    print $query->endform;
#
# startform() will return a <FORM> tag with the optional method and
# action that you specify (POST and none assumed).
# endform() returns a </FORM> tag.

# CREATING A TEXT FIELD
#
#    print $query->textfield('foo','starting value',50);
#
# textfield() will return a text input field.  
# - The first parameter is the required name for the field.  The 
#   second parameter is an optional starting value for the field contents.  
# - The optional third parameter is the size of the field in
#   characters.
# As with all these methods, the field will be initialized with its 
# previous contents from earlier invocations of the script.
# When the form is processed, the value of the text field can be
# retrieved with:
#       $value = $query->param('foo');

# CREATING A BIG TEXT FIELD
#
#   print $query->textarea('foo','starting value',10,50);
#
# textarea() is just like textfield, but it allows you to specify
# rows and columns for a multiline text entry box.  You can provide
# a starting value for the field, which can be long and contain
# multiple lines.

# CREATING A PASSWORD FIELD
#
#   print $query->password('secret','starting value',50);
#
# password() is identical to textfield(), except that its contents 
# will be starred out on the web page.

# CREATING A POPUP MENU
#
#   print $query->popup_menu('menu_name',['eenie','meenie','minie'],'meenie');
#
#
# popup_menu() creates a menu.
# - The required first argument is the menu's name.
# - The required second argument is an array _reference_ containing the list
#   of menu items in the menu.  You can pass the method an anonymous 
#   array, as shown in the example, or a reference to a named array,
#   such as "\@foo".
# - The optional third parameter is the name of the default menu choice.  
#   If not specified, the first item will be the default.  The values of 
#   the previous choice will be maintained across queries.
# When the form is processed, the selected value of the popup menu can
# be retrieved using:
#      $popup_menu_value = $query->param('menu_name');

# CREATING A SCROLLING LIST
#
#   print $query->scrolling_list('list_name',
#                                ['eenie','meenie','minie','moe'],
#                                ['eenie','moe'],5,'true');
#
# scrolling_list() creates a scrolling list.  
# - The first and second arguments are the list name and values, 
#   respectively.  As in the popup menu, the second argument should 
#   be an array reference.
# - The optional third argument can be either a reference to a list
#   containing the values to be selected by default, or can be a 
#   single value to select.  If this argument is missing or undefined,
#   then nothing is selected when the list first appears.
# - The optional fourth argument is the size of the list.
# - The optional fifth argument should be set to true to allow multiple
#   simultaneous selections.
# When this form is procesed, all selected list items will be returned as
# a list under the parameter name 'list_name'.  The values of the
# selected items can be retrieved with:
#      @selected = $query->param('list_name');

# CREATING A GROUP OF RELATED CHECKBOXES
#
#   print $query->checkbox_group('group_name',
#                                ['eenie','meenie','minie','moe'],
#                                ['eenie','moe'],'true');
#
# checkbox_group() creates a list of checkboxes that are related
#   by the same name.
# - The first and second arguments are the checkbox name and values, 
#   respectively.  As in the popup menu, the second argument should 
#   be an array reference.  These values are used for the user-readable
#   labels printed next to the checkboxes as well as for the values
#   passed to your script in the query string.
# - The optional third argument can be either a reference to a list
#   containing the values to be checked by default, or can be a 
#   single value to checked.  If this argument is missing or undefined,
#   then nothing is selected when the list first appears.
# - The optional fourth argument can be set to true to place line breaks
#   between the checkboxes so that they appear as a vertical list.
#   Otherwise, they will be strung together on a horizontal line.
# When the form is procesed, all checked boxes will be returned as
# a list under the parameter name 'group_name'.  The values of the
# "on" checkboxes can be retrieved with:
#      @turned_on = $query->param('group_name');

# CREATING A STANDALONE CHECKBOX
#
#    print $query->checkbox('checkbox_name','TURNED ON');
#
# checkbox() is used to create an isolated checkbox that isn't logically
# related to any others.
# - The first parameter is the required name for the checkbox.  It
#   will also be used for the user-readable label printed next to
#   the checkbox.
# - The optional second parameter specifies the value of the checkbox
#   when it is checked.  If not provided, the word "on" is assumed.
# The value of the checkbox can be retrieved using:
#    $turned_on = $query->param('checkbox_name');

# CREATING A RADIO BUTTON GROUP
#
#   print $query->radio_group('group_name',['eenie','meenie','minie'],
#                                          'meenie','true');
#
#
# radio_group() creates a set of logically-related radio buttons
#   (turning one member of the group on turns the others off)
# - The first argument is the name of the group and is required.
# - The second argument is the list of values for the radio buttons.
#   The values and the labels that appear on the page are identical.
#   Pass an array _reference_ in the second argument, either using 
#   an anonymous array, as shown, or by referencing a named array as 
#   in "\@foo".  
# - The optional third parameter is the name of the default button to
#   turn on. If not specified, the first item will be the default.
# - The optional fourth parameter can be set to 'true' to put
#   line breaks between the buttons, creating a vertical list.
# When the form is processed, the selected radio button can
# be retrieved using:
#      $which_radio_button = $query->param('group_name');

# CREATING A SUBMIT BUTTON 
#
#   print $query->submit('button_name','value');
#
# submit() will create the query submission button.  Every form
#     should have one of these.
# - The first argument is optional.  You can give the button a
#   name if you have several submission buttons in your form and
#   you want to distinguish between them.  The name will also be
#   used as the user-visible label.
# - The second argument is also optional.  This gives the button
#   a value that will be passed to your script in the query string.
# You can figure out which button was pressed by using different
# values for each one:
#     $which_one = $query->param('button_name');

# CREATING A RESET BUTTON
#
#   print $query->reset
#
# reset() creates the "reset" button.  Note that it restores the
# form to its value from the last time the script was called, 
# NOT necessarily to the defaults.

# CREATING A DEFAULT BUTTON
#
#   print $query->defaults('button_label')
#
# defaults() creates a button that, when invoked, will cause the
# form to be completely reset to its defaults, wiping out all the
# changes the user ever made.

# CREATING A HIDDEN FIELD
#
# print $query->hidden('hidden_name','hidden_value');
#
# hidden() produces a text field that can't be seen by the user.  It
# is useful for passing state variable information from one invocation
# of the script to the next.
# - The first argument is required and specifies the name of this
#   field.
# - The second argument is also required and specifies its value.
# Fetch the value of a hidden field this way:
#     $hidden_value = $query->param('hidden_name');

# DEBUGGING:
# If you are running the script
# from the command line or in the perl debugger, you can pass the script
# a list of keywords or parameter=value pairs on the command line or 
# from standard input (you don't have to worry about tricking your
# script into reading from environment variables).
# You can pass keywords like this:
#    your_script.pl keyword1 keyword2 keyword3
#
# or this:
#    your_script.pl keyword1+keyword2+keyword3
#
# or this:
#    your_script.pl name1=value1 name2=value2
#
# or this:
#    your_script.pl name1=value1&name2=value2
#
# or even as newline-delimited parameters on standard input

# DUMPING OUT ALL THE NAME/VALUE PAIRS
# The dump() method produces a string consisting of all the query's
# name/value pairs formatted nicely as a nested list.  This is useful
# for debugging purposes:
#
#    print $query->dump
#    
#    Produces something that looks like:
#    <UL>
#    <LI>name1
#        <UL>
#        <LI>value1
#        <LI>value2
#        </UL>
#    <LI>name2
#        <UL>
#        <LI>value1
#        </UL>
#    </UL>

# FETCHING ENVIRONMENT VARIABLES
#
# Some of the more useful environment variables can be fetched
# through this interface.  The methods are as follows:
#
# accept()   Return a list of MIME types that the remote browser
#            accepts. If you give this method a single argument
#            corresponding to a MIME type, as in
#            $query->accept('text/html'), it will return a
#            floating point value corresponding to the browser's
#            preference for this type from 0.0 (don't want) to 1.0.
#            Glob types (e.g. text/*) in the browser's accept list
#            are handled correctly.
#
# path_info() 
#            Returns additional path information from the script URL.
#            E.G. fetching /cgi-bin/your_script/additional/stuff will
#            result in $query->path_info() returning
#            "additional/stuff".
#
# path_translated()  
#            As per path_info() but returns the additional
#            path information translated into a physical path, e.g.
#            "/usr/local/etc/httpd/htdocs/additional/stuff".
#
# remote_host() 
#            Returns either the remote host name or IP address.
#            if the former is unavailable.
#
# script_name()
#            Return the script name as a partial URL, for self-refering
#            scripts.
#
# referer()
#            Return the URL of the page the browser was viewing
#            prior to fetching your script.  Not available for all
#            browsers.

######################################################################
# AUTHOR INFORMATION
#
# This code is copyright 1995 by Lincoln Stein and the Whitehead 
# Institute for Biomedical Research.  It may be used and modified 
# freely.  I request, but do not require, that this credit appear
# in the code.
#
# Address bug reports and comments to:
# lstein@genome.wi.mit.edu
######################################################################

######################################################################
# CREDITS
# Thanks very much to Matt Heffron (heffron@falstaff.css.beckman.com)
# and James Taylor (james.taylor@srs.gov) for useful bug patches.
#######################################################################

#######################################################################
# A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
#
# #!/usr/local/bin/perl
# # CGI Script: object-form.pl
# 
# BEGIN {
#     unshift(@INC,'/usr/local/etc/httpd/cgi-bin');
# }
# use CGI;
# 
# &print_header;
# &print_head;
# $query = new CGI;
# &print_prompt($query);
# &do_work($query);
# &print_tail;
# sub print_header { print "Content-type: text/html\n\n"; }
# 
# sub print_head {
#     print <<END;
# <HTML><HEAD>
# <TITLE>Example CGI.pm Form</TITLE>
# </HEAD><BODY>
# <H1>Example CGI.pm Form</H1>
# END
# }
# 
# sub print_prompt {
#     local($query) = @_;
# 
#     print $query->startform;
#     print "<EM>What's your name?</EM><BR>";
#     print $query->textfield('name');
#     print $query->checkbox('Not my real name');
# 
#     print "<P><EM>Where can you find English Sparrows?</EM><BR>";
#     print $BLANK;
#     print $query->checkbox_group('Sparrow locations',
# 				 [England,France,Spain,Asia,Hoboken],
# 				 [England,Asia]);
# 
#     print "<P><EM>How far can they fly?</EM><BR>",
#            $query->radio_group('how far',
# 			       ['10 ft','1 mile','10 miles','real far'],
# 			       '1 mile');
# 
#     print "<P><EM>What's your favorite color?</EM>  ";
#     print $query->popup_menu('Color',['black','brown','red','yellow'],'red');
# 
#     print $query->hidden('Reference','Monty Python and the Holy Grail');
# 
#     print "<P><EM>What have you got there?</EM>  ";
#     print $query->scrolling_list('possessions',
# 				 ['A Coconut','A Grail','An Icon',
# 				  'A Sword','A Ticket'],
# 				 undef,
# 				 10,
# 				 'true');
# 
#     print "<P><EM>Any parting comments?</EM><BR>";
#     print $query->textarea('Comments',undef,10,50);
# 
#     print "<P>",$query->reset;
#     print $query->submit('Action','Shout');
#     print $query->submit('Action','Scream');
#     print $query->endform;
#     print "<HR>\n";
# }
# 
# sub do_work {
#     local($query) = @_;
#     local(@values,$key);
#
#     print "<H2>Here are the current settings in this form</H2>";
#
#     foreach $key ($query->param) {
# 	print "<STRONG>$key</STRONG> -> ";
# 	@values = $query->param($key);
# 	print join(", ",@values),"<BR>\n";
#     }
#
# }
# 
# sub print_tail {
#     print <<END;
# <HR>
# <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
# <A HREF="/">Home Page</A>
# END
# }
#######################################################################


# ------------------ START OF THE LIBRARY ------------
package CGI;

$VERSION=1.2;

#### Method: new
# The new routine.  This will check the current environment
# for an existing query string, and initialize itself, if so.
####
sub new {
    my $self = {};
    bless $self;
    $self->initialize;
    return $self;
}

#### Method: param
# Returns the value(s)of a named parameter.
# If invoked in a list context, returns the
# entire list.  Otherwise returns the first
# member of the list.
# If name is not provided, return a list of all
# the known parameters names available.
# If more than one argument is provided, the
# second and subsequent arguments are used to
# set the value of the parameter.
####
sub param {
    local($self,$name,@values) = @_;
    return grep ($_ !~ /^\./,keys %{$self}) unless $name;

    # If values is provided, then we set it.
    $self->{$name}=[@values] if @values;
    return () unless $self->{$name};
    return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
}

#### Method: keywords
# Keywords acts a bit differently.  Calling it in a list context
# returns the list of keywords.  
# Calling it in a scalar context gives you the size of the list.
####
sub keywords {
    my($self,@values) = @_;
    # If values is provided, then we set it.
    $self->{'keywords'}=[@values] if @values;
    local(@result) = @{$self->{'keywords'}};
    @result;
}

#### Method: version
# Return the current version
####
sub version {
    return $VERSION;
}

#### Method: dump
# Returns a string in which all the known parameter/value 
# pairs are represented as nested lists, mainly for the purposes 
# of debugging.
####
sub dump {
    my($self) = @_;
    my($param,$value,@result);
    push(@result,"<UL>");
    foreach $param ($self->param) {
	push(@result,"<LI><STRONG>$param</STRONG>");
	push(@result,"<UL>");
	foreach $value ($self->param($param)) {
	    push(@result,"<LI>$value");
	}
	push(@result,"</UL>");
    }
    push(@result,"</UL>");
    return join("\n",@result);
}

#### Method: header
# Return a Content-type: style header
#
####
sub header {
    local($self,$type) = @_;
    $type = $type || 'text/html';
    return "Content-type: $type\n\n";
}
################################
# METHODS USED IN BUILDING FORMS
################################

#### Method: isindex
# Just prints out the isindex tag.
# Parameters:
#  $action -> optional URL of script to run
# Returns:
#   A string containing a <ISINDEX> tag
sub isindex {
    local($self,$action) = @_;
    $action = qq/ACTION="$action"/ if $action;
    return "<ISINDEX $action>";
}

#### Method: startform
# Start a form
sub startform {
    local($self,$method,$action) = @_;
    $method = $method || 'POST';
    $action = qq/ACTION="$action"/ if $action;
    return qq/<FORM METHOD="$method" $action>\n/;
}

#### Method: endform
# End a form
sub endform {
    return "</FORM>\n";
}

#### Method: textfield
# Parameters:
#   $name -> Name of the text field
#   $default -> Optional default value of the field if not
#                already defined.
#   $size ->  Optional size of field.
# Returns:
#   A string containing a <INPUT TYPE="text"> field
#
sub textfield {
    local($self,$name,$default,$size) = @_;
    local($current)=$self->inited ? $self->param($name) : $default;
    local($s) = qq/SIZE=$size/ if $size;
    return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current" $s>/; #[BII] default this right
}

#### Method: password
# Create a "secret password" entry field
# Parameters:
#   $name -> Name of the field
#   $default -> Optional default value of the field if not
#                already defined.
#   $size ->  Optional size of field.
# Returns:
#   A string containing a <INPUT TYPE="password"> field
#
sub password_field {
    local($self,$name,$default,$size)=@_;
    local($current) =  $self->inited ? $self->param($name) : $default;
    local($s) = qq/SIZE=$size/ if $size;
    return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current" $s>/;
}

#### Method: textarea
# Parameters:
#   $name -> Name of the text field
#   $default -> Optional default value of the field if not
#                already defined.
#   $rows ->  Optional number of rows in text area
#   $columns -> Optional number of columns in text area
# Returns:
#   A string containing a <TEXTAREA></TEXTAREA> tag
#
sub textarea {
    local($self,$name,$default,$rows,$cols)=@_;
    local($current)= $self->inited ? $self->param($name) : $default;
    local($r) = "ROWS=$rows" if $rows;
    local($c) = "COLS=$cols" if $cols;
    return <<END;
<TEXTAREA NAME="$name" $r $c>$current</TEXTAREA>
END
}

#### Method: submit
# Create a "submit query" button.
# Parameters:
#   $label -> (optional) Name for the button.
#   $value -> (optional) Value of the button when selected.
# Returns:
#   A string containing a <INPUT TYPE="submit"> tag
####
sub submit {
    local($self,$label,$value) = @_;
    local($name) = qq/NAME="$label"/ if $label;
    $value = $value || $label;
    local($val) = qq/VALUE="$value"/ if $value;
    return qq/<INPUT TYPE="submit" $name $val>\n/;
}

#### Method: reset
# Create a "reset" button.
# Parameters:
#   $label -> (optional) Name for the button.
# Returns:
#   A string containing a <INPUT TYPE="reset"> tag
####
sub reset {
    local($self,$label) = @_;
    local($value) = qq/VALUE="$name"/ if $name;

    return qq/<INPUT TYPE="reset" $value>\n/;
}

#### Method: defaults
# Create a "defaults" button.
# Parameters:
#   $label -> (optional) Name for the button.
# Returns:
#   A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
#
# Note: this button has a special meaning to the initialization script,
# and tells it to ERASE the current query string so that your defaults
# are used again!
####
sub defaults {
    local($self,$label) = @_;
    $label = $label || "Defaults";
    local($value) = qq/VALUE="$label"/;
    return qq/<INPUT TYPE="submit" NAME=".defaults" $value>\n/;
}

#### Method: checkbox
# Create a checkbox that is not logically linked to any others.
# The field value is "on" when the button is checked.
# Parameters:
#   $name -> Name of the checkbox
#   $checked -> (optional) turned on by default if true
#   $value -> (optional) value of the checkbox, 'on' by default
# Returns:
#   A string containing a <INPUT TYPE="checkbox"> field
####
sub checkbox {
    local($self,$name,$checked,$value)=@_;
    if ($self->inited) {
	$checked = $self->param($name) ? 'CHECKED' : undef;
	$value = $self->param($name) || $value || 'on';
    } else {
	$checked = 'CHECKED' if $checked;
	$value = $value || 'on';
    }
    return <<END;
<INPUT TYPE="checkbox" NAME="$name" VALUE="$value" $checked>$name
END
}

#### Method: checkbox_group
# Create a list of logically-linked checkboxes.
# Parameters:
#   $name -> Common name for all the check boxes
#   $values -> A pointer to a regular array containing the
#             values for each checkbox in the group.
#   $settings -> (optional)
#             1. If a pointer to a regular array of checkbox values,
#             then this will be used to decide which
#             checkboxes to turn on by default.
#             2. If a scalar, will be assumed to hold the
#             value of a single checkbox in the group to turn on. 
#   $linebreak -> (optional) Set to true to place linebreaks
#             between the buttons.
# Returns:
#   A string containing a series of <INPUT TYPE="checkbox"> fields
####
sub checkbox_group {
    local($self,$name,$values,$defaults,$linebreak)=@_;
    local(%checked,$break,$result);

    if ($self->inited) {
	grep($checked{$_}++,$self->param($name));
    } elsif (ref($defaults) eq 'ARRAY') {
	grep($checked{$_}++,@{$defaults});
    } else {
	$checked{$defaults}++;
    }
    $result = $break = "<BR>" if $linebreak;

    foreach (@{$values}) {
	$checked = $checked{$_} ? 'CHECKED' : undef;
	$result .= 
	    qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_" $checked>$_$break\n/;
    }

    return $result;
}

#### Method: radio_group
# Create a list of logically-linked radio buttons.
# Parameters:
#   $name -> Common name for all the buttons.
#   $values -> A pointer to a regular array containing the
#             values for each button in the group.
#   $default -> (optional) Value of the button to turn on by default.
#   $linebreak -> (optional) Set to true to place linebreaks
#             between the buttons.
# Returns:
#   A string containing a series of <INPUT TYPE="radio"> fields
####
sub radio_group {
    local($self,$name,$values,$default,$linebreak)=@_;
    local($result,$checked);

    if ($self->inited) {
	$checked = $self->param($name);
    } else {
	$checked = $default;
    }
    # If no check array is specified, check the first by default
    $checked = $values->[0] unless $checked;
    $result = "<BR>" if $linebreak;

    foreach (@{$values}) {
	my($checkit) = $checked eq $_ ? 'CHECKED' : undef;
	my($break) = $linebreak ? '<BR>' : undef;
	$result .= qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_" $checkit>$_$break\n/;
    }
    return $result;
}


#### Method: popup_menu
# Create a popup menu.
# Parameters:
#   $name -> Name for all the menu
#   $values -> A pointer to a regular array containing the
#             text of each menu item.
#   $default -> (optional) Default item to display
# Returns:
#   A string containing the definition of a popup menu.
####
sub popup_menu {
    local($self,$name,$values,$default)=@_;
    local($result,$selected);

    if ($self->inited) {
	$selected = $self->param($name);
    } else {
	$selected = $default;
    }

    $result = qq/<SELECT NAME="$name">\n/;
    foreach (@{$values}) {
	my($selectit) = $selected eq $_ ? 'SELECTED' : undef;
	$result .= "<OPTION $selectit>$_\n";
    }

    $result .= "</SELECT>\n";
    return $result;
}

#### Method: scrolling_list
# Create a scrolling list.
# Parameters:
#   $name -> name for the list
#   $values -> A pointer to a regular array containing the
#             values for each option line in the list.
#   $defaults -> (optional)
#             1. If a pointer to a regular array of options,
#             then this will be used to decide which
#             lines to turn on by default.
#             2. Otherwise holds the value of the single line to turn on.
#   $size -> (optional) Size of the list.
#   $multiple -> (optional) If set, allow multiple selections.
# Returns:
#   A string containing the definition of a scrolling list.
####
sub scrolling_list {
    local($self,$name,$values,$default,$size,$multiple)=@_;
    local($result,%selected);

    if ($self->inited) {
	grep($selected{$_}++,$self->param($name));
    } elsif (ref($default) eq 'ARRAY') {
	grep($selected{$_}++,@{$default});
    } else {
	$selected{$default}++;
    }

    my($is_multiple) = $multiple ? 'MULTIPLE' : undef;
    my($has_size) = $size ? "SIZE=$size" : undef;
    $result = qq/<SELECT NAME="$name" $has_size $is_multiple>\n/;
    foreach (@{$values}) {
	my($selectit) = $selected{$_} ? 'SELECTED' : undef;
	$result .= "<OPTION $selectit>$_\n";
    }
    $result .= "</SELECT>\n";
    return $result;
}

#### Method: hidden
# Parameters:
#   $name -> Name of the hidden field
#   $default -> (optional) Initial value of field
# Returns:
#   A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
####
sub hidden {
    local($self,$name,$default)=@_;
    local($v);
    if ($self->inited) {
	my($value) = $self->param($name);
	$v = qq/VALUE="$value"/;
    } else {
	$v = qq/VALUE="$default"/;
    }
    return qq/<INPUT TYPE="hidden" NAME="$name" $v>/;
}

###############################################
# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
###############################################

#### Method: path_info
# Return the extra virtual path information provided
# after the URL (if any)
####
sub path_info {
    return $ENV{'PATH_INFO'};
}

#### Method: path_translated
# Return the physical path information provided
# by the URL (if any)
####
sub path_translated {
    return $ENV{'PATH_TRANSLATED'};
}

#### Method: accept
# Without parameters, returns an array of the
# MIME types the browser accepts.
# With a single parameter equal to a MIME
# type, will return undef if the browser won't
# accept it, 1 if the browser accepts it but
# doesn't give a preference, or a floating point
# value between 0.0 and 1.0 if the browser
# declares a quantitative score for it.
# This handles MIME type globs correctly.
####
sub accept {
    local($self,$search) = @_;
    local(%prefs);
    
    local(@accept) = split(',',$ENV{'HTTP_ACCEPT'});
    
    foreach (@accept) {
	($pref) = /q=(\d\.\d+|\d+)/;
	($type) = m#(\S+/[^;]+)#;
	next unless $type;
	$prefs{$type}=$pref || 1;
    }

    return keys %prefs unless $search;
    
    # if a search type is provided, we may need to
    # perform a pattern matching operation.
    # The MIME types use a glob mechanism, which
    # is easily translated into a perl pattern match

    # First return the preference for directly supported
    # types:
    return $prefs{$search} if $prefs{$search};

    # Didn't get it, so try pattern matching.
    foreach (keys %prefs) {
	next unless /\*/;	# not a pattern match
	$pat=~s/([^\w*])/\\$1/g; # escape meta characters
	($pat = $_) =~ s/\*/.*/g; # turn it into a pattern
	return $prefs{$_} if $search=~/$pat/;
    }
}

#### Method: remote_host
# Return the name of the remote host, or its IP
# address if unavailable
####
sub remote_host {
    return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'};
}

#### Method: remote_addr
# Return the IP addr of the remote host.
####
sub remote_addr {
    return $ENV{'REMOTE_ADDR'};
}

#### Method: script_name
# Return the partial URL to this script for
# self-referencing scripts.
####
sub script_name {
    return $ENV{'SCRIPT_NAME'};
}

#### Method: referer
# Return the HTTP_REFERER: useful for generating
# a GO BACK button.
####
sub referer {
    return $ENV{'HTTP_REFERER'};
}

########################################
# THESE METHODS ARE MORE OR LESS PRIVATE
########################################

# Initialize the query object from the environment.
# If a parameter list is found, this object will be set
# to an associative array in which parameter names are keys
# and the values are stored as lists
# If a keyword list is found, this method creates a bogus
# parameter list with the single parameter 'keywords'.
sub initialize {
    local($self) = @_;

    local($query_string);
    local(@lines);
    local($method)=$ENV{'REQUEST_METHOD'};

    # See whether 
    # If method is GET or HEAD, fetch the query from
    # the environment.
    if ($method=~/^(GET|HEAD)$/) {
	$query_string = $ENV{'QUERY_STRING'};

    # If the method is POST, fetch the query from standard
    # input.
    } elsif ($method eq 'POST') {
	read(STDIN,$query_string,$ENV{'CONTENT_LENGTH'});

    # If neither is set, assume we're being debugged offline.
    # Check the command line and then the standard input for data.
    } elsif (@ARGV) {
	$query_string = "@ARGV";
	# massage it back into standard format
	$query_string=~tr/ /&/ if $query_string=~/=/;

    } else {			# fetch from standard input
	warn "(waiting for standard input)\n";
	chop(@lines = <>);		# remove newlines

	# massage back into standard format
	if ("@lines" =~ /=/) {
	    $query_string=join("&",@lines);
	} else {
	    $query_string=join("+",@lines);
	}
    }
    
    
    # No data.  Leave us empty.
    return unless $query_string;

    # We now have the query string in hand.  We do slightly
    # different things for keyword lists and parameter lists.
    $self->{'.init'}++;		# flag that we've been inited
    if ($query_string =~ /=/) {
	$self->parse_params($query_string);
    } else {
	$self->{'keywords'} = [$self->parse_keywordlist($query_string)];
    }

    # Special case.  Erase everything if there is a field named
    # .defaults.
    if ($self->param('.defaults')) {
	undef %{$self};
    }

}

# Return true if we've been initialized with a query
# string.
sub inited {
    local($self) = shift;
    return $self->{'.init'};
}

sub unescape {
    local($todecode) = @_;
    $todecode =~ tr/+/ /;	# pluses become spaces
    $todecode =~ s/%(..)/pack("c",hex($1))/ge;
    return $todecode;
}

#[BII] Nobody calls this *yet*, but it ought to work right anyway...
sub escape {
    local($toencode) = @_;
    $toencode=~s/([^a-zA-Z0-9_])/sprintf("%%%x",ord($1))/eg;
    return $toencode;
}

# -------------- really private subroutines -----------------
sub parse_keywordlist {
    local($self,$tosplit) = @_;
    $tosplit = &unescape($tosplit); # unescape the keywords
    $tosplit=~tr/+/ /;		# pluses to spaces
    local(@keywords) = split(/\s+/,$tosplit);
    return @keywords;
}

sub parse_params {
    local($self,$tosplit) = @_;
    local(@pairs) = split('&',$tosplit);
    local($param,$value);
    foreach (@pairs) {
	($param,$value) = split('=');
	$param = &unescape($param);
	$value = &unescape($value);
	push (@{$self->{$param}},$value);
    }
}


1; # so that require() returns true