dslinux/user/perl/lib/CGI Apache.pm Carp.pm Changes Cookie.pm Fast.pm Pretty.pm Push.pm Switch.pm Util.pm

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:24 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/lib/CGI
In directory antilope:/tmp/cvs-serv17422/lib/CGI

Added Files:
	Apache.pm Carp.pm Changes Cookie.pm Fast.pm Pretty.pm Push.pm 
	Switch.pm Util.pm 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: Apache.pm ---
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

--- NEW FILE: Fast.pm ---
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 at cshl.org

=head1 BUGS

This section intentionally left blank.

=head1 SEE ALSO

L<CGI::Carp>, L<CGI>

=cut

--- NEW FILE: Cookie.pm ---
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.26';

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}) {
  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);
  my($name,$value,$path,$domain,$secure,$expires) =
    rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES], at _);
  
  # 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, at 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'} = 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'};
}

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 at cshl.org

=head1 BUGS

This section intentionally left blank.

=head1 SEE ALSO

L<CGI::Carp>, L<CGI>

=cut

--- NEW FILE: Push.pm ---
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, at 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, at other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH], at 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 at cshl.org

=head1 BUGS

This section intentionally left blank.

=head1 SEE ALSO

L<CGI::Carp>, L<CGI>

=cut


--- NEW FILE: Switch.pm ---
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

--- NEW FILE: Util.pm ---
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, at 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,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover;
    @result;
}

sub make_attributes {
    my $attr = shift;
    return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
    my $escape =  shift || 0;
    my(@att);
    foreach (keys %{$attr}) {
	my($key) = $_;
	$key=~s/^\-//;     # get rid of initial - if present

	# old way: breaks EBCDIC!
	# $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes

	($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes

	my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
	push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
    }
    return @att;
}

sub simple_escape {
  return unless defined(my $toencode = shift);
  $toencode =~ s{&}{&amp;}gso;
  $toencode =~ s{<}{&lt;}gso;
  $toencode =~ s{>}{&gt;}gso;
  $toencode =~ s{\"}{&quot;}gso;
# Doesn't work.  Can't work.  forget it.
#  $toencode =~ s{\x8b}{&#139;}gso;
#  $toencode =~ s{\x9b}{&#155;}gso;
  $toencode;
}

sub utf8_chr {
        my $c = shift(@_);
	return chr($c) if $] >= 5.006;

        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
    $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 at 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

--- NEW FILE: Pretty.pm ---
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, at 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) {
        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.
    @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 at ThePaulsens.com>, with minor modifications by
Lincoln Stein <lstein at 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 at ThePaulsens.com.  You can also write
to lstein at cshl.org, but this code looks pretty hairy to me and I'm not
sure I understand it!

=head1 SEE ALSO

L<CGI>

=cut

--- NEW FILE: Changes ---
  Version 3.15 Wed Dec  7 15:13:22 EST 2005
   1. Remove extraneous "?" from self_url() when URI contains a ? but no query string.

  Version 3.14 Tue Dec  6 17:12:03 EST 2005
   1. Fixed broken scrolling_list() select attribute.
	
  Version 3.13
    1. Removed extraneous empty "?" from end of self_url().

  Version 3.12
    1. Fixed virtual_port so that it works properly with https protocol.
    2. Fixed documentation for upload_hook().
    3. Added POSTDATA documentation.
    4. Made upload_hook() work in function-oriented mode.
    5. Fixed POST_MAX behavior so that it doesn't cause client to hang.
    6. Disabled automatic tab indexes and added new -tabindex pragma to
	turn automatic indexes back on.
    7. The url() and self_url() methods now work better in the context of Apache
       mod_rewrite. Be advised that path_info() may give you confusing results
[...1177 lines suppressed...]
       problem that some browsers have when jumping to internal links in
       a document that contains a form -- the form information gets lost.
    5. The user-visible labels in checkboxes, radio buttons, popup menus
       and scrolling lists have now been decoupled from the values sent
       to your CGI script. Your script can know a checkbox by the name of
       "cb1" while the user knows it by a more descriptive name. I've
       also added some parameters that were missing from the text fields,
       such as MAXLENGTH.
    6. A whole bunch of methods have been added to get at environment
       variables involved in user verification and other obscure
       features.

  Bug fixes

    1. The problems with the hidden fields have (I hope at last) been
       fixed.
    2. You can create multiple query objects and they will all be
       initialized correctly. This simplifies the creation of multiple
       forms on one page.
    3. The URL unescaping code works correctly now.

--- NEW FILE: Carp.pm ---
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 at 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 at 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 at 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 at 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 at 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.29';
$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=/, at _))
      {
        my($n) = (split(/=/,$name[0]))[1];
        set_progname($n);
        @_=grep(!/^name=/, at _);
      }

    grep($routines{$_}++, at _, at 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, at rest) = @_;
  realdie ($arg, at rest) if ineval();

  if (!ref($arg)) {
    $arg = join("", ($arg, at rest));
    my($file,$line,$id) = id(1);
    $arg .= " at $file line $line." unless $arg=~/\n$/;
    &fatalsToBrowser($arg) if $WRAP;
    if (($arg =~ /\n$/) || !exists($ENV{MOD_PERL})) {
      my $stamp = stamp;
      $arg=~s/^/$stamp/gm;
    }
    if ($arg !~ /\n$/) {
      $arg .= "\n";
    }
  }
  realdie $arg;
}

sub set_message {
    $CGI::Carp::CUSTOM_MSG = shift;
    return $CGI::Carp::CUSTOM_MSG;
}

sub confess { CGI::Carp::die Carp::longmess @_; }
sub croak   { CGI::Carp::die Carp::shortmess @_; }
sub carp    { CGI::Carp::warn Carp::shortmess @_; }
sub cluck   { CGI::Carp::warn Carp::longmess @_; }

# We have to be ready to accept a filehandle as a reference
# or a string.
sub carpout {
    my($in) = @_;
    my($no) = fileno(to_filehandle($in));
    realdie("Invalid filehandle $in\n") unless defined $no;
    
    open(SAVEERR, ">&STDERR");
    open(STDERR, ">&$no") or 
	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
}

sub warningsToBrowser {
    $EMIT_WARNINGS = @_ ? shift : 1;
    _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
}

# headers
sub fatalsToBrowser {
  my($msg) = @_;
  $msg=~s/&/&amp;/g;
  $msg=~s/>/&gt;/g;
  $msg=~s/</&lt;/g;
  $msg=~s/\"/&quot;/g;
  my($wm) = $ENV{SERVER_ADMIN} ? 
    qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
      "this site's webmaster";
  my ($outer_message) = <<END;
For help, please send mail to $wm, giving this error message 
and the time and date of the error.
END
  ;
  my $mod_perl = exists $ENV{MOD_PERL};

  if ($CUSTOM_MSG) {
    if (ref($CUSTOM_MSG) eq 'CODE') {
      print STDOUT "Content-type: text/html\n\n" 
        unless $mod_perl;
      &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
      return;
    } else {
      $outer_message = $CUSTOM_MSG;
    }
  }

  my $mess = <<END;
<h1>Software error:</h1>
<pre>$msg</pre>
<p>
$outer_message
</p>
END
  ;

  if ($mod_perl) {
    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 "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;




More information about the dslinux-commit mailing list