# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.18 1999/06/09 14:52:45 lstein Exp $';
-$CGI::VERSION='2.53';
+$CGI::revision = '$Id: CGI.pm,v 1.19 1999/08/31 17:04:37 lstein Exp $';
+$CGI::VERSION='2.56';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
$OS = 'WINDOWS';
} elsif ($OS=~/vms/i) {
$OS = 'VMS';
+} elsif ($OS=~/bsdos/i) {
+ $OS = 'UNIX';
} elsif ($OS=~/dos/i) {
$OS = 'DOS';
} elsif ($OS=~/^MacOS$/i) {
# if we get called more than once, we want to initialize
# ourselves from the original query (which may be gone
# if it was read from STDIN originally.)
- if (defined(@QUERY_PARAM) && !defined($initializer)) {
+ if (@QUERY_PARAM && !defined($initializer)) {
foreach (@QUERY_PARAM) {
$self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
}
# We now have the query string in hand. We do slightly
# different things for keyword lists and parameter lists.
- if ($query_string ne '') {
+ if (defined $query_string && $query_string) {
if ($query_string =~ /=/) {
$self->parse_params($query_string);
} else {
# unescape URL-encoded data
sub unescape {
- shift() if ref($_[0]) || $_[0] eq $DefaultClass;
+ shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
my $todecode = shift;
return undef unless defined($todecode);
$todecode =~ tr/+/ /; # pluses become spaces
# URL-encode data
sub escape {
- shift() if ref($_[0]) || $_[0] eq $DefaultClass;
- my $toencode = shift;
- return undef unless defined($toencode);
- $toencode=~s/ /+/g;
- $toencode=~s/([^a-zA-Z0-9_.+-])/uc sprintf("%%%02x",ord($1))/eg;
- return $toencode;
+ shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
+ my $toencode = shift;
+ return undef unless defined($toencode);
+ $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+ return $toencode;
}
sub save_request {
sub keywords {
my($self,@values) = self_or_default(@_);
# If values is provided, then we set it.
- $self->{'keywords'}=[@values] if defined(@values);
+ $self->{'keywords'}=[@values] if @values;
my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
@result;
}
# with Steve Brenner's cgi-lib.pl routines
'Vars' => <<'END_OF_FUNC',
sub Vars {
+ my $q = shift;
my %in;
- tie(%in,CGI);
+ tie(%in,CGI,$q);
return %in if wantarray;
return \%in;
}
'TIEHASH' => <<'END_OF_FUNC',
sub TIEHASH {
- return $Q || new CGI;
+ return $_[1] if defined $_[1];
+ return $Q || new shift;
}
END_OF_FUNC
'endform' => <<'END_OF_FUNC',
sub endform {
my($self,@p) = self_or_default(@_);
- return ($self->get_fields,"</FORM>");
+ return wantarray ? ($self->get_fields,"</FORM>") :
+ $self->get_fields ."\n</FORM>";
}
END_OF_FUNC
# rearrange into a pretty table
$result = "<TABLE>";
my($row,$column);
- unshift(@$colheaders,'') if defined(@$colheaders) && defined(@$rowheaders);
- $result .= "<TR>" if defined(@{$colheaders});
+ unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
+ $result .= "<TR>" if @$colheaders;
foreach (@{$colheaders}) {
$result .= "<TH>$_</TH>";
}
for ($row=0;$row<$rows;$row++) {
$result .= "<TR>";
- $result .= "<TH>$rowheaders->[$row]</TH>" if defined(@$rowheaders);
+ $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
for ($column=0;$column<$columns;$column++) {
$result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
if defined($elements[$column*$rows + $row]);
$name=$self->escapeHTML($name);
foreach (@value) {
- $_=$self->escapeHTML($_);
+ $_ = defined($_) ? $self->escapeHTML($_) : '';
push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
}
return wantarray ? @result : join('',@result);
# strip query string
substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
# and path
- substr($script_name,$index) = '' if $path and ($index = rindex($script_name,$path)) >= 0;
+ substr($script_name,$index) = '' if exists($ENV{PATH_INFO})
+ and ($index = rindex($script_name,$ENV{PATH_INFO})) >= 0;
} else {
$script_name = $self->script_name;
}
push(@param,'-expires'=>$expires) if $expires;
push(@param,'-secure'=>$secure) if $secure;
- return new CGI::Cookie(@param);
+ return CGI::Cookie->new(@param);
}
END_OF_FUNC
# If no filename specified, then just read the data and assign it
# to our parameter list.
- unless ($filename) {
+ if ( !defined($filename) || $filename eq '' ) {
my($value) = $buffer->readBody;
push(@{$self->{$param}},$value);
next;
for (my $cnt=10;$cnt>0;$cnt--) {
next unless $tmpfile = new TempFile($seqno);
$tmp = $tmpfile->as_string;
- last if $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES);
+ last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
$seqno += int rand(100);
}
die "CGI open of tmpfile: $!\n" unless $filehandle;
# Save some information about the uploaded file where we can get
# at it later.
- $self->{'.tmpfiles'}->{$filename}= {
+ $self->{'.tmpfiles'}->{fileno($filehandle)}= {
name => $tmpfile,
info => {%header},
};
'tmpFileName' => <<'END_OF_FUNC',
sub tmpFileName {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$filename}->{name} ?
- $self->{'.tmpfiles'}->{$filename}->{name}->as_string
+ return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
+ $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
: '';
}
END_OF_FUNC
'uploadInfo' => <<'END_OF_FUNC',
sub uploadInfo {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$filename}->{info};
+ return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
}
END_OF_FUNC
sub asString {
my $self = shift;
# get rid of package name
- (my $i = $$self) =~ s/^\*(\w+::)+//;
+ (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
$i =~ s/\\(.)/$1/g;
return $i;
# BEGIN DEAD CODE
sub new {
my($pack,$name,$file,$delete) = @_;
require Fcntl unless defined &Fcntl::O_RDWR;
- ++$FH;
- my $ref = \*{'Fh::' . quotemeta($name)};
+ my $ref = \*{'Fh::' . ++$FH . quotemeta($name)};
sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
unlink($file) if $delete;
CORE::delete $Fh::{$FH};
The file format used for save/restore is identical to that used by the
Whitehead Genome Center's data exchange format "Boulderio", and can be
manipulated and even databased using Boulderio utilities. See
-
+
http://stein.cshl.org/boulder/
for further details.
use CGI qw(-no_debug :standard);
restore_parameters(join('&',@ARGV));
-
+
See the section on debugging for more details.
=item -private_tempfiles
"Open a new frame");
<A HREF="fred.html",TARGET="_new">Open a new frame</A>
-
+
You may dispense with the dashes in front of the attribute names if
you prefer:
attribute argument was the same as providing undef. However, this has
changed in order to accommodate those who want to create tags of the form
<IMG ALT="">. The difference is shown in these two pieces of code:
-
+
CODE RESULT
img({alt=>undef}) <IMG ALT>
img({alt=>''}) <IMT ALT="">
$query = new CGI;
$query->autoEscape(undef);
-
+
=head2 CREATING AN ISINDEX TAG
startform() will return a <FORM> tag with the optional method,
action and form encoding that you specify. The defaults are:
-
+
method: POST
action: this script
enctype: application/x-www-form-urlencoded
$file = $query->upload('uploaded_file');
if (!$file && $query->cgi_error) {
- print $query->header(-status->$query->cgi_error);
+ print $query->header(-status=>$query->cgi_error);
exit 0;
}
print $query->checkbox_group(-name=>'group_name',
-values=>['eenie','meenie','minie','moe'],
-rows=2,-columns=>2);
-
+
checkbox_group() creates a list of checkboxes that are related
by the same name.
=item 2. Specify the destination for the document in the HTTP header
You may provide a B<-target> parameter to the header() method:
-
+
print $q->header(-target=>'ResultsWindow');
This will tell the browser to load the output of your script into the
for debugging purposes:
print $query->dump
-
+
Produces something that looks like:
=over 4
=item multipart_init()
-
+
multipart_init(-boundary=>$boundary);
Initialize the multipart system. The -boundary argument specifies
#!/usr/local/bin/perl
-
+
use CGI;
-
+
$query = new CGI;
print $query->header;
&do_work($query);
&print_tail;
print $query->end_html;
-
+
sub print_prompt {
my($query) = @_;
-
+
print $query->startform;
print "<EM>What's your name?</EM><BR>";
print $query->textfield('name');
print $query->checkbox('Not my real name');
-
+
print "<P><EM>Where can you find English Sparrows?</EM><BR>";
print $query->checkbox_group(
-name=>'Sparrow locations',
-values=>[England,France,Spain,Asia,Hoboken],
-linebreak=>'yes',
-defaults=>[England,Asia]);
-
+
print "<P><EM>How far can they fly?</EM><BR>",
$query->radio_group(
-name=>'how far',
-values=>['10 ft','1 mile','10 miles','real far'],
-default=>'1 mile');
-
+
print "<P><EM>What's your favorite color?</EM> ";
print $query->popup_menu(-name=>'Color',
-values=>['black','brown','red','yellow'],
-default=>'red');
-
+
print $query->hidden('Reference','Monty Python and the Holy Grail');
-
+
print "<P><EM>What have you got there?</EM><BR>";
print $query->scrolling_list(
-name=>'possessions',
'A Sword','A Ticket'],
-size=>5,
-multiple=>'true');
-
+
print "<P><EM>Any parting comments?</EM><BR>";
print $query->textarea(-name=>'Comments',
-rows=>10,
-columns=>50);
-
- print "<P>",$query->Reset;
+
+ print "<P>",$query->reset;
print $query->submit('Action','Shout');
print $query->submit('Action','Scream');
print $query->endform;
print "<HR>\n";
}
-
+
sub do_work {
my($query) = @_;
my(@values,$key);
print join(", ",@values),"<BR>\n";
}
}
-
+
sub print_tail {
print <<END;
<HR>
projects / p5sagit/p5-mst-13.2.git / blobdiff