File Coverage

blib/lib/CGI/apacheSSI.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

package CGI::apacheSSI;
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.93';

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?
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'}),
        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'}        = {  # NOTE: TODO: get these from apache config
        errmsg  =>  ($args{'errmsg'}  || '[an error occurred while processing this directive]'),
        sizefmt =>  ($args{'sizefmt'} || 'abbrev'),
        timefmt =>  ($args{'timefmt'} ||  undef),
        SSIUndefinedEcho =>  ($args{'SSIUndefinedEcho'} ||  '(none)'),
        _verbose_errors  =>  ($args{'_verbose_errors'}  ||  0)  # NOTE: TODO: document this option
                                };

    $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 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
			# 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/()/sx, join '',@shtml); # this will slurp up anything inside quotes, single or double

    my $count=0;
    for my $token (@shtml) {
        if($token =~ /^$/sx) {
	    $processed .= $self->_process_ssi_text($1);
	} else {
	    next if $self->_suspended;
	    $processed .= $token;
	}
    }
    return $processed;
}



sub _process_ssi_text {
    my($self,$text) = @_;

    # what's the first \S+?
    if($text !~ s/^(\S+)\s*//)
	{ return $self->SSI_ERROR_FLUSH("failed to find method name at beginning of string: '$text'."); }

    my $method = $1;
    if (! $self->can($method) )
	{ return $self->SSI_ERROR_FLUSH("unknown directive \"$method\" in parsed doc."); }

	# are we suspended?
    return '' if($self->_suspended and $method !~ /^(?:if|else|elif|endif)\b/);

    my $res = $self->$method( $self->parse_args($text, $method) );
    if ($@) { return $self->SSI_ERROR_FLUSH();}
    return $res;
}



# many thanks to HTML::SimpleParse, with a couple of modifications
sub parse_args {
    my ($self, $str, $method) = @_;
    my @returns;

    # Make sure we start searching at the beginning of the string
    pos($str) = 0;

    while (1) {
        next if $str =~ m/\G\s+/gc;  # Get rid of leading whitespace

        if ( $str =~ m/\G
            ([\w.-]+)\s*=\s*			 # the key
            (?:
               # ($RE_all_quote_NC) \s*		 # anything in quotes
               ($RE_apache_expr_quote_all) \s*   # anything in quotes
               |				 #  or
               ([^\s>]*) \s*			 # anything else, without whitespace or >
             )/gcx ) {
            my ($key, $val) = ($1, $+);
                  # ----- NOTE: if $key is not "expr" trim the quotes..
                  # ----- (apache evaluates differently depending on the type of quotes)
            if ($key ne "expr") {$val =~ s/^['"`]?(.*?)['"`]?$/$1/;}
            push @returns,  $key, $val;
        } elsif ( $str =~ m,\G/?([\w.-]+)\s*,gc ) {
            push @returns,  $1  , undef;
        } else {
            if ($str =~ m/\G(.+)/gc)  # anything left over??
                  {
                  $self->SSI_ERROR("missing argument name for value to tag \"$method\" in");
                  # NOTE: notice this is NOT a "return".. we want processing to continue normally
                  }
            last;
        }
    }

# too many arguments for if element in
# else/endif/printenv directive does not take tags in
my %allowed_tag_count;			# NOTE: this needs to be moved up
$allowed_tag_count{'if'}=["expr"];
$allowed_tag_count{'else'}=[];

        if (defined $allowed_tag_count{$method})
            {
            if (@returns > 2 * @{ $allowed_tag_count{$method} })
                {
                if (@{ $allowed_tag_count{$method} } == 0)
                    { $self->SSI_ERROR("\"$method\" directive does not take tags in");}
                else
                    { $self->SSI_ERROR("too many arguments for \"$method\" element in");}
                }
            elsif (@returns < 2 * @{ $allowed_tag_count{$method} })
                { $self->SSI_ERROR("missing arguments for directive \"$method\"");} # NOTE: fix this error message
            }

  return @returns;
}


sub _interp_vars {
    local $^W = 0;
    my($self,$text,$setcmd) = @_;

                # NOTE: var name in ${} MUST start with at least one \w
    $text =~ s{ ((\\*) ((\\)|(\$)) (\{)?(\w (?(6)(.*)\}|(\w*)) )) }
          {
          my ($all,$slashes, $slash,$dollar, $lbrak,$var)=($1,$2, $4,$5, $6,$7);
          $slashes .= $slash;							   #  NOTE: this can be improved
          if ($lbrak) {chop $var};

          if (! $setcmd)
              { chop($slashes); }

          if ($dollar && ! $slashes)
              { $var = $self->_echo($var); }
          else
              {
              $var = "{$var}" if ($lbrak) ;
              $var = $dollar.$var;
              }
          $slashes.$var
          }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 '';
}

#
# 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 {
                return $self->SSI_ERROR_FLUSH("value for sizefmt is '$value'. It must be 'abbrev' or 'bytes'.");
        }
    } elsif($type =~ /^errmsg$/i) {
        $self->{'_config'}->{'errmsg'} = $value;
    } elsif($type =~ /^_verbose_errors/i) {
        $self->{'_config'}->{'_verbose_errors'} = $value;
    } else {
        return $self->SSI_ERROR_FLUSH("arg to config is '$type'. It must be one of: 'timefmt', 'sizefmt', or 'errmsg'.");
    }
    return '';
}

