view release on metacpan or  search on metacpan

SSI.pm  view on Meta::CPAN

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) = ('','','');