diff options
| author | Andreas Brachold <vdr07@deltab.de> | 2007-11-11 06:55:13 +0000 |
|---|---|---|
| committer | Andreas Brachold <vdr07@deltab.de> | 2007-11-11 06:55:13 +0000 |
| commit | 3282be229999dc36c197b264d63063a18d136331 (patch) | |
| tree | 98a42db29d955b39e7bed1b599fdcc56c3a29de9 /lib/CGI | |
| parent | cfdd733c17cfa4f1a43b827a656e9e53cc2524ac (diff) | |
| download | xxv-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.pm | 26 | ||||
| -rw-r--r-- | lib/CGI/Carp.pm | 524 | ||||
| -rw-r--r-- | lib/CGI/Cookie.pm | 478 | ||||
| -rw-r--r-- | lib/CGI/Fast.pm | 230 | ||||
| -rw-r--r-- | lib/CGI/Pretty.pm | 275 | ||||
| -rw-r--r-- | lib/CGI/Push.pm | 328 | ||||
| -rw-r--r-- | lib/CGI/Switch.pm | 27 | ||||
| -rw-r--r-- | lib/CGI/Util.pm | 317 |
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 > and < 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/&/&/g; - $msg=~s/>/>/g; - $msg=~s/</</g; - $msg=~s/\"/"/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{&}{&}gso; - $toencode =~ s{<}{<}gso; - $toencode =~ s{>}{>}gso; - $toencode =~ s{\"}{"}gso; -# Doesn't work. Can't work. forget it. -# $toencode =~ s{\x8b}{‹}gso; -# $toencode =~ s{\x9b}{›}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 |