sub set {
    my($self,%args) = @_;
    if(scalar keys %args > 1) {
        $self->{'_variables'}->{$args{'var'}} = $self->_interp_vars($args{'value'}, 1);
    } else { # var => value notation
        my($var,$value) = %args;
        $self->{'_variables'}->{$var} = $self->_interp_vars($value, 1);
    }
    return '';
}

sub escaped {
    my ($t)=@_;
    $t =~ s/\\\$/\$/g;
    return $t ;
}

sub echo {
    my($self,$key,$var) = @_;
    $var = $key if @_ == 2;
    my $encoding;
    if ($key eq 'encoding') {
        $encoding = $var;		 # NOTE: TODO: handle encoding.
        ($key,$var) = @_[3,4];
        $var = $key if (!$var);
    }

    if($var eq 'DATE_LOCAL') {
          return $loc;
    } elsif($var eq 'DATE_GMT') {
          return $gmt;
    } elsif($var eq 'LAST_MODIFIED') {
          return $lmod;
    }
        # it seems apache's "echo" command escapes out instances of "\$" to display just "$"
    return &escaped($self->{'_variables'}->{$var}) if exists $self->{'_variables'}->{$var};
    return &escaped($ENV{$var}) if exists $ENV{$var};
    return $self->{'_config'}->{'SSIUndefinedEcho'};
}

sub printenv {
    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 {
          return $self->SSI_ERROR_FLUSH("arg to include is '$type'. It must be one of: 'file' or 'virtual'.");
    }
}

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}) {
            return $self->SSI_ERROR_FLUSH("the maximum number of 'include file' recursions has been exceeded for '$filename'.");
    }

        # open the file, or warn and return an error
    my $fh = do { local *STDIN };
    open($fh,$filename) or do {
        return $self->SSI_ERROR_FLUSH("failed to open file ($filename): $!");
    };

        # 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);		 # <----- NOTE: is this a typo here??
                $file = catfile($FindBin::Bin,$file);		 # fixing it just in case
        }
        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 {
        return $self->SSI_ERROR_FLUSH("failed to create a URI based on '$filename'.");
    };
    if($@) {
        return $self->SSI_ERROR_FLUSH("failed to create a URI based on '$filename'.");
    }

    # 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}) {
        return $self->SSI_ERROR_FLUSH("the maximum number of 'include virtual' recursions has been exceeded for '$url'.");
    }

    my $response = $self->{_ua}->get($url);

    # is it a success?
    unless($response->is_success) {
        return $self->SSI_ERROR_FLUSH("failed to get('$url'): ".$response->status_line.".");
    }
        # 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 {
        return $self->SSI_ERROR_FLUSH("arg to exec() is '$type'. It must be one of: 'cmd' or 'cgi'.");
    }
}

