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 eliminated successive slashes and successive "/.".
=cut
sub canonpath {
my ($self,$path) = @_;
$path =~ s/^([a-z]:)/\u$1/s;
$path =~ s|/|\\|g;
$path =~ s|([^\\])\\+|$1\\|g; # xx////xx -> xx/xx
$path =~ s|(\\\.)+\\|\\|g; # xx/././xx -> xx/xx
$path =~ s|^(\.\\)+||s unless $path eq ".\\"; # ./xx -> xx
$path =~ s|\\\Z(?!\n)||
unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx/ -> xx
return $path;
}
=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. Assumes that
the last file is a path unless the path ends in '\\', '\\.', '\\..'
or $no_file is true. On Win32 this means that $no_file true makes this return
( $volume, $path, undef ).
Separators accepted are \ and /.
Volumes can be drive letters or UNC sharenames (\\server\share).
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 ) {
$path =~
m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
(.*)
}xs;
$volume = $1;
$directory = $2;
}
else {
$path =~
m{^ ( (?: [a-zA-Z]: |
(?:\\\\|//)[^\\/]+[\\/][^\\/]+
)?
)
( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
(.*)
}xs;
$volume = $1;
$directory = $2;
$file = $3;
}
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, leading empty and
trailing directory entries can be returned, because these are significant
on some OSs. So,
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 this is just like catfile(). On other OSs,
the $volume become significant.
=cut
sub catpath {
my ($self,$volume,$directory,$file) = @_;
# If it's UNC, make sure the glue separator is there, reusing
# whatever separator is first in the $volume
$volume .= $1
if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
$directory =~ m@^[^\\/]@s
) ;
$volume .= $directory ;
# If the volume is not just A:, make sure the glue separator is
# there, reusing whatever separator is first in the $volume if possible.
if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
$volume =~ m@[^\\/]\Z(?!\n)@ &&
$file =~ m@[^\\/]@
) {
$volume =~ m@([\\/])@ ;
my $sep = $1 ? $1 : '\\' ;
$volume .= $sep ;
}
$volume .= $file ;
return $volume ;
}
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 ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
elsif ( !defined( $base ) || $base eq '' ) {
$base = cwd() ;
}
else {
$base = $self->canonpath( $base ) ;
}
# Split up paths
my ( $path_volume, $path_directories, $path_file ) =
$self->splitpath( $path, 1 ) ;
my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
# 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 ;
}
# No need to catdir, we know these are well formed.
$path_directories = CORE::join( '\\', @pathchunks );
$base_directories = CORE::join( '\\', @basechunks );
# $base_directories 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
#FA Need to replace between backslashes...
$base_directories =~ s|[^\\]+|..|g ;
# Glue the two together, using a separator if necessary, and preventing an
# empty result.
#FA Must check that new directories are not empty.
if ( $path_directories ne '' && $base_directories ne '' ) {
$path_directories = "$base_directories\\$path_directories" ;
} else {
$path_directories = "$base_directories$path_directories" ;
}
# It makes no sense to add a relative path to a UNC volume
$path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ;
return $self->canonpath(
$self->catpath($path_volume, $path_directories, $path_file )
) ;
}
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 ) ;
}
my ( $path_directories, $path_file ) =
($self->splitpath( $path, 1 ))[1,2] ;
my ( $base_volume, $base_directories ) =
$self->splitpath( $base, 1 ) ;
$path = $self->catpath(
$base_volume,
$self->catdir( $base_directories, $path_directories ),
$path_file
) ;
}
return $self->canonpath( $path ) ;
}
=back
=head1 SEE ALSO
L
=cut
1;
cgi-bin/extlib/File/_vti_cnf/0000755002157400001440000000000007776605372022751 5ustar minnesotaviolasociety.orgusers00000000000000cgi-bin/extlib/File/_vti_cnf/Listing.pm0000644002157400001440000000030307771550070024701 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|8380
vti_backlinkinfo:VX|
cgi-bin/extlib/File/_vti_cnf/Spec.pm0000644002157400001440000000030307771550070024162 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|2813
vti_backlinkinfo:VX|
cgi-bin/extlib/File/_vti_cnf/Temp.pm0000644002157400001440000000030407771550070024176 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|53650
vti_backlinkinfo:VX|
cgi-bin/extlib/File/Listing.pm0000644002157400001440000002027407771550070023123 0ustar minnesotaviolasociety.orgusers00000000000000#
# $Id: Listing.pm,v 1.11 1999/03/20 07:37:35 gisle Exp $
package File::Listing;
sub Version { $VERSION; }
$VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/);
=head1 NAME
parse_dir - parse directory listing
=head1 SYNOPSIS
use File::Listing;
for (parse_dir(`ls -l`)) {
($name, $type, $size, $mtime, $mode) = @$_;
next if $type ne 'f'; # plain file
#...
}
# directory listing can also be read from a file
open(LISTING, "zcat ls-lR.gz|");
$dir = parse_dir(\*LISTING, '+0000');
=head1 DESCRIPTION
The parse_dir() routine can be used to parse directory
listings. Currently it only understand Unix C<'ls -l'> and C<'ls -lR'>
format. It should eventually be able to most things you might get
back from a ftp server file listing (LIST command), i.e. VMS listings,
NT listings, DOS listings,...
The first parameter to parse_dir() is the directory listing to parse.
It can be a scalar, a reference to an array of directory lines or a
glob representing a filehandle to read the directory listing from.
The second parameter is the time zone to use when parsing time stamps
in the listing. If this value is undefined, then the local time zone is
assumed.
The third parameter is the type of listing to assume. The values will
be strings like 'unix', 'vms', 'dos'. Currently only 'unix' is
implemented and this is also the default value. Ideally, the listing
type should be determined automatically.
The fourth parameter specifies how unparseable lines should be treated.
Values can be 'ignore', 'warn' or a code reference. Warn means that
the perl warn() function will be called. If a code reference is
passed, then this routine will be called and the return value from it
will be incorporated in the listing. The default is 'ignore'.
Only the first parameter is mandatory.
The return value from parse_dir() is a list of directory entries. In
a scalar context the return value is a reference to the list. The
directory entries are represented by an array consisting of [
$filename, $filetype, $filesize, $filetime, $filemode ]. The
$filetype value is one of the letters 'f', 'd', 'l' or '?'. The
$filetime value is the seconds since Jan 1, 1970. The
$filemode is a bitmask like the mode returned by stat().
=head1 CREDITS
Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and
Net::FTP's parse_dir (Graham Barr).
=cut
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(parse_dir);
use strict;
use Carp ();
use HTTP::Date qw(str2time);
sub parse_dir ($;$$$)
{
my($dir, $tz, $fstype, $error) = @_;
$fstype ||= 'unix';
$fstype = "File::Listing::" . lc $fstype;
my @args = $_[0];
push(@args, $tz) if(@_ >= 2);
push(@args, $error) if(@_ >= 4);
$fstype->parse(@args);
}
sub line { Carp::croak("Not implemented yet"); }
sub init { } # Dummy sub
sub file_mode ($)
{
# This routine was originally borrowed from Graham Barr's
# Net::FTP package.
local $_ = shift;
my $mode = 0;
my($type,$ch);
s/^(.)// and $type = $1;
while (/(.)/g) {
$mode <<= 1;
$mode |= 1 if $1 ne "-" &&
$1 ne 'S' &&
$1 ne 't' &&
$1 ne 'T';
}
$type eq "d" and $mode |= 0040000 or # Directory
$type eq "l" and $mode |= 0120000 or # Symbolic Link
$mode |= 0100000; # Regular File
$mode |= 0004000 if /^...s....../i;
$mode |= 0002000 if /^......s.../i;
$mode |= 0001000 if /^.........t/i;
$mode;
}
sub parse
{
my($pkg, $dir, $tz, $error) = @_;
# First let's try to determine what kind of dir parameter we have
# received. We allow both listings, reference to arrays and
# file handles to read from.
if (ref($dir) eq 'ARRAY') {
# Already splitted up
} elsif (ref($dir) eq 'GLOB') {
# A file handle
} elsif (ref($dir)) {
Carp::croak("Illegal argument to parse_dir()");
} elsif ($dir =~ /^\*\w+(::\w+)+$/) {
# This scalar looks like a file handle, so we assume it is
} else {
# A normal scalar listing
$dir = [ split(/\n/, $dir) ];
}
$pkg->init();
my @files = ();
if (ref($dir) eq 'ARRAY') {
for (@$dir) {
push(@files, $pkg->line($_, $tz, $error));
}
} else {
local($_);
while (<$dir>) {
chomp;
push(@files, $pkg->line($_, $tz, $error));
}
}
wantarray ? @files : \@files;
}
package File::Listing::unix;
use HTTP::Date qw(str2time);
# A place to remember current directory from last line parsed.
use vars qw($curdir);
no strict qw(vars);
@ISA = qw(File::Listing);
sub init
{
$curdir = '';
}
sub line
{
shift; # package name
local($_) = shift;
my($tz, $error) = @_;
s/\015//g;
#study;
my ($kind, $size, $date, $name);
if (($kind, $size, $date, $name) =
/^([\-FlrwxsStTdD]{10}) # Type and permission bits
.* # Graps
\D(\d+) # File size
\s+ # Some space
(\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})) # Date
\s+ # Some more space
(.*)$ # File name
/x )
{
return if $name eq '.' || $name eq '..';
$name = "$curdir/$name" if length $curdir;
my $type = '?';
if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) {
$name = $1;
$type = "l $2";
} elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file
$type = 'f';
} elsif ($kind =~ /^[dD]/) {
$type = 'd';
$size = undef; # Don't believe the reported size
}
return [$name, $type, $size, str2time($date, $tz),
File::Listing::file_mode($kind)];
} elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) {
my $dir = $1;
return () if $dir eq '.';
$curdir = $dir;
return ();
} elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
return ();
} elsif (/not found/ || # OSF1, HPUX, and SunOS return
# "$file not found"
/No such file/ || # IRIX returns
# "UX:ls: ERROR: Cannot access $file: No such file or directory"
# Solaris returns
# "$file: No such file or directory"
/cannot find/ # Windows NT returns
# "The system cannot find the path specified."
) {
return () unless defined $error;
&$error($_) if ref($error) eq 'CODE';
warn "Error: $_\n" if $error eq 'warn';
return ();
} elsif ($_ eq '') { # AIX, and Linux return nothing
return () unless defined $error;
&$error("No such file or directory") if ref($error) eq 'CODE';
warn "Warning: No such file or directory\n" if $error eq 'warn';
return ();
} else {
# parse failed, check if the dosftp parse understands it
return(File::Listing::dosftp->line($_,$tz,$error));
}
}
package File::Listing::dosftp;
use HTTP::Date qw(str2time);
# A place to remember current directory from last line parsed.
use vars qw($curdir);
no strict qw(vars);
@ISA = qw(File::Listing);
sub init
{
$curdir = '';
}
sub line
{
shift; # package name
local($_) = shift;
my($tz, $error) = @_;
s/\015//g;
my ($kind, $size, $date, $name);
# 02-05-96 10:48AM 1415 src.slf
# 09-10-96 09:18AM sl_util
if (($date,$size_or_dir,$name) =
/^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM) # Date and time info
\s+ # Some space
(<\w{3}>|\d+) # Dir or Size
\s+ # Some more space
(.+)$ # File name
/x )
{
return if $name eq '.' || $name eq '..';
$name = "$curdir/$name" if length $curdir;
my $type = '?';
if ($size_or_dir eq '') {
$type = "d";
$size = ""; # directories have no size in the pc listing
} else {
$type = 'f';
$size = $size_or_dir;
}
return [$name, $type, $size, str2time($date, $tz),
File::Listing::file_mode($kind)];
} else {
return () unless defined $error;
&$error($_) if ref($error) eq 'CODE';
warn "Can't parse: $_\n" if $error eq 'warn';
return ();
}
}
package File::Listing::vms;
@File::Listing::unix::ISA = qw(File::Listing);
package File::Listing::netware;
@File::Listing::unix::ISA = qw(File::Listing);
1;
cgi-bin/extlib/File/Spec.pm0000644002157400001440000000537507771550070022411 0ustar minnesotaviolasociety.orgusers00000000000000package File::Spec;
use strict;
use vars qw(@ISA $VERSION);
$VERSION = 0.82 ;
my %module = (MacOS => 'Mac',
MSWin32 => 'Win32',
os2 => 'OS2',
VMS => 'VMS');
my $module = $module{$^O} || 'Unix';
require "File/Spec/$module.pm";
@ISA = ("File::Spec::$module");
1;
__END__
=head1 NAME
File::Spec - portably perform operations on file names
=head1 SYNOPSIS
use File::Spec;
$x=File::Spec->catfile('a', 'b', 'c');
which returns 'a/b/c' under Unix. Or:
use File::Spec::Functions;
$x = catfile('a', 'b', 'c');
=head1 DESCRIPTION
This module is designed to support operations commonly performed on file
specifications (usually called "file names", but not to be confused with the
contents of a file, or Perl's file handles), such as concatenating several
directory and file names into a single path, or determining whether a path
is rooted. It is based on code directly taken from MakeMaker 5.17, code
written by Andreas KEnig, Andy Dougherty, Charles Bailey, Ilya
Zakharevich, Paul Schinder, and others.
Since these functions are different for most operating systems, each set of
OS specific routines is available in a separate module, including:
File::Spec::Unix
File::Spec::Mac
File::Spec::OS2
File::Spec::Win32
File::Spec::VMS
The module appropriate for the current OS is automatically loaded by
File::Spec. Since some modules (like VMS) make use of facilities available
only under that OS, it may not be possible to load all modules under all
operating systems.
Since File::Spec is object oriented, subroutines should not called directly,
as in:
File::Spec::catfile('a','b');
but rather as class methods:
File::Spec->catfile('a','b');
For simple uses, L provides convenient functional
forms of these methods.
For a list of available methods, 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.
=head1 SEE ALSO
File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, File::Spec::Win32,
File::Spec::VMS, File::Spec::Functions, ExtUtils::MakeMaker
=head1 AUTHORS
Kenneth Albanowski >, Andy Dougherty
>, Andreas KEnig
>, Tim Bunce >. VMS
support by Charles Bailey >. OS/2 support by
Ilya Zakharevich >. Mac support by Paul Schinder
>. abs2rel() and rel2abs() written by
Shigio Yamaguchi >, modified by Barrie Slaymaker
>. splitpath(), splitdir(), catpath() and catdir()
by Barrie Slaymaker.
cgi-bin/extlib/File/Temp.pm0000644002157400001440000015062207771550070022420 0ustar minnesotaviolasociety.orgusers00000000000000package File::Temp;
=head1 NAME
File::Temp - return name and handle of a temporary file safely
=begin __INTERNALS
=head1 PORTABILITY
This module is designed to be portable across operating systems
and it currently supports Unix, VMS, DOS, OS/2 and Windows. When
porting to a new OS there are generally three main issues
that have to be solved:
=over 4
=item *
Can the OS unlink an open file? If it can not then the
C<_can_unlink_opened_file> method should be modified.
=item *
Are the return values from C reliable? By default all the
return values from C are compared when unlinking a temporary
file using the filename and the handle. Operating systems other than
unix do not always have valid entries in all fields. If C fails
then the C comparison should be modified accordingly.
=item *
Security. Systems that can not support a test for the sticky bit
on a directory can not use the MEDIUM and HIGH security tests.
The C<_can_do_level> method should be modified accordingly.
=back
=end __INTERNALS
=head1 SYNOPSIS
use File::Temp qw/ tempfile tempdir /;
$dir = tempdir( CLEANUP => 1 );
($fh, $filename) = tempfile( DIR => $dir );
($fh, $filename) = tempfile( $template, DIR => $dir);
($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
$fh = tempfile();
MkTemp family:
use File::Temp qw/ :mktemp /;
($fh, $file) = mkstemp( "tmpfileXXXXX" );
($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
$tmpdir = mkdtemp( $template );
$unopened_file = mktemp( $template );
POSIX functions:
use File::Temp qw/ :POSIX /;
$file = tmpnam();
$fh = tmpfile();
($fh, $file) = tmpnam();
($fh, $file) = tmpfile();
Compatibility functions:
$unopened_file = File::Temp::tempnam( $dir, $pfx );
=begin later
Objects (NOT YET IMPLEMENTED):
require File::Temp;
$fh = new File::Temp($template);
$fname = $fh->filename;
=end later
=head1 DESCRIPTION
C can be used to create and open temporary files in a safe way.
The tempfile() function can be used to return the name and the open
filehandle of a temporary file. The tempdir() function can
be used to create a temporary directory.
The security aspect of temporary file creation is emphasized such that
a filehandle and filename are returned together. This helps guarantee
that a race condition can not occur where the temporary file is
created by another process between checking for the existence of the
file and its opening. Additional security levels are provided to
check, for example, that the sticky bit is set on world writable
directories. See L<"safe_level"> for more information.
For compatibility with popular C library functions, Perl implementations of
the mkstemp() family of functions are provided. These are, mkstemp(),
mkstemps(), mkdtemp() and mktemp().
Additionally, implementations of the standard L
tmpnam() and tmpfile() functions are provided if required.
Implementations of mktemp(), tmpnam(), and tempnam() are provided,
but should be used with caution since they return only a filename
that was valid when function was called, so cannot guarantee
that the file will not exist by the time the caller opens the filename.
=cut
# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
# People would like a version on 5.005 so give them what they want :-)
use 5.005;
use strict;
use Carp;
use File::Spec 0.8;
use File::Path qw/ rmtree /;
use Fcntl 1.03;
use Errno;
require VMS::Stdio if $^O eq 'VMS';
# Need the Symbol package if we are running older perl
require Symbol if $] < 5.006;
# use 'our' on v5.6.0
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG);
$DEBUG = 0;
# We are exporting functions
use base qw/Exporter/;
# Export list - to allow fine tuning of export table
@EXPORT_OK = qw{
tempfile
tempdir
tmpnam
tmpfile
mktemp
mkstemp
mkstemps
mkdtemp
unlink0
};
# Groups of functions for export
%EXPORT_TAGS = (
'POSIX' => [qw/ tmpnam tmpfile /],
'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
);
# add contents of these tags to @EXPORT
Exporter::export_tags('POSIX','mktemp');
# Version number
$VERSION = '0.12';
# This is a list of characters that can be used in random filenames
my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
a b c d e f g h i j k l m n o p q r s t u v w x y z
0 1 2 3 4 5 6 7 8 9 _
/);
# Maximum number of tries to make a temp file before failing
use constant MAX_TRIES => 10;
# Minimum number of X characters that should be in a template
use constant MINX => 4;
# Default template when no template supplied
use constant TEMPXXX => 'X' x 10;
# Constants for the security level
use constant STANDARD => 0;
use constant MEDIUM => 1;
use constant HIGH => 2;
# OPENFLAGS. If we defined the flag to use with Sysopen here this gives
# us an optimisation when many temporary files are requested
my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
no strict 'refs';
$OPENFLAGS |= $bit if eval {
# Make sure that redefined die handlers do not cause problems
# eg CGI::Carp
local $SIG{__DIE__} = sub {};
local $SIG{__WARN__} = sub {};
$bit = &$func();
1;
};
}
# On some systems the O_TEMPORARY flag can be used to tell the OS
# to automatically remove the file when it is closed. This is fine
# in most cases but not if tempfile is called with UNLINK=>0 and
# the filename is requested -- in the case where the filename is to
# be passed to another routine. This happens on windows. We overcome
# this by using a second open flags variable
my $OPENTEMPFLAGS = $OPENFLAGS;
for my $oflag (qw/ TEMPORARY /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
no strict 'refs';
$OPENTEMPFLAGS |= $bit if eval {
# Make sure that redefined die handlers do not cause problems
# eg CGI::Carp
local $SIG{__DIE__} = sub {};
local $SIG{__WARN__} = sub {};
$bit = &$func();
1;
};
}
# INTERNAL ROUTINES - not to be used outside of package
# Generic routine for getting a temporary filename
# modelled on OpenBSD _gettemp() in mktemp.c
# The template must contain X's that are to be replaced
# with the random values
# Arguments:
# TEMPLATE - string containing the XXXXX's that is converted
# to a random filename and opened if required
# Optionally, a hash can also be supplied containing specific options
# "open" => if true open the temp file, else just return the name
# default is 0
# "mkdir"=> if true, we are creating a temp directory rather than tempfile
# default is 0
# "suffixlen" => number of characters at end of PATH to be ignored.
# default is 0.
# "unlink_on_close" => indicates that, if possible, the OS should remove
# the file as soon as it is closed. Usually indicates
# use of the O_TEMPORARY flag to sysopen.
# Usually irrelevant on unix
# Optionally a reference to a scalar can be passed into the function
# On error this will be used to store the reason for the error
# "ErrStr" => \$errstr
# "open" and "mkdir" can not both be true
# "unlink_on_close" is not used when "mkdir" is true.
# The default options are equivalent to mktemp().
# Returns:
# filehandle - open file handle (if called with doopen=1, else undef)
# temp name - name of the temp file or directory
# For example:
# ($fh, $name) = _gettemp($template, "open" => 1);
# for the current version, failures are associated with
# stored in an error string and returned to give the reason whilst debugging
# This routine is not called by any external function
sub _gettemp {
croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
unless scalar(@_) >= 1;
# the internal error string - expect it to be overridden
# Need this in case the caller decides not to supply us a value
# need an anonymous scalar
my $tempErrStr;
# Default options
my %options = (
"open" => 0,
"mkdir" => 0,
"suffixlen" => 0,
"unlink_on_close" => 0,
"ErrStr" => \$tempErrStr,
);
# Read the template
my $template = shift;
if (ref($template)) {
# Use a warning here since we have not yet merged ErrStr
carp "File::Temp::_gettemp: template must not be a reference";
return ();
}
# Check that the number of entries on stack are even
if (scalar(@_) % 2 != 0) {
# Use a warning here since we have not yet merged ErrStr
carp "File::Temp::_gettemp: Must have even number of options";
return ();
}
# Read the options and merge with defaults
%options = (%options, @_) if @_;
# Make sure the error string is set to undef
${$options{ErrStr}} = undef;
# Can not open the file and make a directory in a single call
if ($options{"open"} && $options{"mkdir"}) {
${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
return ();
}
# Find the start of the end of the Xs (position of last X)
# Substr starts from 0
my $start = length($template) - 1 - $options{"suffixlen"};
# Check that we have at least MINX x X (eg 'XXXX") at the end of the string
# (taking suffixlen into account). Any fewer is insecure.
# Do it using substr - no reason to use a pattern match since
# we know where we are looking and what we are looking for
if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
${$options{ErrStr}} = "The template must contain at least ".
MINX . " 'X' characters\n";
return ();
}
# Replace all the X at the end of the substring with a
# random character or just all the XX at the end of a full string.
# Do it as an if, since the suffix adjusts which section to replace
# and suffixlen=0 returns nothing if used in the substr directly
# and generate a full path from the template
my $path = _replace_XX($template, $options{"suffixlen"});
# Split the path into constituent parts - eventually we need to check
# whether the directory exists
# We need to know whether we are making a temp directory
# or a tempfile
my ($volume, $directories, $file);
my $parent; # parent directory
if ($options{"mkdir"}) {
# There is no filename at the end
($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
# The parent is then $directories without the last directory
# Split the directory and put it back together again
my @dirs = File::Spec->splitdir($directories);
# If @dirs only has one entry that means we are in the current
# directory
if ($#dirs == 0) {
$parent = File::Spec->curdir;
} else {
if ($^O eq 'VMS') { # need volume to avoid relative dir spec
$parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
$parent = 'sys$disk:[]' if $parent eq '';
} else {
# Put it back together without the last one
$parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
# ...and attach the volume (no filename)
$parent = File::Spec->catpath($volume, $parent, '');
}
}
} else {
# Get rid of the last filename (use File::Basename for this?)
($volume, $directories, $file) = File::Spec->splitpath( $path );
# Join up without the file part
$parent = File::Spec->catpath($volume,$directories,'');
# If $parent is empty replace with curdir
$parent = File::Spec->curdir
unless $directories ne '';
}
# Check that the parent directories exist
# Do this even for the case where we are simply returning a name
# not a file -- no point returning a name that includes a directory
# that does not exist or is not writable
unless (-d $parent) {
${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
return ();
}
unless (-w _) {
${$options{ErrStr}} = "Parent directory ($parent) is not writable\n";
return ();
}
# Check the stickiness of the directory and chown giveaway if required
# If the directory is world writable the sticky bit
# must be set
if (File::Temp->safe_level == MEDIUM) {
my $safeerr;
unless (_is_safe($parent,\$safeerr)) {
${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
return ();
}
} elsif (File::Temp->safe_level == HIGH) {
my $safeerr;
unless (_is_verysafe($parent, \$safeerr)) {
${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
return ();
}
}
# Now try MAX_TRIES time to open the file
for (my $i = 0; $i < MAX_TRIES; $i++) {
# Try to open the file if requested
if ($options{"open"}) {
my $fh;
# If we are running before perl5.6.0 we can not auto-vivify
if ($] < 5.006) {
$fh = &Symbol::gensym;
}
# Try to make sure this will be marked close-on-exec
# XXX: Win32 doesn't respect this, nor the proper fcntl,
# but may have O_NOINHERIT. This may or may not be in Fcntl.
local $^F = 2;
# Store callers umask
my $umask = umask();
# Set a known umask
umask(066);
# Attempt to open the file
my $open_success = undef;
if ( $^O eq 'VMS' and $options{"unlink_on_close"} ) {
# make it auto delete on close by setting FAB$V_DLT bit
$fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
$open_success = $fh;
} else {
my $flags = ( $options{"unlink_on_close"} ?
$OPENTEMPFLAGS :
$OPENFLAGS );
$open_success = sysopen($fh, $path, $flags, 0600);
}
if ( $open_success ) {
# Reset umask
umask($umask);
# Opened successfully - return file handle and name
return ($fh, $path);
} else {
# Reset umask
umask($umask);
# Error opening file - abort with error
# if the reason was anything but EEXIST
unless ($!{EEXIST}) {
${$options{ErrStr}} = "Could not create temp file $path: $!";
return ();
}
# Loop round for another try
}
} elsif ($options{"mkdir"}) {
# Store callers umask
my $umask = umask();
# Set a known umask
umask(066);
# Open the temp directory
if (mkdir( $path, 0700)) {
# created okay
# Reset umask
umask($umask);
return undef, $path;
} else {
# Reset umask
umask($umask);
# Abort with error if the reason for failure was anything
# except EEXIST
unless ($!{EEXIST}) {
${$options{ErrStr}} = "Could not create directory $path: $!";
return ();
}
# Loop round for another try
}
} else {
# Return true if the file can not be found
# Directory has been checked previously
return (undef, $path) unless -e $path;
# Try again until MAX_TRIES
}
# Did not successfully open the tempfile/dir
# so try again with a different set of random letters
# No point in trying to increment unless we have only
# 1 X say and the randomness could come up with the same
# file MAX_TRIES in a row.
# Store current attempt - in principal this implies that the
# 3rd time around the open attempt that the first temp file
# name could be generated again. Probably should store each
# attempt and make sure that none are repeated
my $original = $path;
my $counter = 0; # Stop infinite loop
my $MAX_GUESS = 50;
do {
# Generate new name from original template
$path = _replace_XX($template, $options{"suffixlen"});
$counter++;
} until ($path ne $original || $counter > $MAX_GUESS);
# Check for out of control looping
if ($counter > $MAX_GUESS) {
${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
return ();
}
}
# If we get here, we have run out of tries
${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
. MAX_TRIES . ") to open temp file/dir";
return ();
}
# Internal routine to return a random character from the
# character list. Does not do an srand() since rand()
# will do one automatically
# No arguments. Return value is the random character
# No longer called since _replace_XX runs a few percent faster if
# I inline the code. This is important if we are creating thousands of
# temporary files.
sub _randchar {
$CHARS[ int( rand( $#CHARS ) ) ];
}
# Internal routine to replace the XXXX... with random characters
# This has to be done by _gettemp() every time it fails to
# open a temp file/dir
# Arguments: $template (the template with XXX),
# $ignore (number of characters at end to ignore)
# Returns: modified template
sub _replace_XX {
croak 'Usage: _replace_XX($template, $ignore)'
unless scalar(@_) == 2;
my ($path, $ignore) = @_;
# Do it as an if, since the suffix adjusts which section to replace
# and suffixlen=0 returns nothing if used in the substr directly
# Alternatively, could simply set $ignore to length($path)-1
# Don't want to always use substr when not required though.
if ($ignore) {
substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
} else {
$path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
}
return $path;
}
# internal routine to check to see if the directory is safe
# First checks to see if the directory is not owned by the
# current user or root. Then checks to see if anyone else
# can write to the directory and if so, checks to see if
# it has the sticky bit set
# Will not work on systems that do not support sticky bit
#Args: directory path to check
# Optionally: reference to scalar to contain error message
# Returns true if the path is safe and false otherwise.
# Returns undef if can not even run stat() on the path
# This routine based on version written by Tom Christiansen
# Presumably, by the time we actually attempt to create the
# file or directory in this directory, it may not be safe
# anymore... Have to run _is_safe directly after the open.
sub _is_safe {
my $path = shift;
my $err_ref = shift;
# Stat path
my @info = stat($path);
unless (scalar(@info)) {
$$err_ref = "stat(path) returned no values";
return 0;
};
return 1 if $^O eq 'VMS'; # owner delete control at file level
# Check to see whether owner is neither superuser (or a system uid) nor me
# Use the real uid from the $< variable
# UID is in [4]
if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) {
Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'",
File::Temp->top_system_uid());
$$err_ref = "Directory owned neither by root nor the current user"
if ref($err_ref);
return 0;
}
# check whether group or other can write file
# use 066 to detect either reading or writing
# use 022 to check writability
# Do it with S_IWOTH and S_IWGRP for portability (maybe)
# mode is in info[2]
if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
# Must be a directory
unless (-d _) {
$$err_ref = "Path ($path) is not a directory"
if ref($err_ref);
return 0;
}
# Must have sticky bit set
unless (-k _) {
$$err_ref = "Sticky bit not set on $path when dir is group|world writable"
if ref($err_ref);
return 0;
}
}
return 1;
}
# Internal routine to check whether a directory is safe
# for temp files. Safer than _is_safe since it checks for
# the possibility of chown giveaway and if that is a possibility
# checks each directory in the path to see if it is safe (with _is_safe)
# If _PC_CHOWN_RESTRICTED is not set, does the full test of each
# directory anyway.
# Takes optional second arg as scalar ref to error reason
sub _is_verysafe {
# Need POSIX - but only want to bother if really necessary due to overhead
require POSIX;
my $path = shift;
print "_is_verysafe testing $path\n" if $DEBUG;
return 1 if $^O eq 'VMS'; # owner delete control at file level
my $err_ref = shift;
# Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
# and If it is not there do the extensive test
my $chown_restricted;
$chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
# If chown_resticted is set to some value we should test it
if (defined $chown_restricted) {
# Return if the current directory is safe
return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
}
# To reach this point either, the _PC_CHOWN_RESTRICTED symbol
# was not avialable or the symbol was there but chown giveaway
# is allowed. Either way, we now have to test the entire tree for
# safety.
# Convert path to an absolute directory if required
unless (File::Spec->file_name_is_absolute($path)) {
$path = File::Spec->rel2abs($path);
}
# Split directory into components - assume no file
my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
# Slightly less efficient than having a a function in File::Spec
# to chop off the end of a directory or even a function that
# can handle ../ in a directory tree
# Sometimes splitdir() returns a blank at the end
# so we will probably check the bottom directory twice in some cases
my @dirs = File::Spec->splitdir($directories);
# Concatenate one less directory each time around
foreach my $pos (0.. $#dirs) {
# Get a directory name
my $dir = File::Spec->catpath($volume,
File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
''
);
print "TESTING DIR $dir\n" if $DEBUG;
# Check the directory
return 0 unless _is_safe($dir,$err_ref);
}
return 1;
}
# internal routine to determine whether unlink works on this
# platform for files that are currently open.
# Returns true if we can, false otherwise.
# Currently WinNT, OS/2 and VMS can not unlink an opened file
# On VMS this is because the O_EXCL flag is used to open the
# temporary file. Currently I do not know enough about the issues
# on VMS to decide whether O_EXCL is a requirement.
sub _can_unlink_opened_file {
if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos') {
return 0;
} else {
return 1;
}
}
# internal routine to decide which security levels are allowed
# see safe_level() for more information on this
# Controls whether the supplied security level is allowed
# $cando = _can_do_level( $level )
sub _can_do_level {
# Get security level
my $level = shift;
# Always have to be able to do STANDARD
return 1 if $level == STANDARD;
# Currently, the systems that can do HIGH or MEDIUM are identical
if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos') {
return 0;
} else {
return 1;
}
}
# This routine sets up a deferred unlinking of a specified
# filename and filehandle. It is used in the following cases:
# - Called by unlink0 if an opened file can not be unlinked
# - Called by tempfile() if files are to be removed on shutdown
# - Called by tempdir() if directories are to be removed on shutdown
# Arguments:
# _deferred_unlink( $fh, $fname, $isdir );
#
# - filehandle (so that it can be expclicitly closed if open
# - filename (the thing we want to remove)
# - isdir (flag to indicate that we are being given a directory)
# [and hence no filehandle]
# Status is not referred to since all the magic is done with an END block
{
# Will set up two lexical variables to contain all the files to be
# removed. One array for files, another for directories
# They will only exist in this block
# This means we only have to set up a single END block to remove all files
# @files_to_unlink contains an array ref with the filehandle and filename
my (@files_to_unlink, @dirs_to_unlink);
# Set up an end block to use these arrays
END {
# Files
foreach my $file (@files_to_unlink) {
# close the filehandle without checking its state
# in order to make real sure that this is closed
# if its already closed then I dont care about the answer
# probably a better way to do this
close($file->[0]); # file handle is [0]
if (-f $file->[1]) { # file name is [1]
unlink $file->[1] or warn "Error removing ".$file->[1];
}
}
# Dirs
foreach my $dir (@dirs_to_unlink) {
if (-d $dir) {
rmtree($dir, $DEBUG, 1);
}
}
}
# This is the sub called to register a file for deferred unlinking
# This could simply store the input parameters and defer everything
# until the END block. For now we do a bit of checking at this
# point in order to make sure that (1) we have a file/dir to delete
# and (2) we have been called with the correct arguments.
sub _deferred_unlink {
croak 'Usage: _deferred_unlink($fh, $fname, $isdir)'
unless scalar(@_) == 3;
my ($fh, $fname, $isdir) = @_;
warn "Setting up deferred removal of $fname\n"
if $DEBUG;
# If we have a directory, check that it is a directory
if ($isdir) {
if (-d $fname) {
# Directory exists so store it
# first on VMS turn []foo into [.foo] for rmtree
$fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
push (@dirs_to_unlink, $fname);
} else {
carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
}
} else {
if (-f $fname) {
# file exists so store handle and name for later removal
push(@files_to_unlink, [$fh, $fname]);
} else {
carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
}
}
}
}
=head1 FUNCTIONS
This section describes the recommended interface for generating
temporary files and directories.
=over 4
=item B
This is the basic function to generate temporary files.
The behaviour of the file can be changed using various options:
($fh, $filename) = tempfile();
Create a temporary file in the directory specified for temporary
files, as specified by the tmpdir() function in L.
($fh, $filename) = tempfile($template);
Create a temporary file in the current directory using the supplied
template. Trailing `X' characters are replaced with random letters to
generate the filename. At least four `X' characters must be present
in the template.
($fh, $filename) = tempfile($template, SUFFIX => $suffix)
Same as previously, except that a suffix is added to the template
after the `X' translation. Useful for ensuring that a temporary
filename has a particular extension when needed by other applications.
But see the WARNING at the end.
($fh, $filename) = tempfile($template, DIR => $dir);
Translates the template as before except that a directory name
is specified.
($fh, $filename) = tempfile($template, UNLINK => 1);
Return the filename and filehandle as before except that the file is
automatically removed when the program exits. Default is for the file
to be removed if a file handle is requested and to be kept if the
filename is requested. In a scalar context (where no filename is
returned) the file is always deleted either on exit or when it is closed.
If the template is not specified, a template is always
automatically generated. This temporary file is placed in tmpdir()
(L) unless a directory is specified explicitly with the
DIR option.
$fh = tempfile( $template, DIR => $dir );
If called in scalar context, only the filehandle is returned
and the file will automatically be deleted when closed (see
the description of tmpfile() elsewhere in this document).
This is the preferred mode of operation, as if you only
have a filehandle, you can never create a race condition
by fumbling with the filename. On systems that can not unlink
an open file or can not mark a file as temporary when it is opened
(for example, Windows NT uses the C flag))
the file is marked for deletion when the program ends (equivalent
to setting UNLINK to 1). The C flag is ignored if present.
(undef, $filename) = tempfile($template, OPEN => 0);
This will return the filename based on the template but
will not open this file. Cannot be used in conjunction with
UNLINK set to true. Default is to always open the file
to protect from possible race conditions. A warning is issued
if warnings are turned on. Consider using the tmpnam()
and mktemp() functions described elsewhere in this document
if opening the file is not required.
Options can be combined as required.
=cut
sub tempfile {
# Can not check for argument count since we can have any
# number of args
# Default options
my %options = (
"DIR" => undef, # Directory prefix
"SUFFIX" => '', # Template suffix
"UNLINK" => 0, # Do not unlink file on exit
"OPEN" => 1, # Open file
);
# Check to see whether we have an odd or even number of arguments
my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef);
# Read the options and merge with defaults
%options = (%options, @_) if @_;
# First decision is whether or not to open the file
if (! $options{"OPEN"}) {
warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
if $^W;
}
if ($options{"DIR"} and $^O eq 'VMS') {
# on VMS turn []foo into [.foo] for concatenation
$options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
}
# Construct the template
# Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
# functions or simply constructing a template and using _gettemp()
# explicitly. Go for the latter
# First generate a template if not defined and prefix the directory
# If no template must prefix the temp directory
if (defined $template) {
if ($options{"DIR"}) {
$template = File::Spec->catfile($options{"DIR"}, $template);
}
} else {
if ($options{"DIR"}) {
$template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
} else {
$template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
}
}
# Now add a suffix
$template .= $options{"SUFFIX"};
# Determine whether we should tell _gettemp to unlink the file
# On unix this is irrelevant and can be worked out after the file is
# opened (simply by unlinking the open filehandle). On Windows or VMS
# we have to indicate temporary-ness when we open the file. In general
# we only want a true temporary file if we are returning just the
# filehandle - if the user wants the filename they probably do not
# want the file to disappear as soon as they close it.
# For this reason, tie unlink_on_close to the return context regardless
# of OS.
my $unlink_on_close = ( wantarray ? 0 : 1);
# Create the file
my ($fh, $path, $errstr);
croak "Error in tempfile() using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => $options{'OPEN'},
"mkdir"=> 0 ,
"unlink_on_close" => $unlink_on_close,
"suffixlen" => length($options{'SUFFIX'}),
"ErrStr" => \$errstr,
) );
# Set up an exit handler that can do whatever is right for the
# system. This removes files at exit when requested explicitly or when
# system is asked to unlink_on_close but is unable to do so because
# of OS limitations.
# The latter should be achieved by using a tied filehandle.
# Do not check return status since this is all done with END blocks.
_deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
# Return
if (wantarray()) {
if ($options{'OPEN'}) {
return ($fh, $path);
} else {
return (undef, $path);
}
} else {
# Unlink the file. It is up to unlink0 to decide what to do with
# this (whether to unlink now or to defer until later)
unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
# Return just the filehandle.
return $fh;
}
}
=item B
This is the recommended interface for creation of temporary directories.
The behaviour of the function depends on the arguments:
$tempdir = tempdir();
Create a directory in tmpdir() (see L).
$tempdir = tempdir( $template );
Create a directory from the supplied template. This template is
similar to that described for tempfile(). `X' characters at the end
of the template are replaced with random letters to construct the
directory name. At least four `X' characters must be in the template.
$tempdir = tempdir ( DIR => $dir );
Specifies the directory to use for the temporary directory.
The temporary directory name is derived from an internal template.
$tempdir = tempdir ( $template, DIR => $dir );
Prepend the supplied directory name to the template. The template
should not include parent directory specifications itself. Any parent
directory specifications are removed from the template before
prepending the supplied directory.
$tempdir = tempdir ( $template, TMPDIR => 1 );
Using the supplied template, creat the temporary directory in
a standard location for temporary files. Equivalent to doing
$tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
but shorter. Parent directory specifications are stripped from the
template itself. The C option is ignored if C is set
explicitly. Additionally, C is implied if neither a template
nor a directory are supplied.
$tempdir = tempdir( $template, CLEANUP => 1);
Create a temporary directory using the supplied template, but
attempt to remove it (and all files inside it) when the program
exits. Note that an attempt will be made to remove all files from
the directory even if they were not created by this module (otherwise
why ask to clean it up?). The directory removal is made with
the rmtree() function from the L module.
Of course, if the template is not specified, the temporary directory
will be created in tmpdir() and will also be removed at program exit.
=cut
# '
sub tempdir {
# Can not check for argument count since we can have any
# number of args
# Default options
my %options = (
"CLEANUP" => 0, # Remove directory on exit
"DIR" => '', # Root directory
"TMPDIR" => 0, # Use tempdir with template
);
# Check to see whether we have an odd or even number of arguments
my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
# Read the options and merge with defaults
%options = (%options, @_) if @_;
# Modify or generate the template
# Deal with the DIR and TMPDIR options
if (defined $template) {
# Need to strip directory path if using DIR or TMPDIR
if ($options{'TMPDIR'} || $options{'DIR'}) {
# Strip parent directory from the filename
#
# There is no filename at the end
$template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
# Last directory is then our template
$template = (File::Spec->splitdir($directories))[-1];
# Prepend the supplied directory or temp dir
if ($options{"DIR"}) {
$template = File::Spec->catdir($options{"DIR"}, $template);
} elsif ($options{TMPDIR}) {
# Prepend tmpdir
$template = File::Spec->catdir(File::Spec->tmpdir, $template);
}
}
} else {
if ($options{"DIR"}) {
$template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
} else {
$template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
}
}
# Create the directory
my $tempdir;
my $suffixlen = 0;
if ($^O eq 'VMS') { # dir names can end in delimiters
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
my $errstr;
croak "Error in tempdir() using $template: $errstr"
unless ((undef, $tempdir) = _gettemp($template,
"open" => 0,
"mkdir"=> 1 ,
"suffixlen" => $suffixlen,
"ErrStr" => \$errstr,
) );
# Install exit handler; must be dynamic to get lexical
if ( $options{'CLEANUP'} && -d $tempdir) {
_deferred_unlink(undef, $tempdir, 1);
}
# Return the dir name
return $tempdir;
}
=back
=head1 MKTEMP FUNCTIONS
The following functions are Perl implementations of the
mktemp() family of temp file generation system calls.
=over 4
=item B
Given a template, returns a filehandle to the temporary file and the name
of the file.
($fh, $name) = mkstemp( $template );
In scalar context, just the filehandle is returned.
The template may be any filename with some number of X's appended
to it, for example F. The trailing X's are replaced
with unique alphanumeric combinations.
=cut
sub mkstemp {
croak "Usage: mkstemp(template)"
if scalar(@_) != 1;
my $template = shift;
my ($fh, $path, $errstr);
croak "Error in mkstemp using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => 1,
"mkdir"=> 0 ,
"suffixlen" => 0,
"ErrStr" => \$errstr,
) );
if (wantarray()) {
return ($fh, $path);
} else {
return $fh;
}
}
=item B
Similar to mkstemp(), except that an extra argument can be supplied
with a suffix to be appended to the template.
($fh, $name) = mkstemps( $template, $suffix );
For example a template of C and suffix of C<.dat>
would generate a file similar to F.
Returns just the filehandle alone when called in scalar context.
=cut
sub mkstemps {
croak "Usage: mkstemps(template, suffix)"
if scalar(@_) != 2;
my $template = shift;
my $suffix = shift;
$template .= $suffix;
my ($fh, $path, $errstr);
croak "Error in mkstemps using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => 1,
"mkdir"=> 0 ,
"suffixlen" => length($suffix),
"ErrStr" => \$errstr,
) );
if (wantarray()) {
return ($fh, $path);
} else {
return $fh;
}
}
=item B
Create a directory from a template. The template must end in
X's that are replaced by the routine.
$tmpdir_name = mkdtemp($template);
Returns the name of the temporary directory created.
Returns undef on failure.
Directory must be removed by the caller.
=cut
#' # for emacs
sub mkdtemp {
croak "Usage: mkdtemp(template)"
if scalar(@_) != 1;
my $template = shift;
my $suffixlen = 0;
if ($^O eq 'VMS') { # dir names can end in delimiters
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
my ($junk, $tmpdir, $errstr);
croak "Error creating temp directory from template $template\: $errstr"
unless (($junk, $tmpdir) = _gettemp($template,
"open" => 0,
"mkdir"=> 1 ,
"suffixlen" => $suffixlen,
"ErrStr" => \$errstr,
) );
return $tmpdir;
}
=item B
Returns a valid temporary filename but does not guarantee
that the file will not be opened by someone else.
$unopened_file = mktemp($template);
Template is the same as that required by mkstemp().
=cut
sub mktemp {
croak "Usage: mktemp(template)"
if scalar(@_) != 1;
my $template = shift;
my ($tmpname, $junk, $errstr);
croak "Error getting name to temp file from template $template: $errstr"
unless (($junk, $tmpname) = _gettemp($template,
"open" => 0,
"mkdir"=> 0 ,
"suffixlen" => 0,
"ErrStr" => \$errstr,
) );
return $tmpname;
}
=back
=head1 POSIX FUNCTIONS
This section describes the re-implementation of the tmpnam()
and tmpfile() functions described in L
using the mkstemp() from this module.
Unlike the L implementations, the directory used
for the temporary file is not specified in a system include
file (C) but simply depends on the choice of tmpdir()
returned by L. On some implementations this
location can be set using the C environment variable, which
may not be secure.
If this is a problem, simply use mkstemp() and specify a template.
=over 4
=item B
When called in scalar context, returns the full name (including path)
of a temporary file (uses mktemp()). The only check is that the file does
not already exist, but there is no guarantee that that condition will
continue to apply.
$file = tmpnam();
When called in list context, a filehandle to the open file and
a filename are returned. This is achieved by calling mkstemp()
after constructing a suitable template.
($fh, $file) = tmpnam();
If possible, this form should be used to prevent possible
race conditions.
See L for information on the choice of temporary
directory for a particular operating system.
=cut
sub tmpnam {
# Retrieve the temporary directory name
my $tmpdir = File::Spec->tmpdir;
croak "Error temporary directory is not writable"
if $tmpdir eq '';
# Use a ten character template and append to tmpdir
my $template = File::Spec->catfile($tmpdir, TEMPXXX);
if (wantarray() ) {
return mkstemp($template);
} else {
return mktemp($template);
}
}
=item B
In scalar context, returns the filehandle of a temporary file.
$fh = tmpfile();
The file is removed when the filehandle is closed or when the program
exits. No access to the filename is provided.
If the temporary file can not be created undef is returned.
Currently this command will probably not work when the temporary
directory is on an NFS file system.
=cut
sub tmpfile {
# Simply call tmpnam() in a list context
my ($fh, $file) = tmpnam();
# Make sure file is removed when filehandle is closed
# This will fail on NFS
unlink0($fh, $file)
or return undef;
return $fh;
}
=back
=head1 ADDITIONAL FUNCTIONS
These functions are provided for backwards compatibility
with common tempfile generation C library functions.
They are not exported and must be addressed using the full package
name.
=over 4
=item B
Return the name of a temporary file in the specified directory
using a prefix. The file is guaranteed not to exist at the time
the function was called, but such guarantees are good for one
clock tick only. Always use the proper form of C
with C if you must open such a filename.
$filename = File::Temp::tempnam( $dir, $prefix );
Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
(using unix file convention as an example)
Because this function uses mktemp(), it can suffer from race conditions.
=cut
sub tempnam {
croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
my ($dir, $prefix) = @_;
# Add a string to the prefix
$prefix .= 'XXXXXXXX';
# Concatenate the directory to the file
my $template = File::Spec->catfile($dir, $prefix);
return mktemp($template);
}
=back
=head1 UTILITY FUNCTIONS
Useful functions for dealing with the filehandle and filename.
=over 4
=item B
Given an open filehandle and the associated filename, make a safe
unlink. This is achieved by first checking that the filename and
filehandle initially point to the same file and that the number of
links to the file is 1 (all fields returned by stat() are compared).
Then the filename is unlinked and the filehandle checked once again to
verify that the number of links on that file is now 0. This is the
closest you can come to making sure that the filename unlinked was the
same as the file whose descriptor you hold.
unlink0($fh, $path) or die "Error unlinking file $path safely";
Returns false on error. The filehandle is not closed since on some
occasions this is not required.
On some platforms, for example Windows NT, it is not possible to
unlink an open file (the file must be closed first). On those
platforms, the actual unlinking is deferred until the program ends and
good status is returned. A check is still performed to make sure that
the filehandle and filename are pointing to the same thing (but not at
the time the end block is executed since the deferred removal may not
have access to the filehandle).
Additionally, on Windows NT not all the fields returned by stat() can
be compared. For example, the C and C fields seem to be
different. Also, it seems that the size of the file returned by stat()
does not always agree, with C being more accurate than
C, presumably because of caching issues even when
using autoflush (this is usually overcome by waiting a while after
writing to the tempfile before attempting to C it).
Finally, on NFS file systems the link count of the file handle does
not always go to zero immediately after unlinking. Currently, this
command is expected to fail on NFS disks.
=cut
sub unlink0 {
croak 'Usage: unlink0(filehandle, filename)'
unless scalar(@_) == 2;
# Read args
my ($fh, $path) = @_;
warn "Unlinking $path using unlink0\n"
if $DEBUG;
# Stat the filehandle
my @fh = stat $fh;
if ($fh[3] > 1 && $^W) {
carp "unlink0: fstat found too many links; SB=@fh" if $^W;
}
# Stat the path
my @path = stat $path;
unless (@path) {
carp "unlink0: $path is gone already" if $^W;
return;
}
# this is no longer a file, but may be a directory, or worse
unless (-f _) {
confess "panic: $path is no longer a file: SB=@fh";
}
# Do comparison of each member of the array
# On WinNT dev and rdev seem to be different
# depending on whether it is a file or a handle.
# Cannot simply compare all members of the stat return
# Select the ones we can use
my @okstat = (0..$#fh); # Use all by default
if ($^O eq 'MSWin32') {
@okstat = (1,2,3,4,5,7,8,9,10);
} elsif ($^O eq 'os2') {
@okstat = (0, 2..$#fh);
} elsif ($^O eq 'VMS') { # device and file ID are sufficient
@okstat = (0, 1);
} elsif ($^O eq 'dos') {
@okstat = (0,2..7,11..$#fh);
}
# Now compare each entry explicitly by number
for (@okstat) {
print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
# Use eq rather than == since rdev, blksize, and blocks (6, 11,
# and 12) will be '' on platforms that do not support them. This
# is fine since we are only comparing integers.
unless ($fh[$_] eq $path[$_]) {
warn "Did not match $_ element of stat\n" if $DEBUG;
return 0;
}
}
# attempt remove the file (does not work on some platforms)
if (_can_unlink_opened_file()) {
# XXX: do *not* call this on a directory; possible race
# resulting in recursive removal
croak "unlink0: $path has become a directory!" if -d $path;
unlink($path) or return 0;
# Stat the filehandle
@fh = stat $fh;
print "Link count = $fh[3] \n" if $DEBUG;
# Make sure that the link count is zero
# - Cygwin provides deferred unlinking, however,
# on Win9x the link count remains 1
# On NFS the link count may still be 1 but we cant know that
# we are on NFS
return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0);
} else {
_deferred_unlink($fh, $path, 0);
return 1;
}
}
=back
=head1 PACKAGE VARIABLES
These functions control the global state of the package.
=over 4
=item B
Controls the lengths to which the module will go to check the safety of the
temporary file or directory before proceeding.
Options are:
=over 8
=item STANDARD
Do the basic security measures to ensure the directory exists and
is writable, that the umask() is fixed before opening of the file,
that temporary files are opened only if they do not already exist, and
that possible race conditions are avoided. Finally the L
function is used to remove files safely.
=item MEDIUM
In addition to the STANDARD security, the output directory is checked
to make sure that it is owned either by root or the user running the
program. If the directory is writable by group or by other, it is then
checked to make sure that the sticky bit is set.
Will not work on platforms that do not support the C<-k> test
for sticky bit.
=item HIGH
In addition to the MEDIUM security checks, also check for the
possibility of ``chown() giveaway'' using the L
sysconf() function. If this is a possibility, each directory in the
path is checked in turn for safeness, recursively walking back to the
root directory.
For platforms that do not support the L
C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
assumed that ``chown() giveaway'' is possible and the recursive test
is performed.
=back
The level can be changed as follows:
File::Temp->safe_level( File::Temp::HIGH );
The level constants are not exported by the module.
Currently, you must be running at least perl v5.6.0 in order to
run with MEDIUM or HIGH security. This is simply because the
safety tests use functions from L that are not
available in older versions of perl. The problem is that the version
number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
they are different versions.
On systems that do not support the HIGH or MEDIUM safety levels
(for example Win NT or OS/2) any attempt to change the level will
be ignored. The decision to ignore rather than raise an exception
allows portable programs to be written with high security in mind
for the systems that can support this without those programs failing
on systems where the extra tests are irrelevant.
If you really need to see whether the change has been accepted
simply examine the return value of C.
$newlevel = File::Temp->safe_level( File::Temp::HIGH );
die "Could not change to high security"
if $newlevel != File::Temp::HIGH;
=cut
{
# protect from using the variable itself
my $LEVEL = STANDARD;
sub safe_level {
my $self = shift;
if (@_) {
my $level = shift;
if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
} else {
# Dont allow this on perl 5.005 or earlier
if ($] < 5.006 && $level != STANDARD) {
# Cant do MEDIUM or HIGH checks
croak "Currently requires perl 5.006 or newer to do the safe checks";
}
# Check that we are allowed to change level
# Silently ignore if we can not.
$LEVEL = $level if _can_do_level($level);
}
}
return $LEVEL;
}
}
=item TopSystemUID
This is the highest UID on the current system that refers to a root
UID. This is used to make sure that the temporary directory is
owned by a system UID (C, C, C etc) rather than
simply by root.
This is required since on many unix systems C is not owned
by root.
Default is to assume that any UID less than or equal to 10 is a root
UID.
File::Temp->top_system_uid(10);
my $topid = File::Temp->top_system_uid;
This value can be adjusted to reduce security checking if required.
The value is only relevant when C is set to MEDIUM or higher.
=back
=cut
{
my $TopSystemUID = 10;
sub top_system_uid {
my $self = shift;
if (@_) {
my $newuid = shift;
croak "top_system_uid: UIDs should be numeric"
unless $newuid =~ /^\d+$/s;
$TopSystemUID = $newuid;
}
return $TopSystemUID;
}
}
=head1 WARNING
For maximum security, endeavour always to avoid ever looking at,
touching, or even imputing the existence of the filename. You do not
know that that filename is connected to the same file as the handle
you have, and attempts to check this can only trigger more race
conditions. It's far more secure to use the filehandle alone and
dispense with the filename altogether.
If you need to pass the handle to something that expects a filename
then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary
programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl
programs. You will have to clear the close-on-exec bit on that file
descriptor before passing it to another process.
use Fcntl qw/F_SETFD F_GETFD/;
fcntl($tmpfh, F_SETFD, 0)
or die "Can't clear close-on-exec flag on temp fh: $!\n";
=head2 Temporary files and NFS
Some problems are associated with using temporary files that reside
on NFS file systems and it is recommended that a local filesystem
is used whenever possible. Some of the security tests will most probably
fail when the temp file is not local. Additionally, be aware that
the performance of I/O operations over NFS will not be as good as for
a local disk.
=head1 HISTORY
Originally began life in May 1999 as an XS interface to the system
mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
translated to Perl for total control of the code's
security checking, to ensure the presence of the function regardless of
operating system and to help with portability.
=head1 SEE ALSO
L, L, L, L
See L and L for different implementations of
temporary file handling.
=head1 AUTHOR
Tim Jenness Et.jenness@jach.hawaii.eduE
Copyright (C) 1999-2001 Tim Jenness and the UK Particle Physics and
Astronomy Research Council. All Rights Reserved. This program is free
software; you can redistribute it and/or modify it under the same
terms as Perl itself.
Original Perl implementation loosely based on the OpenBSD C code for
mkstemp(). Thanks to Tom Christiansen for suggesting that this module
should be written and providing ideas for code improvements and
security enhancements.
=cut
1;
cgi-bin/extlib/HTML/0000755002157400001440000000000007776605372021047 5ustar minnesotaviolasociety.orgusers00000000000000cgi-bin/extlib/HTML/_vti_cnf/0000755002157400001440000000000007776605372022636 5ustar minnesotaviolasociety.orgusers00000000000000cgi-bin/extlib/HTML/_vti_cnf/Template.pm0000644002157400001440000000030507771550070024732 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|106940
vti_backlinkinfo:VX|
cgi-bin/extlib/HTML/_vti_cnf/Form.pm0000644002157400001440000000030407771550070024061 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|15876
vti_backlinkinfo:VX|
cgi-bin/extlib/HTML/Template.pm0000644002157400001440000032067407771550070023161 0ustar minnesotaviolasociety.orgusers00000000000000package HTML::Template;
$HTML::Template::VERSION = '2.4';
=head1 NAME
HTML::Template - Perl module to use HTML Templates from CGI scripts
=head1 SYNOPSIS
First you make a template - this is just a normal HTML file with a few
extra tags, the simplest being
For example, test.tmpl:
Test Template
My Home Directory is
My Path is set to
Now create a small CGI program:
use HTML::Template;
# open the html template
my $template = HTML::Template->new(filename => 'test.tmpl');
# fill in some parameters
$template->param(
HOME => $ENV{HOME},
PATH => $ENV{PATH},
);
# send the obligatory Content-Type
print "Content-Type: text/html\n\n";
# print the template
print $template->output;
If all is well in the universe this should show something like this in
your browser when visiting the CGI:
My Home Directory is /home/some/directory
My Path is set to /bin;/usr/bin
=head1 DESCRIPTION
This module attempts to make using HTML templates simple and natural. It
extends standard HTML with a few new HTML-esque tags - ,
, , and . The file
written with HTML and these new tags is called a template. It is
usually saved separate from your script - possibly even created by
someone else! Using this module you fill in the values for the
variables, loops and branches declared in the template. This allows
you to separate design - the HTML - from the data, which you generate
in the Perl script.
A Japanese translation of the documentation is available at:
http://member.nifty.ne.jp/hippo2000/perltips/html/template.htm
This module is licensed under the GPL. See the LICENSE section
below for more details.
=head1 MOTIVATION
It is true that there are a number of packages out there to do HTML
templates. On the one hand you have things like HTML::Embperl which
allows you freely mix Perl with HTML. On the other hand lie
home-grown variable substitution solutions. Hopefully the module can
find a place between the two.
One advantage of this module over a full HTML::Embperl-esque solution
is that it enforces an important divide - design and programming. By
limiting the programmer to just using simple variables and loops in
the HTML, the template remains accessible to designers and other
non-perl people. The use of HTML-esque syntax goes further to make
the format understandable to others. In the future this similarity
could be used to extend existing HTML editors/analyzers to support
HTML::Template.
An advantage of this module over home-grown tag-replacement schemes is
the support for loops. In my work I am often called on to produce
tables of data in html. Producing them using simplistic HTML
templates results in CGIs containing lots of HTML since the HTML
itself cannot represent loops. The introduction of loop statements in
the HTML simplifies this situation considerably. The designer can
layout a single row and the programmer can fill it in as many times as
necessary - all they must agree on is the parameter names.
For all that, I think the best thing about this module is that it does
just one thing and it does it quickly and carefully. It doesn't try
to replace Perl and HTML, it just augments them to interact a little
better. And it's pretty fast.
=head1 The Tags
Note: even though these tags look like HTML they are a little
different - they're allowed to "break the rules". Something like:
" is acceptable.
If you're a fanatic about valid HTML and would like your templates
to conform to valid HTML syntax, you may optionally type template tags
in the form of HTML comments. This may be of use to HTML authors who
would like to validate their templates' HTML syntax prior to
HTML::Template processing, or who use DTD-savvy editing tools.
In order to realize a dramatic savings in bandwidth, the standard
(non-comment) tags will be used throughout the rest of this
documentation.
=head2
The tag is very simple. For each tag in the
template you call $template->param(PARAMETER_NAME => "VALUE"). When
the template is output the is replaced with the VALUE text
you specified. If you don't set a parameter it just gets skipped in
the output.
Optionally you can use the "ESCAPE=HTML" option in the tag to indicate
that you want the value to be HTML-escaped before being returned from
output (the old ESCAPE=1 syntax is still supported). This means that
the ", <, >, and & characters get translated into ", <, >
and & respectively. This is useful when you want to use a
TMPL_VAR in a context where those characters would cause trouble.
Example:
The tag is a bit more complicated. The tag
allows you to delimit a section of text and give it a name. Inside
the you place s. Now you pass to param() a list
(an array ref) of parameter assignments (hash refs). The loop
iterates over this list and produces output from the text block for
each pass. Unset parameters are skipped. Here's an example:
In the template:
Name:
Job:
In the script:
$template->param(EMPLOYEE_INFO => [
{ name => 'Sam', job => 'programmer' },
{ name => 'Steve', job => 'soda jerk' },
]
);
print $template->output();
The output:
Name: Sam
Job: programmer
Name: Steve
Job: soda jerk
As you can see above the takes a list of variable
assignments and then iterates over the loop body producing output.
Often you'll want to generate a 's contents
programmatically. Here's an example of how this can be done (many
other ways are possible!):
# a couple of arrays of data to put in a loop:
my @words = qw(I Am Cool);
my @numbers = qw(1 2 3);
my @loop_data = (); # initialize an array to hold your loop
while (@words and @numbers) {
my %row_data; # get a fresh hash for the row data
# fill in this row
$row_data{WORD} = shift @words;
$row_data{NUMBER} = shift @numbers;
# the crucial step - push a reference to this row into the loop!
push(@loop_data, \%row_data);
}
# finally, assign the loop data to the loop param, again with a
# reference:
$template->param(THIS_LOOP => \@loop_data);
The above example would work with a template like:
Word:
It would produce output like:
Word: I
Number: 1
Word: Am
Number: 2
Word: Cool
Number: 3
s within s are fine and work as you would
expect. If the syntax for the param() call has you stumped, here's an
example of a param call with one nested loop:
$template->param('ROW',[
{ name => 'Bobby',
nicknames => [
{ name => 'the big bad wolf' },
{ name => 'He-Man' },
],
},
],
);
Basically, each gets an array reference. Inside the array
are any number of hash references. These hashes contain the
name=>value pairs for a single pass over the loop template.
Inside a , the only variables that are usable are the ones
from the . The variables in the outer blocks are not
visible within a template loop. For the computer-science geeks among
you, a introduces a new scope much like a perl subroutine
call. If you want your variables to be global you can use
'global_vars' option to new described below.
=head2
This tag includes a template directly into the current template at the
point where the tag is found. The included template contents are used
exactly as if its contents were physically included in the master
template.
The file specified can be a full path - beginning with a '/'. If it
isn't a full path, the path to the enclosing file is tried first.
After that the path in the environment variable HTML_TEMPLATE_ROOT is
tried next, if it exists. Next, the "path" new() option is consulted.
As a final attempt, the filename is passed to open() directly. See
below for more information on HTML_TEMPLATE_ROOT and the "path" option
to new().
As a protection against infinitly recursive includes, an arbitary
limit of 10 levels deep is imposed. You can alter this limit with the
"max_includes" option. See the entry for the "max_includes" option
below for more details.
=head2
The tag allows you to include or not include a block of the
template based on the value of a given parameter name. If the
parameter is given a value that is true for Perl - like '1' - then the
block is included in the output. If it is not defined, or given a
false value - like '0' - then it is skipped. The parameters are
specified the same way as with TMPL_VAR.
Example Template:
Some text that only gets displayed if BOOL is true!
Now if you call $template->param(BOOL => 1) then the above block will
be included by output.
blocks can include any valid HTML::Template
construct - VARs and LOOPs and other IF/ELSE blocks. Note, however,
that intersecting a and a is invalid.
Not going to work:
If the name of a TMPL_LOOP is used in a TMPL_IF, the IF block will
output if the loop has at least one row. Example:
This will output if the loop is not empty.
....
WARNING: Much of the benefit of HTML::Template is in decoupling your
Perl and HTML. If you introduce numerous cases where you have
TMPL_IFs and matching Perl if()s, you will create a maintenance
problem in keeping the two synchronized. I suggest you adopt the
practice of only using TMPL_IF if you can do so without requiring a
matching if() in your Perl code.
=head2
You can include an alternate block in your TMPL_IF block by using
TMPL_ELSE. NOTE: You still end the block with , not
!
Example:
Some text that is included only if BOOL is true
Some text that is included only if BOOL is false
=head2
This tag is the opposite of . The block is output if the
CONTROL_PARAMETER is set false or not defined. You can use
with just as you can with .
Example:
Some text that is output only if BOOL is FALSE.
Some text that is output only if BOOL is TRUE.
If the name of a TMPL_LOOP is used in a TMPL_UNLESS, the UNLESS block
output if the loop has zero rows.
This will output if the loop is empty.
....
=cut
=head1 Methods
=head2 new()
Call new() to create a new Template object:
my $template = HTML::Template->new( filename => 'file.tmpl',
option => 'value'
);
You must call new() with at least one name => value pair specifying how
to access the template text. You can use "filename => 'file.tmpl'" to
specify a filename to be opened as the template. Alternately you can
use:
my $t = HTML::Template->new( scalarref => $ref_to_template_text,
option => 'value'
);
and
my $t = HTML::Template->new( arrayref => $ref_to_array_of_lines ,
option => 'value'
);
These initialize the template from in-memory resources. In almost
every case you'll want to use the filename parameter. If you're
worried about all the disk access from reading a template file just
use mod_perl and the cache option detailed below.
You can also read the template from an already opened filehandle,
either traditionally as a glob or as a FileHandle:
my $t = HTML::Template->new( filehandle => *FH, option => 'value');
The four new() calling methods can also be accessed as below, if you
prefer.
my $t = HTML::Template->new_file('file.tmpl', option => 'value');
my $t = HTML::Template->new_scalar_ref($ref_to_template_text,
option => 'value');
my $t = HTML::Template->new_array_ref($ref_to_array_of_lines,
option => 'value');
my $t = HTML::Template->new_filehandle($fh,
option => 'value');
And as a final option, for those that might prefer it, you can call new as:
my $t = HTML::Template->new(type => 'filename',
source => 'file.tmpl');
Which works for all three of the source types.
If the environment variable HTML_TEMPLATE_ROOT is set and your
filename doesn't begin with /, then the path will be relative to the
value of $HTML_TEMPLATE_ROOT. Example - if the environment variable
HTML_TEMPLATE_ROOT is set to "/home/sam" and I call
HTML::Template->new() with filename set to "sam.tmpl", the
HTML::Template will try to open "/home/sam/sam.tmpl" to access the
template file. You can also affect the search path for files with the
"path" option to new() - see below for more information.
You can modify the Template object's behavior with new. These options
are available:
=over 4
=item *
die_on_bad_params - if set to 0 the module will let you call
$template->param(param_name => 'value') even if 'param_name' doesn't
exist in the template body. Defaults to 1.
=item *
strict - if set to 0 the module will allow things that look like they might be TMPL_* tags to get by without dieing. Example:
Would normally cause an error, but if you call new with strict => 0,
HTML::Template will ignore it. Defaults to 1.
=item *
cache - if set to 1 the module will cache in memory the parsed
templates based on the filename parameter and modification date of the
file. This only applies to templates opened with the filename
parameter specified, not scalarref or arrayref templates. Caching
also looks at the modification times of any files included using
tags, but again, only if the template is opened with
filename parameter.
This is mainly of use in a persistent environment like
Apache/mod_perl. It has absolutely no benefit in a normal CGI
environment since the script is unloaded from memory after every
request. For a cache that does work for normal CGIs see the
'shared_cache' option below.
Note that different new() parameter settings do not cause a cache
refresh, only a change in the modification time of the template will
trigger a cache refresh. For most usages this is fine. My simplistic
testing shows that using cache yields a 90% performance increase under
mod_perl. Cache defaults to 0.
=item *
shared_cache - if set to 1 the module will store its cache in shared
memory using the IPC::SharedCache module (available from CPAN). The
effect of this will be to maintain a single shared copy of each parsed
template for all instances of HTML::Template to use. This can be a
significant reduction in memory usage in a multiple server
environment. As an example, on one of our systems we use 4MB of
template cache and maintain 25 httpd processes - shared_cache results
in saving almost 100MB! Of course, some reduction in speed versus
normal caching is to be expected. Another difference between normal
caching and shared_cache is that shared_cache will work in a CGI
environment - normal caching is only useful in a persistent
environment like Apache/mod_perl.
By default HTML::Template uses the IPC key 'TMPL' as a shared root
segment (0x4c504d54 in hex), but this can be changed by setting the
'ipc_key' new() parameter to another 4-character or integer key.
Other options can be used to affect the shared memory cache correspond
to IPC::SharedCache options - ipc_mode, ipc_segment_size and
ipc_max_size. See L for a description of how these
work - in most cases you shouldn't need to change them from the
defaults.
For more information about the shared memory cache system used by
HTML::Template see L.
=item *
double_cache - if set to 1 the module will use a combination of
shared_cache and normal cache mode for the best possible caching. Of
course, it also uses the most memory of all the cache modes. All the
same ipc_* options that work with shared_cache apply to double_cache
as well. By default double_cache is off.
=item *
blind_cache - if set to 1 the module behaves exactly as with normal
caching but does not check to see if the file has changed on each
request. This option should be used with caution, but could be of use
on high-load servers. My tests show blind_cache performing only 1 to
2 percent faster than cache under mod_perl.
NOTE: Combining this option with shared_cache can result in stale
templates stuck permanently in shared memory!
=item *
file_cache - if set to 1 the module will store its cache in a file
using the Storable module. It uses no additional memory, and my
simplistic testing shows that it yields a 50% performance advantage.
Like shared_cache, it will work in a CGI environment. Default is 0.
If you set this option you must set the "file_cache_dir" option. See
below for details.
NOTE: Storable using flock() to ensure safe access to cache files.
Using file_cache on a system or filesystem (NFS) without flock()
support is dangerous.
=item *
file_cache_dir - sets the directory where the module will store the
cache files if file_cache is enabled. Your script will need write
permissions to this directory. You'll also need to make sure the
sufficient space is available to store the cache files.
=item *
file_cache_dir_mode - sets the file mode for newly created file_cache
directories and subdirectories. Defaults to 0700 for security but
this may be inconvenient if you do not have access to the account
running the webserver.
=item *
double_file_cache - if set to 1 the module will use a combination of
file_cache and normal cache mode for the best possible caching. The
file_cache_* options that work with file_cache apply to double_file_cache
as well. By default double_file_cache is 0.
=item *
associate - this option allows you to inherit the parameter values
from other objects. The only requirement for the other object is that
it have a param() method that works like HTML::Template's param(). A
good candidate would be a CGI.pm query object. Example:
my $query = new CGI;
my $template = HTML::Template->new(filename => 'template.tmpl',
associate => $query);
Now, $template->output() will act as though
$template->param('FormField', $cgi->param('FormField'));
had been specified for each key/value pair that would be provided by
the $cgi->param() method. Parameters you set directly take precedence
over associated parameters.
You can specify multiple objects to associate by passing an anonymous
array to the associate option. They are searched for parameters in
the order they appear:
my $template = HTML::Template->new(filename => 'template.tmpl',
associate => [$query, $other_obj]);
The old associateCGI() call is still supported, but should be
considered obsolete.
NOTE: The parameter names are matched in a case-insensitve manner. If
you have two parameters in a CGI object like 'NAME' and 'Name' one
will be chosen randomly by associate. This behavior can be changed by
the following option.
=item *
case_sensitive - setting this option to true causes HTML::Template to
treat template variable names case-sensitively. The following example
would only set one parameter without the "case_sensitive" option:
my $template = HTML::Template->new(filename => 'template.tmpl',
case_sensitive => 1);
$template->param(
FieldA => 'foo',
fIELDa => 'bar',
);
This option defaults to off.
=item *
loop_context_vars - when this parameter is set to true (it is false by
default) four loop context variables are made available inside a loop:
__FIRST__, __LAST__, __INNER__, __ODD__. They can be used with
, and to control how a loop is
output. Example:
This only outputs on the first pass.
This outputs every other pass, on the odd passes.
This outputs every other pass, on the even passes.
This outputs on passes that are neither first nor last.
This only outputs on the last pass.
One use of this feature is to provide a "separator" similar in effect
to the perl function join(). Example:
and
, .
Would output (in a browser) something like:
Apples, Oranges, Brains, Toes, and Kiwi.
Given an appropriate param() call, of course. NOTE: A loop with only
a single pass will get both __FIRST__ and __LAST__ set to true, but
not __INNER__.
=item *
path - you can set this variable with a list of paths to search for
files specified with the "filename" option to new() and for files
included with the tag. This list is only consulted
when the filename is relative. The HTML_TEMPLATE_ROOT environment
variable is always tried first if it exists. In the case of a
file, the path to the including file is also tried
before path is consulted.
Example:
my $template = HTML::Template->new( filename => 'file.tmpl',
path => [ '/path/to/templates',
'/alternate/path'
]
);
NOTE: the paths in the path list must be expressed as UNIX paths,
separated by the forward-slash character ('/').
=item *
no_includes - set this option to 1 to disallow the tag
in the template file. This can be used to make opening untrusted
templates B less dangerous. Defaults to 0.
=item *
max_includes - set this variable to determine the maximum depth that
includes can reach. Set to 10 by default. Including files to a depth
greater than this value causes an error message to be displayed. Set
to 0 to disable this protection.
=item *
search_path_on_include - if set to a true value the module will search
from the top of the array of paths specified by the path option on
every and use the first matching template found. The
normal behavior is to look only in the current directory for a
template to include. Defaults to 0.
=item *
global_vars - normally variables declared outside a loop are not
available inside a loop. This option makes s like global
variables in Perl - they have unlimited scope. This option also
affects and .
Example:
This is a normal variable: .
Here it is inside the loop:
Normally this wouldn't work as expected, since 's
value outside the loop is not available inside the loop.
=item *
filter - this option allows you to specify a filter for your template
files. A filter is a subroutine that will be called after
HTML::Template reads your template file but before it starts parsing
template tags.
In the most simple usage, you simply assign a code reference to the
filter parameter. This subroutine will recieve a single arguement - a
reference to a string containing the template file text. Here is an
example that accepts templates with tags that look like "!!!ZAP_VAR
FOO!!!" and transforms them into HTML::Template tags:
my $filter = sub {
my $text_ref = shift;
$$text_ref =~ s/!!!ZAP_(.*?)!!!//g;
}
# open zap.tmpl using the above filter
my $template = HTML::Template->new(filename => 'zap.tmpl',
filter => $filter);
More complicated usages are possible. You can request that your
filter receieve the template text as an array of lines rather than as
a single scalar. To do that you need to specify your filter using a
hash-ref. In this form you specify the filter using the "sub" key and
the desired argument format using the "format" key. The available
formats are "scalar" and "array". Using the "array" format will incur
a performance penalty but may be more convenient in some situations.
my $template = HTML::Template->new(filename => 'zap.tmpl',
filter => { sub => $filter,
format => 'array' });
You may also have multiple filters. This allows simple filters to be
combined for more elaborate functionality. To do this you specify an
array of filters. The filters are applied in the order they are
specified.
my $template = HTML::Template->new(filename => 'zap.tmpl',
filter => [
{ sub => \&decompress,
format => 'scalar' },
{ sub => \&remove_spaces,
format => 'array' }
]);
The specified filters will be called for any TMPL_INCLUDEed files just
as they are for the main template file.
=item *
vanguard_compatibility_mode - if set to 1 the module will expect to
see s that look like %NAME% in addition to the standard
syntax. Also sets die_on_bad_params => 0. If you're not at Vanguard
Media trying to use an old format template don't worry about this one.
Defaults to 0.
=item *
debug - if set to 1 the module will write random debugging information
to STDERR. Defaults to 0.
=item *
stack_debug - if set to 1 the module will use Data::Dumper to print
out the contents of the parse_stack to STDERR. Defaults to 0.
=item *
cache_debug - if set to 1 the module will send information on cache
loads, hits and misses to STDERR. Defaults to 0.
=item *
shared_cache_debug - if set to 1 the module will turn on the debug
option in IPC::SharedCache - see L for
details. Defaults to 0.
=item *
memory_debug - if set to 1 the module will send information on cache
memory usage to STDERR. Requires the GTop module. Defaults to 0.
=back 4
=cut
use integer; # no floating point math so far!
use strict; # and no funny business, either.
use Carp; # generate better errors with more context
use File::Spec; # generate paths that work on all platforms
# define accessor constants used to improve readability of array
# accesses into "objects". I used to use 'use constant' but that
# seems to cause occasional irritating warnings in older Perls.
package HTML::Template::LOOP;
sub TEMPLATE_HASH { 0; }
sub PARAM_SET { 1 };
package HTML::Template::COND;
sub VARIABLE { 0 };
sub VARIABLE_TYPE { 1 };
sub VARIABLE_TYPE_VAR { 0 };
sub VARIABLE_TYPE_LOOP { 1 };
sub JUMP_IF_TRUE { 2 };
sub JUMP_ADDRESS { 3 };
sub WHICH { 4 };
sub WHICH_IF { 0 };
sub WHICH_UNLESS { 1 };
# back to the main package scope.
package HTML::Template;
# open a new template and return an object handle
sub new {
my $pkg = shift;
my $self; { my %hash; $self = bless(\%hash, $pkg); }
# the options hash
my $options = {};
$self->{options} = $options;
# set default parameters in options hash
%$options = (
debug => 0,
stack_debug => 0,
timing => 0,
search_path_on_include => 0,
cache => 0,
blind_cache => 0,
file_cache => 0,
file_cache_dir => '',
file_cache_dir_mode => 0700,
cache_debug => 0,
shared_cache_debug => 0,
memory_debug => 0,
die_on_bad_params => 1,
vanguard_compatibility_mode => 0,
associate => [],
path => [],
strict => 1,
loop_context_vars => 0,
max_includes => 10,
shared_cache => 0,
double_cache => 0,
double_file_cache => 0,
ipc_key => 'TMPL',
ipc_mode => 0666,
ipc_segment_size => 65536,
ipc_max_size => 0,
global_vars => 0,
no_includes => 0,
case_sensitive => 0,
filter => [],
);
# load in options supplied to new()
for (my $x = 0; $x <= $#_; $x += 2) {
defined($_[($x + 1)]) or croak("HTML::Template->new() called with odd number of option parameters - should be of the form option => value");
$options->{lc($_[$x])} = $_[($x + 1)];
}
# blind_cache = 1 implies cache = 1
$options->{blind_cache} and $options->{cache} = 1;
# shared_cache = 1 implies cache = 1
$options->{shared_cache} and $options->{cache} = 1;
# file_cache = 1 implies cache = 1
$options->{file_cache} and $options->{cache} = 1;
# double_cache is a combination of shared_cache and cache.
$options->{double_cache} and $options->{cache} = 1;
$options->{double_cache} and $options->{shared_cache} = 1;
# double_file_cache is a combination of file_cache and cache.
$options->{double_file_cache} and $options->{cache} = 1;
$options->{double_file_cache} and $options->{file_cache} = 1;
# vanguard_compatibility_mode implies die_on_bad_params = 0
$options->{vanguard_compatibility_mode} and
$options->{die_on_bad_params} = 0;
# handle the "type", "source" parameter format (does anyone use it?)
if (exists($options->{type})) {
exists($options->{source}) or croak("HTML::Template->new() called with 'type' parameter set, but no 'source'!");
($options->{type} eq 'filename' or $options->{type} eq 'scalarref' or
$options->{type} eq 'arrayref' or $options->{type} eq 'filehandle') or
croak("HTML::Template->new() : type parameter must be set to 'filename', 'arrayref', 'scalarref' or 'filehandle'!");
$options->{$options->{type}} = $options->{source};
delete $options->{type};
delete $options->{source};
}
# associate should be an array of one element if it's not
# already an array.
if (ref($options->{associate}) ne 'ARRAY') {
$options->{associate} = [ $options->{associate} ];
}
# path should be an array if it's not already
if (ref($options->{path}) ne 'ARRAY') {
$options->{path} = [ $options->{path} ];
}
# filter should be an array if it's not already
if (ref($options->{filter}) ne 'ARRAY') {
$options->{filter} = [ $options->{filter} ];
}
# make sure objects in associate area support param()
foreach my $object (@{$options->{associate}}) {
defined($object->can('param')) or
croak("HTML::Template->new called with associate option, containing object of type " . ref($object) . " which lacks a param() method!");
}
# check for syntax errors:
my $source_count = 0;
exists($options->{filename}) and $source_count++;
exists($options->{filehandle}) and $source_count++;
exists($options->{arrayref}) and $source_count++;
exists($options->{scalarref}) and $source_count++;
if ($source_count != 1) {
croak("HTML::Template->new called with multiple (or no) template sources specified! A valid call to new() has exactly one filename => 'file' OR exactly one scalarref => \\\$scalar OR exactly one arrayref => \\\@array OR exactly one filehandle => \*FH");
}
# do some memory debugging - this is best started as early as possible
if ($options->{memory_debug}) {
# memory_debug needs GTop
eval { require GTop; };
croak("Could not load GTop. You must have GTop installed to use HTML::Template in memory_debug mode. The error was: $@")
if ($@);
$self->{gtop} = GTop->new();
$self->{proc_mem} = $self->{gtop}->proc_mem($$);
print STDERR "\n### HTML::Template Memory Debug ### START ", $self->{proc_mem}->size(), "\n";
}
if ($options->{file_cache}) {
# make sure we have a file_cache_dir option
croak("You must specify the file_cache_dir option if you want to use file_cache.")
unless defined $options->{file_cache_dir} and
length $options->{file_cache_dir};
# file_cache needs some extra modules loaded
eval { require Storable; };
croak("Could not load Storable. You must have Storable installed to use HTML::Template in file_cache mode. The error was: $@")
if ($@);
eval { require Digest::MD5; };
croak("Could not load Digest::MD5. You must have Digest::MD5 installed to use HTML::Template in file_cache mode. The error was: $@")
if ($@);
}
if ($options->{shared_cache}) {
# shared_cache needs some extra modules loaded
eval { require IPC::SharedCache; };
croak("Could not load IPC::SharedCache. You must have IPC::SharedCache installed to use HTML::Template in shared_cache mode. The error was: $@")
if ($@);
# initialize the shared cache
my %cache;
tie %cache, 'IPC::SharedCache',
ipc_key => $options->{ipc_key},
load_callback => [\&_load_shared_cache, $self],
validate_callback => [\&_validate_shared_cache, $self],
debug => $options->{shared_cache_debug},
ipc_mode => $options->{ipc_mode},
max_size => $options->{ipc_max_size},
ipc_segment_size => $options->{ipc_segment_size};
$self->{cache} = \%cache;
}
print STDERR "### HTML::Template Memory Debug ### POST CACHE INIT ", $self->{proc_mem}->size(), "\n"
if $options->{memory_debug};
# initialize data structures
$self->_init;
print STDERR "### HTML::Template Memory Debug ### POST _INIT CALL ", $self->{proc_mem}->size(), "\n"
if $options->{memory_debug};
# drop the shared cache - leaving out this step results in the
# template object evading garbage collection since the callbacks in
# the shared cache tie hold references to $self! This was not easy
# to find, by the way.
delete $self->{cache} if $options->{shared_cache};
return $self;
}
# an internally used new that receives its parse_stack and param_map as input
sub _new_from_loop {
my $pkg = shift;
my $self; { my %hash; $self = bless(\%hash, $pkg); }
# the options hash
my $options = {};
$self->{options} = $options;
# set default parameters in options hash - a subset of the options
# valid in a normal new(). Since _new_from_loop never calls _init,
# many options have no relevance.
%$options = (
debug => 0,
stack_debug => 0,
die_on_bad_params => 1,
associate => [],
loop_context_vars => 0,
);
# load in options supplied to new()
for (my $x = 0; $x <= $#_; $x += 2) {
defined($_[($x + 1)]) or croak("HTML::Template->new() called with odd number of option parameters - should be of the form option => value");
$options->{lc($_[$x])} = $_[($x + 1)];
}
$self->{param_map} = $options->{param_map};
$self->{parse_stack} = $options->{parse_stack};
delete($options->{param_map});
delete($options->{parse_stack});
return $self;
}
# a few shortcuts to new(), of possible use...
sub new_file {
my $pkg = shift; return $pkg->new('filename', @_);
}
sub new_filehandle {
my $pkg = shift; return $pkg->new('filehandle', @_);
}
sub new_array_ref {
my $pkg = shift; return $pkg->new('arrayref', @_);
}
sub new_scalar_ref {
my $pkg = shift; return $pkg->new('scalarref', @_);
}
# initializes all the object data structures, either from cache or by
# calling the appropriate routines.
sub _init {
my $self = shift;
my $options = $self->{options};
if ($options->{double_cache}) {
# try the normal cache, return if we have it.
$self->_fetch_from_cache();
return if (defined $self->{param_map} and defined $self->{parse_stack});
# try the shared cache
$self->_fetch_from_shared_cache();
# put it in the local cache if we got it.
$self->_commit_to_cache()
if (defined $self->{param_map} and defined $self->{parse_stack});
} elsif ($options->{double_file_cache}) {
# try the normal cache, return if we have it.
$self->_fetch_from_cache();
return if (defined $self->{param_map} and defined $self->{parse_stack});
# try the file cache
$self->_fetch_from_file_cache();
# put it in the local cache if we got it.
$self->_commit_to_cache()
if (defined $self->{param_map} and defined $self->{parse_stack});
} elsif ($options->{shared_cache}) {
# try the shared cache
$self->_fetch_from_shared_cache();
} elsif ($options->{file_cache}) {
# try the file cache
$self->_fetch_from_file_cache();
} elsif ($options->{cache}) {
# try the normal cache
$self->_fetch_from_cache();
}
# if we got a cache hit, return
return if (defined $self->{param_map} and defined $self->{parse_stack});
# if we're here, then we didn't get a cached copy, so do a full
# init.
$self->_init_template();
$self->_parse();
# now that we have a full init, cache the structures if cacheing is
# on. shared cache is already cool.
if($options->{file_cache}){
$self->_commit_to_file_cache();
}
$self->_commit_to_cache() if (($options->{cache}
and not $options->{shared_cache}
and not $options->{file_cache}) or
($options->{double_cache}) or
($options->{double_file_cache}));
}
# Caching subroutines - they handle getting and validating cache
# records from either the in-memory or shared caches.
# handles the normal in memory cache
use vars qw( %CACHE );
sub _fetch_from_cache {
my $self = shift;
my $options = $self->{options};
# return if there's no cache entry for this filename
return unless exists($options->{filename});
my $filepath = $self->_find_file($options->{filename});
return unless (defined($filepath) and
exists $CACHE{$filepath});
$options->{filepath} = $filepath;
# validate the cache
my $mtime = $self->_mtime($filepath);
if (defined $mtime) {
# return if the mtime doesn't match the cache
if (defined($CACHE{$filepath}{mtime}) and
($mtime != $CACHE{$filepath}{mtime})) {
$options->{cache_debug} and
print STDERR "CACHE MISS : $filepath : $mtime\n";
return;
}
# if the template has includes, check each included file's mtime
# and return if different
if (exists($CACHE{$filepath}{included_mtimes})) {
foreach my $filename (keys %{$CACHE{$filepath}{included_mtimes}}) {
next unless
defined($CACHE{$filepath}{included_mtimes}{$filename});
my $included_mtime = (stat($filename))[9];
if ($included_mtime != $CACHE{$filepath}{included_mtimes}{$filename}) {
$options->{cache_debug} and
print STDERR "### HTML::Template Cache Debug ### CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n";
return;
}
}
}
}
# got a cache hit!
$options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath\n";
$self->{param_map} = $CACHE{$filepath}{param_map};
$self->{parse_stack} = $CACHE{$filepath}{parse_stack};
exists($CACHE{$filepath}{included_mtimes}) and
$self->{included_mtimes} = $CACHE{$filepath}{included_mtimes};
# clear out values from param_map from last run
$self->_normalize_options();
$self->clear_params();
}
sub _commit_to_cache {
my $self = shift;
my $options = $self->{options};
my $filepath = $options->{filepath};
if (not defined $filepath) {
$filepath = $self->_find_file($options->{filename});
confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.")
unless defined($filepath);
$options->{filepath} = $filepath;
}
$options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE LOAD : $filepath\n";
$options->{blind_cache} or
$CACHE{$filepath}{mtime} = $self->_mtime($filepath);
$CACHE{$filepath}{param_map} = $self->{param_map};
$CACHE{$filepath}{parse_stack} = $self->{parse_stack};
exists($self->{included_mtimes}) and
$CACHE{$filepath}{included_mtimes} = $self->{included_mtimes};
}
# generates MD5 from filepath to determine filename for cache file
sub _get_cache_filename {
my ($self, $filepath) = @_;
# hash the filename ...
my $hash = Digest::MD5->md5_hex($filepath);
# ... and build a path out of it. Using the first two charcters
# gives us 255 buckets. This means you can have 255,000 templates
# in the cache before any one directory gets over a few thousand
# files in it. That's probably pretty good for this planet. If not
# then it should be configurable.
if (wantarray) {
return (substr($hash,0,2), substr($hash,2))
} else {
return File::Spec->join($self->{options}{file_cache_dir},
substr($hash,0,2), substr($hash,2));
}
}
# handles the file cache
sub _fetch_from_file_cache {
my $self = shift;
my $options = $self->{options};
return unless exists($options->{filename});
# return if there's no cache entry for this filename
my $filepath = $self->_find_file($options->{filename});
return unless defined $filepath;
my $cache_filename = $self->_get_cache_filename($filepath);
return unless -e $cache_filename;
eval {
$self->{record} = Storable::lock_retrieve($cache_filename);
};
croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $@")
if $@;
croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $!")
unless defined $self->{record};
($self->{mtime},
$self->{included_mtimes},
$self->{param_map},
$self->{parse_stack}) = @{$self->{record}};
$options->{filepath} = $filepath;
# validate the cache
my $mtime = $self->_mtime($filepath);
if (defined $mtime) {
# return if the mtime doesn't match the cache
if (defined($self->{mtime}) and
($mtime != $self->{mtime})) {
$options->{cache_debug} and
print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : $mtime\n";
($self->{mtime},
$self->{included_mtimes},
$self->{param_map},
$self->{parse_stack}) = (undef, undef, undef, undef);
return;
}
# if the template has includes, check each included file's mtime
# and return if different
if (exists($self->{included_mtimes})) {
foreach my $filename (keys %{$self->{included_mtimes}}) {
next unless
defined($self->{included_mtimes}{$filename});
my $included_mtime = (stat($filename))[9];
if ($included_mtime != $self->{included_mtimes}{$filename}) {
$options->{cache_debug} and
print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n";
($self->{mtime},
$self->{included_mtimes},
$self->{param_map},
$self->{parse_stack}) = (undef, undef, undef, undef);
return;
}
}
}
}
# got a cache hit!
$options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE HIT : $filepath\n";
# clear out values from param_map from last run
$self->_normalize_options();
$self->clear_params();
}
sub _commit_to_file_cache {
my $self = shift;
my $options = $self->{options};
my $filepath = $options->{filepath};
if (not defined $filepath) {
$filepath = $self->_find_file($options->{filename});
confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.")
unless defined($filepath);
$options->{filepath} = $filepath;
}
my ($cache_dir, $cache_file) = $self->_get_cache_filename($filepath);
$cache_dir = File::Spec->join($options->{file_cache_dir}, $cache_dir);
if (not -d $cache_dir) {
if (not -d $options->{file_cache_dir}) {
mkdir($options->{file_cache_dir},$options->{file_cache_dir_mode})
or croak("HTML::Template->new() : can't mkdir $options->{file_cache_dir} (file_cache => 1): $!");
}
mkdir($cache_dir,$options->{file_cache_dir_mode})
or croak("HTML::Template->new() : can't mkdir $cache_dir (file_cache => 1): $!");
}
$options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE LOAD : $options->{filepath}\n";
my $result;
eval {
$result = Storable::lock_store([ $self->{mtime},
$self->{included_mtimes},
$self->{param_map},
$self->{parse_stack} ],
scalar File::Spec->join($cache_dir, $cache_file)
);
};
croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $@")
if $@;
croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $!")
unless defined $result;
}
# Shared cache routines.
sub _fetch_from_shared_cache {
my $self = shift;
my $options = $self->{options};
my $filepath = $self->_find_file($options->{filename});
return unless defined $filepath;
# fetch from the shared cache.
$self->{record} = $self->{cache}{$filepath};
($self->{mtime},
$self->{included_mtimes},
$self->{param_map},
$self->{parse_stack}) = @{$self->{record}}
if defined($self->{record});
$options->{cache_debug} and defined($self->{record}) and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath\n";
# clear out values from param_map from last run
$self->_normalize_options(), $self->clear_params()
if (defined($self->{record}));
delete($self->{record});
return $self;
}
sub _validate_shared_cache {
my ($self, $filename, $record) = @_;
my $options = $self->{options};
$options->{shared_cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE VALIDATE : $filename\n";
return 1 if $options->{blind_cache};
my ($c_mtime, $included_mtimes, $param_map, $parse_stack) = @$record;
# if the modification time has changed return false
my $mtime = $self->_mtime($filename);
if (defined $mtime and defined $c_mtime
and $mtime != $c_mtime) {
$options->{cache_debug} and
print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : $mtime\n";
return 0;
}
# if the template has includes, check each included file's mtime
# and return false if different
if (defined $mtime and defined $included_mtimes) {
foreach my $fname (keys %$included_mtimes) {
next unless defined($included_mtimes->{$fname});
if ($included_mtimes->{$fname} != (stat($fname))[9]) {
$options->{cache_debug} and
print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : INCLUDE $fname\n";
return 0;
}
}
}
# all done - return true
return 1;
}
sub _load_shared_cache {
my ($self, $filename) = @_;
my $options = $self->{options};
my $cache = $self->{cache};
$self->_init_template();
$self->_parse();
$options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE LOAD : $options->{filepath}\n";
print STDERR "### HTML::Template Memory Debug ### END CACHE LOAD ", $self->{proc_mem}->size(), "\n"
if $options->{memory_debug};
return [ $self->{mtime},
$self->{included_mtimes},
$self->{param_map},
$self->{parse_stack} ];
}
# utility function - given a filename performs documented search and
# returns a full path of undef if the file cannot be found.
sub _find_file {
my ($self, $filename, $extra_path) = @_;
my $options = $self->{options};
my $filepath;
# first check for a full path
return File::Spec->canonpath($filename)
if (File::Spec->file_name_is_absolute($filename) and (-e $filename));
# try the extra_path if one was specified
if (defined($extra_path)) {
$extra_path->[$#{$extra_path}] = $filename;
$filepath = File::Spec->canonpath(File::Spec->catfile(@$extra_path));
return File::Spec->canonpath($filepath) if -e $filepath;
}
# try pre-prending HTML_Template_Root
if (exists($ENV{HTML_TEMPLATE_ROOT})) {
$filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $filename);
return File::Spec->canonpath($filepath) if -e $filepath;
}
# try "path" option list..
foreach my $path (@{$options->{path}}) {
$filepath = File::Spec->canonpath(File::Spec->catfile($path, $filename));
return File::Spec->canonpath($filepath) if -e $filepath;
}
# try even a relative path from the current directory...
return File::Spec->canonpath($filename) if -e $filename;
return undef;
}
# utility function - computes the mtime for $filename
sub _mtime {
my ($self, $filepath) = @_;
my $options = $self->{options};
return(undef) if ($options->{blind_cache});
# make sure it still exists in the filesystem
(-r $filepath) or Carp::confess("HTML::Template : template file $filepath does not exist or is unreadable.");
# get the modification time
return (stat(_))[9];
}
# utility function - enforces new() options across LOOPs that have
# come from a cache. Otherwise they would have stale options hashes.
sub _normalize_options {
my $self = shift;
my $options = $self->{options};
my @pstacks = ($self->{parse_stack});
while(@pstacks) {
my $pstack = pop(@pstacks);
foreach my $item (@$pstack) {
next unless (ref($item) eq 'HTML::Template::LOOP');
foreach my $template (values %{$item->[HTML::Template::LOOP::TEMPLATE_HASH]}) {
# must be the same list as the call to _new_from_loop...
$template->{options}{debug} = $options->{debug};
$template->{options}{stack_debug} = $options->{stack_debug};
$template->{options}{die_on_bad_params} = $options->{die_on_bad_params};
$template->{options}{case_sensitive} = $options->{case_sensitive};
push(@pstacks, $template->{parse_stack});
}
}
}
}
# initialize the template buffer
sub _init_template {
my $self = shift;
my $options = $self->{options};
print STDERR "### HTML::Template Memory Debug ### START INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n"
if $options->{memory_debug};
if (exists($options->{filename})) {
my $filepath = $options->{filepath};
if (not defined $filepath) {
$filepath = $self->_find_file($options->{filename});
confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.")
unless defined($filepath);
# we'll need this for future reference - to call stat() for example.
$options->{filepath} = $filepath;
}
confess("HTML::Template->new() : Cannot open included file $options->{filename} : $!")
unless defined(open(TEMPLATE, $filepath));
$self->{mtime} = $self->_mtime($filepath);
# read into scalar, note the mtime for the record
$self->{template} = "";
while (read(TEMPLATE, $self->{template}, 10240, length($self->{template}))) {}
close(TEMPLATE);
} elsif (exists($options->{scalarref})) {
# copy in the template text
$self->{template} = ${$options->{scalarref}};
delete($options->{scalarref});
} elsif (exists($options->{arrayref})) {
# if we have an array ref, join and store the template text
$self->{template} = join("", @{$options->{arrayref}});
delete($options->{arrayref});
} elsif (exists($options->{filehandle})) {
# just read everything in in one go
local $/ = undef;
$self->{template} = readline($options->{filehandle});
delete($options->{filehandle});
} else {
confess("HTML::Template : Need to call new with filename, filehandle, scalarref or arrayref parameter specified.");
}
print STDERR "### HTML::Template Memory Debug ### END INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n"
if $options->{memory_debug};
# handle filters if necessary
$self->_call_filters(\$self->{template}) if @{$options->{filter}};
return $self;
}
# handle calling user defined filters
sub _call_filters {
my $self = shift;
my $template_ref = shift;
my $options = $self->{options};
my ($format, $sub);
foreach my $filter (@{$options->{filter}}) {
croak("HTML::Template->new() : bad value set for filter parameter - must be a code ref or a hash ref.")
unless ref $filter;
# translate into CODE->HASH
$filter = { 'format' => 'scalar', 'sub' => $filter }
if (ref $filter eq 'CODE');
if (ref $filter eq 'HASH') {
$format = $filter->{'format'};
$sub = $filter->{'sub'};
# check types and values
croak("HTML::Template->new() : bad value set for filter parameter - hash must contain \"format\" key and \"sub\" key.")
unless defined $format and defined $sub;
croak("HTML::Template->new() : bad value set for filter parameter - \"format\" must be either 'array' or 'scalar'")
unless $format eq 'array' or $format eq 'scalar';
croak("HTML::Template->new() : bad value set for filter parameter - \"sub\" must be a code ref")
unless ref $sub and ref $sub eq 'CODE';
# catch errors
eval {
if ($format eq 'scalar') {
# call
$sub->($template_ref);
} else {
# modulate
my @array = map { $_."\n" } split("\n", $$template_ref);
# call
$sub->(\@array);
# demodulate
$$template_ref = join("", @array);
}
};
croak("HTML::Template->new() : fatal error occured during filter call: $@") if $@;
} else {
croak("HTML::Template->new() : bad value set for filter parameter - must be code ref or hash ref");
}
}
# all done
return $template_ref;
}
# _parse sifts through a template building up the param_map and
# parse_stack structures.
#
# The end result is a Template object that is fully ready for
# output().
sub _parse {
my $self = shift;
my $options = $self->{options};
$options->{debug} and print STDERR "### HTML::Template Debug ### In _parse:\n";
# setup the stacks and maps - they're accessed by typeglobs that
# reference the top of the stack. They are masked so that a loop
# can transparently have its own versions.
use vars qw(@pstack %pmap @ifstack @ucstack %top_pmap);
local (*pstack, *ifstack, *pmap, *ucstack, *top_pmap);
# the pstack is the array of scalar refs (plain text from the
# template file), VARs, LOOPs, IFs and ELSEs that output() works on
# to produce output. Looking at output() should make it clear what
# _parse is trying to accomplish.
my @pstacks = ([]);
*pstack = $pstacks[0];
$self->{parse_stack} = $pstacks[0];
# the pmap binds names to VARs, LOOPs and IFs. It allows param() to
# access the right variable. NOTE: output() does not look at the
# pmap at all!
my @pmaps = ({});
*pmap = $pmaps[0];
*top_pmap = $pmaps[0];
$self->{param_map} = $pmaps[0];
# the ifstack is a temporary stack containing pending ifs and elses
# waiting for a /if.
my @ifstacks = ([]);
*ifstack = $ifstacks[0];
# the ucstack is a temporary stack containing conditions that need
# to be bound to param_map entries when their block is finished.
# This happens when a conditional is encountered before any other
# reference to its NAME. Since a conditional can reference VARs and
# LOOPs it isn't possible to make the link right away.
my @ucstacks = ([]);
*ucstack = $ucstacks[0];
# the loopstack is another temp stack for closing loops. unlike
# those above it doesn't get scoped inside loops, therefore it
# doesn't need the typeglob magic.
my @loopstack = ();
# the fstack is a stack of filenames and counters that keeps track
# of which file we're in and where we are in it. This allows
# accurate error messages even inside included files!
# fcounter, fmax and fname are aliases for the current file's info
use vars qw($fcounter $fname $fmax);
local (*fcounter, *fname, *fmax);
my @fstack = ([$options->{filename} || "main template",
1,
scalar @{[$self->{template} =~ m/(\n)/g]} + 1
]);
(*fname, *fcounter, *fmax) = \ ( @{$fstack[0]} );
my $NOOP = HTML::Template::NOOP->new();
my $ESCAPE = HTML::Template::ESCAPE->new();
my $URLESCAPE = HTML::Template::URLESCAPE->new();
# all the tags that need NAMEs:
my %need_names = map { $_ => 1 }
qw(TMPL_VAR TMPL_LOOP TMPL_IF TMPL_UNLESS TMPL_INCLUDE);
# variables used below that don't need to be my'd in the loop
my ($name, $which, $escape);
# handle the old vanguard format
$options->{vanguard_compatibility_mode} and
$self->{template} =~ s/%([-\w\/\.+]+)%//g;
# now split up template on '<', leaving them in
my @chunks = split(m/(?=<)/, $self->{template});
# all done with template
delete $self->{template};
# loop through chunks, filling up pstack
my $last_chunk = $#chunks;
CHUNK: for (my $chunk_number = 0;
$chunk_number <= $last_chunk;
$chunk_number++) {
next unless defined $chunks[$chunk_number];
my $chunk = $chunks[$chunk_number];
# a general regex to match any and all TMPL_* tags
if ($chunk =~ /^<
(?:!--\s*)?
(
\/?[Tt][Mm][Pp][Ll]_
(?:
(?:[Vv][Aa][Rr])
|
(?:[Ll][Oo][Oo][Pp])
|
(?:[Ii][Ff])
|
(?:[Ee][Ll][Ss][Ee])
|
(?:[Uu][Nn][Ll][Ee][Ss][Ss])
|
(?:[Ii][Nn][Cc][Ll][Uu][Dd][Ee])
)
) # $1 => $which - start of the tag
\s*
# ESCAPE attribute
(?:
[Ee][Ss][Cc][Aa][Pp][Ee]
\s*=\s*
(?:
( 0 | (?:"0") | (?:'0') ) # $2 => ESCAPE off
|
( 1 | (?:"1") | (?:'1') |
(?:[Hh][Tt][Mm][Ll]) |
(?:"[Hh][Tt][Mm][Ll]") |
(?:'[Hh][Tt][Mm][Ll]') |
(?:[Uu][Rr][Ll]) |
(?:"[Uu][Rr][Ll]") |
(?:'[Uu][Rr][Ll]') |
) # $3 => ESCAPE on
)
)* # allow multiple ESCAPEs
\s*
# NAME attribute
(?:
(?:
[Nn][Aa][Mm][Ee]
\s*=\s*
)?
(?:
"([^">]*)" # $4 => double-quoted NAME value "
|
'([^'>]*)' # $5 => single-quoted NAME value
|
([^\s=>]*) # $6 => unquoted NAME value
)
)?
\s*
# ESCAPE attribute
(?:
[Ee][Ss][Cc][Aa][Pp][Ee]
\s*=\s*
(?:
( 0 | (?:"0") | (?:'0') ) # $7 => ESCAPE off
|
( 1 | (?:"1") | (?:'1') |
(?:[Hh][Tt][Mm][Ll]) |
(?:"[Hh][Tt][Mm][Ll]") |
(?:'[Hh][Tt][Mm][Ll]') |
(?:[Uu][Rr][Ll]) |
(?:"[Uu][Rr][Ll]") |
(?:'[Uu][Rr][Ll]') |
) # $8 => ESCAPE on
)
)* # allow multiple ESCAPEs
\s*
(?:--)?>
(.*) # $9 => $post - text that comes after the tag
$/sx) {
$which = uc($1); # which tag is it
$escape = $3 || $8;
$escape = 0 if $2 || $7; # ESCAPE=0
$escape = 0 unless defined($escape);
# what name for the tag? undef for a /tag at most, one of the
# following three will be defined
undef $name;
$name = $4 if defined($4);
$name = $5 if defined($5);
$name = $6 if defined($6);
# allow mixed case in filenames, otherwise flatten
$name = lc($name) unless ($which eq 'TMPL_INCLUDE' or $options->{case_sensitive});
my $post = $9; # what comes after on the line
# die if we need a name and didn't get one
die "HTML::Template->new() : No NAME given to a $which tag at $fname : line $fcounter." if (!defined($name) and $need_names{$which});
# die if we got an escape but can't use one
die "HTML::Template->new() : ESCAPE option invalid in a $which tag at $fname : line $fcounter." if ( $escape and ($which ne 'TMPL_VAR'));
# take actions depending on which tag found
if ($which eq 'TMPL_VAR') {
$options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : parsed VAR $name\n";
# if we already have this var, then simply link to the existing
# HTML::Template::VAR, else create a new one.
my $var;
if (exists $pmap{$name}) {
$var = $pmap{$name};
(ref($var) eq 'HTML::Template::VAR') or
die "HTML::Template->new() : Already used param name $name as a TMPL_LOOP, found in a TMPL_VAR at $fname : line $fcounter.";
} else {
$var = HTML::Template::VAR->new();
$pmap{$name} = $var;
$top_pmap{$name} = HTML::Template::VAR->new()
if $options->{global_vars} and not exists $top_pmap{$name};
}
# if ESCAPE was set, push an ESCAPE op on the stack before
# the variable. output will handle the actual work.
if ($escape) {
if ($escape =~ /^"?[Uu][Rr][Ll]"?$/) {
push(@pstack, $URLESCAPE);
} else {
push(@pstack, $ESCAPE);
}
}
push(@pstack, $var);
} elsif ($which eq 'TMPL_LOOP') {
# we've got a loop start
$options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP $name start\n";
# if we already have this loop, then simply link to the existing
# HTML::Template::LOOP, else create a new one.
my $loop;
if (exists $pmap{$name}) {
$loop = $pmap{$name};
(ref($loop) eq 'HTML::Template::LOOP') or
die "HTML::Template->new() : Already used param name $name as a TMPL_VAR, TMPL_IF or TMPL_UNLESS, found in a TMP_LOOP at $fname : line $fcounter!";
} else {
# store the results in a LOOP object - actually just a
# thin wrapper around another HTML::Template object.
$loop = HTML::Template::LOOP->new();
$pmap{$name} = $loop;
}
# get it on the loopstack, pstack of the enclosing block
push(@pstack, $loop);
push(@loopstack, [$loop, $#pstack]);
# magic time - push on a fresh pmap and pstack, adjust the typeglobs.
# this gives the loop a separate namespace (i.e. pmap and pstack).
push(@pstacks, []);
*pstack = $pstacks[$#pstacks];
push(@pmaps, {});
*pmap = $pmaps[$#pmaps];
push(@ifstacks, []);
*ifstack = $ifstacks[$#ifstacks];
push(@ucstacks, []);
*ucstack = $ucstacks[$#ucstacks];
# auto-vivify __FIRST__, __LAST__ and __INNER__ if
# loop_context_vars is set. Otherwise, with
# die_on_bad_params set output() will might cause errors
# when it tries to set them.
if ($options->{loop_context_vars}) {
$pmap{__first__} = HTML::Template::VAR->new();
$pmap{__inner__} = HTML::Template::VAR->new();
$pmap{__last__} = HTML::Template::VAR->new();
$pmap{__odd__} = HTML::Template::VAR->new();
}
} elsif ($which eq '/TMPL_LOOP') {
$options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP end\n";
my $loopdata = pop(@loopstack);
die "HTML::Template->new() : found with no matching at $fname : line $fcounter!" unless defined $loopdata;
my ($loop, $starts_at) = @$loopdata;
# resolve pending conditionals
foreach my $uc (@ucstack) {
my $var = $uc->[HTML::Template::COND::VARIABLE];
if (exists($pmap{$var})) {
$uc->[HTML::Template::COND::VARIABLE] = $pmap{$var};
} else {
$pmap{$var} = HTML::Template::VAR->new();
$top_pmap{$var} = HTML::Template::VAR->new()
if $options->{global_vars} and not exists $top_pmap{$var};
$uc->[HTML::Template::COND::VARIABLE] = $pmap{$var};
}
if (ref($pmap{$var}) eq 'HTML::Template::VAR') {
$uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR;
} else {
$uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP;
}
}
# get pmap and pstack for the loop, adjust the typeglobs to
# the enclosing block.
my $param_map = pop(@pmaps);
*pmap = $pmaps[$#pmaps];
my $parse_stack = pop(@pstacks);
*pstack = $pstacks[$#pstacks];
scalar(@ifstack) and die "HTML::Template->new() : Dangling or in loop ending at $fname : line $fcounter.";
pop(@ifstacks);
*ifstack = $ifstacks[$#ifstacks];
pop(@ucstacks);
*ucstack = $ucstacks[$#ucstacks];
# instantiate the sub-Template, feeding it parse_stack and
# param_map. This means that only the enclosing template
# does _parse() - sub-templates get their parse_stack and
# param_map fed to them already filled in.
$loop->[HTML::Template::LOOP::TEMPLATE_HASH]{$starts_at}
= HTML::Template->_new_from_loop(
parse_stack => $parse_stack,
param_map => $param_map,
debug => $options->{debug},
die_on_bad_params => $options->{die_on_bad_params},
loop_context_vars => $options->{loop_context_vars},
case_sensitive => $options->{case_sensitive},
);
} elsif ($which eq 'TMPL_IF' or $which eq 'TMPL_UNLESS' ) {
$options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : $which $name start\n";
# if we already have this var, then simply link to the existing
# HTML::Template::VAR/LOOP, else defer the mapping
my $var;
if (exists $pmap{$name}) {
$var = $pmap{$name};
} else {
$var = $name;
}
# connect the var to a conditional
my $cond = HTML::Template::COND->new($var);
if ($which eq 'TMPL_IF') {
$cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_IF;
$cond->[HTML::Template::COND::JUMP_IF_TRUE] = 0;
} else {
$cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_UNLESS;
$cond->[HTML::Template::COND::JUMP_IF_TRUE] = 1;
}
# push unconnected conditionals onto the ucstack for
# resolution later. Otherwise, save type information now.
if ($var eq $name) {
push(@ucstack, $cond);
} else {
if (ref($var) eq 'HTML::Template::VAR') {
$cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR;
} else {
$cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP;
}
}
# push what we've got onto the stacks
push(@pstack, $cond);
push(@ifstack, $cond);
} elsif ($which eq '/TMPL_IF' or $which eq '/TMPL_UNLESS') {
$options->{debug} and print STDERR "### HTML::Template Debug ###$fname : line $fcounter : $which end\n";
my $cond = pop(@ifstack);
die "HTML::Template->new() : found with no matching at $fname : line $fcounter." unless defined $cond;
if ($which eq '/TMPL_IF') {
die "HTML::Template->new() : found incorrectly terminating a (use ) at $fname : line $fcounter.\n"
if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_UNLESS);
} else {
die "HTML::Template->new() : found incorrectly terminating a (use ) at $fname : line $fcounter.\n"
if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_IF);
}
# connect the matching to this "address" - place a NOOP to
# hold the spot. This allows output() to treat an IF in the
# assembler-esque "Conditional Jump" mode.
push(@pstack, $NOOP);
$cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack;
} elsif ($which eq 'TMPL_ELSE') {
$options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : ELSE\n";
my $cond = pop(@ifstack);
die "HTML::Template->new() : found with no matching or at $fname : line $fcounter." unless defined $cond;
my $else = HTML::Template::COND->new($cond->[HTML::Template::COND::VARIABLE]);
$else->[HTML::Template::COND::WHICH] = $cond->[HTML::Template::COND::WHICH];
$else->[HTML::Template::COND::JUMP_IF_TRUE] = not $cond->[HTML::Template::COND::JUMP_IF_TRUE];
# need end-block resolution?
if (defined($cond->[HTML::Template::COND::VARIABLE_TYPE])) {
$else->[HTML::Template::COND::VARIABLE_TYPE] = $cond->[HTML::Template::COND::VARIABLE_TYPE];
} else {
push(@ucstack, $else);
}
push(@pstack, $else);
push(@ifstack, $else);
# connect the matching to this "address" - thus the if,
# failing jumps to the ELSE address. The else then gets
# elaborated, and of course succeeds. On the other hand, if
# the IF fails and falls though, output will reach the else
# and jump to the /if address.
$cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack;
} elsif ($which eq 'TMPL_INCLUDE') {
# handle TMPL_INCLUDEs
$options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : INCLUDE $name \n";
# no includes here, bub
$options->{no_includes} and croak("HTML::Template : Illegal attempt to use TMPL_INCLUDE in template file : (no_includes => 1)");
my $filename = $name;
# look for the included file...
my @path = split('/', $options->{filepath});
my $filepath;
if ($options->{search_path_on_include} or not @path) {
$filepath = $self->_find_file($filename);
} else {
$filepath = $self->_find_file($filename, \@path);
}
die "HTML::Template->new() : Cannot open included file $filename : file not found."
unless defined($filepath);
die "HTML::Template->new() : Cannot open included file $filename : $!"
unless defined(open(TEMPLATE, $filepath));
# read into the array
my $included_template = "";
while(read(TEMPLATE, $included_template, 10240, length($included_template))) {}
close(TEMPLATE);
# call filters if necessary
$self->_call_filters(\$included_template) if @{$options->{filter}};
if ($included_template) { # not empty
# handle the old vanguard format - this needs to happen here
# since we're not about to do a next CHUNKS.
$options->{vanguard_compatibility_mode} and
$included_template =~ s/%([-\w\/\.+]+)%//g;
# collect mtimes for included files
if ($options->{cache} and !$options->{blind_cache}) {
$self->{included_mtimes}{$filepath} = (stat($filepath))[9];
}
# adjust the fstack to point to the included file info
push(@fstack, [$filepath, 1,
scalar @{[$included_template =~ m/(\n)/g]} + 1]);
(*fname, *fcounter, *fmax) = \ ( @{$fstack[$#fstack]} );
# make sure we aren't infinitely recursing
die "HTML::Template->new() : likely recursive includes - parsed $options->{max_includes} files deep and giving up (set max_includes higher to allow deeper recursion)." if ($options->{max_includes} and (scalar(@fstack) > $options->{max_includes}));
# stick the remains of this chunk onto the bottom of the
# included text.
$included_template .= $post;
$post = undef;
# move the new chunks into place.
splice(@chunks, $chunk_number, 1,
split(m/(?=<)/, $included_template));
# recalculate stopping point
$last_chunk = $#chunks;
# start in on the first line of the included text - nothing
# else to do on this line.
$chunk = $chunks[$chunk_number];
redo CHUNK;
}
} else {
# zuh!?
die "HTML::Template->new() : Unknown or unmatched TMPL construct at $fname : line $fcounter.";
}
# push the rest after the tag
if (defined($post)) {
if (ref($pstack[$#pstack]) eq 'SCALAR') {
${$pstack[$#pstack]} .= $post;
} else {
push(@pstack, \$post);
}
}
} else { # just your ordinary markup
# make sure we didn't reject something TMPL_* but badly formed
if ($options->{strict}) {
die "HTML::Template->new() : Syntax error in tag at $fname : $fcounter." if ($chunk =~ /<(?:!--\s*)?\/?[Tt][Mm][Pp][Ll]_/);
}
# push the rest and get next chunk
if (defined($chunk)) {
if (ref($pstack[$#pstack]) eq 'SCALAR') {
${$pstack[$#pstack]} .= $chunk;
} else {
push(@pstack, \$chunk);
}
}
}
# count newlines in chunk and advance line count
$fcounter += scalar(@{[$chunk =~ m/(\n)/g]});
# if we just crossed the end of an included file
# pop off the record and re-alias to the enclosing file's info
pop(@fstack), (*fname, *fcounter, *fmax) = \ ( @{$fstack[$#fstack]} )
if ($fcounter > $fmax);
} # next CHUNK
# make sure we don't have dangling IF or LOOP blocks
scalar(@ifstack) and die "HTML::Template->new() : At least one or not terminated at end of file!";
scalar(@loopstack) and die "HTML::Template->new() : At least one not terminated at end of file!";
# resolve pending conditionals
foreach my $uc (@ucstack) {
my $var = $uc->[HTML::Template::COND::VARIABLE];
if (exists($pmap{$var})) {
$uc->[HTML::Template::COND::VARIABLE] = $pmap{$var};
} else {
$pmap{$var} = HTML::Template::VAR->new();
$top_pmap{$var} = HTML::Template::VAR->new()
if $options->{global_vars} and not exists $top_pmap{$var};
$uc->[HTML::Template::COND::VARIABLE] = $pmap{$var};
}
if (ref($pmap{$var}) eq 'HTML::Template::VAR') {
$uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR;
} else {
$uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP;
}
}
# want a stack dump?
if ($options->{stack_debug}) {
require 'Data/Dumper.pm';
print STDERR "### HTML::Template _param Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n";
}
# get rid of filters - they cause runtime errors if Storable tries
# to store them. This can happen under global_vars.
delete $options->{filter};
}
# a recursive sub that associates each loop with the loops above
# (treating the top-level as a loop)
sub _globalize_vars {
my $self = shift;
# associate with the loop (and top-level templates) above in the tree.
push(@{$self->{options}{associate}}, @_);
# recurse down into the template tree, adding ourself to the end of
# list.
push(@_, $self);
map { $_->_globalize_vars(@_) }
map {values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]}}
grep { ref($_) eq 'HTML::Template::LOOP'} @{$self->{parse_stack}};
}
# method used to recursively un-hook associate
sub _unglobalize_vars {
my $self = shift;
# disassociate
$self->{options}{associate} = undef;
# recurse down into the template tree disassociating
map { $_->_unglobalize_vars() }
map {values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]}}
grep { ref($_) eq 'HTML::Template::LOOP'} @{$self->{parse_stack}};
}
=head2 param
param() can be called in a number of ways
1) To return a list of parameters in the template :
my @parameter_names = $self->param();
2) To return the value set to a param :
my $value = $self->param('PARAM');
3) To set the value of a parameter :
# For simple TMPL_VARs:
$self->param(PARAM => 'value');
# with a subroutine reference that gets called to get the value
# of the scalar. The sub will recieve the template object as a
# parameter.
$self->param(PARAM => sub { return 'value' });
# And TMPL_LOOPs:
$self->param(LOOP_PARAM =>
[
{ PARAM => VALUE_FOR_FIRST_PASS, ... },
{ PARAM => VALUE_FOR_SECOND_PASS, ... }
...
]
);
4) To set the value of a a number of parameters :
# For simple TMPL_VARs:
$self->param(PARAM => 'value',
PARAM2 => 'value'
);
# And with some TMPL_LOOPs:
$self->param(PARAM => 'value',
PARAM2 => 'value',
LOOP_PARAM =>
[
{ PARAM => VALUE_FOR_FIRST_PASS, ... },
{ PARAM => VALUE_FOR_SECOND_PASS, ... }
...
],
ANOTHER_LOOP_PARAM =>
[
{ PARAM => VALUE_FOR_FIRST_PASS, ... },
{ PARAM => VALUE_FOR_SECOND_PASS, ... }
...
]
);
5) To set the value of a a number of parameters using a hash-ref :
$self->param(
{
PARAM => 'value',
PARAM2 => 'value',
LOOP_PARAM =>
[
{ PARAM => VALUE_FOR_FIRST_PASS, ... },
{ PARAM => VALUE_FOR_SECOND_PASS, ... }
...
],
ANOTHER_LOOP_PARAM =>
[
{ PARAM => VALUE_FOR_FIRST_PASS, ... },
{ PARAM => VALUE_FOR_SECOND_PASS, ... }
...
]
}
);
=cut
sub param {
my $self = shift;
my $options = $self->{options};
my $param_map = $self->{param_map};
# the no-parameter case - return list of parameters in the template.
return keys(%$param_map) unless scalar(@_);
my $first = shift;
my $type = ref $first;
# the one-parameter case - could be a parameter value request or a
# hash-ref.
if (!scalar(@_) and !length($type)) {
my $param = $options->{case_sensitive} ? $first : lc $first;
# check for parameter existence
$options->{die_on_bad_params} and !exists($param_map->{$param}) and
croak("HTML::Template : Attempt to get nonexistent parameter '$param' - this parameter name doesn't match any declarations in the template file : (die_on_bad_params set => 1)");
return undef unless (exists($param_map->{$param}) and
defined($param_map->{$param}));
return ${$param_map->{$param}} if
(ref($param_map->{$param}) eq 'HTML::Template::VAR');
return $param_map->{$param}[HTML::Template::LOOP::PARAM_SET];
}
if (!scalar(@_)) {
croak("HTML::Template->param() : Single reference arg to param() must be a hash-ref! You gave me a $type.")
unless $type eq 'HASH' or
(ref($first) and UNIVERSAL::isa($first, 'HASH'));
push(@_, %$first);
} else {
unshift(@_, $first);
}
croak("HTML::Template->param() : You gave me an odd number of parameters to param()!")
unless ((@_ % 2) == 0);
# strangely, changing this to a "while(@_) { shift, shift }" type
# loop causes perl 5.004_04 to die with some nonsense about a
# read-only value.
for (my $x = 0; $x <= $#_; $x += 2) {
my $param = $options->{case_sensitive} ? $_[$x] : lc $_[$x];
my $value = $_[($x + 1)];
# check that this param exists in the template
$options->{die_on_bad_params} and !exists($param_map->{$param}) and
croak("HTML::Template : Attempt to set nonexistent parameter '$param' - this parameter name doesn't match any declarations in the template file : (die_on_bad_params => 1)");
# if we're not going to die from bad param names, we need to ignore
# them...
next unless (exists($param_map->{$param}));
# figure out what we've got, taking special care to allow for
# objects that are compatible underneath.
my $value_type = ref($value);
if (defined($value_type) and length($value_type) and ($value_type eq 'ARRAY' or ((ref($value) !~ /^(CODE)|(HASH)|(SCALAR)$/) and $value->isa('ARRAY')))) {
(ref($param_map->{$param}) eq 'HTML::Template::LOOP') or
croak("HTML::Template::param() : attempt to set parameter '$param' with an array ref - parameter is not a TMPL_LOOP!");
$param_map->{$param}[HTML::Template::LOOP::PARAM_SET] = [@{$value}];
} else {
(ref($param_map->{$param}) eq 'HTML::Template::VAR') or
croak("HTML::Template::param() : attempt to set parameter '$param' with a scalar - parameter is not a TMPL_VAR!");
${$param_map->{$param}} = $value;
}
}
}
=pod
=head2 clear_params()
Sets all the parameters to undef. Useful internally, if nowhere else!
=cut
sub clear_params {
my $self = shift;
my $type;
foreach my $name (keys %{$self->{param_map}}) {
$type = ref($self->{param_map}{$name});
undef(${$self->{param_map}{$name}})
if ($type eq 'HTML::Template::VAR');
undef($self->{param_map}{$name}[HTML::Template::LOOP::PARAM_SET])
if ($type eq 'HTML::Template::LOOP');
}
}
# obsolete implementation of associate
sub associateCGI {
my $self = shift;
my $cgi = shift;
(ref($cgi) eq 'CGI') or
croak("Warning! non-CGI object was passed to HTML::Template::associateCGI()!\n");
push(@{$self->{options}{associate}}, $cgi);
return 1;
}
=head2 output()
output() returns the final result of the template. In most situations
you'll want to print this, like:
print $template->output();
When output is called each occurrence of is
replaced with the value assigned to "name" via param(). If a named
parameter is unset it is simply replaced with ''. are
evaluated once per parameter set, accumlating output on each pass.
Calling output() is guaranteed not to change the state of the
Template object, in case you were wondering. This property is mostly
important for the internal implementation of loops.
You may optionally supply a filehandle to print to automatically as
the template is generated. This may improve performance and lower
memory consumption. Example:
$template->output(print_to => *STDOUT);
The return value is undefined when using the "print_to" option.
=cut
use vars qw(%URLESCAPE_MAP);
sub output {
my $self = shift;
my $options = $self->{options};
croak("HTML::Template->output() : You gave me an odd number of parameters to output()!")
unless ((@_ % 2) == 0);
my %args = @_;
print STDERR "### HTML::Template Memory Debug ### START OUTPUT ", $self->{proc_mem}->size(), "\n"
if $options->{memory_debug};
$options->{debug} and print STDERR "### HTML::Template Debug ### In output\n";
# want a stack dump?
if ($options->{stack_debug}) {
require 'Data/Dumper.pm';
print STDERR "### HTML::Template output Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n";
}
# globalize vars - this happens here to localize the circular
# references created by global_vars.
$self->_globalize_vars() if ($options->{global_vars});
# support the associate magic, searching for undefined params and
# attempting to fill them from the associated objects.
if (scalar(@{$options->{associate}})) {
# prepare case-mapping hashes to do case-insensitive matching
# against associated objects. This allows CGI.pm to be
# case-sensitive and still work with asssociate.
my (%case_map, $lparam);
foreach my $associated_object (@{$options->{associate}}) {
# what a hack! This should really be optimized out for case_sensitive.
if ($options->{case_sensitive}) {
map {
$case_map{$associated_object}{$_} = $_
} $associated_object->param();
} else {
map {
$case_map{$associated_object}{lc($_)} = $_
} $associated_object->param();
}
}
foreach my $param (keys %{$self->{param_map}}) {
unless (defined($self->param($param))) {
OBJ: foreach my $associated_object (@{$options->{associate}}) {
$self->param($param, scalar $associated_object->param($case_map{$associated_object}{$param})), last OBJ
if (exists($case_map{$associated_object}{$param}));
}
}
}
}
use vars qw($line @parse_stack); local(*line, *parse_stack);
# walk the parse stack, accumulating output in $result
*parse_stack = $self->{parse_stack};
my $result = '';
tie $result, 'HTML::Template::PRINTSCALAR', $args{print_to}
if (defined $args{print_to});
my $type;
my $parse_stack_length = $#parse_stack;
for (my $x = 0; $x <= $parse_stack_length; $x++) {
*line = \$parse_stack[$x];
$type = ref($line);
if ($type eq 'SCALAR') {
$result .= $$line;
} elsif ($type eq 'HTML::Template::VAR' and ref($$line) eq 'CODE') {
defined($$line) and $result .= $$line->($self);
} elsif ($type eq 'HTML::Template::VAR') {
defined($$line) and $result .= $$line;
} elsif ($type eq 'HTML::Template::LOOP') {
if (defined($line->[HTML::Template::LOOP::PARAM_SET])) {
eval { $result .= $line->output($x, $options->{loop_context_vars}); };
croak("HTML::Template->output() : fatal error in loop output : $@")
if $@;
}
} elsif ($type eq 'HTML::Template::COND') {
if ($line->[HTML::Template::COND::JUMP_IF_TRUE]) {
if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) {
if (defined ${$line->[HTML::Template::COND::VARIABLE]}) {
if (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') {
$x = $line->[HTML::Template::COND::JUMP_ADDRESS] if ${$line->[HTML::Template::COND::VARIABLE]}->($self);
} else {
$x = $line->[HTML::Template::COND::JUMP_ADDRESS] if ${$line->[HTML::Template::COND::VARIABLE]};
}
}
} else {
$x = $line->[HTML::Template::COND::JUMP_ADDRESS] if
(defined $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] and
scalar @{$line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]});
}
} else {
if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) {
if (defined ${$line->[HTML::Template::COND::VARIABLE]}) {
if (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') {
$x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless ${$line->[HTML::Template::COND::VARIABLE]}->($self);
} else {
$x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless ${$line->[HTML::Template::COND::VARIABLE]};
}
} else {
$x = $line->[HTML::Template::COND::JUMP_ADDRESS];
}
} else {
$x = $line->[HTML::Template::COND::JUMP_ADDRESS] if
(not defined $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] or
not scalar @{$line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]});
}
}
} elsif ($type eq 'HTML::Template::NOOP') {
next;
} elsif ($type eq 'HTML::Template::ESCAPE') {
$x++;
*line = \$parse_stack[$x];
if (defined($$line)) {
my $toencode = $$line;
# straight from the CGI.pm bible.
$toencode=~s/&/&/g;
$toencode=~s/\"/"/g; #"
$toencode=~s/>/>/g;
$toencode=~s/hex map if one isn't already available
unless (exists($URLESCAPE_MAP{chr(1)})) {
for (0..255) { $URLESCAPE_MAP{chr($_)} = sprintf('%%%02X', $_); }
}
# do the translation (RFC 2396 ^uric)
$toencode =~ s!([^a-zA-Z0-9_.\-])!$URLESCAPE_MAP{$1}!g;
$result .= $toencode;
}
} else {
confess("HTML::Template::output() : Unknown item in parse_stack : " . $type);
}
}
# undo the globalization circular refs
$self->_unglobalize_vars() if ($options->{global_vars});
print STDERR "### HTML::Template Memory Debug ### END OUTPUT ", $self->{proc_mem}->size(), "\n"
if $options->{memory_debug};
return undef if defined $args{print_to};
return $result;
}
=pod
=head2 query()
This method allow you to get information about the template structure.
It can be called in a number of ways. The simplest usage of query is
simply to check whether a parameter name exists in the template, using
the C option:
if ($template->query(name => 'foo')) {
# do something if a varaible of any type
# named FOO is in the template
}
This same usage returns the type of the parameter. The type is the
same as the tag minus the leading 'TMPL_'. So, for example, a
TMPL_VAR parameter returns 'VAR' from query().
if ($template->query(name => 'foo') eq 'VAR') {
# do something if FOO exists and is a TMPL_VAR
}
Note that the variables associated with TMPL_IFs and TMPL_UNLESSs will
be identified as 'VAR' unless they are also used in a TMPL_LOOP, in
which case they will return 'LOOP'.
C also allows you to get a list of parameters inside a loop
(and inside loops inside loops). Example loop:
And some query calls:
# returns 'LOOP'
$type = $template->query(name => 'EXAMPLE_LOOP');
# returns ('bop', 'bee', 'example_inner_loop')
@param_names = $template->query(loop => 'EXAMPLE_LOOP');
# both return 'VAR'
$type = $template->query(name => ['EXAMPLE_LOOP', 'BEE']);
$type = $template->query(name => ['EXAMPLE_LOOP', 'BOP']);
# and this one returns 'LOOP'
$type = $template->query(name => ['EXAMPLE_LOOP',
'EXAMPLE_INNER_LOOP']);
# and finally, this returns ('inner_bee', 'inner_bop')
@inner_param_names = $template->query(loop => ['EXAMPLE_LOOP',
'EXAMPLE_INNER_LOOP']);
# for non existent parameter names you get undef
# this returns undef.
$type = $template->query(name => 'DWEAZLE_ZAPPA');
# calling loop on a non-loop parameter name will cause an error.
# this dies:
$type = $template->query(loop => 'DWEAZLE_ZAPPA');
As you can see above the C option returns a list of parameter
names and both C and C take array refs in order to refer
to parameters inside loops. It is an error to use C with a
parameter that is not a loop.
Note that all the names are returned in lowercase and the types are
uppercase.
Just like C, C with no arguements returns all the
parameter names in the template at the top level.
=cut
sub query {
my $self = shift;
$self->{options}{debug} and print STDERR "### HTML::Template Debug ### query(", join(', ', @_), ")\n";
# the no-parameter case - return $self->param()
return $self->param() unless scalar(@_);
croak("HTML::Template::query() : Odd number of parameters passed to query!")
if (scalar(@_) % 2);
croak("HTML::Template::query() : Wrong number of parameters passed to query - should be 2.")
if (scalar(@_) != 2);
my ($opt, $path) = (lc shift, shift);
croak("HTML::Template::query() : invalid parameter ($opt)")
unless ($opt eq 'name' or $opt eq 'loop');
# make path an array unless it already is
$path = [$path] unless (ref $path);
# find the param in question.
my @objs = $self->_find_param(@$path);
return undef unless scalar(@objs);
my ($obj, $type);
# do what the user asked with the object
if ($opt eq 'name') {
# we only look at the first one. new() should make sure they're
# all the same.
($obj, $type) = (shift(@objs), shift(@objs));
return undef unless defined $obj;
return 'VAR' if $type eq 'HTML::Template::VAR';
return 'LOOP' if $type eq 'HTML::Template::LOOP';
croak("HTML::Template::query() : unknown object ($type) in param_map!");
} elsif ($opt eq 'loop') {
my %results;
while(@objs) {
($obj, $type) = (shift(@objs), shift(@objs));
croak("HTML::Template::query() : Search path [", join(', ', @$path), "] doesn't end in a TMPL_LOOP - it is an error to use the 'loop' option on a non-loop parameter. To avoid this problem you can use the 'name' option to query() to check the type first.")
unless ((defined $obj) and ($type eq 'HTML::Template::LOOP'));
# SHAZAM! This bit extracts all the parameter names from all the
# loop objects for this name.
map {$results{$_} = 1} map { keys(%{$_->{'param_map'}}) }
values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]});
}
# this is our loop list, return it.
return keys(%results);
}
}
# a function that returns the object(s) corresponding to a given path and
# its (their) ref()(s). Used by query() in the obvious way.
sub _find_param {
my $self = shift;
my $spot = $self->{options}{case_sensitive} ? shift : lc shift;
# get the obj and type for this spot
my $obj = $self->{'param_map'}{$spot};
return unless defined $obj;
my $type = ref $obj;
# return if we're here or if we're not but this isn't a loop
return ($obj, $type) unless @_;
return unless ($type eq 'HTML::Template::LOOP');
# recurse. this is a depth first seach on the template tree, for
# the algorithm geeks in the audience.
return map { $_->_find_param(@_) }
values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]});
}
# HTML::Template::VAR, LOOP, etc are *light* objects - their internal
# spec is used above. No encapsulation or information hiding is to be
# assumed.
package HTML::Template::VAR;
sub new {
my ($pkg) = @_;
my $value;
my $self = \$value;
bless($self, $pkg);
return $self;
}
package HTML::Template::LOOP;
sub new {
my ($pkg) = shift;
my $self = [];
bless($self, $pkg);
return $self;
}
sub output {
my $self = shift;
my $index = shift;
my $loop_context_vars = shift;
my $template = $self->[TEMPLATE_HASH]{$index};
my $value_sets_array = $self->[PARAM_SET];
return unless defined($value_sets_array);
my $result = '';
my $count = 0;
my $odd = 0;
foreach my $value_set (@$value_sets_array) {
if ($loop_context_vars) {
if ($count == 0) {
@{$value_set}{qw(__first__ __inner__ __last__)} = (1,0,$#{$value_sets_array} == 0);
} elsif ($count == $#{$value_sets_array}) {
@{$value_set}{qw(__first__ __inner__ __last__)} = (0,0,1);
} else {
@{$value_set}{qw(__first__ __inner__ __last__)} = (0,1,0);
}
$odd = $value_set->{__odd__} = not $odd;
}
$template->param($value_set);
$result .= $template->output;
$template->clear_params;
@{$value_set}{qw(__first__ __last__ __inner__ __odd__)} = (0,0,0,0)
if ($loop_context_vars);
$count++;
}
return $result;
}
package HTML::Template::COND;
sub new {
my $pkg = shift;
my $var = shift;
my $self = [];
$self->[VARIABLE] = $var;
bless($self, $pkg);
return $self;
}
package HTML::Template::NOOP;
sub new {
my $unused;
my $self = \$unused;
bless($self, $_[0]);
return $self;
}
package HTML::Template::ESCAPE;
sub new {
my $unused;
my $self = \$unused;
bless($self, $_[0]);
return $self;
}
package HTML::Template::URLESCAPE;
sub new {
my $unused;
my $self = \$unused;
bless($self, $_[0]);
return $self;
}
# scalar-tying package for output(print_to => *HANDLE) implementation
package HTML::Template::PRINTSCALAR;
use strict;
sub TIESCALAR { bless \$_[1], $_[0]; }
sub FETCH { }
sub STORE {
my $self = shift;
local *FH = $$self;
print FH @_;
}
1;
__END__
=head1 FREQUENTLY ASKED QUESTIONS
In the interest of greater understanding I've started a FAQ section of
the perldocs. Please look in here before you send me email.
1) Is there a place to go to discuss HTML::Template and/or get help?
There's a mailing-list for HTML::Template at htmltmpl@lists.vm.com.
Send a blank message to htmltmpl-subscribe@lists.vm.com to join!
2) I want support for ! How about it?
Maybe. I definitely encourage people to discuss their ideas for
HTML::Template on the mailing list. Please be ready to explain to me
how the new tag fits in with HTML::Template's mission to provide a
fast, lightweight system for using HTML templates.
NOTE: Offering to program said addition and provide it in the form of
a patch to the most recent version of HTML::Template will definitely
have a softening effect on potential opponents!
3) I found a bug, can you fix it?
That depends. Did you send me the VERSION of HTML::Template, a test
script and a test template? If so, then almost certainly.
If you're feeling really adventurous, HTML::Template has a publically
available CVS server. See below for more information in the PUBLIC
CVS SERVER section.
4) s from the main template aren't working inside a ! Why?
This is the intended behavior. introduces a separate
scope for s much like a subroutine call in Perl introduces a
separate scope for "my" variables.
If you want your s to be global you can set the
'global_vars' option when you call new(). See above for documentation
of the 'global_vars' new() option.
5) Why do you use /[Tt]/ instead of /t/i? It's so ugly!
Simple - the case-insensitive match switch is very inefficient.
According to _Mastering_Regular_Expressions_ from O'Reilly Press,
/[Tt]/ is faster and more space efficient than /t/i - by as much as
double against long strings. //i essentially does a lc() on the
string and keeps a temporary copy in memory.
When this changes, and it is in the 5.6 development series, I will
gladly use //i. Believe me, I realize [Tt] is hideously ugly.
6) How can I pre-load my templates using cache-mode and mod_perl?
Add something like this to your startup.pl:
use HTML::Template;
use File::Find;
print STDERR "Pre-loading HTML Templates...\n";
find(
sub {
return unless /\.tmpl$/;
HTML::Template->new(
filename => "$File::Find::dir/$_",
cache => 1,
);
},
'/path/to/templates',
'/another/path/to/templates/'
);
Note that you'll need to modify the "return unless" line to specify
the extension you use for your template files - I use .tmpl, as you
can see. You'll also need to specify the path to your template files.
One potential problem: the "/path/to/templates/" must be EXACTLY the
same path you use when you call HTML::Template->new(). Otherwise the
cache won't know they're the same file and will load a new copy -
instead getting a speed increase, you'll double your memory usage. To
find out if this is happening set cache_debug => 1 in your application
code and look for "CACHE MISS" messages in the logs.
7) What characters are allowed in TMPL_* NAMEs?
Numbers, letters, '.', '/', '+', '-' and '_'.
8) How can I execute a program from inside my template?
Short answer: you can't. Longer answer: you shouldn't since this
violates the fundamental concept behind HTML::Template - that design
and code should be seperate.
But, inevitably some people still want to do it. At times it has even
seemed that HTML::Template development might split over this issue, so
I will attempt a compromise. Here is a method you can use to allow
your template authors to evaluate arbitrary perl scripts from within
the template.
First, tell all your designers that when they want to run a perl
script named "program.pl" they should use a tag like:
Then, have all your programmers call this subroutine instead of
calling HTML::Template::new directly. They still use the same
parameters, but they also get the program execution.
sub new_template {
# get the template object
my $template = HTML::Template->new(@_);
# find program parameters and fill them in
my @params = $template->param();
for my $param (@params) {
if ($param =~ /^__execute_(.*)__$/) {
$template->param($param, do($1));
}
}
# return the template object
return $template;
}
The programs called in this way should return a string containing
their output. A more complicated subroutine could be written to
capture STDOUT from the scripts, but this one is simple enough to
include in the FAQ. Another improvement would be to use query() to
enable program execution inside loops.
9) Can I get a copy of these docs in Japanese?
Yes you can. See Kawai Takanori's translation at:
http://member.nifty.ne.jp/hippo2000/perltips/html/template.htm
=head1 BUGS
I am aware of no bugs - if you find one, join the mailing list and
tell us about it (htmltmpl@lists.vm.com). You can join the
HTML::Template mailing-list by sending a blank email to
htmltmpl-subscribe@lists.vm.com. Of course, you can still email me
directly (sam@tregar.com) with bugs, but I reserve the right to
forward bug reports to the mailing list.
When submitting bug reports, be sure to include full details,
including the VERSION of the module, a test script and a test template
demonstrating the problem!
If you're feeling really adventurous, HTML::Template has a publically
available CVS server. See below for more information in the PUBLIC
CVS SERVER section.
=head1 CREDITS
This module was the brain child of my boss, Jesse Erlbaum
(jesse@vm.com) here at Vanguard Media. The most original idea in this
module - the - was entirely his.
Fixes, Bug Reports, Optimizations and Ideas have been generously
provided by:
Richard Chen
Mike Blazer
Adriano Nagelschmidt Rodrigues
Andrej Mikus
Ilya Obshadko
Kevin Puetz
Steve Reppucci
Richard Dice
Tom Hukins
Eric Zylberstejn
David Glasser
Peter Marelas
James William Carlson
Frank D. Cringle
Winfried Koenig
Matthew Wickline
Doug Steinwand
Drew Taylor
Tobias Brox
Michael Lloyd
Simran Gambhir
Chris Houser
Larry Moore
Todd Larason
Jody Biggs
T.J. Mather
Martin Schroth
Dave Wolfe
uchum
Kawai Takanori
Peter Guelich
Chris Nokleberg
Ralph Corderoy
William Ward
Ade Olonoh
Mark Stosberg
Lance Thomas
Roland Giersig
Jere Julian
Peter Leonard
Thanks!
=head1 PUBLIC CVS SERVER
HTML::Template now has a publicly accessible CVS server provided by
SourceForge (www.sourceforge.net). You can access it by going to
http://sourceforge.net/cvs/?group_id=1075. Give it a try!
=head1 AUTHOR
Sam Tregar, sam@tregar.com (you can also find me on the mailing list
at htmltmpl@lists.vm.com - join it by sending a blank message to
htmltmpl-subscribe@lists.vm.com).
=head1 LICENSE
HTML::Template : A module for using HTML Templates with Perl
Copyright (C) 2000 Sam Tregar (sam@tregar.com)
This module is free software; you can redistribute it and/or modify it
under the terms of either:
a) the GNU General Public License as published by the Free Software
Foundation; either version 1, or (at your option) any later version,
or
b) the "Artistic License" which comes with this module.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
the GNU General Public License or the Artistic License for more details.
You should have received a copy of the Artistic License with this
module, in the file ARTISTIC. If not, I'll be glad to provide one.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
=cut
cgi-bin/extlib/HTML/Form.pm0000644002157400001440000003700407771550070022301 0ustar minnesotaviolasociety.orgusers00000000000000package HTML::Form;
use strict;
use URI;
use Carp ();
use vars qw($VERSION);
$VERSION='0.03';
my %form_tags = map {$_ => 1} qw(input textarea button select option);
my %type2class = (
text => "TextInput",
password => "TextInput",
file => "TextInput",
hidden => "TextInput",
textarea => "TextInput",
button => "IgnoreInput",
"reset" => "IgnoreInput",
radio => "ListInput",
checkbox => "ListInput",
option => "ListInput",
submit => "SubmitInput",
image => "ImageInput",
);
=head1 NAME
HTML::Form - Class that represents HTML forms
=head1 SYNOPSIS
use HTML::Form;
$form = HTML::Form->parse($html, $base_uri);
$form->value(query => "Perl");
use LWP;
LWP::UserAgent->new->request($form->click);
=head1 DESCRIPTION
Objects of the C class represents a single HTML instance. A form consist of a sequence of inputs that
usually have names, and which can take on various values.
The following methods are available:
=over 4
=item $form = HTML::Form->new($method, $action_uri, [[$enctype], $input,...])
The constructor takes a $method and a $uri as argument. The $enctype
and and initial inputs are optional. You will normally use
HTML::Form->parse() to create new HTML::Form objects.
=cut
sub new {
my $class = shift;
my $self = bless {}, $class;
$self->{method} = uc(shift || "GET");
$self->{action} = shift || Carp::croak("No action defined");
$self->{enctype} = shift || "application/x-www-form-urlencoded";
$self->{inputs} = [@_];
$self;
}
=item @forms = HTML::Form->parse($html_document, $base_uri)
The parse() class method will parse an HTML document and build up
C objects for each
if you wish; however, if
the file is not a plain file, there will be no Content-Length header
defined for the request. Not all servers (or server
applications) like this. Also, if the file(s) change in size between
the time the Content-Length is calculated and the time that the last
chunk is delivered, the subroutine will C.
=back
=head1 SEE ALSO
L, L
=head1 COPYRIGHT
Copyright 1997-2000, Gisle Aas
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
cgi-bin/extlib/HTTP/_vti_cnf/0000755002157400001440000000000007776605372022651 5ustar minnesotaviolasociety.orgusers00000000000000cgi-bin/extlib/HTTP/_vti_cnf/Cookies.pm0000644002157400001440000000030407771550070024565 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|21391
vti_backlinkinfo:VX|
cgi-bin/extlib/HTTP/_vti_cnf/Daemon.pm0000644002157400001440000000030407771550070024374 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|21577
vti_backlinkinfo:VX|
cgi-bin/extlib/HTTP/_vti_cnf/Date.pm0000644002157400001440000000030407771550070024046 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|10592
vti_backlinkinfo:VX|
cgi-bin/extlib/HTTP/_vti_cnf/Headers.pm0000644002157400001440000000030407771550070024544 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|17977
vti_backlinkinfo:VX|
cgi-bin/extlib/HTTP/_vti_cnf/Message.pm0000644002157400001440000000030307771550070024554 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|4794
vti_backlinkinfo:VX|
cgi-bin/extlib/HTTP/_vti_cnf/Negotiate.pm0000644002157400001440000000030407771550070025110 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|16217
vti_backlinkinfo:VX|
cgi-bin/extlib/HTTP/_vti_cnf/Request.pm0000644002157400001440000000030307771550070024620 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|4309
vti_backlinkinfo:VX|
cgi-bin/extlib/HTTP/_vti_cnf/Response.pm0000644002157400001440000000030307771550070024766 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|9706
vti_backlinkinfo:VX|
cgi-bin/extlib/HTTP/_vti_cnf/Status.pm0000644002157400001440000000030307771550070024453 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|6725
vti_backlinkinfo:VX|
cgi-bin/extlib/HTTP/Cookies.pm0000644002157400001440000005161707771550070023013 0ustar minnesotaviolasociety.orgusers00000000000000package HTTP::Cookies;
use strict;
use HTTP::Date qw(str2time time2str);
use HTTP::Headers::Util qw(split_header_words join_header_words);
use LWP::Debug ();
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/);
my $EPOCH_OFFSET = 0; # difference from Unix epoch
if ($^O eq "MacOS") {
require Time::Local;
$EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
}
=head1 NAME
HTTP::Cookies - Cookie storage and management
=head1 SYNOPSIS
use HTTP::Cookies;
$cookie_jar = HTTP::Cookies->new;
$cookie_jar->add_cookie_header($request);
$cookie_jar->extract_cookies($response);
=head1 DESCRIPTION
Cookies are a general mechanism which server side connections can use
to both store and retrieve information on the client side of the
connection. For more information about cookies refer to
and
.
The two variants of cookies are supposed to be able to coexist happily.
Instances of the class I are able to store a collection
of Set-Cookie2: and Set-Cookie: headers and are able to use this
information to initialize Cookie-headers in I objects.
The state of a I object can be saved in and restored from
files.
=head1 METHODS
The following methods are provided:
=over 4
=cut
# A HTTP::Cookies object is a hash. The main attribute is the
# COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}.
=item $cookie_jar = HTTP::Cookies->new;
The constructor takes hash style parameters. The following
parameters are recognized:
file: name of the file to restore cookies from and save cookies to
autosave: save during destruction (bool)
ignore_discard: save even cookies that are requested to be discarded (bool)
hide_cookie2: don't add Cookie2 header to requests
Future parameters might include (not yet implemented):
max_cookies 300
max_cookies_per_domain 20
max_cookie_size 4096
no_cookies list of domain names that we never return cookies to
=cut
sub new
{
my $class = shift;
my $self = bless {
COOKIES => {},
}, $class;
my %cnf = @_;
for (keys %cnf) {
$self->{lc($_)} = $cnf{$_};
}
$self->load;
$self;
}
=item $cookie_jar->add_cookie_header($request);
The add_cookie_header() method will set the appropriate Cookie:-header
for the I object given as argument. The $request must
have a valid url attribute before this method is called.
=cut
sub add_cookie_header
{
my $self = shift;
my $request = shift || return;
my $url = $request->url;
my $domain = _host($request, $url);
$domain = "$domain.local" unless $domain =~ /\./;
my $secure_request = ($url->scheme eq "https");
my $req_path = _url_path($url);
my $req_port = $url->port;
my $now = time();
_normalize_path($req_path) if $req_path =~ /%/;
my @cval; # cookie values for the "Cookie" header
my $set_ver;
my $netscape_only = 0; # An exact domain match applies to any cookie
while ($domain =~ /\./) {
LWP::Debug::debug("Checking $domain for cookies");
my $cookies = $self->{COOKIES}{$domain};
next unless $cookies;
# Want to add cookies corresponding to the most specific paths
# first (i.e. longest path first)
my $path;
for $path (sort {length($b) <=> length($a) } keys %$cookies) {
LWP::Debug::debug("- checking cookie path=$path");
if (index($req_path, $path) != 0) {
LWP::Debug::debug(" path $path:$req_path does not fit");
next;
}
my($key,$array);
while (($key,$array) = each %{$cookies->{$path}}) {
my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
LWP::Debug::debug(" - checking cookie $key=$val");
if ($secure && !$secure_request) {
LWP::Debug::debug(" not a secure requests");
next;
}
if ($expires && $expires < $now) {
LWP::Debug::debug(" expired");
next;
}
if ($port) {
my $found;
if ($port =~ s/^_//) {
# The correponding Set-Cookie attribute was empty
$found++ if $port eq $req_port;
$port = "";
} else {
my $p;
for $p (split(/,/, $port)) {
$found++, last if $p eq $req_port;
}
}
unless ($found) {
LWP::Debug::debug(" port $port:$req_port does not fit");
next;
}
}
if ($version > 0 && $netscape_only) {
LWP::Debug::debug(" domain $domain applies to " .
"Netscape-style cookies only");
next;
}
LWP::Debug::debug(" it's a match");
# set version number of cookie header.
# XXX: What should it be if multiple matching
# Set-Cookie headers have different versions themselves
if (!$set_ver++) {
if ($version >= 1) {
push(@cval, "\$Version=$version");
} elsif (!$self->{hide_cookie2}) {
$request->header(Cookie2 => '$Version="1"');
}
}
# do we need to quote the value
if ($val =~ /\W/ && $version) {
$val =~ s/([\\\"])/\\$1/g;
$val = qq("$val");
}
# and finally remember this cookie
push(@cval, "$key=$val");
if ($version >= 1) {
push(@cval, qq(\$Path="$path")) if $path_spec;
push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
if (defined $port) {
my $p = '$Port';
$p .= qq(="$port") if length $port;
push(@cval, $p);
}
}
}
}
} continue {
# Try with a more general domain, alternately stripping
# leading name components and leading dots. When this
# results in a domain with no leading dot, it is for
# Netscape cookie compatibility only:
#
# a.b.c.net Any cookie
# .b.c.net Any cookie
# b.c.net Netscape cookie only
# .c.net Any cookie
if ($domain =~ s/^\.+//) {
$netscape_only = 1;
} else {
$domain =~ s/[^.]*//;
$netscape_only = 0;
}
}
$request->header(Cookie => join("; ", @cval)) if @cval;
$request;
}
=item $cookie_jar->extract_cookies($response);
The extract_cookies() method will look for Set-Cookie: and
Set-Cookie2: headers in the I object passed as
argument. Any of these headers that are found are used to update
the state of the $cookie_jar.
=cut
sub extract_cookies
{
my $self = shift;
my $response = shift || return;
my @set = split_header_words($response->_header("Set-Cookie2"));
my @ns_set = $response->_header("Set-Cookie");
return $response unless @set || @ns_set; # quick exit
my $request = $response->request;
my $url = $request->url;
my $req_host = _host($request, $url);
$req_host = "$req_host.local" unless $req_host =~ /\./;
my $req_port = $url->port;
my $req_path = _url_path($url);
_normalize_path($req_path) if $req_path =~ /%/;
if (@ns_set) {
# The old Netscape cookie format for Set-Cookie
# http://www.netscape.com/newsref/std/cookie_spec.html
# can for instance contain an unquoted "," in the expires
# field, so we have to use this ad-hoc parser.
my $now = time();
# Build a hash of cookies that was present in Set-Cookie2
# headers. We need to skip them if we also find them in a
# Set-Cookie header.
my %in_set2;
for (@set) {
$in_set2{$_->[0]}++;
}
my $set;
for $set (@ns_set) {
my @cur;
my $param;
my $expires;
for $param (split(/;\s*/, $set)) {
my($k,$v) = split(/\s*=\s*/, $param, 2);
$v =~ s/\s+$//;
#print "$k => $v\n";
my $lc = lc($k);
if ($lc eq "expires") {
my $etime = str2time($v);
if ($etime) {
push(@cur, "Max-Age" => str2time($v) - $now);
$expires++;
}
} else {
push(@cur, $k => $v);
}
}
next if $in_set2{$cur[0]};
# push(@cur, "Port" => $req_port);
push(@cur, "Discard" => undef) unless $expires;
push(@cur, "Version" => 0);
push(@cur, "ns-cookie" => 1);
push(@set, \@cur);
}
}
SET_COOKIE:
for my $set (@set) {
next unless @$set >= 2;
my $key = shift @$set;
my $val = shift @$set;
LWP::Debug::debug("Set cookie $key => $val");
my %hash;
while (@$set) {
my $k = shift @$set;
my $v = shift @$set;
my $lc = lc($k);
# don't loose case distinction for unknown fields
$k = $lc if $lc =~ /^(?:discard|domain|max-age|
path|port|secure|version)$/x;
if ($k eq "discard" || $k eq "secure") {
$v = 1 unless defined $v;
}
next if exists $hash{$k}; # only first value is signigicant
$hash{$k} = $v;
};
my %orig_hash = %hash;
my $version = delete $hash{version};
$version = 1 unless defined($version);
my $discard = delete $hash{discard};
my $secure = delete $hash{secure};
my $maxage = delete $hash{'max-age'};
my $ns_cookie = delete $hash{'ns-cookie'};
# Check domain
my $domain = delete $hash{domain};
if (defined($domain)
&& $domain ne $req_host && $domain ne ".$req_host") {
if ($domain !~ /\./ && $domain ne "local") {
LWP::Debug::debug("Domain $domain contains no dot");
next SET_COOKIE;
}
$domain = ".$domain" unless $domain =~ /^\./;
if ($domain =~ /\.\d+$/) {
LWP::Debug::debug("IP-address $domain illeagal as domain");
next SET_COOKIE;
}
my $len = length($domain);
unless (substr($req_host, -$len) eq $domain) {
LWP::Debug::debug("Domain $domain does not match host $req_host");
next SET_COOKIE;
}
my $hostpre = substr($req_host, 0, length($req_host) - $len);
if ($hostpre =~ /\./ && !$ns_cookie) {
LWP::Debug::debug("Host prefix contain a dot: $hostpre => $domain");
next SET_COOKIE;
}
} else {
$domain = $req_host;
}
my $path = delete $hash{path};
my $path_spec;
if (defined $path && $path ne '') {
$path_spec++;
_normalize_path($path) if $path =~ /%/;
if (!$ns_cookie &&
substr($req_path, 0, length($path)) ne $path) {
LWP::Debug::debug("Path $path is not a prefix of $req_path");
next SET_COOKIE;
}
} else {
$path = $req_path;
$path =~ s,/[^/]*$,,;
$path = "/" unless length($path);
}
my $port;
if (exists $hash{port}) {
$port = delete $hash{port};
if (defined $port) {
$port =~ s/\s+//g;
my $found;
for my $p (split(/,/, $port)) {
unless ($p =~ /^\d+$/) {
LWP::Debug::debug("Bad port $port (not numeric)");
next SET_COOKIE;
}
$found++ if $p eq $req_port;
}
unless ($found) {
LWP::Debug::debug("Request port ($req_port) not found in $port");
next SET_COOKIE;
}
} else {
$port = "_$req_port";
}
}
$self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
if $self->set_cookie_ok(\%orig_hash);
}
$response;
}
sub set_cookie_ok { 1 };
=item $cookie_jar->set_cookie($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest)
The set_cookie() method updates the state of the $cookie_jar. The
$key, $val, $domain, $port and $path arguments are strings. The
$path_spec, $secure, $discard arguments are boolean values. The $maxage
value is a number indicating number of seconds that this cookie will
live. A value <= 0 will delete this cookie. %rest defines
various other attributes like "Comment" and "CommentURL".
=cut
sub set_cookie
{
my $self = shift;
my($version,
$key, $val, $path, $domain, $port,
$path_spec, $secure, $maxage, $discard, $rest) = @_;
# path and key can not be empty (key can't start with '$')
return $self if !defined($path) || $path !~ m,^/, ||
!defined($key) || $key !~ m,[^\$],;
# ensure legal port
if (defined $port) {
return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
}
my $expires;
if (defined $maxage) {
if ($maxage <= 0) {
delete $self->{COOKIES}{$domain}{$path}{$key};
return $self;
}
$expires = time() + $maxage;
}
$version = 0 unless defined $version;
my @array = ($version, $val,$port,
$path_spec,
$secure, $expires, $discard);
push(@array, {%$rest}) if defined($rest) && %$rest;
# trim off undefined values at end
pop(@array) while !defined $array[-1];
$self->{COOKIES}{$domain}{$path}{$key} = \@array;
$self;
}
=item $cookie_jar->save( [$file] );
This method file saves the state of the $cookie_jar to a file.
The state can then be restored later using the load() method. If a
filename is not specified we will use the name specified during
construction. If the attribute I is set, then we
will even save cookies that are marked to be discarded.
The default is to save a sequence of "Set-Cookie3" lines.
"Set-Cookie3" is a proprietary LWP format, not known to be compatible
with any browser. The I sub-class can
be used to save in a format compatible with Netscape.
=cut
sub save
{
my $self = shift;
my $file = shift || $self->{'file'} || return;
local(*FILE);
open(FILE, ">$file") or die "Can't open $file: $!";
print FILE "#LWP-Cookies-1.0\n";
print FILE $self->as_string(!$self->{ignore_discard});
close(FILE);
1;
}
=item $cookie_jar->load( [$file] );
This method reads the cookies from the file and adds them to the
$cookie_jar. The file must be in the format written by the save()
method.
=cut
sub load
{
my $self = shift;
my $file = shift || $self->{'file'} || return;
local(*FILE, $_);
local $/ = "\n"; # make sure we got standard record separator
open(FILE, $file) or return;
my $magic = ;
unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) {
warn "$file does not seem to contain cookies";
return;
}
while () {
next unless s/^Set-Cookie3:\s*//;
chomp;
my $cookie;
for $cookie (split_header_words($_)) {
my($key,$val) = splice(@$cookie, 0, 2);
my %hash;
while (@$cookie) {
my $k = shift @$cookie;
my $v = shift @$cookie;
$hash{$k} = $v;
}
my $version = delete $hash{version};
my $path = delete $hash{path};
my $domain = delete $hash{domain};
my $port = delete $hash{port};
my $expires = str2time(delete $hash{expires});
my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
my $secure = exists $hash{secure}; delete $hash{secure};
my $discard = exists $hash{discard}; delete $hash{discard};
my @array = ($version,$val,$port,
$path_spec,$secure,$expires,$discard);
push(@array, \%hash) if %hash;
$self->{COOKIES}{$domain}{$path}{$key} = \@array;
}
}
close(FILE);
1;
}
=item $cookie_jar->revert;
This method empties the $cookie_jar and re-loads the $cookie_jar
from the last save file.
=cut
sub revert
{
my $self = shift;
$self->clear->load;
$self;
}
=item $cookie_jar->clear( [$domain, [$path, [$key] ] ]);
Invoking this method without arguments will empty the whole
$cookie_jar. If given a single argument only cookies belonging to
that domain will be removed. If given two arguments, cookies
belonging to the specified path within that domain are removed. If
given three arguments, then the cookie with the specified key, path
and domain is removed.
=cut
sub clear
{
my $self = shift;
if (@_ == 0) {
$self->{COOKIES} = {};
} elsif (@_ == 1) {
delete $self->{COOKIES}{$_[0]};
} elsif (@_ == 2) {
delete $self->{COOKIES}{$_[0]}{$_[1]};
} elsif (@_ == 3) {
delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
} else {
require Carp;
Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
}
$self;
}
=item $cookie_jar->clear_temporary_cookies( );
Discard all temporary cookies. Scans for all cookies in the jar
with either no expire field or a true C flag. To be
called when the user agent shuts down according to RFC 2965.
=cut
sub clear_temporary_cookies
{
my($self) = @_;
$self->scan(sub {
if($_[9] or # "Discard" flag set
not $_[8]) { # No expire field?
$_[8] = -1; # Set the expire/max_age field
$self->set_cookie(@_); # Clear the cookie
}
});
}
sub DESTROY
{
my $self = shift;
$self->save if $self->{'autosave'};
}
=item $cookie_jar->scan( \&callback );
The argument is a subroutine that will be invoked for each cookie
stored in the $cookie_jar. The subroutine will be invoked with
the following arguments:
0 version
1 key
2 val
3 path
4 domain
5 port
6 path_spec
7 secure
8 expires
9 discard
10 hash
=cut
sub scan
{
my($self, $cb) = @_;
my($domain,$path,$key);
for $domain (sort keys %{$self->{COOKIES}}) {
for $path (sort keys %{$self->{COOKIES}{$domain}}) {
for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
my($version,$val,$port,$path_spec,
$secure,$expires,$discard,$rest) =
@{$self->{COOKIES}{$domain}{$path}{$key}};
$rest = {} unless defined($rest);
&$cb($version,$key,$val,$path,$domain,$port,
$path_spec,$secure,$expires,$discard,$rest);
}
}
}
}
=item $cookie_jar->as_string( [$skip_discard] );
The as_string() method will return the state of the $cookie_jar
represented as a sequence of "Set-Cookie3" header lines separated by
"\n". If $skip_discard is TRUE, it will not return lines for
cookies with the I attribute.
=cut
sub as_string
{
my($self, $skip_discard) = @_;
my @res;
$self->scan(sub {
my($version,$key,$val,$path,$domain,$port,
$path_spec,$secure,$expires,$discard,$rest) = @_;
return if $discard && $skip_discard;
my @h = ($key, $val);
push(@h, "path", $path);
push(@h, "domain" => $domain);
push(@h, "port" => $port) if defined $port;
push(@h, "path_spec" => undef) if $path_spec;
push(@h, "secure" => undef) if $secure;
push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
push(@h, "discard" => undef) if $discard;
my $k;
for $k (sort keys %$rest) {
push(@h, $k, $rest->{$k});
}
push(@h, "version" => $version);
push(@res, "Set-Cookie3: " . join_header_words(\@h));
});
join("\n", @res, "");
}
sub _host
{
my($request, $url) = @_;
if (my $h = $request->header("Host")) {
$h =~ s/:\d+$//; # might have a port as well
return $h;
}
return $url->host;
}
sub _url_path
{
my $url = shift;
my $path;
if($url->can('epath')) {
$path = $url->epath; # URI::URL method
} else {
$path = $url->path; # URI::_generic method
}
$path = "/" unless length $path;
$path;
}
sub _normalize_path # so that plain string compare can be used
{
my $x;
$_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
$x = uc($1);
$x eq "2F" || $x eq "25" ? "%$x" :
pack("C", hex($x));
/eg;
$_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
}
=back
=head1 SUB CLASSES
We also provide a subclass called I which
loads and saves Netscape compatible cookie files. You
should be able to have LWP share Netscape's cookies by constructing
your $cookie_jar like this:
$cookie_jar = HTTP::Cookies::Netscape->new(
File => "$ENV{HOME}/.netscape/cookies",
AutoSave => 1,
);
Please note that the Netscape cookie file format is not able to store
all the information available in the Set-Cookie2 headers, so you will
probably loose some information if you save in this format.
=cut
package HTTP::Cookies::Netscape;
use vars qw(@ISA);
@ISA=qw(HTTP::Cookies);
sub load
{
my($self, $file) = @_;
$file ||= $self->{'file'} || return;
local(*FILE, $_);
local $/ = "\n"; # make sure we got standard record separator
my @cookies;
open(FILE, $file) || return;
my $magic = ;
unless ($magic =~ /^\# Netscape HTTP Cookie File/) {
warn "$file does not look like a netscape cookies file" if $^W;
close(FILE);
return;
}
my $now = time() - $EPOCH_OFFSET;
while () {
next if /^\s*\#/;
next if /^\s*$/;
chomp;
my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
$secure = ($secure eq "TRUE");
$self->set_cookie(undef,$key,$val,$path,$domain,undef,
0,$secure,$expires-$now, 0);
}
close(FILE);
1;
}
sub save
{
my($self, $file) = @_;
$file ||= $self->{'file'} || return;
local(*FILE, $_);
open(FILE, ">$file") || return;
print FILE <scan(sub {
my($version,$key,$val,$path,$domain,$port,
$path_spec,$secure,$expires,$discard,$rest) = @_;
return if $discard && !$self->{ignore_discard};
$expires = $expires ? $expires - $EPOCH_OFFSET : 0;
return if $now > $expires;
$secure = $secure ? "TRUE" : "FALSE";
my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
});
close(FILE);
1;
}
1;
__END__
=head1 COPYRIGHT
Copyright 1997-1999 Gisle Aas
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
cgi-bin/extlib/HTTP/Daemon.pm0000644002157400001440000005211107771550070022610 0ustar minnesotaviolasociety.orgusers00000000000000# $Id: Daemon.pm,v 1.25 2001/08/07 19:32:40 gisle Exp $
#
use strict;
package HTTP::Daemon;
=head1 NAME
HTTP::Daemon - a simple http server class
=head1 SYNOPSIS
use HTTP::Daemon;
use HTTP::Status;
my $d = HTTP::Daemon->new || die;
print "Please contact me at: url, ">\n";
while (my $c = $d->accept) {
while (my $r = $c->get_request) {
if ($r->method eq 'GET' and $r->url->path eq "/xyzzy") {
# remember, this is *not* recommened practice :-)
$c->send_file_response("/etc/passwd");
} else {
$c->send_error(RC_FORBIDDEN)
}
}
$c->close;
undef($c);
}
=head1 DESCRIPTION
Instances of the I class are HTTP/1.1 servers that
listen on a socket for incoming requests. The I is a
sub-class of I, so you can perform socket operations
directly on it too.
The accept() method will return when a connection from a client is
available. In a scalar context the returned value will be a reference
to a object of the I class which is another
I subclass. In a list context a two-element array
is returned containing the new I reference
and the peer address; the list will be empty upon failure. Calling
the get_request() method on the I object
will read data from the client and return an I object
reference.
This HTTP daemon does not fork(2) for you. Your application, i.e. the
user of the I is reponsible for forking if that is
desirable. Also note that the user is responsible for generating
responses that conform to the HTTP/1.1 protocol. The
I class provides some methods that make this easier.
=head1 METHODS
The following is a list of methods that are new (or enhanced) relative
to the I base class.
=over 4
=cut
use vars qw($VERSION @ISA $PROTO $DEBUG);
$VERSION = sprintf("%d.%02d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/);
use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
@ISA=qw(IO::Socket::INET);
$PROTO = "HTTP/1.1";
=item $d = new HTTP::Daemon
The constructor takes the same parameters as the
I constructor. It can also be called without specifying
any parameters. The daemon will then set up a listen queue of 5
connections and allocate some random port number. A server that wants
to bind to some specific address on the standard HTTP port will be
constructed like this:
$d = new HTTP::Daemon
LocalAddr => 'www.someplace.com',
LocalPort => 80;
=cut
sub new
{
my($class, %args) = @_;
$args{Listen} ||= 5;
$args{Proto} ||= 'tcp';
return $class->SUPER::new(%args);
}
=item $c = $d->accept([$pkg])
This method is the same as I but returns an
I reference by default. It returns undef if
you specify a timeout and no connection is made within that time. In
a scalar context the returned value will be a reference to a object of
the I class which is another
I subclass. In a list context a two-element array
is returned containing the new I reference
and the peer address; the list will be empty upon failure.
=cut
sub accept
{
my $self = shift;
my $pkg = shift || "HTTP::Daemon::ClientConn";
my ($sock, $peer) = $self->SUPER::accept($pkg);
if ($sock) {
${*$sock}{'httpd_daemon'} = $self;
return wantarray ? ($sock, $peer) : $sock;
} else {
return;
}
}
=item $d->url
Returns a URL string that can be used to access the server root.
=cut
sub url
{
my $self = shift;
my $url = "http://";
my $addr = $self->sockaddr;
if ($addr eq INADDR_ANY) {
require Sys::Hostname;
$url .= lc Sys::Hostname::hostname();
}
else {
$url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
}
my $port = $self->sockport;
$url .= ":$port" if $port != 80;
$url .= "/";
$url;
}
=item $d->product_tokens
Returns the name that this server will use to identify itself. This
is the string that is sent with the I response header. The
main reason to have this method is that subclasses can override it if
they want to use another product name.
=cut
sub product_tokens
{
"libwww-perl-daemon/$HTTP::Daemon::VERSION";
}
package HTTP::Daemon::ClientConn;
use vars qw(@ISA $DEBUG);
use IO::Socket ();
@ISA=qw(IO::Socket::INET);
*DEBUG = \$HTTP::Daemon::DEBUG;
use HTTP::Request ();
use HTTP::Response ();
use HTTP::Status;
use HTTP::Date qw(time2str);
use LWP::MediaTypes qw(guess_media_type);
use Carp ();
my $CRLF = "\015\012"; # "\r\n" is not portable
my $HTTP_1_0 = _http_version("HTTP/1.0");
my $HTTP_1_1 = _http_version("HTTP/1.1");
=back
The I is also a I
subclass. Instances of this class are returned by the accept() method
of I. The following additional methods are
provided:
=over 4
=item $c->get_request([$headers_only])
Read data from the client and turn it into an
I object which is then returned. It returns C
if reading of the request fails. If it fails, then the
I object ($c) should be discarded, and you
should not call this method again. The $c->reason method might give
you some information about why $c->get_request returned C.
The $c->get_request method supports HTTP/1.1 request content bodies,
including I transfer encoding with footer and self delimiting
I content types.
The $c->get_request method will normally not return until the whole
request has been received from the client. This might not be what you
want if the request is an upload of a multi-mega-byte file (and with
chunked transfer encoding HTTP can even support infinite request
messages - uploading live audio for instance). If you pass a TRUE
value as the $headers_only argument, then $c->get_request will return
immediately after parsing the request headers and you are responsible
for reading the rest of the request content. If you are going to
call $c->get_request again on the same connection you better read the
correct number of bytes.
=cut
sub get_request
{
my($self, $only_headers) = @_;
if (${*$self}{'httpd_nomore'}) {
$self->reason("No more requests from this connection");
return;
}
$self->reason("");
my $buf = ${*$self}{'httpd_rbuf'};
$buf = "" unless defined $buf;
my $timeout = $ {*$self}{'io_socket_timeout'};
my $fdset = "";
vec($fdset, $self->fileno, 1) = 1;
local($_);
READ_HEADER:
while (1) {
# loop until we have the whole header in $buf
$buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines
if ($buf =~ /\012/) { # potential, has at least one line
if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
if ($buf =~ /\015?\012\015?\012/) {
last READ_HEADER; # we have it
} elsif (length($buf) > 16*1024) {
$self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
$self->reason("Very long header");
return;
}
} else {
last READ_HEADER; # HTTP/0.9 client
}
} elsif (length($buf) > 16*1024) {
$self->send_error(414); # REQUEST_URI_TOO_LARGE
$self->reason("Very long first line");
return;
}
print STDERR "Need more data for complete header\n" if $DEBUG;
return unless $self->_need_more($buf, $timeout, $fdset);
}
if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
$self->send_error(400); # BAD_REQUEST
$self->reason("Bad request line: $buf");
return;
}
my $method = $1;
my $uri = $2;
my $proto = $3 || "HTTP/0.9";
$uri = "http://$uri" if $method eq "CONNECT";
$uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
my $r = HTTP::Request->new($method, $uri);
$r->protocol($proto);
${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
if ($proto >= $HTTP_1_0) {
# we expect to find some headers
my($key, $val);
HEADER:
while ($buf =~ s/^([^\012]*)\012//) {
$_ = $1;
s/\015$//;
if (/^([\w\-]+)\s*:\s*(.*)/) {
$r->push_header($key, $val) if $key;
($key, $val) = ($1, $2);
} elsif (/^\s+(.*)/) {
$val .= " $1";
} else {
last HEADER;
}
}
$r->push_header($key, $val) if $key;
}
my $conn = $r->header('Connection');
if ($proto >= $HTTP_1_1) {
${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
} else {
${*$self}{'httpd_nomore'}++ unless $conn &&
lc($conn) =~ /\bkeep-alive\b/;
}
if ($only_headers) {
${*$self}{'httpd_rbuf'} = $buf;
return $r;
}
# Find out how much content to read
my $te = $r->header('Transfer-Encoding');
my $ct = $r->header('Content-Type');
my $len = $r->header('Content-Length');
if ($te && lc($te) eq 'chunked') {
# Handle chunked transfer encoding
my $body = "";
CHUNK:
while (1) {
print STDERR "Chunked\n" if $DEBUG;
if ($buf =~ s/^([^\012]*)\012//) {
my $chunk_head = $1;
unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
$self->send_error(400);
$self->reason("Bad chunk header $chunk_head");
return;
}
my $size = hex($1);
last CHUNK if $size == 0;
my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
# must read until we have a complete chunk
while ($missing > 0) {
print STDERR "Need $missing more bytes\n" if $DEBUG;
my $n = $self->_need_more($buf, $timeout, $fdset);
return unless $n;
$missing -= $n;
}
$body .= substr($buf, 0, $size);
substr($buf, 0, $size+2) = '';
} else {
# need more data in order to have a complete chunk header
return unless $self->_need_more($buf, $timeout, $fdset);
}
}
$r->content($body);
# pretend it was a normal entity body
$r->remove_header('Transfer-Encoding');
$r->header('Content-Length', length($body));
my($key, $val);
FOOTER:
while (1) {
if ($buf !~ /\012/) {
# need at least one line to look at
return unless $self->_need_more($buf, $timeout, $fdset);
} else {
$buf =~ s/^([^\012]*)\012//;
$_ = $1;
s/\015$//;
if (/^([\w\-]+)\s*:\s*(.*)/) {
$r->push_header($key, $val) if $key;
($key, $val) = ($1, $2);
} elsif (/^\s+(.*)/) {
$val .= " $1";
} elsif (!length) {
last FOOTER;
} else {
$self->reason("Bad footer syntax");
return;
}
}
}
$r->push_header($key, $val) if $key;
} elsif ($te) {
$self->send_error(501); # Unknown transfer encoding
$self->reason("Unknown transfer encoding '$te'");
return;
} elsif ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) {
# Handle multipart content type
my $boundary = "$CRLF--$1--$CRLF";
my $index;
while (1) {
$index = index($buf, $boundary);
last if $index >= 0;
# end marker not yet found
return unless $self->_need_more($buf, $timeout, $fdset);
}
$index += length($boundary);
$r->content(substr($buf, 0, $index));
substr($buf, 0, $index) = '';
} elsif ($len) {
# Plain body specified by "Content-Length"
my $missing = $len - length($buf);
while ($missing > 0) {
print "Need $missing more bytes of content\n" if $DEBUG;
my $n = $self->_need_more($buf, $timeout, $fdset);
return unless $n;
$missing -= $n;
}
if (length($buf) > $len) {
$r->content(substr($buf,0,$len));
substr($buf, 0, $len) = '';
} else {
$r->content($buf);
$buf='';
}
}
${*$self}{'httpd_rbuf'} = $buf;
$r;
}
sub _need_more
{
my $self = shift;
#my($buf,$timeout,$fdset) = @_;
if ($_[1]) {
my($timeout, $fdset) = @_[1,2];
print STDERR "select(,,,$timeout)\n" if $DEBUG;
my $n = select($fdset,undef,undef,$timeout);
unless ($n) {
$self->reason(defined($n) ? "Timeout" : "select: $!");
return;
}
}
print STDERR "sysread()\n" if $DEBUG;
my $n = sysread($self, $_[0], 2048, length($_[0]));
$self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
$n;
}
=item $c->read_buffer([$new_value])
Bytes read by $c->get_request, but not used are placed in the I. The next time $c->get_request is called it will consume the
bytes in this buffer before reading more data from the network
connection itself. The read buffer is invalid after $c->get_request
has returned an undefined value.
If you handle the reading of the request content yourself you need to
empty this buffer before you read more and you need to place
unconsumed bytes here. You also need this buffer if you implement
services like I<101 Switching Protocols>.
This method always return the old buffer content and can optionally
replace the buffer content if you pass it an argument.
=cut
sub read_buffer
{
my $self = shift;
my $old = ${*$self}{'httpd_rbuf'};
if (@_) {
${*$self}{'httpd_rbuf'} = shift;
}
$old;
}
=item $c->reason
When $c->get_request returns C you can obtain a short string
describing why it happened by calling $c->reason.
=cut
sub reason
{
my $self = shift;
my $old = ${*$self}{'httpd_reason'};
if (@_) {
${*$self}{'httpd_reason'} = shift;
}
$old;
}
=item $c->proto_ge($proto)
Return TRUE if the client announced a protocol with version number
greater or equal to the given argument. The $proto argument can be a
string like "HTTP/1.1" or just "1.1".
=cut
sub proto_ge
{
my $self = shift;
${*$self}{'httpd_client_proto'} >= _http_version(shift);
}
sub _http_version
{
local($_) = shift;
return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
$1 * 1000 + $2;
}
=item $c->antique_client
Return TRUE if the client speaks the HTTP/0.9 protocol. No status
code and no headers should be returned to such a client. This should
be the same as !$c->proto_ge("HTTP/1.0").
=cut
sub antique_client
{
my $self = shift;
${*$self}{'httpd_client_proto'} < $HTTP_1_0;
}
=item $c->force_last_request
Make sure that $c->get_request will not try to read more requests off
this connection. If you generate a response that is not self
delimiting, then you should signal this fact by calling this method.
This attribute is turned on automatically if the client announces
protocol HTTP/1.0 or worse and does not include a "Connection:
Keep-Alive" header. It is also turned on automatically when HTTP/1.1
or better clients send the "Connection: close" request header.
=cut
sub force_last_request
{
my $self = shift;
${*$self}{'httpd_nomore'}++;
}
=item $c->send_status_line( [$code, [$mess, [$proto]]] )
Send the status line back to the client. If $code is omitted 200 is
assumed. If $mess is omitted, then a message corresponding to $code
is inserted. If $proto is missing the content of the
$HTTP::Daemon::PROTO variable is used.
=cut
sub send_status_line
{
my($self, $status, $message, $proto) = @_;
return if $self->antique_client;
$status ||= RC_OK;
$message ||= status_message($status) || "";
$proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
print $self "$proto $status $message$CRLF";
}
=item $c->send_crlf
Send the CRLF sequence to the client.
=cut
sub send_crlf
{
my $self = shift;
print $self $CRLF;
}
=item $c->send_basic_header( [$code, [$mess, [$proto]]] )
Send the status line and the "Date:" and "Server:" headers back to
the client. This header is assumed to be continued and does not end
with an empty CRLF line.
=cut
sub send_basic_header
{
my $self = shift;
return if $self->antique_client;
$self->send_status_line(@_);
print $self "Date: ", time2str(time), $CRLF;
my $product = $self->daemon->product_tokens;
print $self "Server: $product$CRLF" if $product;
}
=item $c->send_response( [$res] )
Write a I object to the
client as a response. We try hard to make sure that the response is
self delimiting so that the connection can stay persistent for further
request/response exchanges.
The content attribute of the I object can be a normal
string or a subroutine reference. If it is a subroutine, then
whatever this callback routine returns is written back to the
client as the response content. The routine will be called until it
return an undefined or empty value. If the client is HTTP/1.1 aware
then we will use chunked transfer encoding for the response.
=cut
sub send_response
{
my $self = shift;
my $res = shift;
if (!ref $res) {
$res ||= RC_OK;
$res = HTTP::Response->new($res, @_);
}
my $content = $res->content;
my $chunked;
unless ($self->antique_client) {
my $code = $res->code;
$self->send_basic_header($code, $res->message, $res->protocol);
if ($code =~ /^(1\d\d|[23]04)$/) {
# make sure content is empty
$res->remove_header("Content-Length");
$content = "";
} elsif ($res->request && $res->request->method eq "HEAD") {
# probably OK
} elsif (ref($content) eq "CODE") {
if ($self->proto_ge("HTTP/1.1")) {
$res->push_header("Transfer-Encoding" => "chunked");
$chunked++;
} else {
$self->force_last_request;
}
} elsif (length($content)) {
$res->header("Content-Length" => length($content));
} else {
$self->force_last_request;
}
print $self $res->headers_as_string($CRLF);
print $self $CRLF; # separates headers and content
}
if (ref($content) eq "CODE") {
while (1) {
my $chunk = &$content();
last unless defined($chunk) && length($chunk);
if ($chunked) {
printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
} else {
print $self $chunk;
}
}
print $self "0$CRLF$CRLF" if $chunked; # no trailers either
} elsif (length $content) {
print $self $content;
}
}
=item $c->send_redirect( $loc, [$code, [$entity_body]] )
Send a redirect response back to the client. The location ($loc) can
be an absolute or relative URL. The $code must be one the redirect
status codes, and defaults to "301 Moved Permanently"
=cut
sub send_redirect
{
my($self, $loc, $status, $content) = @_;
$status ||= RC_MOVED_PERMANENTLY;
Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
$self->send_basic_header($status);
my $base = $self->daemon->url;
$loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
$loc = $loc->abs($base);
print $self "Location: $loc$CRLF";
if ($content) {
my $ct = $content =~ /^\s*force_last_request; # no use keeping the connection open
}
=item $c->send_error( [$code, [$error_message]] )
Send an error response back to the client. If the $code is missing a
"Bad Request" error is reported. The $error_message is a string that
is incorporated in the body of the HTML entity body.
=cut
sub send_error
{
my($self, $status, $error) = @_;
$status ||= RC_BAD_REQUEST;
Carp::croak("Status '$status' is not an error") unless is_error($status);
my $mess = status_message($status);
$error ||= "";
$mess = <$status $mess
$status $mess
$error
EOT
unless ($self->antique_client) {
$self->send_basic_header($status);
print $self "Content-Type: text/html$CRLF";
print $self "Content-Length: " . length($mess) . $CRLF;
print $self $CRLF;
}
print $self $mess;
$status;
}
=item $c->send_file_response($filename)
Send back a response with the specified $filename as content. If the
file is a directory we try to generate an HTML index of it.
=cut
sub send_file_response
{
my($self, $file) = @_;
if (-d $file) {
$self->send_dir($file);
} elsif (-f _) {
# plain file
local(*F);
sysopen(F, $file, 0) or
return $self->send_error(RC_FORBIDDEN);
binmode(F);
my($ct,$ce) = guess_media_type($file);
my($size,$mtime) = (stat _)[7,9];
unless ($self->antique_client) {
$self->send_basic_header;
print $self "Content-Type: $ct$CRLF";
print $self "Content-Encoding: $ce$CRLF" if $ce;
print $self "Content-Length: $size$CRLF" if $size;
print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
print $self $CRLF;
}
$self->send_file(\*F);
return RC_OK;
} else {
$self->send_error(RC_NOT_FOUND);
}
}
sub send_dir
{
my($self, $dir) = @_;
$self->send_error(RC_NOT_FOUND) unless -d $dir;
$self->send_error(RC_NOT_IMPLEMENTED);
}
=item $c->send_file($fd);
Copy the file to the client. The file can be a string (which
will be interpreted as a filename) or a reference to an I
or glob.
=cut
sub send_file
{
my($self, $file) = @_;
my $opened = 0;
if (!ref($file)) {
local(*F);
open(F, $file) || return undef;
binmode(F);
$file = \*F;
$opened++;
}
my $cnt = 0;
my $buf = "";
my $n;
while ($n = sysread($file, $buf, 8*1024)) {
last if !$n;
$cnt += $n;
print $self $buf;
}
close($file) if $opened;
$cnt;
}
=item $c->daemon
Return a reference to the corresponding I object.
=cut
sub daemon
{
my $self = shift;
${*$self}{'httpd_daemon'};
}
=back
=head1 SEE ALSO
RFC 2068
L, L
=head1 COPYRIGHT
Copyright 1996-2001, Gisle Aas
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
1;
cgi-bin/extlib/HTTP/Date.pm0000644002157400001440000002454007771550070022267 0ustar minnesotaviolasociety.orgusers00000000000000package HTTP::Date; # $Date: 2001/01/04 20:27:15 $
$VERSION = sprintf("%d.%02d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/);
require 5.004;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(time2str str2time);
@EXPORT_OK = qw(parse_date time2iso time2isoz);
use strict;
require Time::Local;
use vars qw(@DoW @MoY %MoY);
@DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@MoY{@MoY} = (1..12);
my %GMT_ZONE = (GMT => 1, UTC => 1, UT => 1, Z => 1);
sub time2str (;$)
{
my $time = shift;
$time = time unless defined $time;
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
$DoW[$wday],
$mday, $MoY[$mon], $year+1900,
$hour, $min, $sec);
}
sub str2time ($;$)
{
my $str = shift;
return undef unless defined $str;
# fast exit for strictly conforming string
if ($str =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/) {
return eval {
my $t = Time::Local::timegm($6, $5, $4, $1, $MoY{$2}-1, $3-1900);
$t < 0 ? undef : $t;
};
}
my @d = parse_date($str);
return undef unless @d;
$d[0] -= 1900; # year
$d[1]--; # month
my $tz = pop(@d);
unless (defined $tz) {
unless (defined($tz = shift)) {
return eval { my $t = Time::Local::timelocal(reverse @d);
$t < 0 ? undef : $t;
};
}
}
my $offset = 0;
if ($GMT_ZONE{uc $tz}) {
# offset already zero
}
elsif ($tz =~ /^([-+])?(\d\d?):?(\d\d)?$/) {
$offset = 3600 * $2;
$offset += 60 * $3 if $3;
$offset *= -1 if $1 && $1 eq '-';
}
else {
eval { require Time::Zone } || return undef;
$offset = Time::Zone::tz_offset($tz);
return undef unless defined $offset;
}
return eval { my $t = Time::Local::timegm(reverse @d);
$t < 0 ? undef : $t - $offset;
};
}
sub parse_date ($)
{
local($_) = shift;
return unless defined;
# More lax parsing below
s/^\s+//; # kill leading space
s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday
my($day, $mon, $yr, $hr, $min, $sec, $tz, $ampm);
# Then we are able to check for most of the formats with this regexp
(($day,$mon,$yr,$hr,$min,$sec,$tz) =
/^
(\d\d?) # day
(?:\s+|[-\/])
(\w+) # month
(?:\s+|[-\/])
(\d+) # year
(?:
(?:\s+|:) # separator before clock
(\d\d?):(\d\d) # hour:min
(?::(\d\d))? # optional seconds
)? # optional clock
\s*
([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
\s*
(?:\(\w+\))? # ASCII representation of timezone in parens.
\s*$
/x)
||
# Try the ctime and asctime format
(($mon, $day, $hr, $min, $sec, $tz, $yr) =
/^
(\w{1,3}) # month
\s+
(\d\d?) # day
\s+
(\d\d?):(\d\d) # hour:min
(?::(\d\d))? # optional seconds
\s+
(?:([A-Za-z]+)\s+)? # optional timezone
(\d+) # year
\s*$ # allow trailing whitespace
/x)
||
# Then the Unix 'ls -l' date format
(($mon, $day, $yr, $hr, $min, $sec) =
/^
(\w{3}) # month
\s+
(\d\d?) # day
\s+
(?:
(\d\d\d\d) | # year
(\d{1,2}):(\d{2}) # hour:min
(?::(\d\d))? # optional seconds
)
\s*$
/x)
||
# ISO 8601 format '1996-02-29 12:00:00 -0100' and variants
(($yr, $mon, $day, $hr, $min, $sec, $tz) =
/^
(\d{4}) # year
[-\/]?
(\d\d?) # numerical month
[-\/]?
(\d\d?) # day
(?:
(?:\s+|[-:Tt]) # separator before clock
(\d\d?):?(\d\d) # hour:min
(?::?(\d\d(?:\.\d*)?))? # optional seconds (and fractional)
)? # optional clock
\s*
([-+]?\d\d?:?(:?\d\d)?
|Z|z)? # timezone (Z is "zero meridian", i.e. GMT)
\s*$
/x)
||
# Windows 'dir' 11-12-96 03:52PM
(($mon, $day, $yr, $hr, $min, $ampm) =
/^
(\d{2}) # numerical month
-
(\d{2}) # day
-
(\d{2}) # year
\s+
(\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM
\s*$
/x)
||
return; # unrecognized format
# Translate month name to number
$mon = $MoY{$mon} ||
$MoY{"\u\L$mon"} ||
($mon >= 1 && $mon <= 12 && int($mon)) ||
return;
# If the year is missing, we assume first date before the current,
# because of the formats we support such dates are mostly present
# on "ls -l" listings.
unless (defined $yr) {
my $cur_mon;
($cur_mon, $yr) = (localtime)[4, 5];
$yr += 1900;
$cur_mon++;
$yr-- if $mon > $cur_mon;
}
elsif (length($yr) < 3) {
# Find "obvious" year
my $cur_yr = (localtime)[5] + 1900;
my $m = $cur_yr % 100;
my $tmp = $yr;
$yr += $cur_yr - $m;
$m -= $tmp;
$yr += ($m > 0) ? 100 : -100
if abs($m) > 50;
}
# Make sure clock elements are defined
$hr = 0 unless defined($hr);
$min = 0 unless defined($min);
$sec = 0 unless defined($sec);
# Compensate for AM/PM
if ($ampm) {
$ampm = uc $ampm;
$hr = 0 if $hr == 12 && $ampm eq 'AM';
$hr += 12 if $ampm eq 'PM' && $hr != 12;
}
return($yr, $mon, $day, $hr, $min, $sec, $tz)
if wantarray;
if (defined $tz) {
$tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/;
} else {
$tz = "";
}
return sprintf("%04d-%02d-%02d %02d:%02d:%02d%s",
$yr, $mon, $day, $hr, $min, $sec, $tz);
}
sub time2iso (;$)
{
my $time = shift;
$time = time unless defined $time;
my($sec,$min,$hour,$mday,$mon,$year) = localtime($time);
sprintf("%04d-%02d-%02d %02d:%02d:%02d",
$year+1900, $mon+1, $mday, $hour, $min, $sec);
}
sub time2isoz (;$)
{
my $time = shift;
$time = time unless defined $time;
my($sec,$min,$hour,$mday,$mon,$year) = gmtime($time);
sprintf("%04d-%02d-%02d %02d:%02d:%02dZ",
$year+1900, $mon+1, $mday, $hour, $min, $sec);
}
1;
__END__
=head1 NAME
HTTP::Date - date conversion routines
=head1 SYNOPSIS
use HTTP::Date;
$string = time2str($time); # Format as GMT ASCII time
$time = str2time($string); # convert ASCII date to machine time
=head1 DESCRIPTION
This module provides functions that deal the date formats used by the
HTTP protocol (and then some more). Only the first two functions,
time2str() and str2time(), are exported by default.
=over 4
=item time2str( [$time] )
The time2str() function converts a machine time (seconds since epoch)
to a string. If the function is called without an argument, it will
use the current time.
The string returned is in the format preferred for the HTTP protocol.
This is a fixed length subset of the format defined by RFC 1123,
represented in Universal Time (GMT). An example of a time stamp
in this format is:
Sun, 06 Nov 1994 08:49:37 GMT
=item str2time( $str [, $zone] )
The str2time() function converts a string to machine time. It returns
C if the format of $str is unrecognized, or the time is outside
the representable range. The time formats recognized are the same as
for parse_date().
The function also takes an optional second argument that specifies the
default time zone to use when converting the date. This parameter is
ignored if the zone is found in the date string itself. If this
parameter is missing, and the date string format does not contain any
zone specification, then the local time zone is assumed.
If the zone is not "C" or numerical (like "C<-0800>" or
"C<+0100>"), then the C module must be installed in order
to get the date recognized.
=item parse_date( $str )
This function will try to parse a date string, and then return it as a
list of numerical values followed by a (possible undefined) time zone
specifier; ($year, $month, $day, $hour, $min, $sec, $tz). The $year
returned will B have the number 1900 subtracted from it and the
$month numbers start with 1.
In scalar context the numbers are interpolated in a string of the
"YYYY-MM-DD hh:mm:ss TZ"-format and returned.
If the date is unrecognized, then the empty list is returned.
The function is able to parse the following formats:
"Wed, 09 Feb 1994 22:23:32 GMT" -- HTTP format
"Thu Feb 3 17:03:55 GMT 1994" -- ctime(3) format
"Thu Feb 3 00:00:00 1994", -- ANSI C asctime() format
"Tuesday, 08-Feb-94 14:15:29 GMT" -- old rfc850 HTTP format
"Tuesday, 08-Feb-1994 14:15:29 GMT" -- broken rfc850 HTTP format
"03/Feb/1994:17:03:55 -0700" -- common logfile format
"09 Feb 1994 22:23:32 GMT" -- HTTP format (no weekday)
"08-Feb-94 14:15:29 GMT" -- rfc850 format (no weekday)
"08-Feb-1994 14:15:29 GMT" -- broken rfc850 format (no weekday)
"1994-02-03 14:15:29 -0100" -- ISO 8601 format
"1994-02-03 14:15:29" -- zone is optional
"1994-02-03" -- only date
"1994-02-03T14:15:29" -- Use T as separator
"19940203T141529Z" -- ISO 8601 compact format
"19940203" -- only date
"08-Feb-94" -- old rfc850 HTTP format (no weekday, no time)
"08-Feb-1994" -- broken rfc850 HTTP format (no weekday, no time)
"09 Feb 1994" -- proposed new HTTP format (no weekday, no time)
"03/Feb/1994" -- common logfile format (no time, no offset)
"Feb 3 1994" -- Unix 'ls -l' format
"Feb 3 17:03" -- Unix 'ls -l' format
"11-15-96 03:52PM" -- Windows 'dir' format
The parser ignores leading and trailing whitespace. It also allow the
seconds to be missing and the month to be numerical in most formats.
If the year is missing, then we assume that the date is the first
matching date I current month. If the year is given with only
2 digits, then parse_date() will select the century that makes the
year closest to the current date.
=item time2iso( [$time] )
Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted
string representing time in the local time zone.
=item time2isoz( [$time] )
Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted
string representing Universal Time.
=back
=head1 SEE ALSO
L, L
=head1 COPYRIGHT
Copyright 1995-1999, Gisle Aas
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
cgi-bin/extlib/HTTP/Headers.pm0000644002157400001440000004307107771550070022765 0ustar minnesotaviolasociety.orgusers00000000000000package HTTP::Headers;
# $Id: Headers.pm,v 1.43 2001/11/15 06:19:22 gisle Exp $
=head1 NAME
HTTP::Headers - Class encapsulating HTTP Message headers
=head1 SYNOPSIS
require HTTP::Headers;
$h = HTTP::Headers->new;
$h->header('Content-Type' => 'text/plain'); # set
$ct = $h->header('Content-Type'); # get
$h->remove_header('Content-Type'); # delete
=head1 DESCRIPTION
The C class encapsulates HTTP-style message headers.
The headers consist of attribute-value pairs also called fields, which
may be repeated, and which are printed in a particular order.
Instances of this class are usually created as member variables of the
C and C classes, internal to the
library.
The following methods are available:
=over 4
=cut
use strict;
use Carp ();
use vars qw($VERSION $TRANSLATE_UNDERSCORE);
$VERSION = sprintf("%d.%02d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/);
# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
# as a replacement for '-' in header field names.
$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
# "Good Practice" order of HTTP message headers:
# - General-Headers
# - Request-Headers
# - Response-Headers
# - Entity-Headers
my @header_order = qw(
Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
Via Warning
Accept Accept-Charset Accept-Encoding Accept-Language
Authorization Expect From Host
If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
Max-Forwards Proxy-Authorization Range Referer TE User-Agent
Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
Vary WWW-Authenticate
Allow Content-Encoding Content-Language Content-Length Content-Location
Content-MD5 Content-Range Content-Type Expires Last-Modified
);
# Make alternative representations of @header_order. This is used
# for sorting and case matching.
my %header_order;
my %standard_case;
{
my $i = 0;
for (@header_order) {
my $lc = lc $_;
$header_order{$lc} = ++$i;
$standard_case{$lc} = $_;
}
}
=item $h = HTTP::Headers->new
Constructs a new C object. You might pass some initial
attribute-value pairs as parameters to the constructor. I:
$h = HTTP::Headers->new(
Date => 'Thu, 03 Feb 1994 00:00:00 GMT',
Content_Type => 'text/html; version=3.2',
Content_Base => 'http://www.perl.org/');
The constructor arguments are passed to the C method which is
described below.
=cut
sub new
{
my($class) = shift;
my $self = bless {}, $class;
$self->header(@_); # set up initial headers
$self;
}
=item $h->header($field [=> $value],...)
Get or set the value of one or more header fields. The header field name
($field) is not case sensitive. To make the life easier for perl
users who wants to avoid quoting before the => operator, you can use
'_' as a replacement for '-' in header names (this behaviour can be
suppressed by setting the $HTTP::Headers::TRANSLATE_UNDERSCORE
variable to a FALSE value).
The header() method accepts multiple ($field => $value) pairs, which
means that you can update several fields with a single invocation.
The $value argument may be a plain string or a reference to an array
of strings for a multi-valued field. If the $value is undefined or not
given, then that header field will remain unchanged.
The old value (or values) of the last of the header fields is returned.
If no such field exists C will be returned.
A multi-valued field will be retuned as separate values in list
context and will be concatenated with ", " as separator in scalar
context. The HTTP spec (RFC 2616) promise that joining multiple
values in this way will not change the semantic of a header field, but
in practice there are cases like old-style Netscape cookies (see
L) where "," is used as part of the syntax of a single
field value.
Examples:
$header->header(MIME_Version => '1.0',
User_Agent => 'My-Web-Client/0.01');
$header->header(Accept => "text/html, text/plain, image/*");
$header->header(Accept => [qw(text/html text/plain image/*)]);
@accepts = $header->header('Accept'); # get multiple values
$accepts = $header->header('Accept'); # get values as a single string
=cut
sub header
{
my $self = shift;
my(@old);
while (my($field, $val) = splice(@_, 0, 2)) {
@old = $self->_header($field, $val);
}
return @old if wantarray;
return $old[0] if @old <= 1;
join(", ", @old);
}
=item $h->push_header($field, $value)
Add a new field value for the specified header field. Previous values
for the same field are retained.
As for the header() method, the field name ($field) is not case
sensitive and '_' can be used as a replacement for '-'.
The $value argument may be a scalar or a reference to a list of
scalars.
$header->push_header(Accept => 'image/jpeg');
$header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
=cut
sub push_header
{
Carp::croak('Usage: $h->push_header($field, $val)') if @_ != 3;
shift->_header(@_, 'PUSH');
}
=item $h->init_header($field, $value)
Set the specified header to the given value, but only if no previous
value for that field is set.
The header field name ($field) is not case sensitive and '_'
can be used as a replacement for '-'.
The $value argument may be a scalar or a reference to a list of
scalars.
=cut
sub init_header
{
Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
shift->_header(@_, 'INIT');
}
=item $h->remove_header($field,...)
This function removes the headers fields with the specified names.
The header field names ($field) are not case sensitive and '_'
can be used as a replacement for '-'.
The return value is the values of the fields removed. In scalar
context the number of fields removed is returned.
Note that if you pass in multiple field names then it is generally not
possible to tell which of the returned values belonged to which field.
=cut
sub remove_header
{
my($self, @fields) = @_;
my $field;
my @values;
foreach $field (@fields) {
$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
my $v = delete $self->{lc $field};
push(@values, ref($v) ? @$v : $v) if defined $v;
}
return @values;
}
sub _header
{
my($self, $field, $val, $op) = @_;
$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
# $push is only used interally sub push_header
Carp::croak('Need a field name') unless length($field);
my $lc_field = lc $field;
unless(defined $standard_case{$lc_field}) {
# generate a %standard_case entry for this field
$field =~ s/\b(\w)/\u$1/g;
$standard_case{$lc_field} = $field;
}
my $h = $self->{$lc_field};
my @old = ref($h) ? @$h : (defined($h) ? ($h) : ());
$op ||= "";
$val = undef if $op eq 'INIT' && @old;
if (defined($val)) {
my @new = ($op eq 'PUSH') ? @old : ();
if (!ref($val)) {
push(@new, $val);
} elsif (ref($val) eq 'ARRAY') {
push(@new, @$val);
} else {
Carp::croak("Unexpected field value $val");
}
$self->{$lc_field} = @new > 1 ? \@new : $new[0];
}
@old;
}
# Compare function which makes it easy to sort headers in the
# recommended "Good Practice" order.
sub _header_cmp
{
($header_order{$a} || 999) <=> ($header_order{$b} || 999) || $a cmp $b;
}
=item $h->scan(\&doit)
Apply a subroutine to each header field in turn. The callback routine
is called with two parameters; the name of the field and a single
value (a string). If a header field is multi-valued, then the
routine is called once for each value. The field name passed to the
callback routine has case as suggested by HTTP spec, and the headers
will be visited in the recommended "Good Practice" order.
Any return values of the callback routine are ignored. The loop can
be broken by raising an exception (C).
=cut
sub scan
{
my($self, $sub) = @_;
my $key;
foreach $key (sort _header_cmp keys %$self) {
next if $key =~ /^_/;
my $vals = $self->{$key};
if (ref($vals)) {
my $val;
for $val (@$vals) {
&$sub($standard_case{$key} || $key, $val);
}
} else {
&$sub($standard_case{$key} || $key, $vals);
}
}
}
=item $h->as_string([$endl])
Return the header fields as a formatted MIME header. Since it
internally uses the C method to build the string, the result
will use case as suggested by HTTP spec, and it will follow
recommended "Good Practice" of ordering the header fieds. Long header
values are not folded.
The optional $endl parameter specifies the line ending sequence to
use. The default is "\n". Embedded "\n" characters in header field
values will be substitued with this line ending sequence.
=cut
sub as_string
{
my($self, $endl) = @_;
$endl = "\n" unless defined $endl;
my @result = ();
$self->scan(sub {
my($field, $val) = @_;
if ($val =~ /\n/) {
# must handle header values with embedded newlines with care
$val =~ s/\s+$//; # trailing newlines and space must go
$val =~ s/\n\n+/\n/g; # no empty lines
$val =~ s/\n([^\040\t])/\n $1/g; # intial space for continuation
$val =~ s/\n/$endl/g; # substitute with requested line ending
}
push(@result, "$field: $val");
});
join($endl, @result, '');
}
=item $h->clone
Returns a copy of this C object.
=back
=cut
sub clone
{
my $self = shift;
my $clone = new HTTP::Headers;
$self->scan(sub { $clone->push_header(@_);} );
$clone;
}
=head1 CONVENIENCE METHODS
The most frequently used headers can also be accessed through the
following convenience methods. These methods can both be used to read
and to set the value of a header. The header value is set if you pass
an argument to the method. The old header value is always returned.
If the given header did not exists then C is returned.
Methods that deal with dates/times always convert their value to system
time (seconds since Jan 1, 1970) and they also expect this kind of
value when the header value is set.
=over 4
=item $h->date
This header represents the date and time at which the message was
originated. I:
$h->date(time); # set current date
=item $h->expires
This header gives the date and time after which the entity should be
considered stale.
=item $h->if_modified_since
=item $h->if_unmodified_since
These header fields are used to make a request conditional. If the requested
resource has (or has not) been modified since the time specified in this field,
then the server will return a C<304 Not Modified> response instead of
the document itself.
=item $h->last_modified
This header indicates the date and time at which the resource was last
modified. I:
# check if document is more than 1 hour old
if (my $last_mod = $h->last_modified) {
if ($last_mod < time - 60*60) {
...
}
}
=item $h->content_type
The Content-Type header field indicates the media type of the message
content. I:
$h->content_type('text/html');
The value returned will be converted to lower case, and potential
parameters will be chopped off and returned as a separate value if in
an array context. This makes it safe to do the following:
if ($h->content_type eq 'text/html') {
# we enter this place even if the real header value happens to
# be 'TEXT/HTML; version=3.0'
...
}
=item $h->content_encoding
The Content-Encoding header field is used as a modifier to the
media type. When present, its value indicates what additional
encoding mechanism has been applied to the resource.
=item $h->content_length
A decimal number indicating the size in bytes of the message content.
=item $h->content_language
The natural language(s) of the intended audience for the message
content. The value is one or more language tags as defined by RFC
1766. Eg. "no" for some kind of Norwegian and "en-US" for English the
way it is written in the US.
=item $h->title
The title of the document. In libwww-perl this header will be
initialized automatically from the ETITLE>...E/TITLE> element
of HTML documents. I
=item $h->user_agent
This header field is used in request messages and contains information
about the user agent originating the request. I:
$h->user_agent('Mozilla/1.2');
=item $h->server
The server header field contains information about the software being
used by the originating server program handling the request.
=item $h->from
This header should contain an Internet e-mail address for the human
user who controls the requesting user agent. The address should be
machine-usable, as defined by RFC822. E.g.:
$h->from('King Kong ');
I
=item $h->referer
Used to specify the address (URI) of the document from which the
requested resouce address was obtained.
The "Free On-line Dictionary of Computing" as this to say about the
word I:
A misspelling of "referrer" which
somehow made it into the {HTTP} standard. A given {web
page}'s referer (sic) is the {URL} of whatever web page
contains the link that the user followed to the current
page. Most browsers pass this information as part of a
request.
(1998-10-19)
By popular demand C exists as an alias for this method so you
can avoid this misspelling in your programs and still send the right
thing on the wire.
=item $h->www_authenticate
This header must be included as part of a C<401 Unauthorized> response.
The field value consist of a challenge that indicates the
authentication scheme and parameters applicable to the requested URI.
=item $h->proxy_authenticate
This header must be included in a C<407 Proxy Authentication Required>
response.
=item $h->authorization
=item $h->proxy_authorization
A user agent that wishes to authenticate itself with a server or a
proxy, may do so by including these headers.
=item $h->authorization_basic
This method is used to get or set an authorization header that use the
"Basic Authentication Scheme". In array context it will return two
values; the user name and the password. In scalar context it will
return I<"uname:password"> as a single string value.
When used to set the header value, it expects two arguments. I:
$h->authorization_basic($uname, $password);
The method will croak if the $uname contains a colon ':'.
=item $h->proxy_authorization_basic
Same as authorization_basic() but will set the "Proxy-Authorization"
header instead.
=back
=cut
sub _date_header
{
require HTTP::Date;
my($self, $header, $time) = @_;
my($old) = $self->_header($header);
if (defined $time) {
$self->_header($header, HTTP::Date::time2str($time));
}
HTTP::Date::str2time($old);
}
sub date { shift->_date_header('Date', @_); }
sub expires { shift->_date_header('Expires', @_); }
sub if_modified_since { shift->_date_header('If-Modified-Since', @_); }
sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
sub last_modified { shift->_date_header('Last-Modified', @_); }
# This is used as a private LWP extention. The Client-Date header is
# added as a timestamp to a response when it has been received.
sub client_date { shift->_date_header('Client-Date', @_); }
# The retry_after field is dual format (can also be a expressed as
# number of seconds from now), so we don't provide an easy way to
# access it until we have know how both these interfaces can be
# addressed. One possibility is to return a negative value for
# relative seconds and a positive value for epoch based time values.
#sub retry_after { shift->_date_header('Retry-After', @_); }
sub content_type {
my $ct = (shift->_header('Content-Type', @_))[0];
return '' unless defined($ct) && length($ct);
my @ct = split(/\s*;\s*/, lc($ct));
wantarray ? @ct : $ct[0];
}
sub title { (shift->_header('Title', @_))[0] }
sub content_encoding { (shift->_header('Content-Encoding', @_))[0] }
sub content_language { (shift->_header('Content-Language', @_))[0] }
sub content_length { (shift->_header('Content-Length', @_))[0] }
sub user_agent { (shift->_header('User-Agent', @_))[0] }
sub server { (shift->_header('Server', @_))[0] }
sub from { (shift->_header('From', @_))[0] }
sub referer { (shift->_header('Referer', @_))[0] }
*referrer = \&referer; # on tchrist's request
sub warning { (shift->_header('Warning', @_))[0] }
sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
sub authorization { (shift->_header('Authorization', @_))[0] }
sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] }
sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
sub authorization_basic { shift->_basic_auth("Authorization", @_) }
sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
sub _basic_auth {
require MIME::Base64;
my($self, $h, $user, $passwd) = @_;
my($old) = $self->_header($h);
if (defined $user) {
Carp::croak("Basic authorization user name can't contain ':'")
if $user =~ /:/;
$passwd = '' unless defined $passwd;
$self->_header($h => 'Basic ' .
MIME::Base64::encode("$user:$passwd", ''));
}
if (defined $old && $old =~ s/^\s*Basic\s+//) {
my $val = MIME::Base64::decode($old);
return $val unless wantarray;
return split(/:/, $val, 2);
}
return;
}
=head1 COPYRIGHT
Copyright 1995-2001 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
1;
cgi-bin/extlib/HTTP/Message.pm0000644002157400001440000001127207771550070022774 0ustar minnesotaviolasociety.orgusers00000000000000#
# $Id: Message.pm,v 1.25 2001/11/15 06:42:23 gisle Exp $
package HTTP::Message;
=head1 NAME
HTTP::Message - Class encapsulating HTTP messages
=head1 SYNOPSIS
package HTTP::Request; # or HTTP::Response
require HTTP::Message;
@ISA=qw(HTTP::Message);
=head1 DESCRIPTION
An C object contains some headers and a content (body).
The class is abstract, i.e. it only used as a base class for
C and C and should never instantiated
as itself.
The following methods are available:
=over 4
=cut
#####################################################################
require HTTP::Headers;
require Carp;
use strict;
use vars qw($VERSION $AUTOLOAD);
$VERSION = sprintf("%d.%02d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/);
$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
eval "require $HTTP::URI_CLASS"; die $@ if $@;
=item $mess = HTTP::Message->new
This is the object constructor. It should only be called internally
by this library. External code should construct C or
C objects.
=cut
sub new
{
my($class, $header, $content) = @_;
if (defined $header) {
Carp::croak("Bad header argument") unless ref $header;
$header = $header->clone;
} else {
$header = HTTP::Headers->new;
}
$content = '' unless defined $content;
bless {
'_headers' => $header,
'_content' => $content,
}, $class;
}
=item $mess->clone()
Returns a copy of the object.
=cut
sub clone
{
my $self = shift;
my $clone = HTTP::Message->new($self->{'_headers'}, $self->{'_content'});
$clone;
}
=item $mess->protocol([$proto])
Sets the HTTP protocol used for the message. The protocol() is a string
like C or C.
=cut
sub protocol { shift->_elem('_protocol', @_); }
=item $mess->content([$content])
The content() method sets the content if an argument is given. If no
argument is given the content is not touched. In either case the
previous content is returned.
=item $mess->add_content($data)
The add_content() methods appends more data to the end of the current
content buffer.
=cut
sub content { shift->_elem('_content', @_); }
sub add_content
{
my $self = shift;
if (ref($_[0])) {
$self->{'_content'} .= ${$_[0]}; # for backwards compatability
} else {
$self->{'_content'} .= $_[0];
}
}
=item $mess->content_ref
The content_ref() method will return a reference to content buffer string.
It can be more efficient to access the content this way if the content
is huge, and it can even be used for direct manipulation of the content,
for instance:
${$res->content_ref} =~ s/\bfoo\b/bar/g;
=cut
sub content_ref
{
my $self = shift;
\$self->{'_content'};
}
sub as_string
{
""; # To be overridden in subclasses
}
=item $mess->headers;
Return the embedded HTTP::Headers object.
=item $mess->headers_as_string([$endl])
Call the as_string() method for the headers in the
message. This will be the same as:
$mess->headers->as_string
but it will make your program a whole character shorter :-)
=cut
sub headers { shift->{'_headers'}; }
sub headers_as_string { shift->{'_headers'}->as_string(@_); }
=back
All unknown C methods are delegated to the
C object that is part of every message. This allows
convenient access to these methods. Refer to L for
details of these methods:
$mess->header($field => $val);
$mess->push_header($field => $val);
$mess->init_header($field => $val);
$mess->remove_header($field);
$mess->scan(\&doit);
$mess->date;
$mess->expires;
$mess->if_modified_since;
$mess->if_unmodified_since;
$mess->last_modified;
$mess->content_type;
$mess->content_encoding;
$mess->content_length;
$mess->content_language
$mess->title;
$mess->user_agent;
$mess->server;
$mess->from;
$mess->referer;
$mess->www_authenticate;
$mess->authorization;
$mess->proxy_authorization;
$mess->authorization_basic;
$mess->proxy_authorization_basic;
=cut
# delegate all other method calls the the _headers object.
sub AUTOLOAD
{
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
return if $method eq "DESTROY";
# We create the function here so that it will not need to be
# autoloaded the next time.
no strict 'refs';
*$method = eval "sub { shift->{'_headers'}->$method(\@_) }";
goto &$method;
}
# Private method to access members in %$self
sub _elem
{
my $self = shift;
my $elem = shift;
my $old = $self->{$elem};
$self->{$elem} = $_[0] if @_;
return $old;
}
1;
=head1 COPYRIGHT
Copyright 1995-2001 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
cgi-bin/extlib/HTTP/Negotiate.pm0000644002157400001440000003753107771550070023335 0ustar minnesotaviolasociety.orgusers00000000000000# $Id: Negotiate.pm,v 1.11 2001/11/27 22:41:33 gisle Exp $
#
package HTTP::Negotiate;
$VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/);
sub Version { $VERSION; }
require 5.002;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(choose);
require HTTP::Headers;
$DEBUG = 0;
sub choose ($;$)
{
my($variants, $request) = @_;
my(%accept);
unless (defined $request) {
# Create a request object from the CGI envirionment variables
$request = new HTTP::Headers;
$request->header('Accept', $ENV{HTTP_ACCEPT})
if $ENV{HTTP_ACCEPT};
$request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
if $ENV{HTTP_ACCEPT_CHARSET};
$request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
if $ENV{HTTP_ACCEPT_ENCODING};
$request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
if $ENV{HTTP_ACCEPT_LANGUAGE};
}
# Get all Accept values from the request. Build a hash initialized
# like this:
#
# %accept = ( type => { 'audio/*' => { q => 0.2, mbx => 20000 },
# 'audio/basic' => { q => 1 },
# },
# language => { 'no' => { q => 1 },
# }
# );
$request->scan(sub {
my($key, $val) = @_;
my $type;
if ($key =~ s/^Accept-//) {
$type = lc($key);
}
elsif ($key eq "Accept") {
$type = "type";
}
else {
return;
}
$val =~ s/\s+//g;
my $default_q = 1;
for my $name (split(/,/, $val)) {
my(%param, $param);
if ($name =~ s/;(.*)//) {
for $param (split(/;/, $1)) {
my ($pk, $pv) = split(/=/, $param, 2);
$param{lc $pk} = $pv;
}
}
$name = lc $name;
if (defined $param{'q'}) {
$param{'q'} = 1 if $param{'q'} > 1;
$param{'q'} = 0 if $param{'q'} < 0;
} else {
$param{'q'} = $default_q;
# This makes sure that the first ones are slightly better off
# and therefore more likely to be chosen.
$default_q -= 0.0001;
}
$accept{$type}{$name} = \%param;
}
});
# Check if any of the variants specify a language. We do this
# because it influences how we treat those without (they default to
# 0.5 instead of 1).
my $any_lang = 0;
for $var (@$variants) {
if ($var->[5]) {
$any_lang = 1;
last;
}
}
if ($DEBUG) {
print "Negotiation parameters in the request\n";
for $type (keys %accept) {
print " $type:\n";
for $name (keys %{$accept{$type}}) {
print " $name\n";
for $pv (keys %{$accept{$type}{$name}}) {
print " $pv = $accept{$type}{$name}{$pv}\n";
}
}
}
}
my @Q = (); # This is where we collect the results of the
# quality calcualtions
# Calculate quality for all the variants that are available.
for (@$variants) {
my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
$qs = 1 unless defined $qs;
$ct = '' unless defined $ct;
$bs = 0 unless defined $bs;
$lang = lc($lang) if $lang; # lg tags are always case-insensitive
if ($DEBUG) {
print "\nEvaluating $id (ct='$ct')\n";
printf " qs = %.3f\n", $qs;
print " enc = $enc\n" if $enc && !ref($enc);
print " enc = @$enc\n" if $enc && ref($enc);
print " cs = $cs\n" if $cs;
print " lang = $lang\n" if $lang;
print " bs = $bs\n" if $bs;
}
# Calculate encoding quality
my $qe = 1;
# If the variant has no assignes Content-Encoding, or if no
# Accept-Encoding field is present, then the value assigned
# is "qe=1". If *all* of the variant's content encoddings
# are listed in the Accept-Encoding field, then the value
# assigned is "qw=1". If *any* of the variant's content
# encodings are not listed in the provided Accept-Encoding
# field, then the value assigned is "qe=0"
if (exists $accept{'encoding'} && $enc) {
my @enc = ref($enc) ? @$enc : ($enc);
for (@enc) {
print "Is encoding $_ accepted? " if $DEBUG;
unless(exists $accept{'encoding'}{$_}) {
print "no\n" if $DEBUG;
$qe = 0;
last;
} else {
print "yes\n" if $DEBUG;
}
}
}
# Calculate charset quality
my $qc = 1;
# If the variant's media-type has not charset parameter,
# or the variant's charset is US-ASCII, or if no Accept-Charset
# field is present, then the value assigned is "qc=1". If the
# variant's charset is listed in the Accept-Charset field,
# then the value assigned is "qc=1. Otherwise, if the variant's
# charset is not listed in the provided Accept-Encoding field,
# then the value assigned is "qc=0".
if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) {
$qc = 0 unless $accept{'charset'}{$cs};
}
# Calculate language quality
my $ql = 1;
if ($lang && exists $accept{'language'}) {
my @lang = ref($lang) ? @$lang : ($lang);
# If any of the variant's content languages are listed
# in the Accept-Language field, the the value assigned is
# the maximus of the "q" paramet values for thos language
# tags.
my $q = undef;
for (@lang) {
next unless exists $accept{'language'}{$_};
my $this_q = $accept{'language'}{$_}{'q'};
$q = $this_q unless defined $q;
$q = $this_q if $this_q > $q;
}
if(defined $q) {
$DEBUG and print " -- Exact language match at q=$q\n";
} else {
# If there was no exact match and at least one of
# the Accept-Language field values is a complete
# subtag prefix of the content language tag(s), then
# the "q" parameter value of the largest matching
# prefix is used.
$DEBUG and print " -- No exact language match\n";
my $selected = undef;
for $al (keys %{ $accept{'language'} }) {
if (substr($lang, 0, 1 + length($al)) eq "$al-") {
# $lang starting with $al isn't enough, or else
# Accept-Language: hu (Hungarian) would seem
# to accept a document in hup (Hupa)
$DEBUG and print " -- $lang ISA $al\n";
$selected = $al unless defined $selected;
$selected = $al if length($al) > length($selected);
} else {
$DEBUG and print " -- $lang isn't a $al\n";
}
}
$q = $accept{'language'}{$selected}{'q'} if $selected;
# If none of the variant's content language tags or
# tag prefixes are listed in the provided
# Accept-Language field, then the value assigned
# is "ql=0.001"
$q = 0.001 unless defined $q;
}
$ql = $q;
} else {
$ql = 0.5 if $any_lang && exists $accept{'language'};
}
my $q = 1;
my $mbx = undef;
# If no Accept field is given, then the value assigned is "q=1".
# If at least one listed media range matches the variant's media
# type, then the "q" parameter value assigned to the most specific
# of those matched is used (e.g. "text/html;version=3.0" is more
# specific than "text/html", which is more specific than "text/*",
# which in turn is more specific than "*/*"). If not media range
# in the provided Accept field matches the variant's media type,
# then the value assigned is "q=0".
if (exists $accept{'type'} && $ct) {
# First we clean up our content-type
$ct =~ s/\s+//g;
my $params = "";
$params = $1 if $ct =~ s/;(.*)//;
my($type, $subtype) = split("/", $ct, 2);
my %param = ();
for $param (split(/;/, $params)) {
my($pk,$pv) = split(/=/, $param, 2);
$param{$pk} = $pv;
}
my $sel_q = undef;
my $sel_mbx = undef;
my $sel_specificness = 0;
ACCEPT_TYPE:
for $at (keys %{ $accept{'type'} }) {
print "Consider $at...\n" if $DEBUG;
my($at_type, $at_subtype) = split("/", $at, 2);
# Is it a match on the type
next if $at_type ne '*' && $at_type ne $type;
next if $at_subtype ne '*' && $at_subtype ne $subtype;
my $specificness = 0;
$specificness++ if $at_type ne '*';
$specificness++ if $at_subtype ne '*';
# Let's see if content-type parameters also match
while (($pk, $pv) = each %param) {
print "Check if $pk = $pv is true\n" if $DEBUG;
next unless exists $accept{'type'}{$at}{$pk};
next ACCEPT_TYPE
unless $accept{'type'}{$at}{$pk} eq $pv;
print "yes it is!!\n" if $DEBUG;
$specificness++;
}
print "Hurray, type match with specificness = $specificness\n"
if $DEBUG;
if (!defined($sel_q) || $sel_specificness < $specificness) {
$sel_q = $accept{'type'}{$at}{'q'};
$sel_mbx = $accept{'type'}{$at}{'mbx'};
$sel_specificness = $specificness;
}
}
$q = $sel_q || 0;
$mbx = $sel_mbx;
}
my $Q;
if (!defined($mbx) || $mbx >= $bs) {
$Q = $qs * $qe * $qc * $ql * $q;
} else {
$Q = 0;
print "Variant's size is too large ==> Q=0\n" if $DEBUG;
}
if ($DEBUG) {
$mbx = "undef" unless defined $mbx;
printf "Q=%.4f", $Q;
print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
}
push(@Q, [$id, $Q, $bs]);
}
@Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q;
return @Q if wantarray;
return undef unless @Q;
return undef if $Q[0][1] == 0;
$Q[0][0];
}
1;
__END__
=head1 NAME
choose - choose a variant of a document to serve (HTTP content negotiation)
=head1 SYNOPSIS
use HTTP::Negotiate;
# ID QS Content-Type Encoding Char-Set Lang Size
$variants =
[['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000],
['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400],
['var3', 0.3, 'image/gif', undef, undef, undef, 43555],
];
@prefered = choose($variants, $request_headers);
$the_one = choose($variants);
=head1 DESCRIPTION
This module provides a complete implementation of the HTTP content
negotiation algorithm specified in F
chapter 12. Content negotiation allows for the selection of a
preferred content representation based upon attributes of the
negotiable variants and the value of the various Accept* header fields
in the request.
The variants are ordered by preference by calling the function
choose().
The first parameter is reference to an array of the variants to
choose among.
Each element in this array is an array with the values [$id, $qs,
$content_type, $content_encoding, $charset, $content_language,
$content_length] whose meanings are described
below. The $content_encoding and $content_language can be either a
single scalar value or an array reference if there are several values.
The second optional parameter is either a HTTP::Headers or a HTTP::Request
object which is searched for "Accept*" headers. If this
parameter is missing, then the accept specification is initialized
from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET,
HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE.
In an array context, choose() returns a list of variant
identifier/calculated quality pairs. The values are sorted by
quality, highest quality first. If the calculated quality is the same
for two variants, then they are sorted by size (smallest first). I:
(['var1' => 1], ['var2', 0.3], ['var3' => 0]);
Note that also zero quality variants are included in the return list
even if these should never be served to the client.
In a scalar context, it returns the identifier of the variant with the
highest score or C if none have non-zero quality.
If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of
noise is generated on STDOUT during evaluation of choose().
=head1 VARIANTS
A variant is described by a list of the following values. If the
attribute does not make sense or is unknown for a variant, then use
C instead.
=over 3
=item identifier
This is a string that you use as the name for the variant. This
identifier for the preferred variants returned by choose().
=item qs
This is a number between 0.000 and 1.000 that describes the "source
quality". This is what F says about this
value:
Source quality is measured by the content provider as representing the
amount of degradation from the original source. For example, a
picture in JPEG form would have a lower qs when translated to the XBM
format, and much lower qs when translated to an ASCII-art
representation. Note, however, that this is a function of the source
- an original piece of ASCII-art may degrade in quality if it is
captured in JPEG form. The qs values should be assigned to each
variant by the content provider; if no qs value has been assigned, the
default is generally "qs=1".
=item content-type
This is the media type of the variant. The media type does not
include a charset attribute, but might contain other parameters.
Examples are:
text/html
text/html;version=2.0
text/plain
image/gif
image/jpg
=item content-encoding
This is one or more content encodings that has been applied to the
variant. The content encoding is generally used as a modifier to the
content media type. The most common content encodings are:
gzip
compress
=item content-charset
This is the character set used when the variant contains text.
The charset value should generally be C or one of these:
us-ascii
iso-8859-1 ... iso-8859-9
iso-2022-jp
iso-2022-jp-2
iso-2022-kr
unicode-1-1
unicode-1-1-utf-7
unicode-1-1-utf-8
=item content-language
This describes one or more languages that are used in the variant.
Language is described like this in F: A
language is in this context a natural language spoken, written, or
otherwise conveyed by human beings for communication of information to
other human beings. Computer languages are explicitly excluded.
The language tags are defined by RFC 3066. Examples
are:
no Norwegian
en International English
en-US US English
en-cockney
=item content-length
This is the number of bytes used to represent the content.
=back
=head1 ACCEPT HEADERS
The following Accept* headers can be used for describing content
preferences in a request (This description is an edited extract from
F):
=over 3
=item Accept
This header can be used to indicate a list of media ranges which are
acceptable as a reponse to the request. The "*" character is used to
group media types into ranges, with "*/*" indicating all media types
and "type/*" indicating all subtypes of that type.
The parameter q is used to indicate the quality factor, which
represents the user's preference for that range of media types. The
parameter mbx gives the maximum acceptable size of the response
content. The default values are: q=1 and mbx=infinity. If no Accept
header is present, then the client accepts all media types with q=1.
For example:
Accept: audio/*;q=0.2;mbx=200000, audio/basic
would mean: "I prefer audio/basic (of any size), but send me any audio
type if it is the best available after an 80% mark-down in quality and
its size is less than 200000 bytes"
=item Accept-Charset
Used to indicate what character sets are acceptable for the response.
The "us-ascii" character set is assumed to be acceptable for all user
agents. If no Accept-Charset field is given, the default is that any
charset is acceptable. Example:
Accept-Charset: iso-8859-1, unicode-1-1
=item Accept-Encoding
Restricts the Content-Encoding values which are acceptable in the
response. If no Accept-Encoding field is present, the server may
assume that the client will accept any content encoding. An empty
Accept-Encoding means that no content encoding is acceptable. Example:
Accept-Encoding: compress, gzip
=item Accept-Language
This field is similar to Accept, but restricts the set of natural
languages that are preferred in a response. Each language may be
given an associated quality value which represents an estimate of the
user's comprehension of that language. For example:
Accept-Language: no, en-gb;q=0.8, de;q=0.55
would mean: "I prefer Norwegian, but will accept British English (with
80% comprehension) or German (with 55% comprehension).
=back
=head1 COPYRIGHT
Copyright 1996,2001 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 AUTHOR
Gisle Aas
=cut
cgi-bin/extlib/HTTP/Request.pm0000644002157400001440000001032507771550070023036 0ustar minnesotaviolasociety.orgusers00000000000000#
# $Id: Request.pm,v 1.30 2001/11/15 06:42:40 gisle Exp $
package HTTP::Request;
=head1 NAME
HTTP::Request - Class encapsulating HTTP Requests
=head1 SYNOPSIS
require HTTP::Request;
$request = HTTP::Request->new(GET => 'http://www.oslo.net/');
=head1 DESCRIPTION
C is a class encapsulating HTTP style requests,
consisting of a request line, some headers, and some (potentially empty)
content. Note that the LWP library also uses this HTTP style requests
for non-HTTP protocols.
Instances of this class are usually passed to the C method
of an C object:
$ua = LWP::UserAgent->new;
$request = HTTP::Request->new(GET => 'http://www.oslo.net/');
$response = $ua->request($request);
C is a subclass of C and therefore
inherits its methods. The inherited methods most often used are header(),
push_header(), remove_header(), and content(). See L for details.
The following additional methods are available:
=over 4
=cut
require HTTP::Message;
@ISA = qw(HTTP::Message);
$VERSION = sprintf("%d.%02d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/);
use strict;
=item $r = HTTP::Request->new($method, $uri)
=item $r = HTTP::Request->new($method, $uri, $header)
=item $r = HTTP::Request->new($method, $uri, $header, $content)
Constructs a new C object describing a request on the
object C<$uri> using method C<$method>. The C<$uri> argument can be
either a string, or a reference to a C object. The optional $header
argument should be a reference to an C object.
The optional $content argument should be a string.
=cut
sub new
{
my($class, $method, $uri, $header, $content) = @_;
my $self = $class->SUPER::new($header, $content);
$self->method($method);
$self->uri($uri);
$self;
}
sub clone
{
my $self = shift;
my $clone = bless $self->SUPER::clone, ref($self);
$clone->method($self->method);
$clone->uri($self->uri);
$clone;
}
=item $r->method([$val])
=item $r->uri([$val])
These methods provide public access to the attributes containing
respectively the method of the request and the URI object of the
request.
If an argument is given the attribute is given that as its new
value. If no argument is given the value is not touched. In either
case the previous value is returned.
The method() method argument should be a string.
The uri() method accept both a reference to a URI object and a
string as its argument. If a string is given, then it should be
parseable as an absolute URI.
=cut
sub method { shift->_elem('_method', @_); }
sub uri
{
my $self = shift;
my $old = $self->{'_uri'};
if (@_) {
my $uri = shift;
if (!defined $uri) {
# that's ok
} elsif (ref $uri) {
Carp::croak("A URI can't be a " . ref($uri) . " reference")
if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
Carp::croak("Can't use a " . ref($uri) . " object as a URI")
unless $uri->can('scheme');
$uri = $uri->clone;
unless ($HTTP::URI_CLASS eq "URI") {
# Argh!! Hate this... old LWP legacy!
eval { local $SIG{__DIE__}; $uri = $uri->abs; };
die $@ if $@ && $@ !~ /Missing base argument/;
}
} else {
$uri = $HTTP::URI_CLASS->new($uri);
}
$self->{'_uri'} = $uri;
}
$old;
}
*url = \&uri; # this is the same for now
=item $r->as_string()
Method returning a textual representation of the request.
Mainly useful for debugging purposes. It takes no arguments.
=cut
sub as_string
{
my $self = shift;
my @result;
#push(@result, "---- $self -----");
my $req_line = $self->method || "[NO METHOD]";
my $uri = $self->uri;
$uri = (defined $uri) ? $uri->as_string : "[NO URI]";
$req_line .= " $uri";
my $proto = $self->protocol;
$req_line .= " $proto" if $proto;
push(@result, $req_line);
push(@result, $self->headers_as_string);
my $content = $self->content;
if (defined $content) {
push(@result, $content);
}
#push(@result, ("-" x 40));
join("\n", @result, "");
}
1;
=back
=head1 SEE ALSO
L, L, L
=head1 COPYRIGHT
Copyright 1995-2001 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
cgi-bin/extlib/HTTP/Response.pm0000644002157400001440000002275207771550070023213 0ustar minnesotaviolasociety.orgusers00000000000000#
# $Id: Response.pm,v 1.36 2001/11/15 06:42:40 gisle Exp $
package HTTP::Response;
=head1 NAME
HTTP::Response - Class encapsulating HTTP Responses
=head1 SYNOPSIS
require HTTP::Response;
=head1 DESCRIPTION
The C class encapsulates HTTP style responses. A
response consists of a response line, some headers, and (potentially
empty) content. Note that the LWP library also uses HTTP style
responses for non-HTTP protocol schemes.
Instances of this class are usually created and returned by the
C method of an C object:
#...
$response = $ua->request($request)
if ($response->is_success) {
print $response->content;
} else {
print $response->error_as_HTML;
}
C is a subclass of C and therefore
inherits its methods. The inherited methods most often used are header(),
push_header(), remove_header(), and content().
The header convenience methods are also available. See
L for details.
The following additional methods are available:
=over 4
=cut
require HTTP::Message;
@ISA = qw(HTTP::Message);
$VERSION = sprintf("%d.%02d", q$Revision: 1.36 $ =~ /(\d+)\.(\d+)/);
use HTTP::Status ();
use strict;
=item $r = HTTP::Response->new($rc, [$msg, [$header, [$content]]])
Constructs a new C object describing a response with
response code C<$rc> and optional message C<$msg>. The message is a
short human readable single line string that explains the response
code.
=cut
sub new
{
my($class, $rc, $msg, $header, $content) = @_;
my $self = $class->SUPER::new($header, $content);
$self->code($rc);
$self->message($msg);
$self;
}
sub clone
{
my $self = shift;
my $clone = bless $self->SUPER::clone, ref($self);
$clone->code($self->code);
$clone->message($self->message);
$clone->request($self->request->clone) if $self->request;
# we don't clone previous
$clone;
}
=item $r->code([$code])
=item $r->message([$message])
=item $r->request([$request])
=item $r->previous([$previousResponse])
These methods provide public access to the object attributes. The
first two contain respectively the response code and the message
of the response.
The request attribute is a reference the request that caused this
response. It does not have to be the same request as passed to the
$ua->request() method, because there might have been redirects and
authorization retries in between.
The previous attribute is used to link together chains of responses.
You get chains of responses if the first response is redirect or
unauthorized.
=cut
sub code { shift->_elem('_rc', @_); }
sub message { shift->_elem('_msg', @_); }
sub previous { shift->_elem('_previous',@_); }
sub request { shift->_elem('_request', @_); }
=item $r->status_line
Returns the string "Ecode> Emessage>". If the message attribute
is not set then the official name of Ecode> (see L