<HR>
<MENU>
<LI> <A HREF="../cgi_docs.html">CGI.pm documentation</A>
- <LI> <A HREF="../../CGI.pm.tar.gz">Download the CGI.pm distribution</A>
+ <LI> <A HREF="../CGI.pm.tar.gz">Download the CGI.pm distribution</A>
</MENU>
<HR>
<ADDRESS>Lincoln D. Stein, lstein@genome.wi.mit.edu<br>
<a href="/">Whitehead Institute/MIT Center for Genome Research</a></ADDRESS>
<!-- hhmts start -->
-Last modified: Tue Nov 24 18:07:15 MET 1998
+Last modified: Wed Jun 23 15:31:47 EDT 1999
<!-- hhmts end -->
</BODY> </HTML>
# 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) {
# 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 {
# 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
$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;
}
# 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};
$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;
}
-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;
-package CGI::Apache;
-use Apache ();
-use vars qw(@ISA $VERSION);
-require CGI;
-@ISA = qw(CGI);
-
-$VERSION = (qw$Revision: 1.1 $)[1];
-$CGI::DefaultClass = 'CGI::Apache';
-$CGI::Apache::AutoloadClass = 'CGI';
-
-sub import {
- my $self = shift;
- my ($callpack, $callfile, $callline) = caller;
- ${"${callpack}::AutoloadClass"} = 'CGI';
-}
-
-sub new {
- my($class) = shift;
- my($r) = Apache->request;
- %ENV = $r->cgi_env unless defined $ENV{GATEWAY_INTERFACE}; #PerlSetupEnv On
- my $self = $class->SUPER::new(@_);
- $self->{'.req'} = $r;
- $self;
-}
-
-sub header {
- my ($self,@rest) = CGI::self_or_default(@_);
- my $r = $self->{'.req'};
- $r->basic_http_header;
- return CGI::header($self,@rest);
-}
-
-sub print {
- my($self,@rest) = CGI::self_or_default(@_);
- $self->{'.req'}->print(@rest);
-}
-
-sub read_from_client {
- my($self, $fh, $buff, $len, $offset) = @_;
- my $r = $self->{'.req'} || Apache->request;
- return $r->read($$buff, $len, $offset);
-}
-
-sub new_MultipartBuffer {
- my $self = shift;
- my $new = CGI::Apache::MultipartBuffer->new($self, @_);
- $new->{'.req'} = $self->{'.req'} || Apache->request;
- return $new;
-}
-
-package CGI::Apache::MultipartBuffer;
-use vars qw(@ISA);
-@ISA = qw(MultipartBuffer);
-
-$CGI::Apache::MultipartBuffer::AutoloadClass = 'MultipartBuffer';
-*CGI::Apache::MultipartBuffer::read_from_client =
- \&CGI::Apache::read_from_client;
-
-
+use CGI;
1;
-
__END__
=head1 NAME
-CGI::Apache - Make things work with CGI.pm against Perl-Apache API
+CGI::Apache - Backward compatibility module for CGI.pm
=head1 SYNOPSIS
- require CGI::Apache;
-
- my $q = new Apache::CGI;
+Do not use this module. It is deprecated.
- $q->print($q->header);
-
- #do things just like you do with CGI.pm
+=head1 ABSTRACT
=head1 DESCRIPTION
-When using the Perl-Apache API, your applications are faster, but the
-environment is different than CGI.
-This module attempts to set-up that environment as best it can.
-
-=head1 NOTE 1
+=head1 AUTHOR INFORMATION
-This module used to be named Apache::CGI. Sorry for the confusion.
-
-=head1 NOTE 2
-
-If you're going to inherit from this class, make sure to "use" it
-after your package declaration rather than "require" it. This is
-because CGI.pm does a little magic during the import() step in order
-to make autoloading work correctly.
+=head1 BUGS
=head1 SEE ALSO
-perl(1), Apache(3), CGI(3)
-
-=head1 AUTHOR
-
-Doug MacEachern E<lt>dougm@osf.orgE<gt>, hacked over by Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt>
-
=cut
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
-$CGI::Cookie::VERSION='1.10';
+$CGI::Cookie::VERSION='1.12';
-use CGI;
+use CGI qw(-no_debug);
use overload '""' => \&as_string,
'cmp' => \&compare,
'fallback'=>1;
},$class;
# IE requires the path and domain to be present for some reason.
- $path ||= CGI::url(-absolute=>1);
- $domain ||= CGI::virtual_host();
+ $path = CGI::url(-absolute=>1) unless defined $path;
+# however, this breaks networks which use host tables without fully qualified
+# names, so we comment it out.
+# $domain = CGI::virtual_host() unless defined $domain;
- $self->path($path) if defined $path;
+ $self->path($path) if defined $path;
$self->domain($domain) if defined $domain;
$self->secure($secure) if defined $secure;
$self->expires($expires) if defined $expires;
if you specify the path "/cgi-bin", then the cookie will be returned
to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and
"/cgi-bin/customer_service/complain.pl", but not to the script
-"/cgi-private/site_admin.pl". By default, the path is set to the
-directory that contains your script.
+"/cgi-private/site_admin.pl". By default, the path is set to your
+script, so that only it will receive the cookie.
=item B<4. secure flag>
# documentation in manual or html file format (these utilities are part of the
# Perl 5 distribution).
+use strict;
use CGI ();
-$VERSION = '1.0';
+$CGI::Pretty::VERSION = '1.03';
$CGI::DefaultClass = __PACKAGE__;
-$AutoloadClass = 'CGI';
-@ISA = 'CGI';
+$CGI::Pretty::AutoloadClass = 'CGI';
+@CGI::Pretty::ISA = qw( CGI );
-# These tags should not be prettify'd. If we did prettify them, the
-# browser would output text that would have extraneous spaces
-@AS_IS = qw( A PRE );
-my $NON_PRETTIFY_ENDTAGS = join "", map { "</$_>" } @AS_IS;
+initialize_globals();
+
+sub _prettyPrint {
+ my $input = shift;
+
+ foreach my $i ( @CGI::Pretty::AS_IS ) {
+ if ( $$input =~ /<\/$i>/si ) {
+ my ( $a, $b, $c, $d, $e ) = $$input =~ /(.*)<$i(\s?)(.*?)>(.*?)<\/$i>(.*)/si;
+ _prettyPrint( \$a );
+ _prettyPrint( \$e );
+
+ $$input = "$a<$i$b$c>$d</$i>$e";
+ return;
+ }
+ }
+ $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g;
+}
+
+sub comment {
+ my($self,@p) = CGI::self_or_CGI(@_);
+
+ my $s = "@p";
+ $s =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g;
+
+ return $self->SUPER::comment( "$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT$s$CGI::Pretty::LINEBREAK" ) . $CGI::Pretty::LINEBREAK;
+}
sub _make_tag_func {
my ($self,$tagname) = @_;
return $self->SUPER::_make_tag_func($tagname) if $tagname=~/^(start|end)_/;
+ # As Lincoln as noted, the last else clause is VERY hairy, and it
+ # took me a while to figure out what I was trying to do.
+ # What it does is look for tags that shouldn't be indented (e.g. PRE)
+ # and makes sure that when we nest tags, those tags don't get
+ # indented.
+ # For an example, try print td( pre( "hello\nworld" ) );
+ # If we didn't care about stuff like that, the code would be
+ # MUCH simpler. BTW: I won't claim to be a regular expression
+ # guru, so if anybody wants to contribute something that would
+ # be quicker, easier to read, etc, I would be more than
+ # willing to put it in - Brian
+
return qq{
sub $tagname {
# handle various cases in which we're called
# most of this bizarre stuff is to avoid -w errors
shift if \$_[0] &&
-# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
+ (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
(ref(\$_[0]) &&
(substr(ref(\$_[0]),0,3) eq 'CGI' ||
UNIVERSAL::isa(\$_[0],'CGI')));
return \$tag unless \@_;
my \@result;
- if ( "$NON_PRETTIFY_ENDTAGS" =~ /\$untag/ ) {
- \@result = map { "\$tag\$_\$untag\\n" }
+ my \$NON_PRETTIFY_ENDTAGS = join "", map { "</\$_>" } \@CGI::Pretty::AS_IS;
+
+ if ( \$NON_PRETTIFY_ENDTAGS =~ /\$untag/ ) {
+ \@result = map { "\$tag\$_\$untag\$CGI::Pretty::LINEBREAK" }
(ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
}
else {
\@result = map {
chomp;
if ( \$_ !~ /<\\// ) {
- s/\\n/\\n /g;
+ s/\$CGI::Pretty::LINEBREAK/\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT/g;
}
else {
- my \$text = "";
- my ( \$pretag, \$thistag, \$posttag );
- while ( /<\\/.*>/si ) {
- if ( (\$pretag, \$thistag, \$posttag ) =
- /(.*?)<(.*?)>(.*)/si ) {
- \$pretag =~ s/\\n/\\n /g;
- \$text .= "\$pretag<\$thistag>";
-
- ( \$thistag ) = split ' ', \$thistag;
- my \$endtag = "</" . uc(\$thistag) . ">";
- if ( "$NON_PRETTIFY_ENDTAGS" =~ /\$endtag/ ) {
- if ( ( \$pretag, \$posttag ) =
- \$posttag =~ /(.*?)\$endtag(.*)/si ) {
- \$text .= "\$pretag\$endtag";
- }
- }
-
- \$_ = \$posttag;
- }
- }
- \$_ = \$text;
- if ( defined \$posttag ) {
- \$posttag =~ s/\\n/\\n /g;
- \$_ .= \$posttag;
- }
+ my \$tmp = \$_;
+ CGI::Pretty::_prettyPrint( \\\$tmp );
+ \$_ = \$tmp;
}
- "\$tag\\n \$_\\n\$untag\\n" }
+ "\$tag\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT\$_\$CGI::Pretty::LINEBREAK\$untag\$CGI::Pretty::LINEBREAK" }
(ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
}
+ local \$" = "";
return "\@result";
}
};
}
+sub start_html {
+ return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK;
+}
+
+sub end_html {
+ return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK;
+}
+
sub new {
my $class = shift;
my $this = $class->SUPER::new( @_ );
+ Apache->request->register_cleanup(\&CGI::Pretty::_reset_globals) if ($CGI::MOD_PERL);
+ $class->_reset_globals if $CGI::PERLEX;
+
return bless $this, $class;
}
+sub initialize_globals {
+ # This is the string used for indentation of tags
+ $CGI::Pretty::INDENT = "\t";
+
+ # This is the string used for seperation between tags
+ $CGI::Pretty::LINEBREAK = "\n";
+
+ # These tags are not prettify'd.
+ @CGI::Pretty::AS_IS = qw( A PRE CODE SCRIPT TEXTAREA );
+
+ 1;
+}
+sub _reset_globals { initialize_globals(); }
+
1;
=head1 NAME
push @CGI::Pretty::AS_IS,qw(CODE XMP);
+=head2 Customizing the Indenting
+
+If you wish to have your own personal style of indenting, you can change the
+C<$INDENT> variable:
+
+ $CGI::Pretty::INDENT = "\t\t";
+
+would cause the indents to be two tabs.
+
+Similarly, if you wish to have more space between lines, you may change the
+C<$LINEBREAK> variable:
+
+ $CGI::Pretty::LINEBREAK = "\n\n";
+
+would create two carriage returns between lines.
+
+If you decide you want to use the regular CGI indenting, you can easily do
+the following:
+
+ $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
+
=head1 BUGS
This section intentionally left blank.
=head1 AUTHOR
-Brian Paulsen <bpaulsen@lehman.com>, with minor modifications by
+Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by
Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm
distribution.
-Copyright 1998, Brian Paulsen. All rights reserved.
+Copyright 1999, Brian Paulsen. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-Bug reports and comments to bpaulsen@lehman.com. You can also write
+Bug reports and comments to Brian@ThePaulsens.com. You can also write
to lstein@cshl.org, but this code looks pretty hairy to me and I'm not
sure I understand it!
L<CGI>
=cut
-
-package CGI::Switch;
-use Carp;
-use strict;
-use vars qw($VERSION @Pref);
-$VERSION = '0.06';
-@Pref = qw(CGI::Apache CGI); #default
-
-sub import {
- my($self,@arg) = @_;
- @Pref = @arg if @arg;
-}
-
-sub new {
- shift;
- my($file,$pack);
- for $pack (@Pref) {
- ($file = $pack) =~ s|::|/|g;
- eval { require "$file.pm"; };
- if ($@) {
-#XXX warn $@;
- next;
- } else {
-#XXX warn "Going to try $pack\->new\n";
- my $obj;
- eval {$obj = $pack->new(@_)};
- if ($@) {
-#XXX warn $@;
- } else {
- return $obj;
- }
- }
- }
- Carp::croak "Couldn't load+construct any of @Pref\n";
-}
-
+use CGI;
1;
+
__END__
=head1 NAME
-CGI::Switch - Try more than one constructors and return the first object available
+CGI::Switch - Backward compatibility module for defunct CGI::Switch
=head1 SYNOPSIS
-
- use CGISwitch;
-
- -or-
+Do not use this module. It is deprecated.
- use CGI::Switch This, That, CGI::XA, Foo, Bar, CGI;
-
- my $q = new CGI::Switch;
+=head1 ABSTRACT
=head1 DESCRIPTION
-Per default the new() method tries to call new() in the three packages
-Apache::CGI, CGI::XA, and CGI. It returns the first CGI object it
-succeeds with.
+=head1 AUTHOR INFORMATION
-The import method allows you to set up the default order of the
-modules to be tested.
+=head1 BUGS
=head1 SEE ALSO
-perl(1), Apache(3), CGI(3), CGI::XA(3)
-
-=head1 AUTHOR
-
-Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt>
-
=cut
END
;
test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq
- 'fred=chocolate&chip; domain=localhost; path=/',"cookie()");
+ 'fred=chocolate&chip; path=/',"cookie()");
if (!$Is_EBCDIC) {
-test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; domain=localhost; path=/\015\012Date:.*\015\012Content-Type: text/html\015\012\015\012!s,
+test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/\015\012Date:.*\015\012Content-Type: text/html\015\012\015\012!s,
"header(-cookie)");
} else {
-test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; domain=localhost; path=/\r\nDate:.*\r\nContent-Type: text/html\r\n\r\n!s,
+test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/\r\nDate:.*\r\nContent-Type: text/html\r\n\r\n!s,
"header(-cookie)");
}
test(18,start_h3 eq '<H3>');
projects / platform / upstream / perl.git / commitdiff