summaryrefslogtreecommitdiff
path: root/lib/CGI
diff options
context:
space:
mode:
authorAndreas Brachold <vdr07@deltab.de>2007-11-11 06:55:13 +0000
committerAndreas Brachold <vdr07@deltab.de>2007-11-11 06:55:13 +0000
commit3282be229999dc36c197b264d63063a18d136331 (patch)
tree98a42db29d955b39e7bed1b599fdcc56c3a29de9 /lib/CGI
parentcfdd733c17cfa4f1a43b827a656e9e53cc2524ac (diff)
downloadxxv-3282be229999dc36c197b264d63063a18d136331.tar.gz
xxv-3282be229999dc36c197b264d63063a18d136331.tar.bz2
* Update installation list with required modules
* Remove unused/doubled provided external perl moduls
Diffstat (limited to 'lib/CGI')
-rw-r--r--lib/CGI/Apache.pm26
-rw-r--r--lib/CGI/Carp.pm524
-rw-r--r--lib/CGI/Cookie.pm478
-rw-r--r--lib/CGI/Fast.pm230
-rw-r--r--lib/CGI/Pretty.pm275
-rw-r--r--lib/CGI/Push.pm328
-rw-r--r--lib/CGI/Switch.pm27
-rw-r--r--lib/CGI/Util.pm317
8 files changed, 0 insertions, 2205 deletions
diff --git a/lib/CGI/Apache.pm b/lib/CGI/Apache.pm
deleted file mode 100644
index c711a48..0000000
--- a/lib/CGI/Apache.pm
+++ /dev/null
@@ -1,26 +0,0 @@
-use CGI;
-
-$VERSION = '1.00';
-
-1;
-__END__
-
-=head1 NAME
-
-CGI::Apache - Backward compatibility module for CGI.pm
-
-=head1 SYNOPSIS
-
-Do not use this module. It is deprecated.
-
-=head1 ABSTRACT
-
-=head1 DESCRIPTION
-
-=head1 AUTHOR INFORMATION
-
-=head1 BUGS
-
-=head1 SEE ALSO
-
-=cut
diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm
deleted file mode 100644
index e25cd7f..0000000
--- a/lib/CGI/Carp.pm
+++ /dev/null
@@ -1,524 +0,0 @@
-package CGI::Carp;
-
-=head1 NAME
-
-B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log
-
-=head1 SYNOPSIS
-
- use CGI::Carp;
-
- croak "We're outta here!";
- confess "It was my fault: $!";
- carp "It was your fault!";
- warn "I'm confused";
- die "I'm dying.\n";
-
- use CGI::Carp qw(cluck);
- cluck "I wouldn't do that if I were you";
-
- use CGI::Carp qw(fatalsToBrowser);
- die "Fatal error messages are now sent to browser";
-
-=head1 DESCRIPTION
-
-CGI scripts have a nasty habit of leaving warning messages in the error
-logs that are neither time stamped nor fully identified. Tracking down
-the script that caused the error is a pain. This fixes that. Replace
-the usual
-
- use Carp;
-
-with
-
- use CGI::Carp
-
-And the standard warn(), die (), croak(), confess() and carp() calls
-will automagically be replaced with functions that write out nicely
-time-stamped messages to the HTTP server error log.
-
-For example:
-
- [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
- [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
- [Fri Nov 17 21:40:43 1995] test.pl: I'm dying.
-
-=head1 REDIRECTING ERROR MESSAGES
-
-By default, error messages are sent to STDERR. Most HTTPD servers
-direct STDERR to the server's error log. Some applications may wish
-to keep private error logs, distinct from the server's error log, or
-they may wish to direct error messages to STDOUT so that the browser
-will receive them.
-
-The C<carpout()> function is provided for this purpose. Since
-carpout() is not exported by default, you must import it explicitly by
-saying
-
- use CGI::Carp qw(carpout);
-
-The carpout() function requires one argument, which should be a
-reference to an open filehandle for writing errors. It should be
-called in a C<BEGIN> block at the top of the CGI application so that
-compiler errors will be caught. Example:
-
- BEGIN {
- use CGI::Carp qw(carpout);
- open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
- die("Unable to open mycgi-log: $!\n");
- carpout(LOG);
- }
-
-carpout() does not handle file locking on the log for you at this point.
-
-The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. Some
-servers, when dealing with CGI scripts, close their connection to the
-browser when the script closes STDOUT and STDERR. CGI::Carp::SAVEERR is there to
-prevent this from happening prematurely.
-
-You can pass filehandles to carpout() in a variety of ways. The "correct"
-way according to Tom Christiansen is to pass a reference to a filehandle
-GLOB:
-
- carpout(\*LOG);
-
-This looks weird to mere mortals however, so the following syntaxes are
-accepted as well:
-
- carpout(LOG);
- carpout(main::LOG);
- carpout(main'LOG);
- carpout(\LOG);
- carpout(\'main::LOG');
-
- ... and so on
-
-FileHandle and other objects work as well.
-
-Use of carpout() is not great for performance, so it is recommended
-for debugging purposes or for moderate-use applications. A future
-version of this module may delay redirecting STDERR until one of the
-CGI::Carp methods is called to prevent the performance hit.
-
-=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
-
-If you want to send fatal (die, confess) errors to the browser, ask to
-import the special "fatalsToBrowser" subroutine:
-
- use CGI::Carp qw(fatalsToBrowser);
- die "Bad error here";
-
-Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp
-arranges to send a minimal HTTP header to the browser so that even errors that
-occur in the early compile phase will be seen.
-Nonfatal errors will still be directed to the log file only (unless redirected
-with carpout).
-
-=head2 Changing the default message
-
-By default, the software error message is followed by a note to
-contact the Webmaster by e-mail with the time and date of the error.
-If this message is not to your liking, you can change it using the
-set_message() routine. This is not imported by default; you should
-import it on the use() line:
-
- use CGI::Carp qw(fatalsToBrowser set_message);
- set_message("It's not a bug, it's a feature!");
-
-You may also pass in a code reference in order to create a custom
-error message. At run time, your code will be called with the text
-of the error message that caused the script to die. Example:
-
- use CGI::Carp qw(fatalsToBrowser set_message);
- BEGIN {
- sub handle_errors {
- my $msg = shift;
- print "<h1>Oh gosh</h1>";
- print "<p>Got an error: $msg</p>";
- }
- set_message(\&handle_errors);
- }
-
-In order to correctly intercept compile-time errors, you should call
-set_message() from within a BEGIN{} block.
-
-=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
-
-It is now also possible to make non-fatal errors appear as HTML
-comments embedded in the output of your program. To enable this
-feature, export the new "warningsToBrowser" subroutine. Since sending
-warnings to the browser before the HTTP headers have been sent would
-cause an error, any warnings are stored in an internal buffer until
-you call the warningsToBrowser() subroutine with a true argument:
-
- use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
- use CGI qw(:standard);
- print header();
- warningsToBrowser(1);
-
-You may also give a false argument to warningsToBrowser() to prevent
-warnings from being sent to the browser while you are printing some
-content where HTML comments are not allowed:
-
- warningsToBrowser(0); # disable warnings
- print "<script type=\"text/javascript\"><!--\n";
- print_some_javascript_code();
- print "//--></script>\n";
- warningsToBrowser(1); # re-enable warnings
-
-Note: In this respect warningsToBrowser() differs fundamentally from
-fatalsToBrowser(), which you should never call yourself!
-
-=head1 OVERRIDING THE NAME OF THE PROGRAM
-
-CGI::Carp includes the name of the program that generated the error or
-warning in the messages written to the log and the browser window.
-Sometimes, Perl can get confused about what the actual name of the
-executed program was. In these cases, you can override the program
-name that CGI::Carp will use for all messages.
-
-The quick way to do that is to tell CGI::Carp the name of the program
-in its use statement. You can do that by adding
-"name=cgi_carp_log_name" to your "use" statement. For example:
-
- use CGI::Carp qw(name=cgi_carp_log_name);
-
-. If you want to change the program name partway through the program,
-you can use the C<set_progname()> function instead. It is not
-exported by default, you must import it explicitly by saying
-
- use CGI::Carp qw(set_progname);
-
-Once you've done that, you can change the logged name of the program
-at any time by calling
-
- set_progname(new_program_name);
-
-You can set the program back to the default by calling
-
- set_progname(undef);
-
-Note that this override doesn't happen until after the program has
-compiled, so any compile-time errors will still show up with the
-non-overridden program name
-
-=head1 CHANGE LOG
-
-1.05 carpout() added and minor corrections by Marc Hedlund
- <hedlund@best.com> on 11/26/95.
-
-1.06 fatalsToBrowser() no longer aborts for fatal errors within
- eval() statements.
-
-1.08 set_message() added and carpout() expanded to allow for FileHandle
- objects.
-
-1.09 set_message() now allows users to pass a code REFERENCE for
- really custom error messages. croak and carp are now
- exported by default. Thanks to Gunther Birznieks for the
- patches.
-
-1.10 Patch from Chris Dean (ctdean@cogit.com) to allow
- module to run correctly under mod_perl.
-
-1.11 Changed order of &gt; and &lt; escapes.
-
-1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning.
-
-1.13 Added cluck() to make the module orthogonal with Carp.
- More mod_perl related fixes.
-
-1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added
- warningsToBrowser(). Replaced <CODE> tags with <PRE> in
- fatalsToBrowser() output.
-
-1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern
- (hack alert!) in order to accomodate various combinations of Perl and
- mod_perl.
-
-1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
- for overriding program name.
-
-1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the
- former isn't working in some people's hands. There is no such thing
- as reliable exception handling in Perl.
-
-1.27 Replaced tell STDOUT with bytes=tell STDOUT.
-
-=head1 AUTHORS
-
-Copyright 1995-2002, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org
-
-=head1 SEE ALSO
-
-Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
-CGI::Response
- if (defined($CGI::Carp::PROGNAME))
- {
- $file = $CGI::Carp::PROGNAME;
- }
-
-=cut
-
-require 5.000;
-use Exporter;
-#use Carp;
-BEGIN {
- require Carp;
- *CORE::GLOBAL::die = \&CGI::Carp::die;
-}
-
-use File::Spec;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_progname cluck ^name= die);
-
-$main::SIG{__WARN__}=\&CGI::Carp::warn;
-
-$CGI::Carp::VERSION = '1.28';
-$CGI::Carp::CUSTOM_MSG = undef;
-
-
-# fancy import routine detects and handles 'errorWrap' specially.
-sub import {
- my $pkg = shift;
- my(%routines);
- my(@name);
-
- if (@name=grep(/^name=/,@_))
- {
- my($n) = (split(/=/,$name[0]))[1];
- set_progname($n);
- @_=grep(!/^name=/,@_);
- }
-
- grep($routines{$_}++,@_,@EXPORT);
- $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
- $WARN++ if $routines{'warningsToBrowser'};
- my($oldlevel) = $Exporter::ExportLevel;
- $Exporter::ExportLevel = 1;
- Exporter::import($pkg,keys %routines);
- $Exporter::ExportLevel = $oldlevel;
- $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
-# $pkg->export('CORE::GLOBAL','die');
-}
-
-# These are the originals
-sub realwarn { CORE::warn(@_); }
-sub realdie { CORE::die(@_); }
-
-sub id {
- my $level = shift;
- my($pack,$file,$line,$sub) = caller($level);
- my($dev,$dirs,$id) = File::Spec->splitpath($file);
- return ($file,$line,$id);
-}
-
-sub stamp {
- my $time = scalar(localtime);
- my $frame = 0;
- my ($id,$pack,$file,$dev,$dirs);
- if (defined($CGI::Carp::PROGNAME)) {
- $id = $CGI::Carp::PROGNAME;
- } else {
- do {
- $id = $file;
- ($pack,$file) = caller($frame++);
- } until !$file;
- }
- ($dev,$dirs,$id) = File::Spec->splitpath($id);
- return "[$time] $id: ";
-}
-
-sub set_progname {
- $CGI::Carp::PROGNAME = shift;
- return $CGI::Carp::PROGNAME;
-}
-
-
-sub warn {
- my $message = shift;
- my($file,$line,$id) = id(1);
- $message .= " at $file line $line.\n" unless $message=~/\n$/;
- _warn($message) if $WARN;
- my $stamp = stamp;
- $message=~s/^/$stamp/gm;
- realwarn $message;
-}
-
-sub _warn {
- my $msg = shift;
- if ($EMIT_WARNINGS) {
- # We need to mangle the message a bit to make it a valid HTML
- # comment. This is done by substituting similar-looking ISO
- # 8859-1 characters for <, > and -. This is a hack.
- $msg =~ tr/<>-/\253\273\255/;
- chomp $msg;
- print STDOUT "<!-- warning: $msg -->\n";
- } else {
- push @WARNINGS, $msg;
- }
-}
-
-
-# The mod_perl package Apache::Registry loads CGI programs by calling
-# eval. These evals don't count when looking at the stack backtrace.
-sub _longmess {
- my $message = Carp::longmess();
- $message =~ s,eval[^\n]+(ModPerl|Apache)/Registry\w*\.pm.*,,s
- if exists $ENV{MOD_PERL};
- return $message;
-}
-
-sub ineval {
- (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m
-}
-
-sub die {
- my ($arg,@rest) = @_;
- realdie ($arg,@rest) if ineval();
-
- if (!ref($arg)) {
- $arg = join("", ($arg,@rest));
- my($file,$line,$id) = id(1);
- $arg .= " at $file line $line." unless $arg=~/\n$/;
- &fatalsToBrowser($arg) if $WRAP;
- if (($arg =~ /\n$/) || !exists($ENV{MOD_PERL})) {
- my $stamp = stamp;
- $arg=~s/^/$stamp/gm;
- }
- if ($arg !~ /\n$/) {
- $arg .= "\n";
- }
- }
- realdie $arg;
-}
-
-sub set_message {
- $CGI::Carp::CUSTOM_MSG = shift;
- return $CGI::Carp::CUSTOM_MSG;
-}
-
-sub confess { CGI::Carp::die Carp::longmess @_; }
-sub croak { CGI::Carp::die Carp::shortmess @_; }
-sub carp { CGI::Carp::warn Carp::shortmess @_; }
-sub cluck { CGI::Carp::warn Carp::longmess @_; }
-
-# We have to be ready to accept a filehandle as a reference
-# or a string.
-sub carpout {
- my($in) = @_;
- my($no) = fileno(to_filehandle($in));
- realdie("Invalid filehandle $in\n") unless defined $no;
-
- open(SAVEERR, ">&STDERR");
- open(STDERR, ">&$no") or
- ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
-}
-
-sub warningsToBrowser {
- $EMIT_WARNINGS = @_ ? shift : 1;
- _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
-}
-
-# headers
-sub fatalsToBrowser {
- my($msg) = @_;
- $msg=~s/&/&amp;/g;
- $msg=~s/>/&gt;/g;
- $msg=~s/</&lt;/g;
- $msg=~s/\"/&quot;/g;
- my($wm) = $ENV{SERVER_ADMIN} ?
- qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
- "this site's webmaster";
- my ($outer_message) = <<END;
-For help, please send mail to $wm, giving this error message
-and the time and date of the error.
-END
- ;
- my $mod_perl = exists $ENV{MOD_PERL};
-
- if ($CUSTOM_MSG) {
- if (ref($CUSTOM_MSG) eq 'CODE') {
- print STDOUT "Content-type: text/html\n\n"
- unless $mod_perl;
- &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
- return;
- } else {
- $outer_message = $CUSTOM_MSG;
- }
- }
-
- my $mess = <<END;
-<h1>Software error:</h1>
-<pre>$msg</pre>
-<p>
-$outer_message
-</p>
-END
- ;
-
- if ($mod_perl) {
- require mod_perl;
- if ($mod_perl::VERSION >= 1.99) {
- $mod_perl = 2;
- require Apache::RequestRec;
- require Apache::RequestIO;
- require Apache::RequestUtil;
- require APR::Pool;
- require ModPerl::Util;
- require Apache::Response;
- }
- my $r = Apache->request;
- # If bytes have already been sent, then
- # we print the message out directly.
- # Otherwise we make a custom error
- # handler to produce the doc for us.
- if ($r->bytes_sent) {
- $r->print($mess);
- $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
- } else {
- # MSIE won't display a custom 500 response unless it is >512 bytes!
- if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) {
- $mess = "<!-- " . (' ' x 513) . " -->\n$mess";
- }
- $r->custom_response(500,$mess);
- }
- } else {
- my $bytes_written = eval{tell STDOUT};
- if (defined $bytes_written && $bytes_written > 0) {
- print STDOUT $mess;
- }
- else {
- print STDOUT "Content-type: text/html\n\n";
- print STDOUT $mess;
- }
- }
-
- warningsToBrowser(1); # emit warnings before dying
-}
-
-# Cut and paste from CGI.pm so that we don't have the overhead of
-# always loading the entire CGI module.
-sub to_filehandle {
- my $thingy = shift;
- return undef unless $thingy;
- return $thingy if UNIVERSAL::isa($thingy,'GLOB');
- return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
- if (!ref($thingy)) {
- my $caller = 1;
- while (my $package = caller($caller++)) {
- my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
- return $tmp if defined(fileno($tmp));
- }
- }
- return undef;
-}
-
-1;
diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm
deleted file mode 100644
index 27a93c5..0000000
--- a/lib/CGI/Cookie.pm
+++ /dev/null
@@ -1,478 +0,0 @@
-package CGI::Cookie;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-# Copyright 1995-1999, Lincoln D. Stein. All rights reserved.
-# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
-# wish, but if you redistribute a modified version, please attach a note
-# listing the modifications you have made.
-
-$CGI::Cookie::VERSION='1.24';
-
-use CGI::Util qw(rearrange unescape escape);
-use overload '""' => \&as_string,
- 'cmp' => \&compare,
- 'fallback'=>1;
-
-# Turn on special checking for Doug MacEachern's modperl
-my $MOD_PERL = 0;
-if (exists $ENV{MOD_PERL}) {
- eval "require mod_perl";
- if (defined $mod_perl::VERSION) {
- if ($mod_perl::VERSION >= 1.99) {
- $MOD_PERL = 2;
- require Apache::RequestUtil;
- } else {
- $MOD_PERL = 1;
- require Apache;
- }
- }
-}
-
-# fetch a list of cookies from the environment and
-# return as a hash. the cookies are parsed as normal
-# escaped URL data.
-sub fetch {
- my $class = shift;
- my $raw_cookie = get_raw_cookie(@_) or return;
- return $class->parse($raw_cookie);
-}
-
-# Fetch a list of cookies from the environment or the incoming headers and
-# return as a hash. The cookie values are not unescaped or altered in any way.
- sub raw_fetch {
- my $class = shift;
- my $raw_cookie = get_raw_cookie(@_) or return;
- my %results;
- my($key,$value);
-
- my(@pairs) = split("; ?",$raw_cookie);
- foreach (@pairs) {
- s/\s*(.*?)\s*/$1/;
- if (/^([^=]+)=(.*)/) {
- $key = $1;
- $value = $2;
- }
- else {
- $key = $_;
- $value = '';
- }
- $results{$key} = $value;
- }
- return \%results unless wantarray;
- return %results;
-}
-
-sub get_raw_cookie {
- my $r = shift;
- $r ||= eval { Apache->request() } if $MOD_PERL;
- if ($r) {
- $raw_cookie = $r->headers_in->{'Cookie'};
- } else {
- if ($MOD_PERL && !exists $ENV{REQUEST_METHOD}) {
- die "Run $r->subprocess_env; before calling fetch()";
- }
- $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
- }
-}
-
-
-sub parse {
- my ($self,$raw_cookie) = @_;
- my %results;
-
- my(@pairs) = split("; ?",$raw_cookie);
- foreach (@pairs) {
- s/\s*(.*?)\s*/$1/;
- my($key,$value) = split("=",$_,2);
-
- # Some foreign cookies are not in name=value format, so ignore
- # them.
- next if !defined($value);
- my @values = ();
- if ($value ne '') {
- @values = map unescape($_),split(/[&;]/,$value.'&dmy');
- pop @values;
- }
- $key = unescape($key);
- # A bug in Netscape can cause several cookies with same name to
- # appear. The FIRST one in HTTP_COOKIE is the most recent version.
- $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
- }
- return \%results unless wantarray;
- return %results;
-}
-
-sub new {
- my $class = shift;
- $class = ref($class) if ref($class);
- my($name,$value,$path,$domain,$secure,$expires) =
- rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
-
- # Pull out our parameters.
- my @values;
- if (ref($value)) {
- if (ref($value) eq 'ARRAY') {
- @values = @$value;
- } elsif (ref($value) eq 'HASH') {
- @values = %$value;
- }
- } else {
- @values = ($value);
- }
-
- bless my $self = {
- 'name'=>$name,
- 'value'=>[@values],
- },$class;
-
- # IE requires the path and domain to be present for some reason.
- $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->domain($domain) if defined $domain;
- $self->secure($secure) if defined $secure;
- $self->expires($expires) if defined $expires;
-# $self->max_age($expires) if defined $expires;
- return $self;
-}
-
-sub as_string {
- my $self = shift;
- return "" unless $self->name;
-
- my(@constant_values,$domain,$path,$expires,$max_age,$secure);
-
- push(@constant_values,"domain=$domain") if $domain = $self->domain;
- push(@constant_values,"path=$path") if $path = $self->path;
- push(@constant_values,"expires=$expires") if $expires = $self->expires;
- push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age;
- push(@constant_values,"secure") if $secure = $self->secure;
-
- my($key) = escape($self->name);
- my($cookie) = join("=",$key,join("&",map escape($_),$self->value));
- return join("; ",$cookie,@constant_values);
-}
-
-sub compare {
- my $self = shift;
- my $value = shift;
- return "$self" cmp $value;
-}
-
-# accessors
-sub name {
- my $self = shift;
- my $name = shift;
- $self->{'name'} = $name if defined $name;
- return $self->{'name'};
-}
-
-sub value {
- my $self = shift;
- my $value = shift;
- if (defined $value) {
- my @values;
- if (ref($value)) {
- if (ref($value) eq 'ARRAY') {
- @values = @$value;
- } elsif (ref($value) eq 'HASH') {
- @values = %$value;
- }
- } else {
- @values = ($value);
- }
- $self->{'value'} = [@values];
- }
- return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
-}
-
-sub domain {
- my $self = shift;
- my $domain = shift;
- $self->{'domain'} = $domain if defined $domain;
- return $self->{'domain'};
-}
-
-sub secure {
- my $self = shift;
- my $secure = shift;
- $self->{'secure'} = $secure if defined $secure;
- return $self->{'secure'};
-}
-
-sub expires {
- my $self = shift;
- my $expires = shift;
- $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
- return $self->{'expires'};
-}
-
-sub max_age {
- my $self = shift;
- my $expires = shift;
- $self->{'max-age'} = CGI::Util::expire_calc($expires)-time() if defined $expires;
- return $self->{'max-age'};
-}
-
-sub path {
- my $self = shift;
- my $path = shift;
- $self->{'path'} = $path if defined $path;
- return $self->{'path'};
-}
-
-1;
-
-=head1 NAME
-
-CGI::Cookie - Interface to Netscape Cookies
-
-=head1 SYNOPSIS
-
- use CGI qw/:standard/;
- use CGI::Cookie;
-
- # Create new cookies and send them
- $cookie1 = new CGI::Cookie(-name=>'ID',-value=>123456);
- $cookie2 = new CGI::Cookie(-name=>'preferences',
- -value=>{ font => Helvetica,
- size => 12 }
- );
- print header(-cookie=>[$cookie1,$cookie2]);
-
- # fetch existing cookies
- %cookies = fetch CGI::Cookie;
- $id = $cookies{'ID'}->value;
-
- # create cookies returned from an external source
- %cookies = parse CGI::Cookie($ENV{COOKIE});
-
-=head1 DESCRIPTION
-
-CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an
-innovation that allows Web servers to store persistent information on
-the browser's side of the connection. Although CGI::Cookie is
-intended to be used in conjunction with CGI.pm (and is in fact used by
-it internally), you can use this module independently.
-
-For full information on cookies see
-
- http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
-
-=head1 USING CGI::Cookie
-
-CGI::Cookie is object oriented. Each cookie object has a name and a
-value. The name is any scalar value. The value is any scalar or
-array value (associative arrays are also allowed). Cookies also have
-several optional attributes, including:
-
-=over 4
-
-=item B<1. expiration date>
-
-The expiration date tells the browser how long to hang on to the
-cookie. If the cookie specifies an expiration date in the future, the
-browser will store the cookie information in a disk file and return it
-to the server every time the user reconnects (until the expiration
-date is reached). If the cookie species an expiration date in the
-past, the browser will remove the cookie from the disk file. If the
-expiration date is not specified, the cookie will persist only until
-the user quits the browser.
-
-=item B<2. domain>
-
-This is a partial or complete domain name for which the cookie is
-valid. The browser will return the cookie to any host that matches
-the partial domain name. For example, if you specify a domain name
-of ".capricorn.com", then Netscape will return the cookie to
-Web servers running on any of the machines "www.capricorn.com",
-"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names
-must contain at least two periods to prevent attempts to match
-on top level domains like ".edu". If no domain is specified, then
-the browser will only return the cookie to servers on the host the
-cookie originated from.
-
-=item B<3. path>
-
-If you provide a cookie path attribute, the browser will check it
-against your script's URL before returning the cookie. For example,
-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 "/", so
-that all scripts at your site will receive the cookie.
-
-=item B<4. secure flag>
-
-If the "secure" attribute is set, the cookie will only be sent to your
-script if the CGI request is occurring on a secure channel, such as SSL.
-
-=back
-
-=head2 Creating New Cookies
-
- $c = new CGI::Cookie(-name => 'foo',
- -value => 'bar',
- -expires => '+3M',
- -domain => '.capricorn.com',
- -path => '/cgi-bin/database',
- -secure => 1
- );
-
-Create cookies from scratch with the B<new> method. The B<-name> and
-B<-value> parameters are required. The name must be a scalar value.
-The value can be a scalar, an array reference, or a hash reference.
-(At some point in the future cookies will support one of the Perl
-object serialization protocols for full generality).
-
-B<-expires> accepts any of the relative or absolute date formats
-recognized by CGI.pm, for example "+3M" for three months in the
-future. See CGI.pm's documentation for details.
-
-B<-domain> points to a domain name or to a fully qualified host name.
-If not specified, the cookie will be returned only to the Web server
-that created it.
-
-B<-path> points to a partial URL on the current server. The cookie
-will be returned to all URLs beginning with the specified path. If
-not specified, it defaults to '/', which returns the cookie to all
-pages at your site.
-
-B<-secure> if set to a true value instructs the browser to return the
-cookie only when a cryptographic protocol is in use.
-
-=head2 Sending the Cookie to the Browser
-
-Within a CGI script you can send a cookie to the browser by creating
-one or more Set-Cookie: fields in the HTTP header. Here is a typical
-sequence:
-
- my $c = new CGI::Cookie(-name => 'foo',
- -value => ['bar','baz'],
- -expires => '+3M');
-
- print "Set-Cookie: $c\n";
- print "Content-Type: text/html\n\n";
-
-To send more than one cookie, create several Set-Cookie: fields.
-
-If you are using CGI.pm, you send cookies by providing a -cookie
-argument to the header() method:
-
- print header(-cookie=>$c);
-
-Mod_perl users can set cookies using the request object's header_out()
-method:
-
- $r->headers_out->set('Set-Cookie' => $c);
-
-Internally, Cookie overloads the "" operator to call its as_string()
-method when incorporated into the HTTP header. as_string() turns the
-Cookie's internal representation into an RFC-compliant text
-representation. You may call as_string() yourself if you prefer:
-
- print "Set-Cookie: ",$c->as_string,"\n";
-
-=head2 Recovering Previous Cookies
-
- %cookies = fetch CGI::Cookie;
-
-B<fetch> returns an associative array consisting of all cookies
-returned by the browser. The keys of the array are the cookie names. You
-can iterate through the cookies this way:
-
- %cookies = fetch CGI::Cookie;
- foreach (keys %cookies) {
- do_something($cookies{$_});
- }
-
-In a scalar context, fetch() returns a hash reference, which may be more
-efficient if you are manipulating multiple cookies.
-
-CGI.pm uses the URL escaping methods to save and restore reserved characters
-in its cookies. If you are trying to retrieve a cookie set by a foreign server,
-this escaping method may trip you up. Use raw_fetch() instead, which has the
-same semantics as fetch(), but performs no unescaping.
-
-You may also retrieve cookies that were stored in some external
-form using the parse() class method:
-
- $COOKIES = `cat /usr/tmp/Cookie_stash`;
- %cookies = parse CGI::Cookie($COOKIES);
-
-If you are in a mod_perl environment, you can save some overhead by
-passing the request object to fetch() like this:
-
- CGI::Cookie->fetch($r);
-
-=head2 Manipulating Cookies
-
-Cookie objects have a series of accessor methods to get and set cookie
-attributes. Each accessor has a similar syntax. Called without
-arguments, the accessor returns the current value of the attribute.
-Called with an argument, the accessor changes the attribute and
-returns its new value.
-
-=over 4
-
-=item B<name()>
-
-Get or set the cookie's name. Example:
-
- $name = $c->name;
- $new_name = $c->name('fred');
-
-=item B<value()>
-
-Get or set the cookie's value. Example:
-
- $value = $c->value;
- @new_value = $c->value(['a','b','c','d']);
-
-B<value()> is context sensitive. In a list context it will return
-the current value of the cookie as an array. In a scalar context it
-will return the B<first> value of a multivalued cookie.
-
-=item B<domain()>
-
-Get or set the cookie's domain.
-
-=item B<path()>
-
-Get or set the cookie's path.
-
-=item B<expires()>
-
-Get or set the cookie's expiration time.
-
-=back
-
-
-=head1 AUTHOR INFORMATION
-
-Copyright 1997-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org
-
-=head1 BUGS
-
-This section intentionally left blank.
-
-=head1 SEE ALSO
-
-L<CGI::Carp>, L<CGI>
-
-=cut
diff --git a/lib/CGI/Fast.pm b/lib/CGI/Fast.pm
deleted file mode 100644
index 43b8709..0000000
--- a/lib/CGI/Fast.pm
+++ /dev/null
@@ -1,230 +0,0 @@
-package CGI::Fast;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
-# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
-# wish, but if you redistribute a modified version, please attach a note
-# listing the modifications you have made.
-
-# The most recent version and complete docs are available at:
-# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
-# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
-$CGI::Fast::VERSION='1.05';
-
-use CGI;
-use FCGI;
-@ISA = ('CGI');
-
-# workaround for known bug in libfcgi
-while (($ignore) = each %ENV) { }
-
-# override the initialization behavior so that
-# state is NOT maintained between invocations
-sub save_request {
- # no-op
-}
-
-# If ENV{FCGI_SOCKET_PATH} is specified, we maintain a FCGI Request handle
-# in this package variable.
-use vars qw($Ext_Request);
-BEGIN {
- # If ENV{FCGI_SOCKET_PATH} is given, explicitly open the socket,
- # and keep the request handle around from which to call Accept().
- if ($ENV{FCGI_SOCKET_PATH}) {
- my $path = $ENV{FCGI_SOCKET_PATH};
- my $backlog = $ENV{FCGI_LISTEN_QUEUE} || 100;
- my $socket = FCGI::OpenSocket( $path, $backlog );
- $Ext_Request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR,
- \%ENV, $socket, 1 );
- }
-}
-
-# New is slightly different in that it calls FCGI's
-# accept() method.
-sub new {
- my ($self, $initializer, @param) = @_;
- unless (defined $initializer) {
- if ($Ext_Request) {
- return undef unless $Ext_Request->Accept() >= 0;
- } else {
- return undef unless FCGI::accept() >= 0;
- }
- }
- return $CGI::Q = $self->SUPER::new($initializer, @param);
-}
-
-1;
-
-=head1 NAME
-
-CGI::Fast - CGI Interface for Fast CGI
-
-=head1 SYNOPSIS
-
- use CGI::Fast qw(:standard);
- $COUNTER = 0;
- while (new CGI::Fast) {
- print header;
- print start_html("Fast CGI Rocks");
- print
- h1("Fast CGI Rocks"),
- "Invocation number ",b($COUNTER++),
- " PID ",b($$),".",
- hr;
- print end_html;
- }
-
-=head1 DESCRIPTION
-
-CGI::Fast is a subclass of the CGI object created by
-CGI.pm. It is specialized to work well with the Open Market
-FastCGI standard, which greatly speeds up CGI scripts by
-turning them into persistently running server processes. Scripts
-that perform time-consuming initialization processes, such as
-loading large modules or opening persistent database connections,
-will see large performance improvements.
-
-=head1 OTHER PIECES OF THE PUZZLE
-
-In order to use CGI::Fast you'll need a FastCGI-enabled Web
-server. Open Market's server is FastCGI-savvy. There are also
-freely redistributable FastCGI modules for NCSA httpd 1.5 and Apache.
-FastCGI-enabling modules for Microsoft Internet Information Server and
-Netscape Communications Server have been announced.
-
-In addition, you'll need a version of the Perl interpreter that has
-been linked with the FastCGI I/O library. Precompiled binaries are
-available for several platforms, including DEC Alpha, HP-UX and
-SPARC/Solaris, or you can rebuild Perl from source with patches
-provided in the FastCGI developer's kit. The FastCGI Perl interpreter
-can be used in place of your normal Perl without ill consequences.
-
-You can find FastCGI modules for Apache and NCSA httpd, precompiled
-Perl interpreters, and the FastCGI developer's kit all at URL:
-
- http://www.fastcgi.com/
-
-=head1 WRITING FASTCGI PERL SCRIPTS
-
-FastCGI scripts are persistent: one or more copies of the script
-are started up when the server initializes, and stay around until
-the server exits or they die a natural death. After performing
-whatever one-time initialization it needs, the script enters a
-loop waiting for incoming connections, processing the request, and
-waiting some more.
-
-A typical FastCGI script will look like this:
-
- #!/usr/local/bin/perl # must be a FastCGI version of perl!
- use CGI::Fast;
- &do_some_initialization();
- while ($q = new CGI::Fast) {
- &process_request($q);
- }
-
-Each time there's a new request, CGI::Fast returns a
-CGI object to your loop. The rest of the time your script
-waits in the call to new(). When the server requests that
-your script be terminated, new() will return undef. You can
-of course exit earlier if you choose. A new version of the
-script will be respawned to take its place (this may be
-necessary in order to avoid Perl memory leaks in long-running
-scripts).
-
-CGI.pm's default CGI object mode also works. Just modify the loop
-this way:
-
- while (new CGI::Fast) {
- &process_request;
- }
-
-Calls to header(), start_form(), etc. will all operate on the
-current request.
-
-=head1 INSTALLING FASTCGI SCRIPTS
-
-See the FastCGI developer's kit documentation for full details. On
-the Apache server, the following line must be added to srm.conf:
-
- AddType application/x-httpd-fcgi .fcgi
-
-FastCGI scripts must end in the extension .fcgi. For each script you
-install, you must add something like the following to srm.conf:
-
- FastCgiServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
-
-This instructs Apache to launch two copies of file_upload.fcgi at
-startup time.
-
-=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS
-
-Any script that works correctly as a FastCGI script will also work
-correctly when installed as a vanilla CGI script. However it will
-not see any performance benefit.
-
-=head1 EXTERNAL FASTCGI SERVER INVOCATION
-
-FastCGI supports a TCP/IP transport mechanism which allows FastCGI scripts to run
-external to the webserver, perhaps on a remote machine. To configure the
-webserver to connect to an external FastCGI server, you would add the following
-to your srm.conf:
-
- FastCgiExternalServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -host sputnik:8888
-
-Two environment variables affect how the C<CGI::Fast> object is created,
-allowing C<CGI::Fast> to be used as an external FastCGI server. (See C<FCGI>
-documentation for C<FCGI::OpenSocket> for more information.)
-
-=over
-
-=item FCGI_SOCKET_PATH
-
-The address (TCP/IP) or path (UNIX Domain) of the socket the external FastCGI
-script to which bind an listen for incoming connections from the web server.
-
-=item FCGI_LISTEN_QUEUE
-
-Maximum length of the queue of pending connections.
-
-=back
-
-For example:
-
- #!/usr/local/bin/perl # must be a FastCGI version of perl!
- use CGI::Fast;
- &do_some_initialization();
- $ENV{FCGI_SOCKET_PATH} = "sputnik:8888";
- $ENV{FCGI_LISTEN_QUEUE} = 100;
- while ($q = new CGI::Fast) {
- &process_request($q);
- }
-
-=head1 CAVEATS
-
-I haven't tested this very much.
-
-=head1 AUTHOR INFORMATION
-
-Copyright 1996-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org
-
-=head1 BUGS
-
-This section intentionally left blank.
-
-=head1 SEE ALSO
-
-L<CGI::Carp>, L<CGI>
-
-=cut
diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm
deleted file mode 100644
index d824a02..0000000
--- a/lib/CGI/Pretty.pm
+++ /dev/null
@@ -1,275 +0,0 @@
-package CGI::Pretty;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-use strict;
-use CGI ();
-
-$CGI::Pretty::VERSION = '1.08';
-$CGI::DefaultClass = __PACKAGE__;
-$CGI::Pretty::AutoloadClass = 'CGI';
-@CGI::Pretty::ISA = qw( CGI );
-
-initialize_globals();
-
-sub _prettyPrint {
- my $input = shift;
- return if !$$input;
- return if !$CGI::Pretty::LINEBREAK || !$CGI::Pretty::INDENT;
-
-# print STDERR "'", $$input, "'\n";
-
- foreach my $i ( @CGI::Pretty::AS_IS ) {
- if ( $$input =~ m{</$i>}si ) {
- my ( $a, $b, $c ) = $$input =~ m{(.*)(<$i[\s/>].*?</$i>)(.*)}si;
- next if !$b;
- $a ||= "";
- $c ||= "";
-
- _prettyPrint( \$a ) if $a;
- _prettyPrint( \$c ) if $c;
-
- $b ||= "";
- $$input = "$a$b$c";
- 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 if $CGI::Pretty::LINEBREAK;
-
- return $self->SUPER::comment( "$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT$s$CGI::Pretty::LINEBREAK" ) . $CGI::Pretty::LINEBREAK;
-}
-
-sub _make_tag_func {
- my ($self,$tagname) = @_;
-
- # 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
-
- my $func = qq"
- sub $tagname {";
-
- $func .= q'
- shift if $_[0] &&
- (ref($_[0]) &&
- (substr(ref($_[0]),0,3) eq "CGI" ||
- UNIVERSAL::isa($_[0],"CGI")));
- my($attr) = "";
- if (ref($_[0]) && ref($_[0]) eq "HASH") {
- my(@attr) = make_attributes(shift()||undef,1);
- $attr = " @attr" if @attr;
- }';
-
- if ($tagname=~/start_(\w+)/i) {
- $func .= qq!
- return "<\L$1\E\$attr>\$CGI::Pretty::LINEBREAK";} !;
- } elsif ($tagname=~/end_(\w+)/i) {
- $func .= qq!
- return "<\L/$1\E>\$CGI::Pretty::LINEBREAK"; } !;
- } else {
- $func .= qq#
- return ( \$CGI::XHTML ? "<\L$tagname\E\$attr />" : "<\L$tagname\E\$attr>" ) .
- \$CGI::Pretty::LINEBREAK unless \@_;
- my(\$tag,\$untag) = ("<\L$tagname\E\$attr>","</\L$tagname>\E");
-
- my \%ASIS = map { lc("\$_") => 1 } \@CGI::Pretty::AS_IS;
- my \@args;
- if ( \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT ) {
- if(ref(\$_[0]) eq 'ARRAY') {
- \@args = \@{\$_[0]}
- } else {
- foreach (\@_) {
- \$args[0] .= \$_;
- \$args[0] .= \$CGI::Pretty::LINEBREAK if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 0;
- chomp \$args[0] if exists \$ASIS{ "\L$tagname\E" };
-
- \$args[0] .= \$" if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 1;
- }
- chop \$args[0];
- }
- }
- else {
- \@args = ref(\$_[0]) eq 'ARRAY' ? \@{\$_[0]} : "\@_";
- }
-
- my \@result;
- if ( exists \$ASIS{ "\L$tagname\E" } ) {
- \@result = map { "\$tag\$_\$untag\$CGI::Pretty::LINEBREAK" }
- \@args;
- }
- else {
- \@result = map {
- chomp;
- my \$tmp = \$_;
- CGI::Pretty::_prettyPrint( \\\$tmp );
- \$tag . \$CGI::Pretty::LINEBREAK .
- \$CGI::Pretty::INDENT . \$tmp . \$CGI::Pretty::LINEBREAK .
- \$untag . \$CGI::Pretty::LINEBREAK
- } \@args;
- }
- local \$" = "" if \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT;
- return "\@result";
- }#;
- }
-
- return $func;
-}
-
-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( @_ );
-
- if ($CGI::MOD_PERL) {
- my $r = Apache->request;
- if ($CGI::MOD_PERL == 1) {
- $r->register_cleanup(\&CGI::Pretty::_reset_globals);
- }
- else {
- $r->pool->cleanup_register(\&CGI::Pretty::_reset_globals);
- }
- }
- $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 = $/;
-
- # These tags are not prettify'd.
- @CGI::Pretty::AS_IS = qw( a pre code script textarea td );
-
- 1;
-}
-sub _reset_globals { initialize_globals(); }
-
-1;
-
-=head1 NAME
-
-CGI::Pretty - module to produce nicely formatted HTML code
-
-=head1 SYNOPSIS
-
- use CGI::Pretty qw( :html3 );
-
- # Print a table with a single data element
- print table( TR( td( "foo" ) ) );
-
-=head1 DESCRIPTION
-
-CGI::Pretty is a module that derives from CGI. It's sole function is to
-allow users of CGI to output nicely formatted HTML code.
-
-When using the CGI module, the following code:
- print table( TR( td( "foo" ) ) );
-
-produces the following output:
- <TABLE><TR><TD>foo</TD></TR></TABLE>
-
-If a user were to create a table consisting of many rows and many columns,
-the resultant HTML code would be quite difficult to read since it has no
-carriage returns or indentation.
-
-CGI::Pretty fixes this problem. What it does is add a carriage
-return and indentation to the HTML code so that one can easily read
-it.
-
- print table( TR( td( "foo" ) ) );
-
-now produces the following output:
- <TABLE>
- <TR>
- <TD>
- foo
- </TD>
- </TR>
- </TABLE>
-
-
-=head2 Tags that won't be formatted
-
-The <A> and <PRE> tags are not formatted. If these tags were formatted, the
-user would see the extra indentation on the web browser causing the page to
-look different than what would be expected. If you wish to add more tags to
-the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
-
- 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 <Brian@ThePaulsens.com>, with minor modifications by
-Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm
-distribution.
-
-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 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!
-
-=head1 SEE ALSO
-
-L<CGI>
-
-=cut
diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm
deleted file mode 100644
index 8356c60..0000000
--- a/lib/CGI/Push.pm
+++ /dev/null
@@ -1,328 +0,0 @@
-package CGI::Push;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-# Copyright 1995-2000, Lincoln D. Stein. All rights reserved.
-# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
-# wish, but if you redistribute a modified version, please attach a note
-# listing the modifications you have made.
-
-# The most recent version and complete docs are available at:
-# http://stein.cshl.org/WWW/software/CGI/
-
-$CGI::Push::VERSION='1.04';
-use CGI;
-use CGI::Util 'rearrange';
-@ISA = ('CGI');
-
-$CGI::DefaultClass = 'CGI::Push';
-$CGI::Push::AutoloadClass = 'CGI';
-
-# add do_push() and push_delay() to exported tags
-push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay');
-
-sub do_push {
- my ($self,@p) = CGI::self_or_default(@_);
-
- # unbuffer output
- $| = 1;
- srand;
- my ($random) = sprintf("%08.0f",rand()*1E8);
- my ($boundary) = "----=_NeXtPaRt$random";
-
- my (@header);
- my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,$handle,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH,HANDLE],@p);
- $type = 'text/html' unless $type;
- $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
- $delay = 1 unless defined($delay);
- $self->push_delay($delay);
- $nph = 1 unless defined($nph);
- $handle = \*STDOUT unless defined($handle);
-
-sdf;kjsdlfsdfkl
-
- my(@o);
- foreach (@other) { push(@o,split("=")); }
- push(@o,'-Target'=>$target) if defined($target);
- push(@o,'-Cookie'=>$cookie) if defined($cookie);
- push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\"");
- push(@o,'-Server'=>"CGI.pm Push Module") if $nph;
- push(@o,'-Status'=>'200 OK');
- push(@o,'-nph'=>1) if $nph;
- $handle->print($self->header(@o));
-
- $boundary = "$CGI::CRLF--$boundary";
-
- $handle->print("WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF");
-
- my (@contents) = &$callback($self,++$COUNTER);
-
- # now we enter a little loop
- while (1) {
- $handle->print("Content-type: ${type}$CGI::CRLF$CGI::CRLF") unless $type =~ /^dynamic|heterogeneous$/i;
- $handle->print(@contents);
- @contents = &$callback($self,++$COUNTER);
- if ((@contents) && defined($contents[0])) {
- $handle->print("${boundary}$CGI::CRLF");
- do_sleep($self->push_delay()) if $self->push_delay();
- } else {
- if ($last_page && ref($last_page) eq 'CODE') {
- $handle->print("${boundary}$CGI::CRLF");
- do_sleep($self->push_delay()) if $self->push_delay();
- $handle->print("Content-type: ${type}$CGI::CRLF$CGI::CRLF") unless $type =~ /^dynamic|heterogeneous$/i;
- $handle->print(&$last_page($self,$COUNTER));
- }
- $handle->print("${boundary}--$CGI::CRLF");
- last;
- }
- }
- $handle->print("WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF");
-}
-
-sub simple_counter {
- my ($self,$count) = @_;
- return $self->start_html("CGI::Push Default Counter"),
- $self->h1("CGI::Push Default Counter"),
- "This page has been updated ",$self->strong($count)," times.",
- $self->hr(),
- $self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'),
- $self->end_html;
-}
-
-sub do_sleep {
- my $delay = shift;
- if ( ($delay >= 1) && ($delay!~/\./) ){
- sleep($delay);
- } else {
- select(undef,undef,undef,$delay);
- }
-}
-
-sub push_delay {
- my ($self,$delay) = CGI::self_or_default(@_);
- return defined($delay) ? $self->{'.delay'} =
- $delay : $self->{'.delay'};
-}
-
-1;
-
-=head1 NAME
-
-CGI::Push - Simple Interface to Server Push
-
-=head1 SYNOPSIS
-
- use CGI::Push qw(:standard);
-
- do_push(-next_page=>\&next_page,
- -last_page=>\&last_page,
- -delay=>0.5);
-
- sub next_page {
- my($q,$counter) = @_;
- return undef if $counter >= 10;
- return start_html('Test'),
- h1('Visible'),"\n",
- "This page has been called ", strong($counter)," times",
- end_html();
- }
-
- sub last_page {
- my($q,$counter) = @_;
- return start_html('Done'),
- h1('Finished'),
- strong($counter - 1),' iterations.',
- end_html;
- }
-
-=head1 DESCRIPTION
-
-CGI::Push is a subclass of the CGI object created by CGI.pm. It is
-specialized for server push operations, which allow you to create
-animated pages whose content changes at regular intervals.
-
-You provide CGI::Push with a pointer to a subroutine that will draw
-one page. Every time your subroutine is called, it generates a new
-page. The contents of the page will be transmitted to the browser
-in such a way that it will replace what was there beforehand. The
-technique will work with HTML pages as well as with graphics files,
-allowing you to create animated GIFs.
-
-Only Netscape Navigator supports server push. Internet Explorer
-browsers do not.
-
-=head1 USING CGI::Push
-
-CGI::Push adds one new method to the standard CGI suite, do_push().
-When you call this method, you pass it a reference to a subroutine
-that is responsible for drawing each new page, an interval delay, and
-an optional subroutine for drawing the last page. Other optional
-parameters include most of those recognized by the CGI header()
-method.
-
-You may call do_push() in the object oriented manner or not, as you
-prefer:
-
- use CGI::Push;
- $q = new CGI::Push;
- $q->do_push(-next_page=>\&draw_a_page);
-
- -or-
-
- use CGI::Push qw(:standard);
- do_push(-next_page=>\&draw_a_page);
-
-Parameters are as follows:
-
-=over 4
-
-=item -next_page
-
- do_push(-next_page=>\&my_draw_routine);
-
-This required parameter points to a reference to a subroutine responsible for
-drawing each new page. The subroutine should expect two parameters
-consisting of the CGI object and a counter indicating the number
-of times the subroutine has been called. It should return the
-contents of the page as an B<array> of one or more items to print.
-It can return a false value (or an empty array) in order to abort the
-redrawing loop and print out the final page (if any)
-
- sub my_draw_routine {
- my($q,$counter) = @_;
- return undef if $counter > 100;
- return start_html('testing'),
- h1('testing'),
- "This page called $counter times";
- }
-
-You are of course free to refer to create and use global variables
-within your draw routine in order to achieve special effects.
-
-=item -last_page
-
-This optional parameter points to a reference to the subroutine
-responsible for drawing the last page of the series. It is called
-after the -next_page routine returns a false value. The subroutine
-itself should have exactly the same calling conventions as the
--next_page routine.
-
-=item -type
-
-This optional parameter indicates the content type of each page. It
-defaults to "text/html". Normally the module assumes that each page
-is of a homogenous MIME type. However if you provide either of the
-magic values "heterogeneous" or "dynamic" (the latter provided for the
-convenience of those who hate long parameter names), you can specify
-the MIME type -- and other header fields -- on a per-page basis. See
-"heterogeneous pages" for more details.
-
-=item -delay
-
-This indicates the delay, in seconds, between frames. Smaller delays
-refresh the page faster. Fractional values are allowed.
-
-B<If not specified, -delay will default to 1 second>
-
-=item -cookie, -target, -expires, -nph
-
-These have the same meaning as the like-named parameters in
-CGI::header().
-
-If not specified, -nph will default to 1 (as needed for many servers, see below).
-
-=back
-
-=head2 Heterogeneous Pages
-
-Ordinarily all pages displayed by CGI::Push share a common MIME type.
-However by providing a value of "heterogeneous" or "dynamic" in the
-do_push() -type parameter, you can specify the MIME type of each page
-on a case-by-case basis.
-
-If you use this option, you will be responsible for producing the
-HTTP header for each page. Simply modify your draw routine to
-look like this:
-
- sub my_draw_routine {
- my($q,$counter) = @_;
- return header('text/html'), # note we're producing the header here
- start_html('testing'),
- h1('testing'),
- "This page called $counter times";
- }
-
-You can add any header fields that you like, but some (cookies and
-status fields included) may not be interpreted by the browser. One
-interesting effect is to display a series of pages, then, after the
-last page, to redirect the browser to a new URL. Because redirect()
-does b<not> work, the easiest way is with a -refresh header field,
-as shown below:
-
- sub my_draw_routine {
- my($q,$counter) = @_;
- return undef if $counter > 10;
- return header('text/html'), # note we're producing the header here
- start_html('testing'),
- h1('testing'),
- "This page called $counter times";
- }
-
- sub my_last_page {
- return header(-refresh=>'5; URL=http://somewhere.else/finished.html',
- -type=>'text/html'),
- start_html('Moved'),
- h1('This is the last page'),
- 'Goodbye!'
- hr,
- end_html;
- }
-
-=head2 Changing the Page Delay on the Fly
-
-If you would like to control the delay between pages on a page-by-page
-basis, call push_delay() from within your draw routine. push_delay()
-takes a single numeric argument representing the number of seconds you
-wish to delay after the current page is displayed and before
-displaying the next one. The delay may be fractional. Without
-parameters, push_delay() just returns the current delay.
-
-=head1 INSTALLING CGI::Push SCRIPTS
-
-Server push scripts must be installed as no-parsed-header (NPH)
-scripts in order to work correctly on many servers. On Unix systems,
-this is most often accomplished by prefixing the script's name with "nph-".
-Recognition of NPH scripts happens automatically with WebSTAR and
-Microsoft IIS. Users of other servers should see their documentation
-for help.
-
-Apache web server from version 1.3b2 on does not need server
-push scripts installed as NPH scripts: the -nph parameter to do_push()
-may be set to a false value to disable the extra headers needed by an
-NPH script.
-
-=head1 AUTHOR INFORMATION
-
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org
-
-=head1 BUGS
-
-This section intentionally left blank.
-
-=head1 SEE ALSO
-
-L<CGI::Carp>, L<CGI>
-
-=cut
-
diff --git a/lib/CGI/Switch.pm b/lib/CGI/Switch.pm
deleted file mode 100644
index b8cc9ef..0000000
--- a/lib/CGI/Switch.pm
+++ /dev/null
@@ -1,27 +0,0 @@
-use CGI;
-
-$VERSION = '1.00';
-
-1;
-
-__END__
-
-=head1 NAME
-
-CGI::Switch - Backward compatibility module for defunct CGI::Switch
-
-=head1 SYNOPSIS
-
-Do not use this module. It is deprecated.
-
-=head1 ABSTRACT
-
-=head1 DESCRIPTION
-
-=head1 AUTHOR INFORMATION
-
-=head1 BUGS
-
-=head1 SEE ALSO
-
-=cut
diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm
deleted file mode 100644
index 6af42de..0000000
--- a/lib/CGI/Util.pm
+++ /dev/null
@@ -1,317 +0,0 @@
-package CGI::Util;
-
-use strict;
-use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(rearrange make_attributes unescape escape
- expires ebcdic2ascii ascii2ebcdic);
-
-$VERSION = '1.5';
-
-$EBCDIC = "\t" ne "\011";
-# (ord('^') == 95) for codepage 1047 as on os390, vmesa
-@A2E = (
- 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
- 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
- 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
- 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
- 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
- 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
- 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
- 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
- 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
- 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
- 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
- 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
- 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
- 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
- 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
- );
-@E2A = (
- 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
- 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
- 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
- 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
- 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
- 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
- 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
- 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
- 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
- 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
- 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
- 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
- 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
- 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
- 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
- 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
- );
-
-if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
- $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
- $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
- $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
- $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
- $A2E[249] = 192;
-
- $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
- $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
- $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
- $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
- $E2A[255] = 126;
- }
-elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
- $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
- $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
-
- $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
- $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
-}
-
-# Smart rearrangement of parameters to allow named parameter
-# calling. We do the rearangement if:
-# the first parameter begins with a -
-sub rearrange {
- my($order,@param) = @_;
- return () unless @param;
-
- if (ref($param[0]) eq 'HASH') {
- @param = %{$param[0]};
- } else {
- return @param
- unless (defined($param[0]) && substr($param[0],0,1) eq '-');
- }
-
- # map parameters into positional indices
- my ($i,%pos);
- $i = 0;
- foreach (@$order) {
- foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
- $i++;
- }
-
- my (@result,%leftover);
- $#result = $#$order; # preextend
- while (@param) {
- my $key = lc(shift(@param));
- $key =~ s/^\-//;
- if (exists $pos{$key}) {
- $result[$pos{$key}] = shift(@param);
- } else {
- $leftover{$key} = shift(@param);
- }
- }
-
- push (@result,make_attributes(\%leftover,1)) if %leftover;
- @result;
-}
-
-sub make_attributes {
- my $attr = shift;
- return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
- my $escape = shift || 0;
- my(@att);
- foreach (keys %{$attr}) {
- my($key) = $_;
- $key=~s/^\-//; # get rid of initial - if present
-
- # old way: breaks EBCDIC!
- # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
-
- ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
-
- my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
- push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
- }
- return @att;
-}
-
-sub simple_escape {
- return unless defined(my $toencode = shift);
- $toencode =~ s{&}{&amp;}gso;
- $toencode =~ s{<}{&lt;}gso;
- $toencode =~ s{>}{&gt;}gso;
- $toencode =~ s{\"}{&quot;}gso;
-# Doesn't work. Can't work. forget it.
-# $toencode =~ s{\x8b}{&#139;}gso;
-# $toencode =~ s{\x9b}{&#155;}gso;
- $toencode;
-}
-
-sub utf8_chr {
- my $c = shift(@_);
-
- if ($c < 0x80) {
- return sprintf("%c", $c);
- } elsif ($c < 0x800) {
- return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
- } elsif ($c < 0x10000) {
- return sprintf("%c%c%c",
- 0xe0 | ($c >> 12),
- 0x80 | (($c >> 6) & 0x3f),
- 0x80 | ( $c & 0x3f));
- } elsif ($c < 0x200000) {
- return sprintf("%c%c%c%c",
- 0xf0 | ($c >> 18),
- 0x80 | (($c >> 12) & 0x3f),
- 0x80 | (($c >> 6) & 0x3f),
- 0x80 | ( $c & 0x3f));
- } elsif ($c < 0x4000000) {
- return sprintf("%c%c%c%c%c",
- 0xf8 | ($c >> 24),
- 0x80 | (($c >> 18) & 0x3f),
- 0x80 | (($c >> 12) & 0x3f),
- 0x80 | (($c >> 6) & 0x3f),
- 0x80 | ( $c & 0x3f));
-
- } elsif ($c < 0x80000000) {
- return sprintf("%c%c%c%c%c%c",
- 0xfc | ($c >> 30),
- 0x80 | (($c >> 24) & 0x3f),
- 0x80 | (($c >> 18) & 0x3f),
- 0x80 | (($c >> 12) & 0x3f),
- 0x80 | (($c >> 6) & 0x3f),
- 0x80 | ( $c & 0x3f));
- } else {
- return utf8_chr(0xfffd);
- }
-}
-
-# unescape URL-encoded data
-sub unescape {
- shift() if @_ > 1 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
- my $todecode = shift;
- return undef unless defined($todecode);
- $todecode =~ tr/+/ /; # pluses become spaces
- $EBCDIC = "\t" ne "\011";
- if ($EBCDIC) {
- $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
- } else {
- $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
- defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
- }
- return $todecode;
-}
-
-# URL-encode data
-sub escape {
- shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
- my $toencode = shift;
- return undef unless defined($toencode);
- # force bytes while preserving backward compatibility -- dankogai
- $toencode = pack("C*", unpack("C*", $toencode));
- if ($EBCDIC) {
- $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
- } else {
- $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
- }
- return $toencode;
-}
-
-# This internal routine creates date strings suitable for use in
-# cookies and HTTP headers. (They differ, unfortunately.)
-# Thanks to Mark Fisher for this.
-sub expires {
- my($time,$format) = @_;
- $format ||= 'http';
-
- my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
- my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
-
- # pass through preformatted dates for the sake of expire_calc()
- $time = expire_calc($time);
- return $time unless $time =~ /^\d+$/;
-
- # make HTTP/cookie date string from GMT'ed time
- # (cookies use '-' as date separator, HTTP uses ' ')
- my($sc) = ' ';
- $sc = '-' if $format eq "cookie";
- my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
- $year += 1900;
- return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
- $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
-}
-
-# This internal routine creates an expires time exactly some number of
-# hours from the current time. It incorporates modifications from
-# Mark Fisher.
-sub expire_calc {
- my($time) = @_;
- my(%mult) = ('s'=>1,
- 'm'=>60,
- 'h'=>60*60,
- 'd'=>60*60*24,
- 'M'=>60*60*24*30,
- 'y'=>60*60*24*365);
- # format for time can be in any of the forms...
- # "now" -- expire immediately
- # "+180s" -- in 180 seconds
- # "+2m" -- in 2 minutes
- # "+12h" -- in 12 hours
- # "+1d" -- in 1 day
- # "+3M" -- in 3 months
- # "+2y" -- in 2 years
- # "-3m" -- 3 minutes ago(!)
- # If you don't supply one of these forms, we assume you are
- # specifying the date yourself
- my($offset);
- if (!$time || (lc($time) eq 'now')) {
- $offset = 0;
- } elsif ($time=~/^\d+/) {
- return $time;
- } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
- $offset = ($mult{$2} || 1)*$1;
- } else {
- return $time;
- }
- return (time+$offset);
-}
-
-sub ebcdic2ascii {
- my $data = shift;
- $data =~ s/(.)/chr $E2A[ord($1)]/ge;
- $data;
-}
-
-sub ascii2ebcdic {
- my $data = shift;
- $data =~ s/(.)/chr $A2E[ord($1)]/ge;
- $data;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CGI::Util - Internal utilities used by CGI module
-
-=head1 SYNOPSIS
-
-none
-
-=head1 DESCRIPTION
-
-no public subroutines
-
-=head1 AUTHOR INFORMATION
-
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org. When sending
-bug reports, please provide the version of CGI.pm, the version of
-Perl, the name and version of your Web server, and the name and
-version of the operating system you are using. If the problem is even
-remotely browser dependent, please provide information about the
-affected browers as well.
-
-=head1 SEE ALSO
-
-L<CGI>
-
-=cut