view release on metacpan or  search on metacpan

lib/CGI/apacheSSI.pm  view on Meta::CPAN

package CGI::apacheSSI;
use strict;
#use warnings;

# CHANGES for 0.95:

# DONE:
# include virtual should not be making http requests to other servers.. 
# include virtual can be absolute.. 
# include file cannot be absolute.. 
# flastmod, fsize

# TODO:
# move up the  %allowed_tag_count;
# $allowed_tag_count{'if'}=["expr"]; should use arrays: @allowed_tag_count{'if'}=("expr");
# handle encoding in echo()
# PROPER VIRTUAL CALLS TO CGI SCRIPTS AND mod_rewrite URLS


use File::Spec::Functions; # catfile()
use HTTP::Response;
use HTTP::Cookies;
use Date::Format;
use Cwd;

our $VERSION = '0.96';

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);

			# NOTE: check for escaped \( or \), what should it do? -- DONE?
our $L; # used to return the brackets count
our $RE_parens_2C = qr/
      (	  # g1, everything inside the brackets, incl brackets
      \(
	( (?:	  # g2, everything inside the brackets
	  (?{ $L = 1 })	  #  $L counts ('s inside pattern
	      (?:
		  (?:"[^"\\]*  (?: \\.[^"\\]* )* ")
		| (?:'[^'\\]*  (?: \\.[^'\\]* )* ')
		| (?:`[^`\\]*  (?: \\.[^`\\]* )* `)
		| (?:[^"'`)(])
		| (?:  \(
		      (?{ local  $L=$L+1; })	  # new set of nested parens
		  )
		| (?:  \)
		      (?{ local  $L=$L-1; })	  # close a set of nested parens
		      (?(?{ $L==0 })(?!))	  #  ...if there was no matching open paren...
		  )
	      )*
	  )* )   # end g2
      \)
      )   # end g1
      /x;

our $RE_quote_dbl_NC		  = qr/(?:"[^"\\]*  (?: \\.[^"\\]* )* ")/x;
our $RE_quote_single_NC		  = qr/(?:'[^'\\]*  (?: \\.[^'\\]* )* ')/x; 
our $RE_quote_backtick_NC	  = qr/(?:`[^`\\]*  (?: \\.[^`\\]* )* `)/x;
our $RE_all_quote_NC		  = qr/$RE_quote_dbl_NC|$RE_quote_single_NC|$RE_quote_backtick_NC/;
our $RE_all_no_quote_NC		  = qr/$RE_all_quote_NC|[^'"`]/;
our $RE_all_no_paren_NC		  = qr/$RE_all_quote_NC|[^()'"`]/;
our $RE_all_no_paren_noop_NC	  = qr/$RE_all_quote_NC | [^()'"`&\|] | &[^&] | \|[^\|]/x;
our $RE_single_quote_false_NC	  = qr/^ (?:\s*'')+\s* [']* $
				      |^ '? (?:\\')* $/x; 
					# empty, or 1+ unspaced single quotes,  trivially false
					# pairs of empty single quotes,  false
					# alternating backslash-single quotes,  false


  # apache's own, special way of quoting strings
our $RE_apache_expr_quote	  = qr/ (?:"(?:[^"\\]|[\\]+[^\\])*?")
				       |(?:'(?:[^'\\]|[\\]+[^\\])*?')
				       |(?:`(?:[^`\\]|[\\]+[^\\])*?`)
				      /x;

# NOTE: quotes that would be openers which are immediately preceeded by \w are treated as \w
	  # NOTE: needs to be preceeded by \s or =, otherwise becomes part of token (parsing oddity with apache 2.2.22)
our $RE_apache_expr_quote_all	  = qr/  $RE_apache_expr_quote | [^'"`\s]/x;
our $RE_runaway   =  qr/ \s+  \w+['"`]\S*\s+[^'"`]+['"`]+  /x;
our $RE_token_NC  =  qr{[[:alpha:]]\S+? (?:\s+ $RE_apache_expr_quote_all*? )*?   $RE_runaway? }x; 


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::apacheSSI::Gmt', $self;
    tie $loc, 'CGI::apacheSSI::Local', $self;
    tie $lmod, 'CGI::apacheSSI::LMOD', $self;

    # $ENV{'DOCUMENT_ROOT'} ||= '';
    $self->{'_variables'}     = {
        DOCUMENT_URI    =>  ($args{'DOCUMENT_URI'} || $ENV{'SCRIPT_NAME'}),
        DOCUMENT_NAME   =>  ($args{'DOCUMENT_NAME'} || $script_name),
        DOCUMENT_ROOT   =>  ($args{'DOCUMENT_ROOT'} || $ENV{'DOCUMENT_ROOT'} || cwd()),
        DATE_GMT        =>  $gmt,
        DATE_LOCAL      =>  $loc,
                                };

    $self->{_timefmt_default} = "%A, %d-%B-%Y %T %Z"; # APACHE DEFAULT https://httpd.apache.org/docs/2.2/mod/mod_include.html#ssitimeformat
    
    $self->{'_config'}        = {  # NOTE: TODO: get these from apache config
        errmsg  =>  ($args{'errmsg'}  || '[an error occurred while processing this directive]'),
        sizefmt =>  ($args{'sizefmt'} || 'abbrev'),
        timefmt =>  ($args{'timefmt'} ||  $self->{_timefmt_default}),
        SSIUndefinedEcho =>  ($args{'SSIUndefinedEcho'} ||  '(none)'),
        _enable_exec_cmd  =>  ($args{'_enable_exec_cmd'}  ||  0),
        _verbose_errors  =>  ($args{'_verbose_errors'}  ||  0)
                                };
                                
    
    $self->{'_variables'}->{LAST_MODIFIED}   =  $lmod; # needs to be specified after the above, since it requires DOCUMENT_ROOT to be populated

    $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 _enable_exec_cmd {
    my $self = shift;
    $self->{'_config'}->{'_enable_exec_cmd'} = $_[0];
}

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 SSI_WARN {
    my($self,$msg) = @_;
    warn ref($self)." warn: $msg\n";
}

sub SSI_ERROR {
    (my $self, $@) = @_;
    warn ref($self)." error: $@\n";
    return;	# returning false here allows us to do one line error returns.
}

sub SSI_ERROR_FLUSH {
    my($self,$msg) = @_;
    if ($msg) {$self->SSI_ERROR($msg);}
    $msg=$@;					# NOTE: DEBUG ONLY!
    undef $@;
    return "[SSI ERROR=[$msg]]" if $self->{'_config'}->{'_verbose_errors'}; # NOTE: DEBUG ONLY!
    return $self->{'_config'}->{'errmsg'}; 
}
    



# NOTE: "if" allows expr="myexpr1" expr="myexpr2" where myexpr2 overwrites myexpr1. 

sub process {		# NOTE: -- FIXME -- this fails if we comment out the tokens.. ie <!-- <!--#if -->
			# NOTE: -- FIXME -- this should fail if we have any open quotes (ie, the --> doesnt magically close the tag.. in apache 2.2 at least)
    my($self,@shtml) = @_;
    my $processed = '';

	  # NOTE: FIXME: would this be easier with a global replace  s///ge ?
    @shtml = split(m/(<!--\#$RE_token_NC-->)/sx, join '',@shtml); # this will slurp up anything inside quotes, single or double

    my $count=0;
    for my $token (@shtml) {
        if($token =~ /^<!--\#($RE_token_NC)-->$/sx) {
	    $processed .= $self->_process_ssi_text($1);