view release on metacpan or  search on metacpan

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

    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 {
    my ($self, $args) = @_;
    unshift @{$self->{if_state}}, 0;
    unshift @{$self->{suspend}},  $self->{suspend}[0];
    return '' if $self->{suspend}[0];
    return $self->_handle_ifs( $self->_eval_vars($args->{'expr'}) );
}

sub ssi_elif {
    my ($self, $args) = @_;
    # Make sure we're in an 'if' chain
    return $self->error("Malformed if..endif SSI structure") unless @{$self->{if_state}} > 1;
    return '' if $self->{suspend}[1];
    return $self->_handle_ifs( $self->_eval_vars($args->{'expr'}) );
}

sub ssi_else {
    my $self = shift;
    # Make sure we're in an 'if' chain
    return $self->error("Malformed if..endif SSI structure") unless @{$self->{if_state}} > 1;
    return '' if $self->{suspend}[1];
    return $self->_handle_ifs(1);
}

sub ssi_endif {
    my $self = shift;
    # Make sure we're in an 'if' chain
    return $self->error("Malformed if..endif SSI structure") unless @{$self->{if_state}} > 1;
    shift @{$self->{if_state}};
    shift @{$self->{suspend}};
    return '';
}

sub _handle_ifs {
    my $self = shift;