[ Home | Contents | Search | Post ]
[ Home | Contents | Search | Post ]
[ Home | Contents | Search | Post ]
[ Home | Contents | Search | Post ]
tags with in
fatalsToBrowser() output.
=head1 AUTHORS
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 SEE ALSO
Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
CGI::Response
=cut
require 5.000;
use Exporter;
use Carp;
use File::Spec;
@ISA = qw(Exporter);
@EXPORT = qw(confess croak carp);
@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck);
$main::SIG{__WARN__}=\&CGI::Carp::warn;
$main::SIG{__DIE__}=\&CGI::Carp::die;
$CGI::Carp::VERSION = '1.21';
$CGI::Carp::CUSTOM_MSG = undef;
# fancy import routine detects and handles 'errorWrap' specially.
sub import {
my $pkg = shift;
my(%routines);
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;
}
# 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);
do {
$id = $file;
($pack,$file) = caller($frame++);
} until !$file;
($dev,$dirs,$id) = File::Spec->splitpath($id);
return "[$time] $id: ";
}
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 "\n";
} else {
push @WARNINGS, $msg;
}
}
sub ineval { $^S }
# 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();
my $mod_perl = exists $ENV{MOD_PERL};
$message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
return $message;
}
sub die {
realdie @_ if ineval;
my ($message) = @_;
my $time = scalar(localtime);
my($file,$line,$id) = id(1);
$message .= " at $file line $line." unless $message=~/\n$/;
&fatalsToBrowser($message) if $WRAP;
my $stamp = stamp;
$message=~s/^/$stamp/gm;
realdie $message;
}
sub set_message {
$CGI::Carp::CUSTOM_MSG = shift;
return $CGI::Carp::CUSTOM_MSG;
}
# Avoid generating "subroutine redefined" warnings with the following
# hack:
{
local $^W=0;
eval <&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/$ENV{SERVER_ADMIN})] :
"this site's webmaster";
my ($outer_message) = <Software error:
$msg
$outer_message
END
;
if ($mod_perl && (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);
$r->exit;
} else {
$r->status(500);
$r->custom_response(500,$mess);
}
} else {
print STDOUT $mess;
}
}
# 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;
cgi-bin/extlib/CGI/Cookie.pm0000644002157400001440000003164107771550070022446 0ustar minnesotaviolasociety.orgusers00000000000000package 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.20';
use CGI::Util qw(rearrange unescape escape);
use overload '""' => \&as_string,
'cmp' => \&compare,
'fallback'=>1;
# 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 = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
return () unless $raw_cookie;
return $class->parse($raw_cookie);
}
# fetch a list of cookies from the environment 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 = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
return () unless $raw_cookie;
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 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;
return $self;
}
sub as_string {
my $self = shift;
return "" unless $self->name;
my(@constant_values,$domain,$path,$expires,$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,"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 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 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.
Alternatively, you may concatenate the cookies together with "; " and
send them in one field.
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->header_out('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 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);
=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
Get or set the cookie's name. Example:
$name = $c->name;
$new_name = $c->name('fred');
=item B
Get or set the cookie's value. Example:
$value = $c->value;
@new_value = $c->value(['a','b','c','d']);
B 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 value of a multivalued cookie.
=item B
Get or set the cookie's domain.
=item B
Get or set the cookie's path.
=item B
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, L
=cut
cgi-bin/extlib/CGI/Fast.pm0000644002157400001440000001602707771550070022133 0ustar minnesotaviolasociety.orgusers00000000000000package 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.04';
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 object is created,
allowing C to be used as an external FastCGI server. (See C
documentation for C 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, L
=cut
cgi-bin/extlib/CGI/Pretty.pm0000644002157400001440000001555107771550070022526 0ustar minnesotaviolasociety.orgusers00000000000000package 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.05_00';
$CGI::DefaultClass = __PACKAGE__;
$CGI::Pretty::AutoloadClass = 'CGI';
@CGI::Pretty::ISA = qw( CGI );
initialize_globals();
sub _prettyPrint {
my $input = shift;
foreach my $i ( @CGI::Pretty::AS_IS ) {
if ( $$input =~ /<\/$i>/si ) {
my ( $a, $b, $c, $d, $e ) = $$input =~ /(.*)<$i(\s?)(.*?)>(.*?)<\/$i>(.*)/si;
_prettyPrint( \$a );
_prettyPrint( \$e );
$$input = "$a<$i$b$c>$d$e";
return;
}
}
$$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK;
}
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) = @_;
return $self->SUPER::_make_tag_func($tagname) if $tagname=~/^(start|end)_/;
# As Lincoln as noted, the last else clause is VERY hairy, and it
# took me a while to figure out what I was trying to do.
# What it does is look for tags that shouldn't be indented (e.g. PRE)
# and makes sure that when we nest tags, those tags don't get
# indented.
# For an example, try print td( pre( "hello\nworld" ) );
# If we didn't care about stuff like that, the code would be
# MUCH simpler. BTW: I won't claim to be a regular expression
# guru, so if anybody wants to contribute something that would
# be quicker, easier to read, etc, I would be more than
# willing to put it in - Brian
return qq{
sub $tagname {
# handle various cases in which we're called
# most of this bizarre stuff is to avoid -w errors
shift if \$_[0] &&
(ref(\$_[0]) &&
(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);
\$attr = " \@attr" if \@attr;
}
my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L\E");
return \$tag unless \@_;
my \@result;
my \$NON_PRETTIFY_ENDTAGS = join "", map { "" } \@CGI::Pretty::AS_IS;
if ( \$NON_PRETTIFY_ENDTAGS =~ /\$untag/ ) {
\@result = map { "\$tag\$_\$untag\$CGI::Pretty::LINEBREAK" }
(ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
}
else {
my \@args;
if(ref(\$_[0]) eq 'ARRAY') {
\@args = \@{\$_[0]}
} else {
foreach (\@_) {
\$args[0] .= \$_;
\$args[0] .= " " unless \$args[0] =~ /\\s\$/;
}
chop \$args[0];
}
\@result = map {
chomp;
if ( \$_ !~ /<\\// ) {
s/\$CGI::Pretty::LINEBREAK/\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT/g if \$CGI::Pretty::LINEBREAK;
}
else {
my \$tmp = \$_;
CGI::Pretty::_prettyPrint( \\\$tmp );
\$_ = \$tmp;
}
"\$tag\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT\$_\$CGI::Pretty::LINEBREAK\$untag\$CGI::Pretty::LINEBREAK"
} \@args;
}
local \$" = "";
return "\@result";
}
};
}
sub start_html {
return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK;
}
sub end_html {
return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK;
}
sub new {
my $class = shift;
my $this = $class->SUPER::new( @_ );
Apache->request->register_cleanup(\&CGI::Pretty::_reset_globals) if ($CGI::MOD_PERL);
$class->_reset_globals if $CGI::PERLEX;
return bless $this, $class;
}
sub initialize_globals {
# This is the string used for indentation of tags
$CGI::Pretty::INDENT = "\t";
# This is the string used for seperation between tags
$CGI::Pretty::LINEBREAK = "\n";
# These tags are not prettify'd.
@CGI::Pretty::AS_IS = qw( a pre code script textarea );
1;
}
sub _reset_globals { initialize_globals(); }
1;
=head1 NAME
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:
foo
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:
foo
=head2 Tags that won't be formatted
The and 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 , with minor modifications by
Lincoln Stein 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
=cut
cgi-bin/extlib/CGI/Push.pm0000644002157400001440000002527607771550070022163 0ustar minnesotaviolasociety.orgusers00000000000000package CGI::Push;
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
# You can run this file through either pod2man or pod2html to produce pretty
# documentation in manual or html file format (these utilities are part of the
# Perl 5 distribution).
# Copyright 1995-2000, Lincoln D. Stein. All rights reserved.
# It may be used and modified freely, but I do request that this copyright
# notice remain attached to the file. You may modify this module as you
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
$CGI::Push::VERSION='1.04';
use CGI;
use CGI::Util 'rearrange';
@ISA = ('CGI');
$CGI::DefaultClass = 'CGI::Push';
$CGI::Push::AutoloadClass = 'CGI';
# add do_push() and push_delay() to exported tags
push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay');
sub do_push {
my ($self,@p) = CGI::self_or_default(@_);
# unbuffer output
$| = 1;
srand;
my ($random) = sprintf("%08.0f",rand()*1E8);
my ($boundary) = "----=_NeXtPaRt$random";
my (@header);
my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
$type = 'text/html' unless $type;
$callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
$delay = 1 unless defined($delay);
$self->push_delay($delay);
$nph = 1 unless defined($nph);
my(@o);
foreach (@other) { push(@o,split("=")); }
push(@o,'-Target'=>$target) if defined($target);
push(@o,'-Cookie'=>$cookie) if defined($cookie);
push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\"");
push(@o,'-Server'=>"CGI.pm Push Module") if $nph;
push(@o,'-Status'=>'200 OK');
push(@o,'-nph'=>1) if $nph;
print $self->header(@o);
$boundary = "$CGI::CRLF--$boundary";
print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF";
my (@contents) = &$callback($self,++$COUNTER);
# now we enter a little loop
while (1) {
print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
print @contents;
@contents = &$callback($self,++$COUNTER);
if ((@contents) && defined($contents[0])) {
print "${boundary}$CGI::CRLF";
do_sleep($self->push_delay()) if $self->push_delay();
} else {
if ($last_page && ref($last_page) eq 'CODE') {
print "${boundary}$CGI::CRLF";
do_sleep($self->push_delay()) if $self->push_delay();
print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
print &$last_page($self,$COUNTER);
}
print "${boundary}--$CGI::CRLF";
last;
}
}
print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.$CGI::CRLF";
}
sub simple_counter {
my ($self,$count) = @_;
return $self->start_html("CGI::Push Default Counter"),
$self->h1("CGI::Push Default Counter"),
"This page has been updated ",$self->strong($count)," times.",
$self->hr(),
$self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'),
$self->end_html;
}
sub do_sleep {
my $delay = shift;
if ( ($delay >= 1) && ($delay!~/\./) ){
sleep($delay);
} else {
select(undef,undef,undef,$delay);
}
}
sub push_delay {
my ($self,$delay) = CGI::self_or_default(@_);
return defined($delay) ? $self->{'.delay'} =
$delay : $self->{'.delay'};
}
1;
=head1 NAME
CGI::Push - Simple Interface to Server Push
=head1 SYNOPSIS
use CGI::Push qw(:standard);
do_push(-next_page=>\&next_page,
-last_page=>\&last_page,
-delay=>0.5);
sub next_page {
my($q,$counter) = @_;
return undef if $counter >= 10;
return start_html('Test'),
h1('Visible'),"\n",
"This page has been called ", strong($counter)," times",
end_html();
}
sub last_page {
my($q,$counter) = @_;
return start_html('Done'),
h1('Finished'),
strong($counter - 1),' iterations.',
end_html;
}
=head1 DESCRIPTION
CGI::Push is a subclass of the CGI object created by CGI.pm. It is
specialized for server push operations, which allow you to create
animated pages whose content changes at regular intervals.
You provide CGI::Push with a pointer to a subroutine that will draw
one page. Every time your subroutine is called, it generates a new
page. The contents of the page will be transmitted to the browser
in such a way that it will replace what was there beforehand. The
technique will work with HTML pages as well as with graphics files,
allowing you to create animated GIFs.
Only Netscape Navigator supports server push. Internet Explorer
browsers do not.
=head1 USING CGI::Push
CGI::Push adds one new method to the standard CGI suite, do_push().
When you call this method, you pass it a reference to a subroutine
that is responsible for drawing each new page, an interval delay, and
an optional subroutine for drawing the last page. Other optional
parameters include most of those recognized by the CGI header()
method.
You may call do_push() in the object oriented manner or not, as you
prefer:
use CGI::Push;
$q = new CGI::Push;
$q->do_push(-next_page=>\&draw_a_page);
-or-
use CGI::Push qw(:standard);
do_push(-next_page=>\&draw_a_page);
Parameters are as follows:
=over 4
=item -next_page
do_push(-next_page=>\&my_draw_routine);
This required parameter points to a reference to a subroutine responsible for
drawing each new page. The subroutine should expect two parameters
consisting of the CGI object and a counter indicating the number
of times the subroutine has been called. It should return the
contents of the page as an B 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
=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 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, L
=cut
cgi-bin/extlib/CGI/Switch.pm0000644002157400001440000000043507771550070022473 0ustar minnesotaviolasociety.orgusers00000000000000use 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
cgi-bin/extlib/CGI/Util.pm0000644002157400001440000002476007771550070022156 0ustar minnesotaviolasociety.orgusers00000000000000package 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);
$VERSION = '1.3';
$EBCDIC = "\t" ne "\011";
if ($EBCDIC) {
# (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 (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 (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",
0xfe | ($c >> 30),
0x80 | (($c >> 24) & 0x3f),
0x80 | (($c >> 18) & 0x3f),
0x80 | (($c >> 12) & 0x3f),
0x80 | (($c >> 6) & 0x3f),
0x80 | ( $c & 0x3f));
} else {
return utf8(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);
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);
}
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
=cut
cgi-bin/extlib/File/0000755002157400001440000000000007776605372021162 5ustar minnesotaviolasociety.orgusers00000000000000cgi-bin/extlib/File/Spec/0000755002157400001440000000000007776605372022054 5ustar minnesotaviolasociety.orgusers00000000000000cgi-bin/extlib/File/Spec/_vti_cnf/0000755002157400001440000000000007776605372023643 5ustar minnesotaviolasociety.orgusers00000000000000cgi-bin/extlib/File/Spec/_vti_cnf/Functions.pm0000644002157400001440000000030307771550070026132 0ustar minnesotaviolasociety.orgusers00000000000000vti_encoding:SR|utf8-nl
vti_timelastmodified:TR|22 Dec 2003 11:06:32 -0000
vti_extenderversion:SR|5.0.2.2623
vti_cacheddtm:TX|22 Dec 2003 11:06:32 -0000
vti_filesize:IR|1625
vti_backlinkinfo:VX|
cgi-bin/extlib/File/Spec/_vti_cnf/Mac.pm0000644002157400001440000000030307771550070024662 0ustar minnesotaviolasociety.orgusers00000000000000vti_encoding:SR|utf8-nl
vti_timelastmodified:TR|22 Dec 2003 11:06:32 -0000
vti_extenderversion:SR|5.0.2.2623
vti_cacheddtm:TX|22 Dec 2003 11:06:32 -0000
vti_filesize:IR|8864
vti_backlinkinfo:VX|
cgi-bin/extlib/File/Spec/_vti_cnf/OS2.pm0000644002157400001440000000030307771550070024565 0ustar minnesotaviolasociety.orgusers00000000000000vti_encoding:SR|utf8-nl
vti_timelastmodified:TR|22 Dec 2003 11:06:32 -0000
vti_extenderversion:SR|5.0.2.2623
vti_cacheddtm:TX|22 Dec 2003 11:06:32 -0000
vti_filesize:IR|1142
vti_backlinkinfo:VX|
cgi-bin/extlib/File/Spec/_vti_cnf/Unix.pm0000644002157400001440000000030407771550070025106 0ustar minnesotaviolasociety.orgusers00000000000000vti_encoding:SR|utf8-nl
vti_timelastmodified:TR|22 Dec 2003 11:06:32 -0000
vti_extenderversion:SR|5.0.2.2623
vti_cacheddtm:TX|22 Dec 2003 11:06:32 -0000
vti_filesize:IR|10953
vti_backlinkinfo:VX|
cgi-bin/extlib/File/Spec/_vti_cnf/VMS.pm0000644002157400001440000000030407771550070024630 0ustar minnesotaviolasociety.orgusers00000000000000vti_encoding:SR|utf8-nl
vti_timelastmodified:TR|22 Dec 2003 11:06:32 -0000
vti_extenderversion:SR|5.0.2.2623
vti_cacheddtm:TX|22 Dec 2003 11:06:32 -0000
vti_filesize:IR|13396
vti_backlinkinfo:VX|
cgi-bin/extlib/File/Spec/_vti_cnf/Win32.pm0000644002157400001440000000030307771550070025064 0ustar minnesotaviolasociety.orgusers00000000000000vti_encoding:SR|utf8-nl
vti_timelastmodified:TR|22 Dec 2003 11:06:32 -0000
vti_extenderversion:SR|5.0.2.2623
vti_cacheddtm:TX|22 Dec 2003 11:06:32 -0000
vti_filesize:IR|8723
vti_backlinkinfo:VX|
cgi-bin/extlib/File/Spec/Functions.pm0000644002157400001440000000313107771550070024345 0ustar minnesotaviolasociety.orgusers00000000000000package File::Spec::Functions;
use File::Spec;
use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
$VERSION = '1.1';
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(
canonpath
catdir
catfile
curdir
rootdir
updir
no_upwards
file_name_is_absolute
path
);
@EXPORT_OK = qw(
devnull
tmpdir
splitpath
splitdir
catpath
abs2rel
rel2abs
);
%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
foreach my $meth (@EXPORT, @EXPORT_OK) {
my $sub = File::Spec->can($meth);
no strict 'refs';
*{$meth} = sub {&$sub('File::Spec', @_)};
}
1;
__END__
=head1 NAME
File::Spec::Functions - portably perform operations on file names
=head1 SYNOPSIS
use File::Spec::Functions;
$x = catfile('a','b');
=head1 DESCRIPTION
This module exports convenience functions for all of the class methods
provided by File::Spec.
For a reference of available functions, please consult L,
which contains the entire set, and which is inherited by the modules for
other platforms. For further information, please see L,
L, L, or L.
=head2 Exports
The following functions are exported by default.
canonpath
catdir
catfile
curdir
rootdir
updir
no_upwards
file_name_is_absolute
path
The following functions are exported only by request.
devnull
tmpdir
splitpath
splitdir
catpath
abs2rel
rel2abs
All the functions may be imported using the C<:ALL> tag.
=head1 SEE ALSO
File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2,
File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker
cgi-bin/extlib/File/Spec/Mac.pm0000644002157400001440000002124007771550070023076 0ustar minnesotaviolasociety.orgusers00000000000000package File::Spec::Mac;
use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
$VERSION = '1.2';
@ISA = qw(File::Spec::Unix);
=head1 NAME
File::Spec::Mac - File::Spec for MacOS
=head1 SYNOPSIS
require File::Spec::Mac; # Done internally by File::Spec if needed
=head1 DESCRIPTION
Methods for manipulating file specifications.
=head1 METHODS
=over 2
=item canonpath
On MacOS, there's nothing to be done. Returns what it's given.
=cut
sub canonpath {
my ($self,$path) = @_;
return $path;
}
=item catdir
Concatenate two or more directory names to form a complete path ending with
a directory. Put a trailing : on the end of the complete path if there
isn't one, because that's what's done in MacPerl's environment.
The fundamental requirement of this routine is that
File::Spec->catdir(split(":",$path)) eq $path
But because of the nature of Macintosh paths, some additional
possibilities are allowed to make using this routine give reasonable results
for some common situations. Here are the rules that are used. Each
argument has its trailing ":" removed. Each argument, except the first,
has its leading ":" removed. They are then joined together by a ":".
So
File::Spec->catdir("a","b") = "a:b:"
File::Spec->catdir("a:",":b") = "a:b:"
File::Spec->catdir("a:","b") = "a:b:"
File::Spec->catdir("a",":b") = "a:b"
File::Spec->catdir("a","","b") = "a::b"
etc.
To get a relative path (one beginning with :), begin the first argument with :
or put a "" as the first argument.
If you don't want to worry about these rules, never allow a ":" on the ends
of any of the arguments except at the beginning of the first.
Under MacPerl, there is an additional ambiguity. Does the user intend that
File::Spec->catfile("LWP","Protocol","http.pm")
be relative or absolute? There's no way of telling except by checking for the
existence of LWP: or :LWP, and even there he may mean a dismounted volume or
a relative path in a different directory (like in @INC). So those checks
aren't done here. This routine will treat this as absolute.
=cut
sub catdir {
shift;
my @args = @_;
my $result = shift @args;
$result =~ s/:\Z(?!\n)//;
foreach (@args) {
s/:\Z(?!\n)//;
s/^://s;
$result .= ":$_";
}
return "$result:";
}
=item catfile
Concatenate one or more directory names and a filename to form a
complete path ending with a filename. Since this uses catdir, the
same caveats apply. Note that the leading : is removed from the filename,
so that
File::Spec->catfile($ENV{HOME},"file");
and
File::Spec->catfile($ENV{HOME},":file");
give the same answer, as one might expect.
=cut
sub catfile {
my $self = shift;
my $file = pop @_;
return $file unless @_;
my $dir = $self->catdir(@_);
$file =~ s/^://s;
return $dir.$file;
}
=item curdir
Returns a string representing the current directory.
=cut
sub curdir {
return ":";
}
=item devnull
Returns a string representing the null device.
=cut
sub devnull {
return "Dev:Null";
}
=item rootdir
Returns a string representing the root directory. Under MacPerl,
returns the name of the startup volume, since that's the closest in
concept, although other volumes aren't rooted there.
=cut
sub rootdir {
#
# There's no real root directory on MacOS. The name of the startup
# volume is returned, since that's the closest in concept.
#
require Mac::Files;
my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
&Mac::Files::kSystemFolderType);
$system =~ s/:.*\Z(?!\n)/:/s;
return $system;
}
=item tmpdir
Returns a string representation of the first existing directory
from the following list or '' if none exist:
$ENV{TMPDIR}
=cut
my $tmpdir;
sub tmpdir {
return $tmpdir if defined $tmpdir;
$tmpdir = $ENV{TMPDIR} if -d $ENV{TMPDIR};
$tmpdir = '' unless defined $tmpdir;
return $tmpdir;
}
=item updir
Returns a string representing the parent directory.
=cut
sub updir {
return "::";
}
=item file_name_is_absolute
Takes as argument a path and returns true, if it is an absolute path. In
the case where a name can be either relative or absolute (for example, a
folder named "HD" in the current working directory on a drive named "HD"),
relative wins. Use ":" in the appropriate place in the path if you want to
distinguish unambiguously.
As a special case, the file name '' is always considered to be absolute.
=cut
sub file_name_is_absolute {
my ($self,$file) = @_;
if ($file =~ /:/) {
return ($file !~ m/^:/s);
} elsif ( $file eq '' ) {
return 1 ;
} else {
return (! -e ":$file");
}
}
=item path
Returns the null list for the MacPerl application, since the concept is
usually meaningless under MacOS. But if you're using the MacPerl tool under
MPW, it gives back $ENV{Commands} suitably split, as is done in
:lib:ExtUtils:MM_Mac.pm.
=cut
sub path {
#
# The concept is meaningless under the MacPerl application.
# Under MPW, it has a meaning.
#
return unless exists $ENV{Commands};
return split(/,/, $ENV{Commands});
}
=item splitpath
=cut
sub splitpath {
my ($self,$path, $nofile) = @_;
my ($volume,$directory,$file) = ('','','');
if ( $nofile ) {
( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\Z(?!\n)))?)(.*)@s;
}
else {
$path =~
m@^( (?: [^:]+: )? )
( (?: .*: )? )
( .* )
@xs;
$volume = $1;
$directory = $2;
$file = $3;
}
# Make sure non-empty volumes and directories end in ':'
$volume .= ':' if $volume =~ m@[^:]\Z(?!\n)@ ;
$directory .= ':' if $directory =~ m@[^:]\Z(?!\n)@ ;
return ($volume,$directory,$file);
}
=item splitdir
=cut
sub splitdir {
my ($self,$directories) = @_ ;
#
# split() likes to forget about trailing null fields, so here we
# check to be sure that there will not be any before handling the
# simple case.
#
if ( $directories !~ m@:\Z(?!\n)@ ) {
return split( m@:@, $directories );
}
else {
#
# since there was a trailing separator, add a file name to the end,
# then do the split, then replace it with ''.
#
my( @directories )= split( m@:@, "${directories}dummy" ) ;
$directories[ $#directories ]= '' ;
return @directories ;
}
}
=item catpath
=cut
sub catpath {
my $self = shift ;
my $result = shift ;
$result =~ s@^([^/])@/$1@s ;
my $segment ;
for $segment ( @_ ) {
if ( $result =~ m@[^/]\Z(?!\n)@ && $segment =~ m@^[^/]@s ) {
$result .= "/$segment" ;
}
elsif ( $result =~ m@/\Z(?!\n)@ && $segment =~ m@^/@s ) {
$result =~ s@/+\Z(?!\n)@/@;
$segment =~ s@^/+@@s;
$result .= "$segment" ;
}
else {
$result .= $segment ;
}
}
return $result ;
}
=item abs2rel
See L for general documentation.
Unlike Cabs2rel()>, this function will make
checks against the local filesystem if necessary. See
L for details.
=cut
sub abs2rel {
my($self,$path,$base) = @_;
# Clean up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
$path = $self->rel2abs( $path ) ;
}
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = cwd() ;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path );
my @basechunks = $self->splitdir( $base );
while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) {
shift @pathchunks ;
shift @basechunks ;
}
$path = join( ':', @pathchunks );
# @basechunks now contains the number of directories to climb out of.
$base = ':' x @basechunks ;
return "$base:$path" ;
}
=item rel2abs
See L for general documentation.
Unlike Crel2abs()>, this function will make
checks against the local filesystem if necessary. See
L for details.
=cut
sub rel2abs {
my ($self,$path,$base ) = @_;
if ( ! $self->file_name_is_absolute( $path ) ) {
if ( !defined( $base ) || $base eq '' ) {
$base = cwd() ;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
$path = $self->canonpath("$base$path") ;
}
return $path ;
}
=back
=head1 SEE ALSO
L
=cut
1;
cgi-bin/extlib/File/Spec/OS2.pm0000644002157400001440000000216607771550070023007 0ustar minnesotaviolasociety.orgusers00000000000000package File::Spec::OS2;
use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
$VERSION = '1.1';
@ISA = qw(File::Spec::Unix);
sub devnull {
return "/dev/nul";
}
sub case_tolerant {
return 1;
}
sub file_name_is_absolute {
my ($self,$file) = @_;
return scalar($file =~ m{^([a-z]:)?[\\/]}is);
}
sub path {
my $path = $ENV{PATH};
$path =~ s:\\:/:g;
my @path = split(';',$path);
foreach (@path) { $_ = '.' if $_ eq '' }
return @path;
}
my $tmpdir;
sub tmpdir {
return $tmpdir if defined $tmpdir;
my $self = shift;
foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) {
next unless defined && -d;
$tmpdir = $_;
last;
}
$tmpdir = '' unless defined $tmpdir;
$tmpdir =~ s:\\:/:g;
$tmpdir = $self->canonpath($tmpdir);
return $tmpdir;
}
1;
__END__
=head1 NAME
File::Spec::OS2 - methods for OS/2 file specs
=head1 SYNOPSIS
require File::Spec::OS2; # Done internally by File::Spec if needed
=head1 DESCRIPTION
See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
cgi-bin/extlib/File/Spec/Unix.pm0000644002157400001440000002531107771550070023324 0ustar minnesotaviolasociety.orgusers00000000000000package File::Spec::Unix;
use strict;
use vars qw($VERSION);
$VERSION = '1.2';
use Cwd;
=head1 NAME
File::Spec::Unix - methods used by File::Spec
=head1 SYNOPSIS
require File::Spec::Unix; # Done automatically by File::Spec
=head1 DESCRIPTION
Methods for manipulating file specifications.
=head1 METHODS
=over 2
=item canonpath
No physical check on the filesystem, but a logical cleanup of a
path. On UNIX eliminated successive slashes and successive "/.".
$cpath = File::Spec->canonpath( $path ) ;
=cut
sub canonpath {
my ($self,$path) = @_;
$path =~ s|/+|/|g unless($^O eq 'cygwin'); # xx////xx -> xx/xx
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
$path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
$path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx
$path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
return $path;
}
=item catdir
Concatenate two or more directory names to form a complete path ending
with a directory. But remove the trailing slash from the resulting
string, because it doesn't look good, isn't necessary and confuses
OS2. Of course, if this is the root directory, don't cut off the
trailing slash :-)
=cut
sub catdir {
my $self = shift;
my @args = @_;
foreach (@args) {
# append a slash to each argument unless it has one there
$_ .= "/" if $_ eq '' || substr($_,-1) ne "/";
}
return $self->canonpath(join('', @args));
}
=item catfile
Concatenate one or more directory names and a filename to form a
complete path ending with a filename
=cut
sub catfile {
my $self = shift;
my $file = pop @_;
return $file unless @_;
my $dir = $self->catdir(@_);
$dir .= "/" unless substr($dir,-1) eq "/";
return $dir.$file;
}
=item curdir
Returns a string representation of the current directory. "." on UNIX.
=cut
sub curdir {
return ".";
}
=item devnull
Returns a string representation of the null device. "/dev/null" on UNIX.
=cut
sub devnull {
return "/dev/null";
}
=item rootdir
Returns a string representation of the root directory. "/" on UNIX.
=cut
sub rootdir {
return "/";
}
=item tmpdir
Returns a string representation of the first writable directory
from the following list or "" if none are writable:
$ENV{TMPDIR}
/tmp
=cut
my $tmpdir;
sub tmpdir {
return $tmpdir if defined $tmpdir;
foreach ($ENV{TMPDIR}, "/tmp") {
next unless defined && -d && -w _;
$tmpdir = $_;
last;
}
$tmpdir = '' unless defined $tmpdir;
return $tmpdir;
}
=item updir
Returns a string representation of the parent directory. ".." on UNIX.
=cut
sub updir {
return "..";
}
=item no_upwards
Given a list of file names, strip out those that refer to a parent
directory. (Does not strip symlinks, only '.', '..', and equivalents.)
=cut
sub no_upwards {
my $self = shift;
return grep(!/^\.{1,2}\Z(?!\n)/s, @_);
}
=item case_tolerant
Returns a true or false value indicating, respectively, that alphabetic
is not or is significant when comparing file specifications.
=cut
sub case_tolerant {
return 0;
}
=item file_name_is_absolute
Takes as argument a path and returns true if it is an absolute path.
This does not consult the local filesystem on Unix, Win32, or OS/2. It
does sometimes on MacOS (see L).
It does consult the working environment for VMS (see
L).
=cut
sub file_name_is_absolute {
my ($self,$file) = @_;
return scalar($file =~ m:^/:s);
}
=item path
Takes no argument, returns the environment variable PATH as an array.
=cut
sub path {
my @path = split(':', $ENV{PATH});
foreach (@path) { $_ = '.' if $_ eq '' }
return @path;
}
=item join
join is the same as catfile.
=cut
sub join {
my $self = shift;
return $self->catfile(@_);
}
=item splitpath
($volume,$directories,$file) = File::Spec->splitpath( $path );
($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
Splits a path in to volume, directory, and filename portions. On systems
with no concept of volume, returns undef for volume.
For systems with no syntax differentiating filenames from directories,
assumes that the last file is a path unless $no_file is true or a
trailing separator or /. or /.. is present. On Unix this means that $no_file
true makes this return ( '', $path, '' ).
The directory portion may or may not be returned with a trailing '/'.
The results can be passed to L to get back a path equivalent to
(usually identical to) the original path.
=cut
sub splitpath {
my ($self,$path, $nofile) = @_;
my ($volume,$directory,$file) = ('','','');
if ( $nofile ) {
$directory = $path;
}
else {
$path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs;
$directory = $1;
$file = $2;
}
return ($volume,$directory,$file);
}
=item splitdir
The opposite of L.
@dirs = File::Spec->splitdir( $directories );
$directories must be only the directory portion of the path on systems
that have the concept of a volume or that have path syntax that differentiates
files from directories.
Unlike just splitting the directories on the separator, empty
directory names (C<''>) can be returned, because these are significant
on some OSs (e.g. MacOS).
On Unix,
File::Spec->splitdir( "/a/b//c/" );
Yields:
( '', 'a', 'b', '', 'c', '' )
=cut
sub splitdir {
my ($self,$directories) = @_ ;
#
# split() likes to forget about trailing null fields, so here we
# check to be sure that there will not be any before handling the
# simple case.
#
if ( $directories !~ m|/\Z(?!\n)| ) {
return split( m|/|, $directories );
}
else {
#
# since there was a trailing separator, add a file name to the end,
# then do the split, then replace it with ''.
#
my( @directories )= split( m|/|, "${directories}dummy" ) ;
$directories[ $#directories ]= '' ;
return @directories ;
}
}
=item catpath
Takes volume, directory and file portions and returns an entire path. Under
Unix, $volume is ignored, and directory and file are catenated. A '/' is
inserted if need be. On other OSs, $volume is significant.
=cut
sub catpath {
my ($self,$volume,$directory,$file) = @_;
if ( $directory ne '' &&
$file ne '' &&
substr( $directory, -1 ) ne '/' &&
substr( $file, 0, 1 ) ne '/'
) {
$directory .= "/$file" ;
}
else {
$directory .= $file ;
}
return $directory ;
}
=item abs2rel
Takes a destination path and an optional base path returns a relative path
from the base path to the destination path:
$rel_path = File::Spec->abs2rel( $path ) ;
$rel_path = File::Spec->abs2rel( $path, $base ) ;
If $base is not present or '', then L is used. If $base is relative,
then it is converted to absolute form using L. This means that it
is taken to be relative to L.
On systems with the concept of a volume, this assumes that both paths
are on the $destination volume, and ignores the $base volume.
On systems that have a grammar that indicates filenames, this ignores the
$base filename as well. Otherwise all path components are assumed to be
directories.
If $path is relative, it is converted to absolute form using L.
This means that it is taken to be relative to L.
No checks against the filesystem are made on most systems. On MacOS,
the filesystem may be consulted (see
L). On VMS, there is
interaction with the working environment, as logicals and
macros are expanded.
Based on code written by Shigio Yamaguchi.
=cut
sub abs2rel {
my($self,$path,$base) = @_;
# Clean up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
$path = $self->rel2abs( $path ) ;
}
else {
$path = $self->canonpath( $path ) ;
}
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = cwd() ;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path);
my @basechunks = $self->splitdir( $base);
while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) {
shift @pathchunks ;
shift @basechunks ;
}
$path = CORE::join( '/', @pathchunks );
$base = CORE::join( '/', @basechunks );
# $base now contains the directories the resulting relative path
# must ascend out of before it can descend to $path_directory. So,
# replace all names with $parentDir
$base =~ s|[^/]+|..|g ;
# Glue the two together, using a separator if necessary, and preventing an
# empty result.
if ( $path ne '' && $base ne '' ) {
$path = "$base/$path" ;
} else {
$path = "$base$path" ;
}
return $self->canonpath( $path ) ;
}
=item rel2abs
Converts a relative path to an absolute path.
$abs_path = File::Spec->rel2abs( $path ) ;
$abs_path = File::Spec->rel2abs( $path, $base ) ;
If $base is not present or '', then L is used. If $base is relative,
then it is converted to absolute form using L. This means that it
is taken to be relative to L.
On systems with the concept of a volume, this assumes that both paths
are on the $base volume, and ignores the $path volume.
On systems that have a grammar that indicates filenames, this ignores the
$base filename as well. Otherwise all path components are assumed to be
directories.
If $path is absolute, it is cleaned up and returned using L.
No checks against the filesystem are made on most systems. On MacOS,
the filesystem may be consulted (see
L). On VMS, there is
interaction with the working environment, as logicals and
macros are expanded.
Based on code written by Shigio Yamaguchi.
=cut
sub rel2abs {
my ($self,$path,$base ) = @_;
# Clean up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = cwd() ;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
# Glom them together
$path = $self->catdir( $base, $path ) ;
}
return $self->canonpath( $path ) ;
}
=back
=head1 SEE ALSO
L
=cut
1;
cgi-bin/extlib/File/Spec/VMS.pm0000644002157400001440000003212407771550070023046 0ustar minnesotaviolasociety.orgusers00000000000000package File::Spec::VMS;
use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
$VERSION = '1.1';
@ISA = qw(File::Spec::Unix);
use Cwd;
use File::Basename;
use VMS::Filespec;
=head1 NAME
File::Spec::VMS - methods for VMS file specs
=head1 SYNOPSIS
require File::Spec::VMS; # Done internally by File::Spec if needed
=head1 DESCRIPTION
See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=over
=item eliminate_macros
Expands MM[KS]/Make macros in a text string, using the contents of
identically named elements of C<%$self>, and returns the result
as a file specification in Unix syntax.
=cut
sub eliminate_macros {
my($self,$path) = @_;
return '' unless $path;
$self = {} unless ref $self;
if ($path =~ /\s/) {
return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
}
my($npath) = unixify($path);
my($complex) = 0;
my($head,$macro,$tail);
# perform m##g in scalar context so it acts as an iterator
while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
if ($self->{$2}) {
($head,$macro,$tail) = ($1,$2,$3);
if (ref $self->{$macro}) {
if (ref $self->{$macro} eq 'ARRAY') {
$macro = join ' ', @{$self->{$macro}};
}
else {
print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
"\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
$macro = "\cB$macro\cB";
$complex = 1;
}
}
else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
$npath = "$head$macro$tail";
}
}
if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
$npath;
}
=item fixpath
Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
in any directory specification, in order to avoid juxtaposing two
VMS-syntax directories when MM[SK] is run. Also expands expressions which
are all macro, so that we can tell how long the expansion is, and avoid
overrunning DCL's command buffer when MM[KS] is running.
If optional second argument has a TRUE value, then the return string is
a VMS-syntax directory specification, if it is FALSE, the return string
is a VMS-syntax file specification, and if it is not specified, fixpath()
checks to see whether it matches the name of a directory in the current
default directory, and returns a directory or file specification accordingly.
=cut
sub fixpath {
my($self,$path,$force_path) = @_;
return '' unless $path;
$self = bless {} unless ref $self;
my($fixedpath,$prefix,$name);
if ($path =~ /\s/) {
return join ' ',
map { $self->fixpath($_,$force_path) }
split /\s+/, $path;
}
if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
$fixedpath = vmspath($self->eliminate_macros($path));
}
else {
$fixedpath = vmsify($self->eliminate_macros($path));
}
}
elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
my($vmspre) = $self->eliminate_macros("\$($prefix)");
# is it a dir or just a name?
$vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
$fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
$fixedpath = vmspath($fixedpath) if $force_path;
}
else {
$fixedpath = $path;
$fixedpath = vmspath($fixedpath) if $force_path;
}
# No hints, so we try to guess
if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
$fixedpath = vmspath($fixedpath) if -d $fixedpath;
}
# Trim off root dirname if it's had other dirs inserted in front of it.
$fixedpath =~ s/\.000000([\]>])/$1/;
# Special case for VMS absolute directory specs: these will have had device
# prepended during trip through Unix syntax in eliminate_macros(), since
# Unix syntax has no way to express "absolute from the top of this device's
# directory tree".
if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
$fixedpath;
}
=back
=head2 Methods always loaded
=over
=item canonpath (override)
Removes redundant portions of file specifications according to VMS syntax.
=cut
sub canonpath {
my($self,$path) = @_;
if ($path =~ m|/|) { # Fake Unix
my $pathify = $path =~ m|/\Z(?!\n)|;
$path = $self->SUPER::canonpath($path);
if ($pathify) { return vmspath($path); }
else { return vmsify($path); }
}
else {
$path =~ s-\]\[--g; $path =~ s/> foo.bar
$path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo
1 while $path =~ s{([\[<-])\.-}{$1-}; # [.-.- ==> [--
$path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar]
$path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s
$path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g; # bar.-.foo ==> foo
$path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode
return $path;
}
}
=item catdir
Concatenates a list of file specifications, and returns the result as a
VMS-syntax directory specification. No check is made for "impossible"
cases (e.g. elements other than the first being absolute filespecs).
=cut
sub catdir {
my ($self,@dirs) = @_;
my $dir = pop @dirs;
@dirs = grep($_,@dirs);
my $rslt;
if (@dirs) {
my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
my ($spath,$sdir) = ($path,$dir);
$spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;
$sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
$rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
# Special case for VMS absolute directory specs: these will have had device
# prepended during trip through Unix syntax in eliminate_macros(), since
# Unix syntax has no way to express "absolute from the top of this device's
# directory tree".
if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
}
else {
if (not defined $dir or not length $dir) { $rslt = ''; }
elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; }
else { $rslt = vmspath($dir); }
}
return $self->canonpath($rslt);
}
=item catfile
Concatenates a list of file specifications, and returns the result as a
VMS-syntax file specification.
=cut
sub catfile {
my ($self,@files) = @_;
my $file = pop @files;
@files = grep($_,@files);
my $rslt;
if (@files) {
my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
my $spath = $path;
$spath =~ s/\.dir\Z(?!\n)//;
if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
$rslt = "$spath$file";
}
else {
$rslt = $self->eliminate_macros($spath);
$rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
}
}
else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
return $self->canonpath($rslt);
}
=item curdir (override)
Returns a string representation of the current directory: '[]'
=cut
sub curdir {
return '[]';
}
=item devnull (override)
Returns a string representation of the null device: '_NLA0:'
=cut
sub devnull {
return "_NLA0:";
}
=item rootdir (override)
Returns a string representation of the root directory: 'SYS$DISK:[000000]'
=cut
sub rootdir {
return 'SYS$DISK:[000000]';
}
=item tmpdir (override)
Returns a string representation of the first writable directory
from the following list or '' if none are writable:
sys$scratch
$ENV{TMPDIR}
=cut
my $tmpdir;
sub tmpdir {
return $tmpdir if defined $tmpdir;
foreach ('sys$scratch', $ENV{TMPDIR}) {
next unless defined && -d && -w _;
$tmpdir = $_;
last;
}
$tmpdir = '' unless defined $tmpdir;
return $tmpdir;
}
=item updir (override)
Returns a string representation of the parent directory: '[-]'
=cut
sub updir {
return '[-]';
}
=item case_tolerant (override)
VMS file specification syntax is case-tolerant.
=cut
sub case_tolerant {
return 1;
}
=item path (override)
Translate logical name DCL$PATH as a searchlist, rather than trying
to C string value of C<$ENV{'PATH'}>.
=cut
sub path {
my (@dirs,$dir,$i);
while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
return @dirs;
}
=item file_name_is_absolute (override)
Checks for VMS directory spec as well as Unix separators.
=cut
sub file_name_is_absolute {
my ($self,$file) = @_;
# If it's a logical name, expand it.
$file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
return scalar($file =~ m!^/!s ||
$file =~ m![<\[][^.\-\]>]! ||
$file =~ /:[^<\[]/);
}
=item splitpath (override)
Splits using VMS syntax.
=cut
sub splitpath {
my($self,$path) = @_;
my($dev,$dir,$file) = ('','','');
vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
return ($1 || '',$2 || '',$3);
}
=item splitdir (override)
Split dirspec using VMS syntax.
=cut
sub splitdir {
my($self,$dirspec) = @_;
$dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g;
$dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
my(@dirs) = split('\.', vmspath($dirspec));
$dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
@dirs;
}
=item catpath (override)
Construct a complete filespec using VMS syntax
=cut
sub catpath {
my($self,$dev,$dir,$file) = @_;
if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
if (length($dev) or length($dir)) {
$dir = "[$dir]" unless $dir =~ /[\[<\/]/;
$dir = vmspath($dir);
}
"$dev$dir$file";
}
=item abs2rel (override)
Use VMS syntax when converting filespecs.
=cut
sub abs2rel {
my $self = shift;
return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
if ( join( '', @_ ) =~ m{/} ) ;
my($path,$base) = @_;
# Note: we use '/' to glue things together here, then let canonpath()
# clean them up at the end.
# Clean up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
$path = $self->rel2abs( $path ) ;
}
else {
$path = $self->canonpath( $path ) ;
}
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = cwd() ;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
# Split up paths
my ( $path_directories, $path_file ) =
($self->splitpath( $path, 1 ))[1,2] ;
$path_directories = $1
if $path_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
$base_directories = $1
if $base_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my @basechunks = $self->splitdir( $base_directories );
while ( @pathchunks &&
@basechunks &&
lc( $pathchunks[0] ) eq lc( $basechunks[0] )
) {
shift @pathchunks ;
shift @basechunks ;
}
# @basechunks now contains the directories to climb out of,
# @pathchunks now has the directories to descend in to.
$path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ;
$path_directories =~ s{\.\Z(?!\n)}{} ;
return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
}
=item rel2abs (override)
Use VMS syntax when converting filespecs.
=cut
sub rel2abs {
my $self = shift ;
return vmspath(File::Spec::Unix::rel2abs( $self, @_ ))
if ( join( '', @_ ) =~ m{/} ) ;
my ($path,$base ) = @_;
# Clean up and split up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = cwd() ;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
# Split up paths
my ( $path_directories, $path_file ) =
($self->splitpath( $path ))[1,2] ;
my ( $base_volume, $base_directories ) =
$self->splitpath( $base ) ;
$path_directories = '' if $path_directories eq '[]' ||
$path_directories eq '<>';
my $sep = '' ;
$sep = '.'
if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
$path_directories =~ m{^[^.\[<]}s
) ;
$base_directories = "$base_directories$sep$path_directories";
$base_directories =~ s{\.?[\]>][\[<]\.?}{.};
$path = $self->catpath( $base_volume, $base_directories, $path_file );
}
return $self->canonpath( $path ) ;
}
=back
=head1 SEE ALSO
L
=cut
1;
cgi-bin/extlib/File/Spec/Win32.pm0000644002157400001440000002102307771550070023277 0ustar minnesotaviolasociety.orgusers00000000000000package File::Spec::Win32;
use strict;
use Cwd;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
$VERSION = '1.2';
@ISA = qw(File::Spec::Unix);
=head1 NAME
File::Spec::Win32 - methods for Win32 file specs
=head1 SYNOPSIS
require File::Spec::Win32; # Done internally by File::Spec if needed
=head1 DESCRIPTION
See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=over
=item devnull
Returns a string representation of the null device.
=cut
sub devnull {
return "nul";
}
=item tmpdir
Returns a string representation of the first existing directory
from the following list:
$ENV{TMPDIR}
$ENV{TEMP}
$ENV{TMP}
/tmp
/
=cut
my $tmpdir;
sub tmpdir {
return $tmpdir if defined $tmpdir;
my $self = shift;
foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) {
next unless defined && -d;
$tmpdir = $_;
last;
}
$tmpdir = '' unless defined $tmpdir;
$tmpdir = $self->canonpath($tmpdir);
return $tmpdir;
}
sub case_tolerant {
return 1;
}
sub file_name_is_absolute {
my ($self,$file) = @_;
return scalar($file =~ m{^([a-z]:)?[\\/]}is);
}
=item catfile
Concatenate one or more directory names and a filename to form a
complete path ending with a filename
=cut
sub catfile {
my $self = shift;
my $file = pop @_;
return $file unless @_;
my $dir = $self->catdir(@_);
$dir .= "\\" unless substr($dir,-1) eq "\\";
return $dir.$file;
}
sub path {
my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
my @path = split(';',$path);
foreach (@path) { $_ = '.' if $_ eq '' }
return @path;
}
=item canonpath
No physical check on the filesystem, but a logical cleanup of a
path. On UNIX