summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl.straw/lib/CGI
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2010-03-01 01:54:19 +0000
committerNorbert Preining <preining@logic.at>2010-03-01 01:54:19 +0000
commit904fd0757fe037dbfbf156b31f72e5ff5c7cd796 (patch)
tree36f000ab754854574aad17c01d9cd9ac739f1053 /Master/tlpkg/tlperl.straw/lib/CGI
parent402bd194f686177d2dfca24f7c4766434c514141 (diff)
commit more files of the tlperl.straw dir, still not complete
git-svn-id: svn://tug.org/texlive/trunk@17244 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/CGI')
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Apache.pm27
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Carp.pm606
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Cookie.pm546
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Fast.pm220
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Pretty.pm312
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Push.pm325
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Switch.pm28
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/CGI/Util.pm365
8 files changed, 2429 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/CGI/Apache.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Apache.pm
new file mode 100755
index 00000000000..e055e305551
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Apache.pm
@@ -0,0 +1,27 @@
+package CGI::Apache;
+use CGI;
+
+$VERSION = '1.01';
+
+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/Master/tlpkg/tlperl.straw/lib/CGI/Carp.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Carp.pm
new file mode 100755
index 00000000000..381635e87e0
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Carp.pm
@@ -0,0 +1,606 @@
+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.
+Also, note that carpout() does not work with in-memory file handles, although
+a patch would be welcome to address that.
+
+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).
+
+Note that fatalsToBrowser does B<not> work with mod_perl version 2.0
+and higher.
+
+=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 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS
+
+If fatalsToBrowser in conjunction with set_message does not provide
+you with all of the functionality you need, you can go one step
+further by specifying a function to be executed any time a script
+calls "die", has a syntax error, or dies unexpectedly at runtime
+with a line like "undef->explode();".
+
+ use CGI::Carp qw(set_die_handler);
+ BEGIN {
+ sub handle_errors {
+ my $msg = shift;
+ print "content-type: text/html\n\n";
+ print "<h1>Oh gosh</h1>";
+ print "<p>Got an error: $msg</p>";
+
+ #proceed to send an email to a system administrator,
+ #write a detailed message to the browser and/or a log,
+ #etc....
+ }
+ set_die_handler(\&handle_errors);
+ }
+
+Notice that if you use set_die_handler(), you must handle sending
+HTML headers to the browser yourself if you are printing a message.
+
+If you use set_die_handler(), you will most likely interfere with
+the behavior of fatalsToBrowser, so you must use this or that, not
+both.
+
+Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser),
+and there is only one SIG{__DIE__}. This means that if you are
+attempting to set SIG{__DIE__} yourself, you may interfere with
+this module's functionality, or this module may interfere with
+your module's functionality.
+
+=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.29 Patch from Peter Whaite to fix the unfixable problem of CGI::Carp
+ not behaving correctly in an eval() context.
+
+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 accommodate 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
+
+=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_die_handler set_progname cluck ^name= die);
+
+$main::SIG{__WARN__}=\&CGI::Carp::warn;
+
+$CGI::Carp::VERSION = '3.45';
+$CGI::Carp::CUSTOM_MSG = undef;
+$CGI::Carp::DIE_HANDLER = 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|Dispatch)\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) = @_;
+
+ if ($DIE_HANDLER) {
+ &$DIE_HANDLER($arg,@rest);
+ }
+
+ if ( ineval() ) {
+ if (!ref($arg)) {
+ $arg = join("",($arg,@rest)) || "Died";
+ my($file,$line,$id) = id(1);
+ $arg .= " at $file line $line.\n" unless $arg=~/\n$/;
+ realdie($arg);
+ }
+ else {
+ realdie($arg,@rest);
+ }
+ }
+
+ 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 set_die_handler {
+
+ my ($handler) = shift;
+
+ #setting SIG{__DIE__} here is necessary to catch runtime
+ #errors which are not called by literally saying "die",
+ #such as the line "undef->explode();". however, doing this
+ #will interfere with fatalsToBrowser, which also sets
+ #SIG{__DIE__} in the import() function above (or the
+ #import() function above may interfere with this). for
+ #this reason, you should choose to either set the die
+ #handler here, or use fatalsToBrowser, not both.
+ $main::SIG{__DIE__} = $handler;
+
+ $CGI::Carp::DIE_HANDLER = $handler;
+
+ return $CGI::Carp::DIE_HANDLER;
+}
+
+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;
+ eval {
+ &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
+ };
+ if ($@) { print STDERR q(error while executing the error handler: $@); }
+
+ return;
+ } else {
+ $outer_message = $CUSTOM_MSG;
+ }
+ }
+
+ my $mess = <<END;
+<h1>Software error:</h1>
+<pre>$msg</pre>
+<p>
+$outer_message
+</p>
+END
+ ;
+
+ if ($mod_perl) {
+ my $r;
+ if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $mod_perl = 2;
+ require Apache2::RequestRec;
+ require Apache2::RequestIO;
+ require Apache2::RequestUtil;
+ require APR::Pool;
+ require ModPerl::Util;
+ require Apache2::Response;
+ $r = Apache2::RequestUtil->request;
+ }
+ else {
+ $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 "Status: 500\n";
+ 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/Master/tlpkg/tlperl.straw/lib/CGI/Cookie.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Cookie.pm
new file mode 100755
index 00000000000..85a07f0bc05
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Cookie.pm
@@ -0,0 +1,546 @@
+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.29';
+
+use CGI::Util qw(rearrange unescape escape);
+use CGI;
+use overload '""' => \&as_string,
+ 'cmp' => \&compare,
+ 'fallback'=>1;
+
+my $PERLEX = 0;
+# Turn on special checking for ActiveState's PerlEx
+$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
+
+# Turn on special checking for Doug MacEachern's modperl
+# PerlEx::DBI tries to fool DBI by setting MOD_PERL
+my $MOD_PERL = 0;
+if (exists $ENV{MOD_PERL} && ! $PERLEX) {
+ if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $MOD_PERL = 2;
+ require Apache2::RequestUtil;
+ require APR::Table;
+ } 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 { $MOD_PERL == 2 ?
+ Apache2::RequestUtil->request() :
+ 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);
+ # Ignore mod_perl request object--compatability with Apache::Cookie.
+ shift if ref $_[0]
+ && eval { $_[0]->isa('Apache::Request::Req') || $_[0]->isa('Apache') };
+ my($name,$value,$path,$domain,$secure,$expires,$httponly) =
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@_);
+
+ # 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->httponly($httponly) if defined $httponly;
+# $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,$httponly);
+
+ 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;
+ push(@constant_values,"HttpOnly") if $httponly = $self->httponly;
+
+ my($key) = escape($self->name);
+ my($cookie) = join("=",(defined $key ? $key : ''),join("&",map escape(defined $_ ? $_ : ''),$self->value));
+ return join("; ",$cookie,@constant_values);
+}
+
+sub compare {
+ my $self = shift;
+ my $value = shift;
+ return "$self" cmp $value;
+}
+
+sub bake {
+ my ($self, $r) = @_;
+
+ $r ||= eval {
+ $MOD_PERL == 2
+ ? Apache2::RequestUtil->request()
+ : Apache->request
+ } if $MOD_PERL;
+ if ($r) {
+ $r->headers_out->add('Set-Cookie' => $self->as_string);
+ } else {
+ print CGI::header(-cookie => $self);
+ }
+
+}
+
+# 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'} = lc $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'};
+}
+
+
+sub httponly { # HttpOnly
+ my $self = shift;
+ my $httponly = shift;
+ $self->{'httponly'} = $httponly if defined $httponly;
+ return $self->{'httponly'};
+}
+
+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.
+
+=item B<4. httponly flag>
+
+If the "httponly" attribute is set, the cookie will only be accessible
+through HTTP Requests. This cookie will be inaccessible via JavaScript
+(to prevent XSS attacks).
+
+But, currently this feature only used and recognised by
+MS Internet Explorer 6 Service Pack 1 and later.
+
+See this URL for more information:
+
+L<http://msdn.microsoft.com/en-us/library/ms533046%28VS.85%29.aspx>
+
+=back
+
+=head2 Creating New Cookies
+
+ my $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.
+
+B<-httponly> if set to a true value, the cookie will not be accessible
+via JavaScript.
+
+For compatibility with Apache::Cookie, you may optionally pass in
+a mod_perl request object as the first argument to C<new()>. It will
+simply be ignored:
+
+ my $c = new CGI::Cookie($r,
+ -name => 'foo',
+ -value => ['bar','baz']);
+
+=head2 Sending the Cookie to the Browser
+
+The simplest way to send a cookie to the browser is by calling the bake()
+method:
+
+ $c->bake;
+
+Under mod_perl, pass in an Apache request object:
+
+ $c->bake($r);
+
+If you want to set the cookie yourself, 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/Master/tlpkg/tlperl.straw/lib/CGI/Fast.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Fast.pm
new file mode 100755
index 00000000000..67d67ee6856
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Fast.pm
@@ -0,0 +1,220 @@
+package CGI::Fast;
+use strict;
+$^W=1; # A way to say "use warnings" that's compatible with even older perls.
+
+# 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.
+
+$CGI::Fast::VERSION='1.07';
+
+use CGI;
+use FCGI;
+# use vars works like "our", but is compatible with older Perls.
+use vars qw(
+ @ISA
+ $ignore
+);
+@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;
+ }
+ }
+ CGI->_reset_globals;
+ $self->_setup_symbols(@CGI::SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
+ 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 FCGI module, 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 the FCGI module. See
+http://www.cpan.org/ for details.
+
+=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/bin/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/Master/tlpkg/tlperl.straw/lib/CGI/Pretty.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Pretty.pm
new file mode 100755
index 00000000000..356747824d5
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Pretty.pm
@@ -0,0 +1,312 @@
+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 = '3.46';
+$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] unless \$" eq "";
+ }
+ }
+ else {
+ \@args = ref(\$_[0]) eq 'ARRAY' ? \@{\$_[0]} : "\@_";
+ }
+
+ my \@result;
+ if ( exists \$ASIS{ "\L$tagname\E" } ) {
+ \@result = map { "\$tag\$_\$untag" } \@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;
+ }
+ if (\$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT) {
+ return join ("", \@result);
+ } else {
+ 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) {
+ if ($CGI::MOD_PERL == 1) {
+ my $r = Apache->request;
+ $r->register_cleanup(\&CGI::Pretty::_reset_globals);
+ }
+ else {
+ my $r = Apache2::RequestUtil->request;
+ $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.
+ # When this list is updated, also update the docs.
+ @CGI::Pretty::AS_IS = qw( a pre code script textarea td );
+
+ 1;
+}
+sub _reset_globals { initialize_globals(); }
+
+# ugly, but quick fix
+sub import {
+ my $self = shift;
+ no strict 'refs';
+ ${ "$self\::AutoloadClass" } = 'CGI';
+
+ # This causes modules to clash.
+ undef %CGI::EXPORT;
+ undef %CGI::EXPORT;
+
+ $self->_setup_symbols(@_);
+ my ($callpack, $callfile, $callline) = caller;
+
+ # To allow overriding, search through the packages
+ # Till we find one in which the correct subroutine is defined.
+ my @packages = ($self,@{"$self\:\:ISA"});
+ foreach my $sym (keys %CGI::EXPORT) {
+ my $pck;
+ my $def = ${"$self\:\:AutoloadClass"} || $CGI::DefaultClass;
+ foreach $pck (@packages) {
+ if (defined(&{"$pck\:\:$sym"})) {
+ $def = $pck;
+ last;
+ }
+ }
+ *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
+ }
+}
+
+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 Recommendation for when to use CGI::Pretty
+
+CGI::Pretty is far slower than using CGI.pm directly. A benchmark showed that
+it could be about 10 times slower. Adding newslines and spaces may alter the
+rendered appearance of HTML. Also, the extra newlines and spaces also make the
+file size larger, making the files take longer to download.
+
+With all those considerations, it is recommended that CGI::Pretty be used
+primarily for debugging.
+
+=head2 Tags that won't be formatted
+
+The following tags are not formatted: <a>, <pre>, <code>, <script>, <textarea>, and <td>.
+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(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 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/Master/tlpkg/tlperl.straw/lib/CGI/Push.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Push.pm
new file mode 100755
index 00000000000..9e72abda550
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Push.pm
@@ -0,0 +1,325 @@
+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,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@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);
+
+ 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;
+ print $self->header(@o);
+
+ $boundary = "$CGI::CRLF--$boundary";
+
+ 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) {
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
+ print @contents;
+ @contents = &$callback($self,++$COUNTER);
+ if ((@contents) && defined($contents[0])) {
+ print "${boundary}$CGI::CRLF";
+ do_sleep($self->push_delay()) if $self->push_delay();
+ } else {
+ if ($last_page && ref($last_page) eq 'CODE') {
+ print "${boundary}$CGI::CRLF";
+ do_sleep($self->push_delay()) if $self->push_delay();
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
+ print &$last_page($self,$COUNTER);
+ }
+ print "${boundary}--$CGI::CRLF";
+ last;
+ }
+ }
+ print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.$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/Master/tlpkg/tlperl.straw/lib/CGI/Switch.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Switch.pm
new file mode 100755
index 00000000000..a311080e49f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Switch.pm
@@ -0,0 +1,28 @@
+package CGI::Switch;
+use CGI;
+
+$VERSION = '1.01';
+
+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/Master/tlpkg/tlperl.straw/lib/CGI/Util.pm b/Master/tlpkg/tlperl.straw/lib/CGI/Util.pm
new file mode 100755
index 00000000000..1f4201d0648
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/CGI/Util.pm
@@ -0,0 +1,365 @@
+package CGI::Util;
+
+use strict;
+use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
+ expires ebcdic2ascii ascii2ebcdic);
+
+$VERSION = '3.48';
+
+$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 rearrangement if:
+# the first parameter begins with a -
+
+sub rearrange {
+ my ($order,@param) = @_;
+ my ($result, $leftover) = _rearrange_params( $order, @param );
+ push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
+ if keys %$leftover;
+ @$result;
+}
+
+sub rearrange_header {
+ my ($order,@param) = @_;
+
+ my ($result,$leftover) = _rearrange_params( $order, @param );
+ push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
+
+ @$result;
+}
+
+sub _rearrange_params {
+ 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);
+ }
+ }
+
+ return \@result, \%leftover;
+}
+
+sub make_attributes {
+ my $attr = shift;
+ return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
+ my $escape = shift || 0;
+ my $do_not_quote = shift;
+
+ my $quote = $do_not_quote ? '' : '"';
+
+ 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=$quote$value$quote/ : 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 ($] >= 5.006){
+ require utf8;
+ my $u = chr($c);
+ utf8::encode($u); # drop utf8 flag
+ return $u;
+ }
+ 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 @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
+ my $todecode = shift;
+ return undef unless defined($todecode);
+ $todecode =~ tr/+/ /; # pluses become spaces
+ if ($EBCDIC) {
+ $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
+ } else {
+ # handle surrogate pairs first -- dankogai
+ $todecode =~ s{
+ %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
+ %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
+ }{
+ utf8_chr(
+ 0x10000
+ + (hex($1) - 0xD800) * 0x400
+ + (hex($2) - 0xDC00)
+ )
+ }gex;
+ $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
+#
+# We cannot use the %u escapes, they were rejected by W3C, so the official
+# way is %XX-escaped utf-8 encoding.
+# Naturally, Unicode strings have to be converted to their utf-8 byte
+# representation. (No action is required on 5.6.)
+# Byte strings were traditionally used directly as a sequence of octets.
+# This worked if they actually represented binary data (i.e. in CGI::Compress).
+# This also worked if these byte strings were actually utf-8 encoded; e.g.,
+# when the source file used utf-8 without the apropriate "use utf8;".
+# This fails if the byte string is actually a Latin 1 encoded string, but it
+# was always so and cannot be fixed without breaking the binary data case.
+# -- Stepan Kasal <skasal@redhat.com>
+#
+sub escape {
+ shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
+ my $toencode = shift;
+ return undef unless defined($toencode);
+ utf8::encode($toencode) if ($] > 5.008001 && utf8::is_utf8($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*))([smhdMy])/) {
+ $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