sub _exec_cmd {
    my($self,$filename) = @_;

    # have we reached MAX_RECURSIONS?
    if(++$self->{_recursions}->{$filename} >= $self->{_max_recursions}) {
        return $self->SSI_ERROR_FLUSH("the maximum number of 'exec cmd' recursions has been exceeded for '$filename'.");
    }

    my $output = `$filename`; # security here is mighty bad.

    # was the command a success?
    if($?) {
        return $self->SSI_ERROR_FLUSH("`$filename` was not successful.");
    }

        # 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}) {
        return $self->SSI_ERROR_FLUSH("the maximum number of 'exec cgi' recursions has been exceeded for '$filename'.");
    }

    # 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 {
        return $self->SSI_ERROR_FLUSH("failed to create a URI from '$filename'.");
    };
    if($@) {
        return $self->SSI_ERROR_FLUSH("failed to create a URI from '$filename'.");
    }

    # get the content
    $self->{_ua} ||= $self->_get_ua();
    my $url = $uri->canonical;
    my $response = $self->{_ua}->get($url);

    # success?
    unless($response->is_success) {
          return $self->SSI_ERROR_FLUSH("failed to get('$filename').");
    }

        # 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 {
            return $self->SSI_ERROR_FLUSH("the first argument to flastmod is '$type'. It must be one of: 'file' or 'virtual'.");
    }

    unless(-e $filename) {
            return $self->SSI_ERROR_FLUSH("flastmod failed to find '$filename'.");
            }

    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 {
            return $self->SSI_ERROR_FLUSH("the first argument to fsize is '$type'. It must be one of: 'file' or 'virtual'.");
    }
    unless(-e $filename) {
            return $self->SSI_ERROR_FLUSH("fsize failed to find '$filename'.");
    }

    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
#
                # NOTE: anything calling _test should check $@
