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) { $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 SetHandler cgi-ssi # 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 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 as a named parameter. Other named parameters are possible, as detailed below. These parameters are the same as those passed to the C method. However, C 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: would be $ssi->include(virtual => '/foo/bar.footer'); likewise, would be $ssi->exec(cgi => '/cgi-bin/foo.cgi'); Usually, if there's no chance for ambiguity, the first argument may be left out: 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, 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 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 (see below). =item $ssi->include($type, $arg) Similar to C, but C and C 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. =item $ssi->fsize($type, $filename) Same as C. =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 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"); ok 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<$>: ok 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 and the SSI C at http://www.apache.org/docs/mod/mod_include.html =head1 AUTHOR (c) 2000-2005 James Tolley 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.