section.
As a shortcut, as of version 1.56 you can interpolate the entire
CGI object into a string and it will be replaced with the
the a nice HTML dump shown above:
$query=new CGI;
print "Current Values
$query\n";
=head1 FETCHING ENVIRONMENT VARIABLES
Some of the more useful environment variables can be fetched
through this interface. The methods are as follows:
=item B
Return a list of MIME types that the remote browser
accepts. If you give this method a single argument
corresponding to a MIME type, as in
$query->accept('text/html'), it will return a
floating point value corresponding to the browser's
preference for this type from 0.0 (don't want) to 1.0.
Glob types (e.g. text/*) in the browser's accept list
are handled correctly.
=item B
Returns the HTTP_USER_AGENT variable. If you give
this method a single argument, it will attempt to
pattern match on it, allowing you to do something
like $query->user_agent(netscape);
=item B
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".
=item B
As per path_info() but returns the additional
path information translated into a physical path, e.g.
"/usr/local/etc/httpd/htdocs/additional/stuff".
=item B
Returns either the remote host name or IP address.
if the former is unavailable.
=item B
Return the script name as a partial URL, for self-refering
scripts.
=item B
Return the URL of the page the browser was viewing
prior to fetching your script. Not available for all
browsers.
=head1 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
=head1 CREDITS
Thanks very much to:
=over 4
=item Matt Heffron (heffron@falstaff.css.beckman.com)
=item James Taylor (james.taylor@srs.gov)
=item Scott Anguish
=item Mike Jewell (mlj3u@virginia.edu)
=item Timothy Shimmin (tes@kbs.citri.edu.au)
=item Joergen Haegg (jh@axis.se)
=item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
=item Richard Resnick (applepi1@aol.com)
=item Craig Bishop (csb@barwonwater.vic.gov.au)
=item Tony Curtis (tony@Relay1.Austria.EU.net)
=item ...and many many more...
for suggestions and bug fixes.
=back
=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
#!/usr/local/bin/perl
use CGI;
$query = new CGI;
print $query->header;
print $query->start_html("Example CGI.pm Form");
print " Example CGI.pm Form
\n";
&print_prompt($query);
&do_work($query);
&print_tail;
print $query->end_html;
sub print_prompt {
my($query) = @_;
print $query->startform;
print "What's your name?
";
print $query->textfield('name');
print $query->checkbox('Not my real name');
print "Where can you find English Sparrows?
";
print $query->checkbox_group('Sparrow locations',
[England,France,Spain,Asia,Hoboken],
[England,Asia]);
print "
How far can they fly?
",
$query->radio_group('how far',
['10 ft','1 mile','10 miles','real far'],
'1 mile');
print "
What's your favorite color? ";
print $query->popup_menu('Color',['black','brown','red','yellow'],'red');
print $query->hidden('Reference','Monty Python and the Holy Grail');
print "
What have you got there? ";
print $query->scrolling_list('possessions',
['A Coconut','A Grail','An Icon',
'A Sword','A Ticket'],
undef,
10,
'true');
print "
Any parting comments?
";
print $query->textarea('Comments',undef,10,50);
print "
",$query->reset;
print $query->submit('Action','Shout');
print $query->submit('Action','Scream');
print $query->endform;
print "
\n";
}
sub do_work {
my($query) = @_;
my(@values,$key);
print "Here are the current settings in this form
";
foreach $key ($query->param) {
print "$key -> ";
@values = $query->param($key);
print join(", ",@values),"
\n";
}
}
sub print_tail {
print <
Lincoln D. Stein
Home Page
END
}
=head1 BUGS
This module has grown large and monolithic. Furthermore it's doing many
things, such as handling URLs, parsing CGI input, writing HTML, etc., that
should be done in separate modules. It should be discarded in favor of
the CGI::* modules, but somehow I continue to work on it.
It does not handle the tag introduced in Netscape 2.0.
In fact, it's probable that it never will.
=head1 SEE ALSO
L, L, L, L, L
=cut
# ------------------ START OF THE LIBRARY ------------
%OVERLOAD = ('""'=>'as_string');
#### Method: new
# The new routine. This will check the current environment
# for an existing query string, and initialize itself, if so.
####
sub new {
my($class,$filehandle) = @_;
my($IN);
if ($filehandle) {
my($package) = caller;
$IN="$package\:\:$filehandle"; # force into caller's package
}
my $self = {};
bless $self;
$self->initialize($IN);
return $self;
}
#### Method: autoescape
# If you won't to turn off the autoescaping features,
# call this method with undef as the argument
####
sub autoEscape {
my($self,$escape) = @_;
$self->{'dontescape'}=!$escape;
}
#### Method: param
# Returns the value(s)of a named parameter.
# If invoked in a list context, returns the
# entire list. Otherwise returns the first
# member of the list.
# If name is not provided, return a list of all
# the known parameters names available.
# If more than one argument is provided, the
# second and subsequent arguments are used to
# set the value of the parameter.
####
sub param {
my($self,$name,@values) = @_;
return $self->all_parameters unless $name;
# If values is provided, then we set it.
if (@values) {
$self->add_parameter($name);
$self->{$name}=[@values];
}
return () unless $self->{$name};
return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
}
#### Method: import
# Import all parameters into the given namespace.
# Assumes namespace 'Q' if not specified
####
sub import_names {
my($self,$namespace) = @_;
$namespace = 'Q' unless defined($namespace);
die "Can't import names into 'main'\n"
if $namespace eq 'main';
my($param,@value,$var);
foreach $param ($self->param) {
# protect against silly names
$param=~tr/a-zA-Z0-9_/_/c;
$var = "${namespace}::$param";
@value = $self->param($param);
@{$var} = @value;
${$var} = $value[$#value];
}
}
sub import {
import_names(@_);
}
#### Method: delete
# Deletes the named parameter entirely.
####
sub delete {
my($self,$name) = @_;
delete $self->{$name};
@{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
return wantarray ? () : undef;
}
#### 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;
my(@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);
return unless $self->param;
push(@result,"");
foreach $param ($self->param) {
my($name)=$self->escapeHTML($param);
push(@result,"- $param");
push(@result,"
");
foreach $value ($self->param($param)) {
$value = $self->escapeHTML($value);
push(@result,"- $value");
}
push(@result,"
");
}
push(@result,"
\n");
return join("\n",@result);
}
#### Method as_string
#
# synonym for "dump"
####
sub as_string {
&dump;
}
#### Method: save
# Write values out to a filehandle in such a way that they can
# be reinitialized by the filehandle form of the new() method
####
sub save {
my($self,$filehandle) = @_;
my($param);
my($package) = caller;
$filehandle = "$package\:\:$filehandle";
foreach $param ($self->param) {
my($escaped_param) = &escape($param);
my($value);
foreach $value ($self->param($param)) {
print $filehandle "$escaped_param=",escape($value),"\n";
}
}
}
#### Method: header
# Return a Content-type: style header
#
####
sub header {
my($self,$type,$status,$msg) = @_;
$type = $type || 'text/html';
my $header;
if ($status) {
$header = sprintf("Status: %3d %s\r\n",$status,$msg);
}
$header .= "Pragma: no-cache\r\n";
$header .= "Content-type: $type\r\n\r\n";
return $header;
}
#### Method: redirect
# Return a Location: style header
#
####
sub redirect {
my($self,$url) = @_;
$url = $url || $self->self_url;
return "Location: $url\r\n\r\n";
}
#### Method: start_html
# Canned HTML header
#
# Parameters:
# $title -> (optional) The title for this HTML document
# $author -> (optional) e-mail address of the author
# $base -> (option) if set to true, will enter the BASE address of this document
# for resolving relative references.
# @other -> (option) any parameters you'd like to incorporate into
# the tag
####
sub start_html {
my($self,$title,$author,$base,@other_stuff) = @_;
# strangely enough, the title needs to be escaped as HTML
# while the author needs to be escaped as a URL
$title = $self->escapeHTML($title || 'Untitled Document');
$author = $self->escapeHTML($author);
my(@result);
push(@result,"$title ");
push(@result,"") if $author;
push(@result," server_name.":".$self->server_port.$self->script_name."\">") if $base;
push(@result,"");
return join("\n",@result);
}
#### Method: end_html
# End an HTML document.
# Trivial method for completeness. Just returns ""
####
sub end_html {
return "";
}
################################
# METHODS USED IN BUILDING FORMS
################################
#### Method: isindex
# Just prints out the isindex tag.
# Parameters:
# $action -> optional URL of script to run
# Returns:
# A string containing a tag
sub isindex {
my($self,$action) = @_;
$action = qq/ACTION="$action"/ if $action;
return " ";
}
#### Method: startform
# Start a form
sub startform {
my($self,$method,$action) = @_;
$method = $method || 'POST';
$action = defined($action)? qq/ACTION="$action"/ : '';
return qq/\n";
}
#### Method: textfield
# Parameters:
# $name -> Name of the text field
# $default -> Optional default value of the field if not
# already defined.
# $size -> Optional width of field in characaters.
# $maxlength -> Optional maximum number of characters.
# Returns:
# A string containing a field
#
sub textfield {
my($self,$name,$default,$size,$maxlength) = @_;
my($current) = defined($self->param($name)) ? $self->param($name) : $default;
$current = $self->escapeHTML($current);
$name = $self->escapeHTML($name);
my($s) = defined($size) ? qq/SIZE=$size/ : '';
my($m) = defined($maxlength) ? qq/MAXLENGTH=$maxlength/ : '';
return qq//;
}
#### Method: password
# Create a "secret password" entry field
# Parameters:
# $name -> Name of the field
# $default -> Optional default value of the field if not
# already defined.
# $size -> Optional width of field in characters.
# $maxlength -> Optional maximum characters that can be entered.
# Returns:
# A string containing a field
#
sub password_field {
my($self,$name,$default,$size,$maxlength)=@_;
my($current) = defined($self->param($name)) ? $self->param($name) : $default;
$name=$self->escapeHTML($name);
$current=$self->escapeHTML($current);
my($s) = defined($size) ? qq/SIZE=$size/ : '';
my($m) = defined($maxlength) ? qq/MAXLENGTH=$maxlength/ : '';
return qq//;
}
#### Method: textarea
# Parameters:
# $name -> Name of the text field
# $default -> Optional default value of the field if not
# already defined.
# $rows -> Optional number of rows in text area
# $columns -> Optional number of columns in text area
# Returns:
# A string containing a tag
#
sub textarea {
my($self,$name,$default,$rows,$cols)=@_;
my($current)= defined($self->param($name)) ? $self->param($name) : $default;
$name=$self->escapeHTML($name);
$current=$self->escapeHTML($current);
my($r) = "ROWS=$rows" if $rows;
my($c) = "COLS=$cols" if $cols;
return <$current
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 tag
####
sub submit {
my($self,$label,$value) = @_;
$label=$self->escapeHTML($label);
$value=$self->escapeHTML($value);
my($name) = qq/NAME="$label"/ if $label;
$value = $value || $label;
my($val) = qq/VALUE="$value"/ if $value;
return qq//;
}
#### Method: reset
# Create a "reset" button.
# Parameters:
# $label -> (optional) Name for the button.
# Returns:
# A string containing a tag
####
sub reset {
my($self,$label) = @_;
$label=$self->escapeHTML($label);
my($value) = $label ? qq/VALUE="$label"/ : '';
return qq//;
}
#### Method: defaults
# Create a "defaults" button.
# Parameters:
# $label -> (optional) Name for the button.
# Returns:
# A string containing a tag
#
# Note: this button has a special meaning to the initialization script,
# and tells it to ERASE the current query string so that your defaults
# are used again!
####
sub defaults {
my($self,$label) = @_;
$label=$self->escapeHTML($label);
$label = $label || "Defaults";
my($value) = qq/VALUE="$label"/;
return qq//;
}
#### Method: checkbox
# Create a checkbox that is not logically linked to any others.
# The field value is "on" when the button is checked.
# Parameters:
# $name -> Name of the checkbox
# $checked -> (optional) turned on by default if true
# $value -> (optional) value of the checkbox, 'on' by default
# $label -> (optional) a user-readable label printed next to the box.
# Otherwise the checkbox name is used.
# Returns:
# A string containing a field
####
sub checkbox {
my($self,$name,$checked,$value,$label)=@_;
if ($self->inited) {
$checked = $self->param($name) ? 'CHECKED' : '';
$value = $self->param($name) || $value || 'on';
} else {
$checked = defined($checked) ? 'CHECKED' : '';
$value = $value || 'on';
}
my($the_label) = $label || $name;
$name = $self->escapeHTML($name);
$value = $self->escapeHTML($value);
$the_label = $self->escapeHTML($the_label);
return <$the_label
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.
# $labels -> (optional)
# A pointer to an associative array of labels to print next to each checkbox
# in the form $label{'value'}="Long explanatory label".
# Otherwise the provided values are used as the labels.
# Returns:
# A string containing a series of fields
####
sub checkbox_group {
my($self,$name,$values,$defaults,$linebreak,$labels)=@_;
my(%checked,$checked,$break,$result,$label);
if ($self->inited) {
grep($checked{$_}++,$self->param($name));
} elsif (defined($defaults)) {
grep($checked{$_}++,@$defaults) if ref($defaults)
&& ref($defaults) eq 'ARRAY';
$checked{$defaults}++ unless ref($defaults);
}
$break = $linebreak ? "
" : '';
$name=$self->escapeHTML($name);
foreach (@{$values}) {
$checked = $checked{$_} ? 'CHECKED' : '';
$label = $_;
$label = $labels->{$_} if defined($labels) && $labels->{$_};
$label = $self->escapeHTML($label);
$_ = $self->escapeHTML($_);
$result .=
qq/$label $break/;
}
return $result;
}
#### Method: radio_group
# Create a list of logically-linked radio buttons.
# Parameters:
# $name -> Common name for all the buttons.
# $values -> A pointer to a regular array containing the
# values for each button in the group.
# $default -> (optional) Value of the button to turn on by default. Pass '-'
# to turn _nothing_ on.
# $linebreak -> (optional) Set to true to place linebreaks
# between the buttons.
# $labels -> (optional)
# A pointer to an associative array of labels to print next to each checkbox
# in the form $label{'value'}="Long explanatory label".
# Otherwise the provided values are used as the labels.
# Returns:
# A string containing a series of fields
####
sub radio_group {
my($self,$name,$values,$default,$linebreak,$labels)=@_;
my($result,$checked);
if (defined($self->param($name))) {
$checked = $self->param($name);
} else {
$checked = $default;
}
# If no check array is specified, check the first by default
$checked = $values->[0] unless $checked;
$name=$self->escapeHTML($name);
foreach (@{$values}) {
my($checkit) = $checked eq $_ ? 'CHECKED' : '';
my($break) = $linebreak ? '
' : '';
my($label) = $_;
$label = $labels->{$_} if defined($labels) && $labels->{$_};
$label = $self->escapeHTML($label);
$_=$self->escapeHTML($_);
$result .= qq/$label $break/;
}
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
# $labels -> (optional)
# A pointer to an associative array of labels to print next to each checkbox
# in the form $label{'value'}="Long explanatory label".
# Otherwise the provided values are used as the labels.
# Returns:
# A string containing the definition of a popup menu.
####
sub popup_menu {
my($self,$name,$values,$default,$labels)=@_;
my($result,$selected);
if (defined($self->param($name))) {
$selected = $self->param($name);
} else {
$selected = $default;
}
$name=$self->escapeHTML($name);
$result = qq/\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.
# $labels -> (optional)
# A pointer to an associative array of labels to print next to each checkbox
# in the form $label{'value'}="Long explanatory label".
# Otherwise the provided values are used as the labels.
# Returns:
# A string containing the definition of a scrolling list.
####
sub scrolling_list {
my($self,$name,$values,$default,$size,$multiple,$labels)=@_;
my($result,%selected);
$size = $size || scalar(@{$values});
if (defined($self->param($name))) {
grep($selected{$_}++,$self->param($name));
} elsif (ref($default) eq 'ARRAY') {
grep($selected{$_}++,@{$default});
} else {
$selected{$default}++;
}
my($is_multiple) = $multiple ? 'MULTIPLE' : '';
my($has_size) = $size ? "SIZE=$size" : '';
$name=$self->escapeHTML($name);
$result = qq/\n";
return $result;
}
#### Method: hidden
# Parameters:
# $name -> Name of the hidden field
# @default -> (optional) Initial values of field (may be an array)
# Returns:
# A string containing a
####
sub hidden {
my($self,$name,@default)=@_;
my(@result,@value);
if (@default) {
@value = @default;
} else {
@value = $self->param($name);
}
$name=$self->escapeHTML($name);
foreach (@value) {
$_=$self->escapeHTML($_);
push(@result,qq//);
}
return join("\n",@result);
}
#### Method: image_button
# Parameters:
# $name -> Name of the button
# $src -> URL of the image source
# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
# Returns:
# A string containing a
####
sub image_button {
my($self,$name,$src,$alignment)=@_;
my($align) = "ALIGN=\U$alignment" if $alignment;
$name=$self->escapeHTML($name);
return qq//;
}
#### Method: self_url
# Returns a URL containing the current script and all its
# param/value pairs arranged as a query. You can use this
# to create a link that, when selected, will reinvoke the
# script with all its state information preserved.
####
sub self_url {
my($self) = @_;
my($query_string) = $self->query_string;
my $name = "http://" . $self->server_name;
$name .= ":" . $self->server_port
unless $self->server_port == 80;
$name .= $self->script_name;
$name .= $self->path_info if $self->path_info;
return $name unless $query_string;
return "$name?$query_string";
}
# This is provided as a synonym to self_url() for people unfortunate
# enough to have incorporated it into their programs already!
sub state {
&self_url;
}
###############################################
# 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: query_string
# Synthesize a query string from our current
# parameters
####
sub query_string {
my $self = shift;
my($param,$value,@pairs);
foreach $param ($self->param) {
$param = &escape($param);
foreach $value ($self->param($param)) {
$value = &escape($value);
push(@pairs,"$param=$value");
}
}
return join("&",@pairs);
}
#### Method: accept
# Without parameters, returns an array of the
# MIME types the browser accepts.
# With a single parameter equal to a MIME
# type, will return undef if the browser won't
# accept it, 1 if the browser accepts it but
# doesn't give a preference, or a floating point
# value between 0.0 and 1.0 if the browser
# declares a quantitative score for it.
# This handles MIME type globs correctly.
####
sub accept {
my($self,$search) = @_;
my(%prefs,$type,$pref,$pat);
my(@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: user_agent
# If called with no parameters, returns the user agent.
# If called with one parameter, does a pattern match (case
# insensitive) on the user agent.
####
sub user_agent {
my($self,$match)=@_;
return $ENV{'HTTP_USER_AGENT'} unless $match;
return ($ENV{'HTTP_USER_AGENT'} =~ /$match/i);
}
#### 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'}
|| 'dummy.remote.host';
}
#### Method: remote_addr
# Return the IP addr of the remote host.
####
sub remote_addr {
return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
}
#### Method: script_name
# Return the partial URL to this script for
# self-referencing scripts. Also see
# self_url(), which returns a URL with all state information
# preserved.
####
sub script_name {
return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'};
# These are for debugging
return "/$0" unless $0=~/^\//;
return $0;
}
#### Method: referer
# Return the HTTP_REFERER: useful for generating
# a GO BACK button.
####
sub referer {
return $ENV{'HTTP_REFERER'};
}
#### Method: server_name
# Return the name of the server
####
sub server_name {
return $ENV{'SERVER_NAME'} || 'dummy.host.name';
}
#### Method: server_port
# Return the tcp/ip port the server is running on
####
sub server_port {
return $ENV{'SERVER_PORT'} || 80; # for debugging
}
#### Method: remote_ident
# Return the identity of the remote user
# (but only if his host is running identd)
####
sub remote_ident {
return $ENV{'REMOTE_IDENT'};
}
#### Method: auth_type
# Return the type of use verification/authorization in use, if any.
####
sub auth_type {
return $ENV{'AUTH_TYPE'};
}
#### Method: remote_user
# Return the authorization name used for user
# verification.
####
sub remote_user {
return $ENV{'REMOTE_USER'};
}
########################################
# 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 {
my($self,$filehandle) = @_;
my($query_string,$meth,@lines);
if (defined($QUERY_STRING) && !$filehandle) {
$query_string = $QUERY_STRING;
} else {
$meth=$ENV{'REQUEST_METHOD'};
# If filehandle is defined, then read parameters
# from it.
if ($filehandle) {
chomp(@lines = <$filehandle>);
# massage back into standard format
if ("@lines" =~ /=/) {
$query_string=join("&",@lines);
} else {
$query_string=join("+",@lines);
}
# If method is GET or HEAD, fetch the query from
# the environment.
} elsif ($meth=~/^(GET|HEAD)$/) {
$query_string = $ENV{'QUERY_STRING'};
# If the method is POST, fetch the query from standard
# input.
} elsif ($meth eq 'POST') {
$query_string =''; # hack to avoid 'uninitialized variable' warnings
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.
# We use the shellwords package in order to behave the way that
# UN*X programmers expect.
} else {
require "shellwords.pl";
my($input,@words);
if (@ARGV) {
$input = join(" ",@ARGV);
} else {
warn "(waiting for standard input)\n";
chomp(@lines = <>); # remove newlines
$input = join(" ",@lines);
}
# minimal handling of escape characters
$input=~s/\\=/%3D/g;
$input=~s/\\&/%26/g;
@words = &shellwords($input);
if ("@words"=~/=/) {
$query_string = join('&',@words);
} else {
$query_string = join('+',@words);
}
}
}
# We're going to play with the package globals now so that if we get called
# again, we initialize ourselves in exactly the same way. This allows
# us to have several of these objects.
$QUERY_STRING = $query_string;
# 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->add_parameter('keywords');
$self->{'keywords'} = [$self->parse_keywordlist($query_string)];
}
# Special case. Erase everything if there is a field named
# .defaults.
if ($self->param('.defaults')) {
undef %{$self};
}
}
# Return true if we've been initialized with a query
# string.
sub inited {
my($self) = shift;
return $self->{'.init'};
}
sub unescape {
my($todecode) = @_;
$todecode =~ tr/+/ /; # pluses become spaces
$todecode =~ s/%([0-9a-hA-H]{2})/pack("c",hex($1))/ge;
return $todecode;
}
#[BII] Nobody calls this *yet*, but it ought to work right anyway...
sub escape {
my($toencode) = @_;
$toencode=~s/([^a-zA-Z0-9_])/uc sprintf("%%%02x",ord($1))/eg;
return $toencode;
}
# Escape HTML -- used internally
sub escapeHTML {
my($self,$toencode) = @_;
return undef unless defined($toencode);
return $toencode if $self->{'dontescape'};
$toencode=~s/&/&/g;
$toencode=~s/\"/"/g;
$toencode=~s/>/>/g;
$toencode=~s/</g;
return $toencode;
}
# -------------- really private subroutines -----------------
sub parse_keywordlist {
my($self,$tosplit) = @_;
$tosplit = &unescape($tosplit); # unescape the keywords
$tosplit=~tr/+/ /; # pluses to spaces
my(@keywords) = split(/\s+/,$tosplit);
return @keywords;
}
sub parse_params {
my($self,$tosplit) = @_;
my(@pairs) = split('&',$tosplit);
my($param,$value);
foreach (@pairs) {
($param,$value) = split('=');
$param = &unescape($param);
$value = &unescape($value);
$self->add_parameter($param);
push (@{$self->{$param}},$value);
}
}
sub add_parameter {
my($self,$param)=@_;
push (@{$self->{'.parameters'}},$param)
unless defined($self->{$param});
}
sub all_parameters {
my($self) = @_;
return () unless $self->{'.parameters'};
return () unless @{$self->{'.parameters'}};
return @{$self->{'.parameters'}};
}
1; # so that require() returns true