sub _test {
    my($self,$test) = @_;
    my $quote;
    my ($pound, $pounds);

    $test =~ s/^(['"`])\s*(.*?)\s*(\1)$/$2/; # trim off surrounding (matching) quotes, and whitespace
    $quote= $1;

            # trivial test returns:
    return 0 if $test =~ /$RE_single_quote_false_NC/;
    return 1 if $test =~ /^["`]+$/;  # 1+ double quotes or backticks, trivially true
    return 1 if $test =~ /^[\s`'"]*?([`'"])?[\s]+?\1$/; # whitespace inside second set of quotes, trivially true
    return 1 if $test =~ /^[\w]+$/; # bareword (alphanum) trivially true

    if (1) # ($test =~ m{^\(})
        { # need to do this otherwise it creates infinite loop for some reason
        if ($test =~ m{
                    ((?:\!\s*)*) \s*	  # $1
                    (	  		  # $2
                      $RE_parens_2C	  # ($3, $4) has 2 capture groups
                      |
                      (?:$RE_all_no_paren_noop_NC)*
                    ) \s*
                    (?:
                      (\&\& | \|\| )? \s*   # $5
                      (.*)	 	    # $6
                    )? \s*
                    }x)
            {
            # $1 is pound,    $4 is inside the brackets, $5 is the op, $6 is the RHS
            my $LHS=$2;
            my $LHS_parens=$4;	# inside parentheses, does not include the parentheses
            my $OP=$5;
            my $RHS=$6;
            # expr="x == '\\x'" is split into:    LHS=[ x == ]    RHS=[ '\\x' ]
            $pounds=$pound=$1;
            $pound=~s/(?:\!\s*\!\s*)*//;	  # remove even # of !s, as these cancel out

            # if no op, and LHS and RHS, FAIL... because (x) b..  -- can be no LHS but RHS and noop
            # if no op and no $RHS, return pound != test(LHS)
            # if op, and no RHS or no LHS, FAIL
            # if op, do op.. return [pound != test(LHS)] op [test(LHS)]
            if ($OP)
                { # LOGICAL COMPARISON && and ||
                    # NOTE:  && and || have equal precedence

                if ($LHS=~/^\s*$/)
                    {
                    return $self->SSI_ERROR("empty logical comparison in expr.");
                    }
                if ($RHS=~/^\s*$/)
                    {
                    return $self->SSI_ERROR("empty logical comparison in expr.");
                    }

                if ($LHS_parens) {$LHS = $LHS_parens;}  # needs to be done here, because of empty comparison checker
                $LHS = $self->_test($quote.$LHS.$quote);

                if ($@) {return;} # there were errors in the test

                if ($pound) {$LHS = !$LHS;}
                $RHS = $quote.$RHS.$quote;

                if ($OP eq "&&")
                    { return ($LHS && $self->_test($RHS)); } # short circuits, faster
                else # ($OP eq "||")
                    { return ($LHS || $self->_test($RHS)); } # short circuits, faster
                }
            else
                { # NO OP
                if ($LHS && $RHS)
                    {
                    if ($LHS_parens)
                        {
#                    	return $self->SSI_ERROR("error in expression."); # NOTE: FIXME: improve this error msg..
#                    	return $self->SSI_ERROR("error in expression. LHS and RHS but no OP"); # NOTE: FIXME: improve this error msg..
                        return $self->SSI_ERROR("error in expression. LHS [$LHS] and RHS [$RHS] but no OP"); # NOTE: FIXME: improve this error msg..
                        }
                    $test = $LHS.$RHS;
                    }
                elsif ($LHS)  # brackets or balanced quotes
                    {
                    if ($LHS_parens)
                        {
                        $LHS = $self->_test($quote.$LHS_parens.$quote);
                        if ($pound) {$LHS = !$LHS;}
                        return $LHS;
                        }
                    $test = $LHS;  # NOTE: is this redundant?
                    }
                elsif ($RHS)  # unbalanced quotes
                    { $test = $RHS; }  # NOTE: is this redundant?
                }
            }
        else
            {
            return $self->SSI_ERROR("unknown error in expression."); # SHOULD NOT REACH THIS
            }
        }


    #--------------------------
    # BAREWORD (no comparison sign)
   if ($test =~ /^(?:$RE_all_quote_NC|(?:[^=<>\/]|[\\]\/)*)$/)	# BAREWORD
        {
        if ($test =~ /^(['])(.*?)(?:\1)$/)  {$test=$2;} # need to trim surrounding single quotes
        if ($test =~ /^$/)   {return ($pound);} # no need to parse
        if ($test =~ /^["]/) {return (! $pound);} # no need to parse

        my $interp_test = $self->_interp_vars($test);
        my $RET = ($interp_test =~ /[^']+/);
        if ($interp_test ne $test)
            {	# var interpolation occurred, NOTE: apache deems only '' or empty to be false in this case.
            $test = ($interp_test !~ /^$/) ;
            return (($pound) xor ($test));
            }
        return (($pound) xor ($RET));	# non empty string is true,
        }


    #--------------------------
    # STRING COMPARISON  >,<,==,!=,=~
    if ($test  =~ m{  \s*((?:$RE_all_quote_NC|[^<>=])*?)\s*([<>=!]=?)\s*([^<>=]*)\s*   }x)
        {
        if ($pounds)
            { return $self->SSI_ERROR("invalid expression $quote$test$quote in file"); } # NOTE: FIXME

        my ($s1,$cmp,$s2)=($1, $2, $3);
        if ($s1=~/^\s*$/)
            { return $self->SSI_ERROR("problem in REGEX. blank comparison \$s1"); } 	# NOTE: FIXME
        if ($s2=~/^\s*$/)
            { return $self->SSI_ERROR("problem in REGEX. blank comparison \$s2"); } 	# NOTE: FIXME

        if ($s2 =~ m{^  \s* (?: (?:/\s*[^/]*) | // ) \s* $}x)	# NOTE: what about escaped or stringed
            {
            if ($cmp =~ m/^==?$/)	{return 1;}
            elsif ($cmp =~ m/^!=$/)	{return;}
            else  { return $self->SSI_ERROR("Invalid expression $quote$test$quote in string comparison."); }
            }

        $s1=$self->_interp_vars($s1);
        if ($s1 =~ /^(['"`])(.*?)(?:\1)$/)  {$s1=$2;} # trim off surrounding (matching) quotes

              # REGEX
        if  ($s2 =~ m{^\s* / ((?:(?:(?:\\\\)*\\/) | [^/] )*) / (.*?)\s*$}x) # wrapped by /xx/
            {
            if ($2)
                { return $self->SSI_ERROR("problem in REGEX. s2=[$s2] extra stuff=[$2]"); }		# NOTE: FIXME
            $s2=qr/$1/; # regex s2
            $s2 = $self->_interp_vars($s2);
            if ($cmp =~ m/^==?$/)
                { return  ($s1 =~ m/$s2/);}
            elsif ($cmp eq "!=")
                { return ($s1 !~ $s2); }	# NOTE: FIXME!!!
            }
        else
            {
            if ($s2=~m|^[^\s/]+\s+/|) # unquoted, unescaped slash
                { return $self->SSI_ERROR("problem in REGEX unquoted slash. s2=[$s2]"); }		# NOTE: FIXME

            $s2 = $self->_interp_vars($s2);
            if ($s2 =~ /^(['"])(.*?)(\1)$/)  {$s2 = $2;} # trim off surrounding (matching) quotes
            }

        my $ret;
        $ret = $s1 cmp $s2;

        if ($cmp =~ m/^==?$/)	{$ret = ($ret eq 0);}
        elsif ($cmp =~ m/^!=$/)	{$ret = ($ret ne 0);}

        elsif ($cmp =~ m/^<$/)	{$ret = ($ret lt 0);}
        elsif ($cmp =~ m/^<=$/)	{$ret = ($ret le 0);}

        elsif ($cmp =~ m/^>$/)	{$ret = ($ret gt 0);}
        elsif ($cmp =~ m/^>=$/)	{$ret = ($ret ge 0);}

        else { return $self->SSI_ERROR("unknown comparison"); } # UNKNOWN COMPARISON -- should never reach this

        return $ret;
        }
    else
        {
        if ($test =~ m{[^/]+\s+/})	# NOTE: UNFINISHED!! FIXME non empty unrecognized string that didnt fail
            { return $self->SSI_ERROR("error in expression, regex found in string"); }
        return 1;
        }

   return; # return false.. it seems none of the ops applied..
}

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

    my $res=$self->_test($expr);

    if($@) {
        $self->_true();
        return;
        } # any errors cause the expr to evaluate to true..??

    if($res) {
        $self->_true();
    } else {
        $self->_suspend();
    }
    return '';
}

sub elif {
    my($self,$expr,$test) = @_;

    if (! $self->_in_if() )
        {
        $self->SSI_WARN("Incorrect use of elif ssi directive: no preceeding 'if'."); # NOTE: just a "warn"
        $self->_suspend() unless $self->_suspended();
        return;
        }

    if ($self->_seen_true())
        {
        $self->_suspend() unless $self->_suspended();
        return;
        }

    $expr = $test if @_ == 3;


    my $res= $self->_test($expr);

    if($@) {
        $self->_suspend() unless $self->_suspended();
        return;
        }

    if($res) {
        $self->_true();
        $self->_resume();
    } else {
        $self->_suspend() unless $self->_suspended();
    }
    return '';
}

sub else {
    my $self = shift;

    if (! $self->_in_if() ) {
        $self->SSI_WARN("Incorrect use of else ssi directive: no preceeding 'if'."); # NOTE: just a "warn"
        $self->_suspend() unless $self->_suspended();
        return;
        }
    if ($self->_seen_true()) {
        $self->_suspend() unless $self->_suspended(); }
    else {
        $self->_resume(); }
    return '';
}

sub endif {
    my $self = shift;
    if (! $self->_in_if() )
        {
        # $self->SSI_ERROR("Incorrect use of endif ssi directive: no preceeding 'if'.");
        $self->SSI_WARN("Incorrect use of endif ssi directive: no preceeding 'if'.");
        }
    else
        { $self->_leaving_if(); }
    $self->_resume() if $self->_suspended();	# might be suspended even if not in "if"
    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::apacheSSI')) {
              tie *STDOUT, 'CGI::apacheSSI', 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::apacheSSI::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::apacheSSI::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::apacheSSI::LMOD;

sub TIESCALAR { bless [@_], shift() }
sub FETCH {
    my $self = shift;
        return $self->[-1]->flastmod('file', $ENV{'SCRIPT_FILENAME'} || $ENV{'PATH_TRANSLATED'} || '');
}

1;
__END__