Группа :: Разработка/Perl
Пакет: perl-CGI-SSI
навигация по пакетам
Главная Изменения Спек Патчи Исходники Загрузить Gear Bugs and FR Repocop
CGI-SSI-0.92/ 0000755 0000000 0000000 00000000000 12040107173 0012473 5 ustar 00root root 0000000 0000000 CGI-SSI-0.92/Changes 0000755 0000000 0000000 00000004531 12040107173 0013774 0 ustar 00root root 0000000 0000000 Revision history for Perl extension CGI::SSI.
0.92 Wed Jul 08 2007
- newlines OK in SSI directives
0.91 Mon May 28 2007
- fixed bad LWP::UserAgent arg
- added documentation to make the scope of SSI variables more clear.
- timefmt applied to LAST_MODIFIED
0.90 Tue Apr 24 2007
- fixed bad HTTP::Cookies arg
0.89 Fri Apr 20 2007
- nested if errors fixed (with thanks to Colin Fine)
0.88 Fri Sept 2 2005
- warn on errors
- https URIs
0.87 Fri Sept 2 2005
- CLOSE
0.86 Fri Jun 17 2005
- virtual file w/ params bugfix
- added default include virtual host 'localhost'
0.85 Sat May 07 2005
- minor cookie fix
0.84 Thu May 05 2005
- added cookie support, w/ test
0.83 Thu May 05 2005
- added support for high recursion, w/ test
0.82 Tue Feb 15 2005
- config timefmt fix for DATE_LOCAL and DATE_GMT
0.81 Sun Feb 09 2005
- minor but crucial test.pl fix
0.80 Sun Jan 30 23:59:23 2005
- improved test suite
0.53 Wed Mar 14 10:07:43 2001
- added printf support for tied filehandles
0.52 Mon Feb 26 11:03:24 2001
- fixed $HTML::SimpleParse::FIX_CASE issue
0.51 Mon Feb 05 23:28:34 2001
- corrected the test suite
0.50 Mon Dec 18 15:02:37 2000
- include test suite
- remove cumbersome features (see 0.14)
- better documentation
0.14 Fri Aug 18 11:55:23 2000
- allow $ENV{QUERY_STRING} and
$ENV{QUERY_STRING_UNESCAPED} to be
visible from virtually-included
documents. The query string is passed
in as usual : "/file?query".
0.13 Tue Aug 08 15:46:25 2000
- allow for upper-case arguments, require
Date::Parse instead of Date::Format,
process all included files, add
documentation for the fact that
DOCUMENT_ROOT is a valid parameter
to import() or new().
0.11 Tue Jun 06 01:05:48 2000
- name required pm files in Makefile.PL to
allow for easy install via CPAN.pm
0.10 Thu May 18 12:01:02 2000
- various bug fixes; a total overhaul, as a
matter of fact.
0.01 Fri Jan 14 21:45:28 2000
- original version; created by h2xs 1.19
CGI-SSI-0.92/MANIFEST 0000755 0000000 0000000 00000000211 12040107173 0013621 0 ustar 00root root 0000000 0000000 Changes
MANIFEST
Makefile.PL
README
SSI.pm
test.pl
META.yml Module meta-data (added by MakeMaker)
CGI-SSI-0.92/META.yml 0000755 0000000 0000000 00000001045 12040107173 0013747 0 ustar 00root root 0000000 0000000 # http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: CGI-SSI
version: 0.92
version_from: SSI.pm
installdirs: site
requires:
Date::Format: 0
File::Spec: 0
HTML::SimpleParse: 0
HTTP::Cookies: 0
HTTP::Response: 0
LWP::UserAgent: 0
URI: 0
distribution_type: module
generated_by: ExtUtils::MakeMaker version 6.17
CGI-SSI-0.92/Makefile.PL 0000755 0000000 0000000 00000001201 12040107173 0014442 0 ustar 00root root 0000000 0000000 use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
'NAME' => 'CGI::SSI',
'VERSION_FROM' => 'SSI.pm', # finds $VERSION
'PREREQ_PM' => {
HTML::SimpleParse => 0,
File::Spec => 0,
LWP::UserAgent => 0,
HTTP::Response => 0,
HTTP::Cookies => 0,
URI => 0,
Date::Format => 0,
},
);
CGI-SSI-0.92/README 0000755 0000000 0000000 00000016131 12040107173 0013360 0 ustar 00root root 0000000 0000000 NAME
CGI::SSI - Use SSI from CGI scripts
SYNOPSIS
# autotie STDOUT or any other open filehandle
use CGI::SSI (autotie => 'STDOUT');
print $shtml; # browser sees resulting HTML
# or tie it yourself to any open filehandle
use CGI::SSI;
open(FILE,'+>'.$html_file) or die $!;
$ssi = tie(*FILE, 'CGI::SSI', filehandle => 'FILE');
print FILE $shtml; # HTML arrives in the file
# or use the object-oriented interface
use CGI::SSI;
$ssi = CGI::SSI->new();
$ssi->if('"$varname" =~ /^foo/');
$html .= $ssi->process($shtml);
$ssi->else();
$html .= $ssi->include(file => $filename);
$ssi->endif();
print $ssi->exec(cgi => $url);
print $ssi->flastmod(file => $filename);
#
# or roll your own favorite flavor of SSI
#
package CGI::SSI::MySSI;
use CGI::SSI;
@CGI::SSI::MySSI::ISA = qw(CGI::SSI);
sub include {
my($self,$type,$file_or_url) = @_;
# my idea of include goes something like this...
return $html;
}
1;
__END__
#
# or use .htaccess to include all files in a dir
#
# in .htaccess
Action cgi-ssi /cgi-bin/ssi/process.cgi
<FilesMatch "\.shtml">
SetHandler cgi-ssi
</FilesMatch>
# in /cgi-bin/ssi/process.cgi
#!/usr/local/bin/perl
use CGI::SSI;
CGI::SSI->handler();
__END__
DESCRIPTION
CGI::SSI is meant to be used as an easy way to filter shtml through CGI
scripts in a loose imitation of Apache's mod_include. If you're using
Apache, you may want to use either mod_include or the Apache::SSI module
instead of CGI::SSI. Limitations in a CGI script's knowledge of how the
server behaves make some SSI directives impossible to imitate from a CGI
script.
Most of the time, you'll simply want to filter shtml through STDOUT or
some other open filehandle. "autotie" is available for STDOUT, but in
general, you'll want to tie other filehandles yourself:
$ssi = tie(*FH, 'CGI::SSI', filehandle => 'FH');
print FH $shtml;
Note that you'll need to pass the name of the filehandle to "tie()" as a
named parameter. Other named parameters are possible, as detailed below.
These parameters are the same as those passed to the "new()" method.
However, "new()" will not tie a filehandle for you.
CGI::SSI has it's own flavor of SSI. Test expressions are Perlish. You
may create and use multiple CGI::SSI objects; they will not step on each
others' variables.
Object-Oriented methods use the same general format so as to imitate SSI
directives:
<!--#include virtual="/foo/bar.footer" -->
would be
$ssi->include(virtual => '/foo/bar.footer');
likewise,
<!--#exec cgi="/cgi-bin/foo.cgi" -->
would be
$ssi->exec(cgi => '/cgi-bin/foo.cgi');
Usually, if there's no chance for ambiguity, the first argument may be
left out:
<!--#echo var="var_name" -->
could be either
$ssi->echo(var => 'var_name');
or
$ssi->echo('var_name');
Likewise,
$ssi->set(var => $varname, value => $value)
is the same as
$ssi->set($varname => $value)
$ssi->new([%args])
Creates a new CGI::SSI object. The following are valid (optional)
arguments:
DOCUMENT_URI => $doc_uri,
DOCUMENT_NAME => $doc_name,
DOCUMENT_ROOT => $doc_root,
errmsg => $oops,
sizefmt => ('bytes' || 'abbrev'),
timefmt => $time_fmt,
MAX_RECURSIONS => $default_100, # when to stop infinite loops w/ error msg
COOKIE_JAR => HTTP::Cookies->new,
$ssi->config($type, $arg)
$type is either 'sizefmt', 'timefmt', or 'errmsg'. $arg is similar
to those of the SSI "spec", referenced below.
$ssi->set($varname => $value)
Sets variables internal to the CGI::SSI object. (Not to be confused
with the normal variables your script uses!) These variables may be
used in test expressions, and retreived using $ssi->echo($varname).
These variables also will not be available in external, included
resources.
$ssi->echo($varname)
Returns the value of the variable named $varname. Such variables may
be set manually using the "set()" method. There are also several
built-in variables:
DOCUMENT_URI - the URI of this document
DOCUMENT_NAME - the name of the current document
DATE_GMT - the same as 'gmtime'
DATE_LOCAL - the same as 'localtime'
LAST_MODIFIED - the last time this script was modified
$ssi->exec($type, $arg)
$type is either 'cmd' or 'cgi'. $arg is similar to the SSI "spec"
(see below).
$ssi->include($type, $arg)
Similar to "exec", but "virtual" and "file" are the two valid types.
SSI variables will not be available outside of your CGI::SSI object,
regardless of whether the virtual resource is on the local system or
a remote system.
$ssi->flastmod($type, $filename)
Similar to "include".
$ssi->fsize($type, $filename)
Same as "flastmod".
$ssi->printenv
Returns the environment similar to Apache's mod_include.
$ssi->cookie_jar([$jar])
Returns the currently-used HTTP::Cookies object. You may optionally
pass in a new HTTP::Cookies object. The jar is used for web requests
in exec cgi and include virtual directives.
FLOW-CONTROL METHODS
The following methods may be used to test expressions. During a "block"
where the test $expr is false, nothing will be returned (or printed, if
tied).
$ssi->if($expr)
The expr can be anything Perl, but care should be taken. This causes
problems:
$ssi->set(varname => "foo");
<!--#if expr="'\$varname' =~ /^foo$/" -->ok<!--#endif -->
The $varname is expanded as you would expect. (We escape it so as to
use the $varname within the CGI::SSI object, instead of that within
our progam.) But the $/ inside the regex is also expanded. This is
fixed by escaping the "$":
<!--#if expr="'\$varname' =~ /^value\$/" -->ok<!--#endif -->
The expressions used in if and elif tags/calls are tricky due to the
number of escapes required. In some cases, you'll need to write
"\\\\" to mean "\".
$ssi->elif($expr)
$ssi->else
$ssi->endif
SEE ALSO
"Apache::SSI" and the SSI "spec" at
http://www.apache.org/docs/mod/mod_include.html
AUTHOR
(c) 2000-2007 James Tolley <james@bitperfect.com> All Rights Reserved.
This is free software. You may copy and/or modify it under the same
terms as perl itself.
CREDITS
Many Thanks to Corey Wilson for a bug report and fix.
CGI-SSI-0.92/SSI.pm 0000755 0000000 0000000 00000060015 12040107173 0013474 0 ustar 00root root 0000000 0000000 package CGI::SSI;
use strict;
use HTML::SimpleParse;
use File::Spec::Functions; # catfile()
use FindBin;
use LWP::UserAgent;
use HTTP::Response;
use HTTP::Cookies;
use URI;
use Date::Format;
our $VERSION = '0.92';
our $DEBUG = 0;
sub import {
my($class,%args) = @_;
return unless exists $args{'autotie'};
$args{'filehandle'} = $args{'autotie'} =~ /::/ ? $args{'autotie'} : caller().'::'.$args{'autotie'};
no strict 'refs';
my $self = tie(*{$args{'filehandle'}},$class,%args);
return $self;
}
my($gmt,$loc,$lmod);
sub new {
my($class,%args) = @_;
my $self = bless {}, $class;
$self->{'_handle'} = undef;
my $script_name = '';
if(exists $ENV{'SCRIPT_NAME'}) {
($script_name) = $ENV{'SCRIPT_NAME'} =~ /([^\/]+)$/;
}
tie $gmt, 'CGI::SSI::Gmt', $self;
tie $loc, 'CGI::SSI::Local', $self;
tie $lmod, 'CGI::SSI::LMOD', $self;
$ENV{'DOCUMENT_ROOT'} ||= '';
$self->{'_variables'} = {
DOCUMENT_URI => ($args{'DOCUMENT_URI'} || $ENV{'SCRIPT_NAME'}),
DATE_GMT => $gmt,
DATE_LOCAL => $loc,
LAST_MODIFIED => $lmod,
DOCUMENT_NAME => ($args{'DOCUMENT_NAME'} || $script_name),
DOCUMENT_ROOT => ($args{'DOCUMENT_ROOT'} || $ENV{DOCUMENT_ROOT}),
};
$self->{'_config'} = {
errmsg => ($args{'errmsg'} || '[an error occurred while processing this directive]'),
sizefmt => ($args{'sizefmt'} || 'abbrev'),
timefmt => ($args{'timefmt'} || undef),
};
$self->{_max_recursions} = $args{MAX_RECURSIONS} || 100; # no "infinite" loops
$self->{_recursions} = {};
$self->{_cookie_jar} = $args{COOKIE_JAR} || HTTP::Cookies->new();
$self->{'_in_if'} = 0;
$self->{'_suspend'} = [0];
$self->{'_seen_true'} = [1];
return $self;
}
sub TIEHANDLE {
my($class,%args) = @_;
my $self = $class->new(%args);
$self->{'_handle'} = do { local *STDOUT };
my $handle_to_tie = '';
if($args{'filehandle'} !~ /::/) {
$handle_to_tie = caller().'::'.$args{'filehandle'};
} else {
$handle_to_tie = $args{'filehandle'};
}
open($self->{'_handle'},'>&'.$handle_to_tie) or die "Failed to copy the filehandle ($handle_to_tie): $!";
return $self;
}
sub PRINT {
my $self = shift;
print {$self->{'_handle'}} map { $self->process($_) } @_;
}
sub PRINTF {
my $self = shift;
my $fmt = shift;
printf {$self->{'_handle'}} $fmt, map { $self->process($_) } @_;
}
sub CLOSE {
my($self) = @_;
close $self->{'_handle'};
}
sub process {
my($self,@shtml) = @_;
my $processed = '';
@shtml = split(/(<!--#.+?-->)/s,join '',@shtml);
local($HTML::SimpleParse::FIX_CASE) = 0; # prevent var => value from becoming VAR => value
for my $token (@shtml) {
# next unless(defined $token and length $token);
if($token =~ /^<!--#(.+?)\s*-->$/s) {
$processed .= $self->_process_ssi_text($self->_interp_vars($1));
} else {
next if $self->_suspended;
$processed .= $token;
}
}
return $processed;
}
sub _process_ssi_text {
my($self,$text) = @_;
# are we suspended?
return '' if($self->_suspended and $text !~ /^(?:if|else|elif|endif)\b/);
# what's the first \S+?
if($text !~ s/^(\S+)\s*//) {
warn ref($self)." error: failed to find method name at beginning of string: '$text'.\n";
return $self->{'_config'}->{'errmsg'};
}
my $method = $1;
return $self->$method( HTML::SimpleParse->parse_args($text) );
}
# many thanks to Apache::SSI
sub _interp_vars {
local $^W = 0;
my($self,$text) = @_;
my($a,$b,$c) = ('','','');
$text =~ s{ (^|[^\\]) (\\\\)* \$(?:\{)?(\w+)(?:\})? }
{($a,$b,$c)=($1,$2,$3); $a . substr($b,length($b)/2) . $self->_echo($c) }exg;
return $text;
}
# for internal use only - returns the thing passed in if it's not defined. echo() returns '' in that case.
sub _echo {
my($self,$key,$var) = @_;
$var = $key if @_ == 2;
if($var eq 'DATE_LOCAL') {
return $loc;
} elsif($var eq 'DATE_GMT') {
return $gmt;
} elsif($var eq 'LAST_MODIFIED') {
return $lmod;
}
return $self->{'_variables'}->{$var} if exists $self->{'_variables'}->{$var};
return $ENV{$var} if exists $ENV{$var};
return $var;
}
#
# ssi directive methods
#
sub config {
my($self,$type,$value) = @_;
if($type =~ /^timefmt$/i) {
$self->{'_config'}->{'timefmt'} = $value;
} elsif($type =~ /^sizefmt$/i) {
if(lc $value eq 'abbrev') {
$self->{'_config'}->{'sizefmt'} = 'abbrev';
} elsif(lc $value eq 'bytes') {
$self->{'_config'}->{'sizefmt'} = 'bytes';
} else {
warn ref($self)." error: value for sizefmt is '$value'. It must be 'abbrev' or 'bytes'.\n";
return $self->{'_config'}->{'errmsg'};
}
} elsif($type =~ /^errmsg$/i) {
$self->{'_config'}->{'errmsg'} = $value;
} else {
warn ref($self)." error: arg to config is '$type'. It must be one of: 'timefmt', 'sizefmt', or 'errmsg'.\n";
return $self->{'_config'}->{'errmsg'};
}
return '';
}
sub set {
my($self,%args) = @_;
if(scalar keys %args > 1) {
$self->{'_variables'}->{$args{'var'}} = $args{'value'};
} else { # var => value notation
my($var,$value) = %args;
$self->{'_variables'}->{$var} = $value;
}
return '';
}
sub echo {
my($self,$key,$var) = @_;
$var = $key if @_ == 2;
if($var eq 'DATE_LOCAL') {
return $loc;
} elsif($var eq 'DATE_GMT') {
return $gmt;
} elsif($var eq 'LAST_MODIFIED') {
return $lmod;
}
return $self->{'_variables'}->{$var} if exists $self->{'_variables'}->{$var};
return $ENV{$var} if exists $ENV{$var};
return '';
}
sub printenv {
#my $self = shift;
return join "\n",map {"$_=$ENV{$_}"} keys %ENV;
}
sub include {
$DEBUG and do { local $" = "','"; warn "DEBUG: include('@_')\n" };
my($self,$type,$filename) = @_;
if(lc $type eq 'file') {
return $self->_include_file($filename);
} elsif(lc $type eq 'virtual') {
return $self->_include_virtual($filename);
} else {
warn ref($self)." error: arg to include is '$type'. It must be one of: 'file' or 'virtual'.\n";
return $self->{'_config'}->{'errmsg'};
}
}
sub _include_file {
$DEBUG and do { local $" = "','"; warn "DEBUG: _include_file('@_')\n" };
my($self,$filename) = @_;
# get the filename to open
$filename = catfile($FindBin::Bin,$filename) unless -e $filename;
# if we've reached MAX_RECURSIONS for this filename, warn and return the error
if(++$self->{_recursions}->{$filename} >= $self->{_max_recursions}) {
warn ref($self)." error: the maximum number of 'include file' recursions has been exceeded for '$filename'.\n";
return $self->{'_config'}->{'errmsg'};
}
# open the file, or warn and return an error
my $fh = do { local *STDIN };
open($fh,$filename) or do {
warn ref($self)." error: failed to open file ($filename): $!\n";
return $self->{'_config'}->{'errmsg'};
};
# process the included file and return the result
return $self->process(join '',<$fh>);
}
sub _include_virtual {
$DEBUG and do { local $" = "','"; warn "DEBUG: _include_virtual('@_')\n" };
my($self,$filename) = @_;
# if this is a local file that we can just read, let's do that instead of getting it virtually
if($filename =~ m|^/(.+)|) { # could be on the local server: absolute filename, relative to ., relative to $ENV{DOCUMENT_ROOT}
my $file = $1;
if(-e '/'.$file) { # back to the original
$file = '/'.$file;
} elsif(-e catfile($self->{'_variables'}->{'DOCUMENT_ROOT'},$file)) {
$file = catfile($self->{'_variables'}->{'DOCUMENT_ROOT'},$file);
} elsif(-e catfile($FindBin::Bin,$file)) {
$file = atfile($FindBin::Bin,$file);
}
return $self->_include_file($file) if -e $file;
}
# create the URI to get(), or warn and return the error
my $uri = eval {
my $uri = URI->new($filename);
$uri->scheme($uri->scheme || ($ENV{HTTPS} ? 'https' : 'http')); # ??
$uri->host($uri->host || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'} || 'localhost');
$uri;
} or do {
warn ref($self)." error: failed to create a URI based on '$filename'.\n";
return $self->{'_config'}->{'errmsg'};
};
if($@) {
warn ref($self)." error: failed to create a URI based on '$filename'.\n";
return $self->{'_config'}->{'errmsg'} if $@;
}
# get the content of the request
$self->{_ua} ||= $self->_get_ua();
my $url = $uri->canonical;
# have we reached MAX_RECURSIONS?
if(++$self->{_recursions}->{$url} >= $self->{_max_recursions}) {
warn ref($self)." error: the maximum number of 'include virtual' recursions has been exceeded for '$url'.\n";
return $self->{'_config'}->{'errmsg'};
}
my $response = $self->{_ua}->get($url);
# is it a success?
unless($response->is_success) {
warn ref($self)." error: failed to get('$url'): ".$response->status_line.".\n";
return $self->{_config}->{errmsg};
}
# process the included content and return the result
return $self->process($response->content);
}
sub _get_ua {
my $self = shift;
my %conf = ();
$conf{agent} = $ENV{HTTP_USER_AGENT} if $ENV{HTTP_USER_AGENT};
my $ua = LWP::UserAgent->new(%conf);
$ua->cookie_jar($self->{_cookie_jar});
return $ua;
}
sub cookie_jar {
my $self = shift;
if(my $jar = shift) {
$self->{_cookie_jar} = $jar;
}
return $self->{_cookie_jar};
}
sub exec {
my($self,$type,$filename) = @_;
if(lc $type eq 'cmd') {
return $self->_exec_cmd($filename);
} elsif(lc $type eq 'cgi') {
return $self->_exec_cgi($filename);
} else {
warn ref($self)." error: arg to exec() is '$type'. It must be one of: 'cmd' or 'cgi'.\n";
return $self->{'_config'}->{'errmsg'};
}
}
sub _exec_cmd {
my($self,$filename) = @_;
# have we reached MAX_RECURSIONS?
if(++$self->{_recursions}->{$filename} >= $self->{_max_recursions}) {
warn ref($self)." error: the maximum number of 'exec cmd' recursions has been exceeded for '$filename'.\n";
return $self->{'_config'}->{'errmsg'};
}
my $output = `$filename`; # security here is mighty bad.
# was the command a success?
if($?) {
warn ref($self)." error: `$filename` was not successful.\n";
return $self->{'_config'}->{'errmsg'};
}
# process the output, and return the result
return $self->process($output);
}
sub _exec_cgi { # no relative $filename allowed.
my($self,$filename) = @_;
# have we reached MAX_RECURSIONS?
if(++$self->{_recursions}->{$filename} >= $self->{_max_recursions}) {
warn ref($self)." error: the maximum number of 'exec cgi' recursions has been exceeded for '$filename'.\n";
return $self->{'_config'}->{'errmsg'};
}
# create the URI from the filename
my $uri = eval {
my $uri = URI->new($filename);
$uri->scheme($uri->scheme || ($ENV{HTTPS} ? 'https' : 'http')); # ??
$uri->host($uri->host || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
$uri->query($uri->query || $ENV{'QUERY_STRING'});
$uri;
} or do {
warn ref($self)." error: failed to create a URI from '$filename'.\n";
return $self->{'_config'}->{'errmsg'};
};
if($@) {
warn ref($self)." error: failed to create a URI from '$filename'.\n";
return $self->{'_config'}->{'errmsg'} if $@;
}
# get the content
$self->{_ua} ||= $self->_get_ua();
my $url = $uri->canonical;
my $response = $self->{_ua}->get($url);
# success?
unless($response->is_success) {
warn ref($self)." error: failed to get('$filename').\n";
return $self->{_config}->{errmsg};
}
# process the content and return the result
return $self->process($response->content);
}
sub flastmod {
my($self,$type,$filename) = @_;
if(lc $type eq 'file') {
$filename = catfile($FindBin::Bin,$filename) unless -e $filename;
} elsif(lc $type eq 'virtual') {
$filename = catfile($self->{'_variables'}->{'DOCUMENT_ROOT'},$filename)
unless $filename =~ /$self->{'_variables'}->{'DOCUMENT_ROOT'}/;
} else {
warn ref($self)." error: the first argument to flastmod is '$type'. It must be one of: 'file' or 'virtual'.\n";
return $self->{'_config'}->{'errmsg'};
}
unless(-e $filename) {
warn ref($self)." error: flastmod failed to find '$filename'.\n";
return $self->{'_config'}->{'errmsg'};
}
my $flastmod = (stat $filename)[9];
if($self->{'_config'}->{'timefmt'}) {
my @localtime = localtime($flastmod); # need this??
return Date::Format::strftime($self->{'_config'}->{'timefmt'},@localtime);
} else {
return scalar localtime($flastmod);
}
}
sub fsize {
my($self,$type,$filename) = @_;
if(lc $type eq 'file') {
$filename = catfile($FindBin::Bin,$filename) unless -e $filename;
} elsif(lc $type eq 'virtual') {
$filename = catfile($ENV{'DOCUMENT_ROOT'},$filename) unless $filename =~ /$ENV{'DOCUMENT_ROOT'}/;
} else {
warn ref($self)." error: the first argument to fsize is '$type'. It must be one of: 'file' or 'virtual'.\n";
return $self->{'_config'}->{'errmsg'};
}
unless(-e $filename) {
warn ref($self)." error: fsize failed to find '$filename'.\n";
return $self->{'_config'}->{'errmsg'};
}
my $fsize = (stat $filename)[7];
if(lc $self->{'_config'}->{'sizefmt'} eq 'bytes') {
1 while $fsize =~ s/^(\d+)(\d{3})/$1,$2/g;
return $fsize;
} else { # abbrev
# gratefully lifted from Apache::SSI
return " 0k" unless $fsize;
return " 1k" if $fsize < 1024;
return sprintf("%4dk", ($fsize + 512)/1024) if $fsize < 1048576;
return sprintf("%4.1fM", $fsize/1048576.0) if $fsize < 103809024;
return sprintf("%4dM", ($fsize + 524288)/1048576) if $fsize < 1048576;
}
}
#
# if/elsif/else/endif and related methods
#
sub _test {
my($self,$test) = @_;
my $retval = eval($test);
return undef if $@;
return defined $retval ? $retval : 0;
}
sub _entering_if {
my $self = shift;
$self->{'_in_if'}++;
$self->{'_suspend'}->[$self->{'_in_if'}] = $self->{'_suspend'}->[$self->{'_in_if'} - 1];
$self->{'_seen_true'}->[$self->{'_in_if'}] = 0;
}
sub _seen_true {
my $self = shift;
return $self->{'_seen_true'}->[$self->{'_in_if'}];
}
sub _suspended {
my $self = shift;
return $self->{'_suspend'}->[$self->{'_in_if'}];
}
sub _leaving_if {
my $self = shift;
$self->{'_in_if'}-- if $self->{'_in_if'};
}
sub _true {
my $self = shift;
return $self->{'_seen_true'}->[$self->{'_in_if'}]++;
}
sub _suspend {
my $self = shift;
$self->{'_suspend'}->[$self->{'_in_if'}]++;
}
sub _resume {
my $self = shift;
$self->{'_suspend'}->[$self->{'_in_if'}]--
if $self->{'_suspend'}->[$self->{'_in_if'}];
}
sub _in_if {
my $self = shift;
return $self->{'_in_if'};
}
sub if {
my($self,$expr,$test) = @_;
$expr = $test if @_ == 3;
$self->_entering_if();
if($self->_test($expr)) {
$self->_true();
} else {
$self->_suspend();
}
return '';
}
sub elif {
my($self,$expr,$test) = @_;
die "Incorrect use of elif ssi directive: no preceeding 'if'." unless $self->_in_if();
$expr = $test if @_ == 3;
if(! $self->_seen_true() and $self->_test($expr)) {
$self->_true();
$self->_resume();
} else {
$self->_suspend() unless $self->_suspended();
}
return '';
}
sub else {
my $self = shift;
die "Incorrect use of else ssi directive: no preceeding 'if'." unless $self->_in_if();
unless($self->_seen_true()) {
$self->_resume();
} else {
$self->_suspend();
}
return '';
}
sub endif {
my $self = shift;
die "Incorrect use of endif ssi directive: no preceeding 'if'." unless $self->_in_if();
$self->_leaving_if();
# $self->_resume() if $self->_suspended();
return '';
}
#
# if we're called like this, it means that we're to handle a CGI request ourselves.
# that means that we're to open the file and process the content, sending it to STDOUT
# along with a standard HTTP content header
#
unless(caller) {
goto &handler;
}
sub handler {
eval "use CGI qw(:standard);";
print header();
unless(UNIVERSAL::isa(tied(*STDOUT),'CGI::SSI')) {
tie *STDOUT, 'CGI::SSI', filehandle => 'main::STDOUT';
}
my $filename = "$ENV{DOCUMENT_ROOT}$ENV{REQUEST_URI}";
if(-f $filename) {
open my $fh, '<', $filename or die "Failed to open file ($filename): $!";
print <$fh>;
} else {
print "Failed to find file ($filename).";
}
exit;
}
#
# packages for tie()
#
package CGI::SSI::Gmt;
sub TIESCALAR { bless [@_], shift() }
sub FETCH {
my $self = shift;
if($self->[-1]->{'_config'}->{'timefmt'}) {
my @gt = gmtime;
return Date::Format::strftime($self->[-1]->{'_config'}->{'timefmt'},@gt);
} else {
return scalar gmtime;
}
}
package CGI::SSI::Local;
sub TIESCALAR { bless [@_], shift() }
sub FETCH {
my $self = shift;
if($self->[-1]->{'_config'}->{'timefmt'}) {
my @lt = localtime;
return Date::Format::strftime($self->[-1]->{'_config'}->{'timefmt'},@lt);
} else {
return scalar localtime;
}
}
package CGI::SSI::LMOD;
sub TIESCALAR { bless [@_], shift() }
sub FETCH {
my $self = shift;
return $self->[-1]->flastmod('file', $ENV{'SCRIPT_FILENAME'} || $ENV{'PATH_TRANSLATED'} || '');
}
1;
__END__
=head1 NAME
CGI::SSI - Use SSI from CGI scripts
=head1 SYNOPSIS
# autotie STDOUT or any other open filehandle
use CGI::SSI (autotie => 'STDOUT');
print $shtml; # browser sees resulting HTML
# or tie it yourself to any open filehandle
use CGI::SSI;
open(FILE,'+>'.$html_file) or die $!;
$ssi = tie(*FILE, 'CGI::SSI', filehandle => 'FILE');
print FILE $shtml; # HTML arrives in the file
# or use the object-oriented interface
use CGI::SSI;
$ssi = CGI::SSI->new();
$ssi->if('"$varname" =~ /^foo/');
$html .= $ssi->process($shtml);
$ssi->else();
$html .= $ssi->include(file => $filename);
$ssi->endif();
print $ssi->exec(cgi => $url);
print $ssi->flastmod(file => $filename);
#
# or roll your own favorite flavor of SSI
#
package CGI::SSI::MySSI;
use CGI::SSI;
@CGI::SSI::MySSI::ISA = qw(CGI::SSI);
sub include {
my($self,$type,$file_or_url) = @_;
# my idea of include goes something like this...
return $html;
}
1;
__END__
#
# or use .htaccess to include all files in a dir
#
# in .htaccess
Action cgi-ssi /cgi-bin/ssi/process.cgi
<FilesMatch "\.shtml">
SetHandler cgi-ssi
</FilesMatch>
# in /cgi-bin/ssi/process.cgi
#!/usr/local/bin/perl
use CGI::SSI;
CGI::SSI->handler();
__END__
=head1 DESCRIPTION
CGI::SSI is meant to be used as an easy way to filter shtml
through CGI scripts in a loose imitation of Apache's mod_include.
If you're using Apache, you may want to use either mod_include or
the Apache::SSI module instead of CGI::SSI. Limitations in a CGI
script's knowledge of how the server behaves make some SSI
directives impossible to imitate from a CGI script.
Most of the time, you'll simply want to filter shtml through STDOUT
or some other open filehandle. C<autotie> is available for STDOUT,
but in general, you'll want to tie other filehandles yourself:
$ssi = tie(*FH, 'CGI::SSI', filehandle => 'FH');
print FH $shtml;
Note that you'll need to pass the name of the filehandle to C<tie()> as
a named parameter. Other named parameters are possible, as detailed
below. These parameters are the same as those passed to the C<new()>
method. However, C<new()> will not tie a filehandle for you.
CGI::SSI has it's own flavor of SSI. Test expressions are Perlish.
You may create and use multiple CGI::SSI objects; they will not
step on each others' variables.
Object-Oriented methods use the same general format so as to imitate
SSI directives:
<!--#include virtual="/foo/bar.footer" -->
would be
$ssi->include(virtual => '/foo/bar.footer');
likewise,
<!--#exec cgi="/cgi-bin/foo.cgi" -->
would be
$ssi->exec(cgi => '/cgi-bin/foo.cgi');
Usually, if there's no chance for ambiguity, the first argument may
be left out:
<!--#echo var="var_name" -->
could be either
$ssi->echo(var => 'var_name');
or
$ssi->echo('var_name');
Likewise,
$ssi->set(var => $varname, value => $value)
is the same as
$ssi->set($varname => $value)
=over 4
=item $ssi->new([%args])
Creates a new CGI::SSI object. The following are valid (optional) arguments:
DOCUMENT_URI => $doc_uri,
DOCUMENT_NAME => $doc_name,
DOCUMENT_ROOT => $doc_root,
errmsg => $oops,
sizefmt => ('bytes' || 'abbrev'),
timefmt => $time_fmt,
MAX_RECURSIONS => $default_100, # when to stop infinite loops w/ error msg
COOKIE_JAR => HTTP::Cookies->new,
=item $ssi->config($type, $arg)
$type is either 'sizefmt', 'timefmt', or 'errmsg'. $arg is similar to
those of the SSI C<spec>, referenced below.
=item $ssi->set($varname => $value)
Sets variables internal to the CGI::SSI object. (Not to be confused
with the normal variables your script uses!) These variables may be used
in test expressions, and retreived using $ssi->echo($varname). These
variables also will not be available in external, included resources.
=item $ssi->echo($varname)
Returns the value of the variable named $varname. Such variables may
be set manually using the C<set()> method. There are also several built-in
variables:
DOCUMENT_URI - the URI of this document
DOCUMENT_NAME - the name of the current document
DATE_GMT - the same as 'gmtime'
DATE_LOCAL - the same as 'localtime'
LAST_MODIFIED - the last time this script was modified
=item $ssi->exec($type, $arg)
$type is either 'cmd' or 'cgi'. $arg is similar to the SSI C<spec>
(see below).
=item $ssi->include($type, $arg)
Similar to C<exec>, but C<virtual> and C<file> are the two valid types.
SSI variables will not be available outside of your CGI::SSI object,
regardless of whether the virtual resource is on the local system or
a remote system.
=item $ssi->flastmod($type, $filename)
Similar to C<include>.
=item $ssi->fsize($type, $filename)
Same as C<flastmod>.
=item $ssi->printenv
Returns the environment similar to Apache's mod_include.
=item $ssi->cookie_jar([$jar])
Returns the currently-used HTTP::Cookies object. You may optionally
pass in a new HTTP::Cookies object. The jar is used for web requests
in exec cgi and include virtual directives.
=back
=head2 FLOW-CONTROL METHODS
The following methods may be used to test expressions. During a C<block>
where the test $expr is false, nothing will be returned (or printed,
if tied).
=over 4
=item $ssi->if($expr)
The expr can be anything Perl, but care should be taken. This causes
problems:
$ssi->set(varname => "foo");
<!--#if expr="'\$varname' =~ /^foo$/" -->ok<!--#endif -->
The $varname is expanded as you would expect. (We escape it so as to use
the C<$varname> within the CGI::SSI object, instead of that within our
progam.) But the C<$/> inside the regex is also expanded. This is fixed
by escaping the C<$>:
<!--#if expr="'\$varname' =~ /^value\$/" -->ok<!--#endif -->
The expressions used in if and elif tags/calls are tricky due to
the number of escapes required. In some cases, you'll need to
write C<\\\\> to mean C<\>.
=item $ssi->elif($expr)
=item $ssi->else
=item $ssi->endif
=back
=head1 SEE ALSO
C<Apache::SSI> and the SSI C<spec> at
http://www.apache.org/docs/mod/mod_include.html
=head1 AUTHOR
(c) 2000-2005 James Tolley <james@bitperfect.com> All Rights Reserved.
This is free software. You may copy and/or modify it under
the same terms as perl itself.
=head1 CREDITS
Many Thanks to Corey Wilson and Fitz Elliot for bug reports and fixes.
CGI-SSI-0.92/test.pl 0000755 0000000 0000000 00000021272 12040107173 0014016 0 ustar 00root root 0000000 0000000 use strict;
use warnings FATAL => 'all';
use Test::More tests => 29;
use List::Util qw(sum);
use File::Temp qw(tempfile tempdir);
use_ok('CGI::SSI');
# set and echo
{
my $ssi = CGI::SSI->new();
$ssi->set(var => 'value');
my $value = $ssi->echo('var');
ok($value eq 'value','set/echo 1');
}
# other ways to call set and echo
{
my $ssi = CGI::SSI->new();
$ssi->set(var => "var2", value => "value2");
my $value = $ssi->echo(var => 'var2');
ok($value eq 'value2','set/echo 2');
}
# objects don't crush each other's vars.
{
my $ssi = CGI::SSI->new();
my $ssi2 = CGI::SSI->new();
$ssi->set(var => "value");
$ssi2->set(var => "value2");
my $value = $ssi->echo("var");
my $value2 = $ssi2->echo("var");
ok($value eq "value" && $value2 eq "value2",'data encapsulation');
}
# args to new()
{
my $ssi = CGI::SSI->new(
DOCUMENT_URI => "doc_uri",
DOCUMENT_NAME => "doc_name",
DOCUMENT_ROOT => "/",
errmsg => "[ERROR!]",
sizefmt => "bytes",
timefmt => "%B",
);
ok( ($ssi->echo("DOCUMENT_URI") eq "doc_uri"
and $ssi->echo("DOCUMENT_NAME") eq "doc_name"
and $ssi->echo("DOCUMENT_ROOT") eq "/"),'new()');
}
# config
{
my %months = map { ($_,1) } qw(January February March April May June
July August September October November December);
# create a tmp file for testing.
use IO::File;
use POSIX qw(tmpnam);
my($filename,$fh); # Thanks, Perl Cookbook!
do { $filename = tmpnam() } until $fh = IO::File->new($filename, O_RDWR|O_CREAT|O_EXCL);
# select( ( select($fh), $| = 1 )[0] );
print $fh ' ' x 10;
close $fh;
my $ssi = CGI::SSI->new();
$ssi->config(timefmt => "%B");
ok($months{ $ssi->flastmod(file => $filename) },'config 1');
$ssi->config(sizefmt => "bytes"); # TODO: combine these calls to config.
my $size = $ssi->fsize(file => $filename);
ok($size eq int $size,'config 2');
$ssi->config(errmsg => "error"); # TODO combine config calls
# close STDERR for this test
open COPY,'>&STDERR' or die "no copy of STDERR: $!";
close STDERR;
# perform the test
ok($ssi->flastmod("") eq "error",'config 3');
# re-open STDERR and continue
open STDERR,">©" or die "no reassign to STDERR: $!";
unlink $filename;
}
# tough to do these well, without more info...
# include file - with many types of input
# include virtual - with different types of input
{
my $ssi = CGI::SSI->new();
my $html = $ssi->process(q[<!--#include virtual="http://www.yahoo.com" -->]);
ok($html =~ /yahoo/i && $html =~ /mail/i,'include virtual 1');
}
# tough to do these well, without more info...
# include file - with many types of input
# include virtual - with different types of input
{
my $ssi = CGI::SSI->new(DOCUMENT_ROOT => '.');
my $html = $ssi->process(q[<!--#include virtual="/MANIFEST" -->]);
ok($html =~ /Changes/i,'include virtual 2');
}
# exec cgi - with different input
{
my $ssi = CGI::SSI->new();
my $html = $ssi->process(q[<!--#exec cgi="http://www.yahoo.com/" -->]);
ok($html =~ /yahoo/i,'exec cgi');
}
# exec cmd - with different input
{
my $ssi = CGI::SSI->new();
my $perl = $^X;
$perl =~ s|\\|/|g;
my $html = $ssi->process(qq[<!--#exec cmd="$perl -v" -->]);
ok($html =~ /perl/i,'exec cmd');
}
# flastmod - different input
# fsize - different input
# if/else
{
my $ssi = CGI::SSI->new();
$ssi->set(varname => "test");
my $html = $ssi->process(qq[<!--#if expr="'\$varname' =~ /^TEST\$/i" -->if<!--#else -->else<!--#endif --->]);
ok($html eq "if",'if/else');
}
# if/elif
{
my $ssi = CGI::SSI->new();
my $html = $ssi->process(q[<!--#if expr="my \$i = 2; \$i eq 3;" -->if<!--#elif expr="my \$j = 4; \$j == 4" -->elif<!--#endif -->]);
ok($html eq "elif",'if/elif');
}
# if/elif/else
{
my $ssi = CGI::SSI->new();
my $html = $ssi->process(q[<!--#if expr="0" -->if<!--#elif expr="'$DATE_LOCAL' !~ /\\\\S/" -->elif<!--#else -->else<!--#endif -->]);
ok($html eq "else",'if/elif/else');
}
## nested ifs:
# if false -> if true/else
{
my $ssi = CGI::SSI->new();
my $html = $ssi->process(q[<!--#if expr="0" -->if1<!--#if expr="1" -->if2<!--#else -->else<!--#endif --><!--#endif -->]);
ok(!$html,'if 1');
}
# if true -> if false/else
{
my $ssi = CGI::SSI->new();
my $html = $ssi->process(q[<!--#if expr="1" -->if1<!--#if expr="0" -->if2<!--#else -->else<!--#endif --><!--#endif -->]);
ok($html eq "if1else",'if 2');
}
# if true -> if true/else
{
my $ssi = CGI::SSI->new();
my $html = $ssi->process(q[<!--#if expr="1" -->if1<!--#if expr="1" -->if2<!--#else -->else<!--#endif --><!--#endif -->]);
ok($html eq "if1if2",'if 3');
}
# one bigger test: if true -> if false/elif true/else -> if false/*elif true*/else
{
my $ssi = CGI::SSI->new();
my $html = $ssi->process(q[<!--#if expr="1" -->if1<!--#if expr="0" -->if2<!--#elif expr="1" -->elif1<!--#if expr="0" -->if3<!--#elif expr="1" -->elif2<!--#else -->else1<!--#endif --><!--#else -->else2<!--#endif --><!--#endif -->]);
ok($html eq "if1elif1elif2",'if/elif/else');
}
# derive a class, and do something simple (empty class)
{
package CGI::SSI::Empty;
@CGI::SSI::Empty::ISA = qw(CGI::SSI);
package main;
my $empty = CGI::SSI::Empty->new();
my $html = $empty->process(q[<!--#set var="varname" value="foo" --><!--#echo var="varname" -->]);
ok($html eq "foo",'inherit 1');
}
# derive a class, and do something simple (altered class)
{
package CGI::SSI::UCEcho;
@CGI::SSI::UCEcho::ISA = qw(CGI::SSI);
sub echo {
return uc shift->SUPER::echo(@_);
}
package main;
my $echo = CGI::SSI::UCEcho->new();
my $html = $echo->process(q[<!--#set var="varname" value="foo" --><!--#echo var="varname" -->]);
ok($html eq "FOO",'inherit 2');
}
# DATE_LOCAL/DATE_GMT with config{timefmt}
{
my $ssi = new CGI::SSI (timefmt => '%Y');
ok($ssi->echo('DATE_LOCAL') =~ /^\d{4}$/,'config{timefmt}');
}
# check recursion test
SKIP: {
# create tempfile to hold include directive
my($fh,$filename) = tempfile();
skip("Failed to create tempfile: $!",1) unless $filename;
$filename =~ s/\\/\\\\/g;
print $fh qq[<!--#include file="$filename"-->];
close $fh;
my $ssi = CGI::SSI->new(MAX_RECURSIONS => 42);
# close STDERR for this test
open COPY,'>&STDERR' or die "no copy of STDERR: $!";
close STDERR;
# perform the test
my $html = $ssi->include(file => $filename);
ok($html eq $ssi->{_config}->{errmsg}
&& (
sum(values %{$ssi->{_recursions}}) == 43
||
sum(values %{$ssi->{_recursions}}) == 42
)
, "recursion check");
# re-open STDERR and continue
open STDERR,">©" or die "no reassign to STDERR: $!";
}
# test cookie support
SKIP: {
eval "use HTTP::Cookies; 1" or skip("HTTP::Cookies not installed", 1);
my $jar = HTTP::Cookies->new({});
$jar->set_cookie(1,'mycookie','COOKIEVAL','/','www.bitperfect.com',80,0,0,100);
my $ssi = CGI::SSI->new(COOKIE_JAR => $jar);
my $html = $ssi->process(qq[<!--#include virtual="http://www.bitperfect.com/cgi-bin/cgi-ssi/cookietest.cgi"-->]);
ok($html =~ m'COOKIEVAL', "cookie support");
}
SKIP: {
# tie by hand & close
my($dir) = tempdir();
# print $dir,"\n";
open FH, "+>$dir/AfDCSd43.tmp" or skip('failed to open tempfile',2);
my $ssi = tie *FH, 'CGI::SSI', filehandle => 'FH';
isa_ok(tied(*FH),'CGI::SSI','tied object');
print FH "this is the first test\n";
close FH;
eval { print FH "this is the second test\n" or die "FH is closed" };
ok($@ =~ /^FH is closed/,'close()');
}
{
# nested ifs
my $ssi = CGI::SSI->new();
my $html = $ssi->process(<<"");
<!--#if expr="0" -->
<!--#if expr="1" -->
yes
<!--#else -->
no
<!--#endif -->
no
<!--#else -->
yes
<!--#endif -->
ok($html =~ /^\s*yes\s*$/s,'nested ifs');
}
{
# timefmt applied to LAST_MODIFIED
my $ssi = CGI::SSI->new();
my $html = $ssi->process('<!--#config timefmt="%m/%d/%Y %X" --><!--#echo var="LAST_MODIFIED" -->');
like($html, qr{^\d\d/\d\d/\d{4} \d\d:\d\d:\d\d$}, 'timefmt applied to LAST_MODIFIED');
}
{
# newlines in directives
my $ssi = CGI::SSI->new();
my $html = $ssi->process('<!--#config
timefmt="%m/%d/%Y %X" --><!--#echo var="LAST_MODIFIED" -->');
like($html, qr{^\d\d/\d\d/\d{4} \d\d:\d\d:\d\d$}, 'newlines in directives');
}
# autotie ?
__END__