view release on metacpan or  search on metacpan

lib/Apache/SSI.pm  view on Meta::CPAN

use strict;
use vars qw($VERSION);
use Apache::Constants qw(:common :http OPT_INCNOEXEC);
use File::Basename;
use HTML::SimpleParse;
use Symbol;
use POSIX;

$VERSION = '2.19';
my $debug = 0;


sub handler($$) {
    my ($pack, $r) = @_>1 ? @_ : (__PACKAGE__, shift());
    
    my $fh;
    if (lc($r->dir_config('Filter')) eq 'on') {
        $r = $r->filter_register;
        my ($status);
        ($fh, $status) = $r->filter_input();
        return $status unless $status == OK;
        
    } else {
        my $file = $r->filename;

        unless (-e $file) {
	#unless (-e $r->finfo) {
            $r->log_error("$file not found");
            return NOT_FOUND;
        }

        $fh = gensym;
        unless (open *{$fh}, $file) {
            $r->log_error("$file: $!");
            return FORBIDDEN;
        }
    }
    $r->send_http_header;
    return OK if $r->header_only;
    
    do {local $/=undef; $pack->new( scalar(<$fh>), $r )}->output;
    return OK;
}

sub new {
  my ($pack, $text, $r) = @_;
  $pack = ref($pack) if ref($pack);
  
  return bless 
    {
     'text' => $text,
     '_r'   => $r,
     'suspend' => [0],
     'if_state' => [1], # A stack reflecting the current state of if/else parser.
                        # Each entry is 1 when we've seen a true condition in this if-chain,
                        # 0 when we haven't.  Initially it's as if we're in a big true 
                        # if-block with no else.
     'errmsg'  => "[an error occurred while processing this directive]",
     'sizefmt' => 'abbrev',
     'timefmt' => undef, # undef means the current locale's default
    }, $pack;
}

sub text {
    my $self = shift;
    if (@_) {
        $self->{'text'} = shift;
    }
    return $self->{'text'};
}

sub get_output {
    my $self = shift;
    
    my $out = '';
    my $ssi;
    my @parts = split m/(<!--#.*?-->)/s, $self->{'text'};
    while (@parts) {
        $out .= ('', shift @parts)[1-$self->{'suspend'}[0]];
        last unless @parts;
        $ssi = shift @parts;
        # There's some weird 'uninitialized' warning on the next line, but I can't find it.
        if ($ssi =~ m/^<!--#(.*)-->$/s) {
            $out .= $self->output_ssi($1);
        } else { die 'Parse error' }
    }
    return $out;
}


sub output {
    my $self = shift;
    
    my @parts = split m/(<!--#.*?-->)/s, $self->{'text'};
    while (@parts) {
        $self->{_r}->print( ('', shift @parts)[1-$self->{'suspend'}[0]] );
        last unless @parts;
        my $ssi = shift @parts;
        if ($ssi =~ m/^<!--#(.*)-->$/s) {
            $self->{_r}->print( $self->output_ssi($1) );
        } else { die 'Parse error' }
    }
}

sub output_ssi {
    my ($self, $text) = @_;
    
    if ($text =~ s/^(\w+)\s*//) {
        my $tag = $1;
        return if ($self->{'suspend'}[0] and not $tag =~ /^(if|elif|else|endif)/);
        my $method = lc "ssi_$tag";

	local $HTML::SimpleParse::FIX_CASE = -1;
        my $args = [ HTML::SimpleParse->parse_args($text) ];
        return $self->$method( {@$args}, $args );
    }
    return '';
}

sub ssi_if {