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!

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

Note that you'll need to pass the name of the filehandle to C<tie()> as 
a named parameter. Other named parameters are possible, as detailed 
below. These parameters are the same as those passed to the C<new()> 
method. However, C<new()> will not tie a filehandle for you.

You may create and use multiple CGI::apacheSSI objects; they will not 
step on each others' variables.

Object-Oriented methods use the same general format so as to imitate 
SSI directives:

    <!--#include virtual="/foo/bar.footer" -->

would be

    $ssi->include(virtual => '/foo/bar.footer');

likewise,

    <!--#exec cgi="/cgi-bin/foo.cgi" -->

would be

    $ssi->exec(cgi => '/cgi-bin/foo.cgi');

Usually, if there's no chance for ambiguity, the first argument may 
be left out:

    <!--#echo var="var_name" -->

could be either

    $ssi->echo(var => 'var_name');

or

    $ssi->echo('var_name');

Likewise,

    $ssi->set(var => $varname, value => $value)

is the same as 

    $ssi->set($varname => $value)

=over 4

=item $ssi->new([%args])

Creates a new CGI::apacheSSI object. The following are valid (optional) arguments: 

 DOCUMENT_URI    => $doc_uri,
 DOCUMENT_NAME   => $doc_name,
 DOCUMENT_ROOT   => $doc_root,
 errmsg          => $oops,
 sizefmt         => ('bytes' || 'abbrev'),
 timefmt         => $time_fmt,
 MAX_RECURSIONS  => $default_100, # when to stop infinite loops w/ error msg
 COOKIE_JAR      => HTTP::Cookies->new,
 _verbose_errors  => 0 || 1,
 
=item C<_verbose_errors>

The C<_verbose_errors> option was introduced to enable the output of more verbose
errors directly to the browser (instead of the standard 
C<[an error occurred while processing this directive]> message),
which can be quite useful when debugging. This can be changed during
script execution via $ssi->config('_verbose_errors', 1) to enable or
$ssi->config('_verbose_errors', 0) to disable. Default is 0.

=item $ssi->config($type, $arg)

$type is either 'sizefmt', 'timefmt', 'errmsg', or '_verbose_errors'. $arg is similar to 
those of the SSI C<spec>, referenced below.

=item $ssi->set($varname => $value)

Sets variables internal to the CGI::apacheSSI object. (Not to be confused 
with the normal variables your script uses!) These variables may be used 
in test expressions, and retreived using $ssi->echo($varname). These
variables also will not be available in external, included resources.

=item $ssi->echo($varname)

Returns the value of the variable named $varname. Such variables may 
be set manually using the C<set()> method. There are also several built-in 
variables:

 DOCUMENT_URI  - the URI of this document
 DOCUMENT_NAME - the name of the current document
 DATE_GMT      - the same as 'gmtime'
 DATE_LOCAL    - the same as 'localtime'
 LAST_MODIFIED - the last time this script was modified

=item $ssi->exec($type, $arg)

$type is either 'cmd' or 'cgi'. $arg is similar to the SSI C<spec> 
(see below).

=item $ssi->include($type, $arg)

Similar to C<exec>, but C<virtual> and C<file> are the two valid types.
SSI variables will not be available outside of your CGI::apacheSSI object, 
regardless of whether the virtual resource is on the local system or
a remote system.

=item $ssi->flastmod($type, $filename)

Similar to C<include>.

=item $ssi->fsize($type, $filename)

Same as C<flastmod>.

=item $ssi->printenv

Returns the environment similar to Apache's mod_include.

=item $ssi->cookie_jar([$jar])

Returns the currently-used HTTP::Cookies object. You may optionally
pass in a new HTTP::Cookies object. The jar is used for web requests
in exec cgi and include virtual directives.

=back

=head2 FLOW-CONTROL METHODS

The following methods may be used to test expressions. During a C<block> 
where the test $expr is false, nothing will be returned (or printed, 
if tied).

=over 4

=item $ssi->if($expr)

The expr can be any Apache mod_include expression as you would use in:

 <!--#if expr="'\$varname' =~ /^foo$/" -->ok<!--#endif -->

The $varname is expanded as you would expect. (We escape it so as to use 
the C<$varname> within the CGI::apacheSSI object, instead of that within our 
progam.) But the C<$/> inside the regex is also expanded. This is fixed 
by escaping the C<$>:

 <!--#if expr="'\$varname' =~ /^value\$/" -->ok<!--#endif -->

NOTE: Although "C<if>" allows multiple C<expr>'s:

 <!--#if  expr="$myexpr1" expr="$myexpr2" -->ok<!--#endif -->
 
only the last expression (C<$myexpr2>) is what is used for evaluation. 

=item $ssi->elif($expr)

=item $ssi->else

=item $ssi->endif

=back

=head1 SEE ALSO

C<CGI::SSI>, C<Apache::SSI> and the SSI C<spec> at
http://www.apache.org/docs/mod/mod_include.html

=head1 AUTHOR

(c) 2000-2005 James Tolley <james@bitperfect.com>, et al., All Rights Reserved.

(c) 2013-2014 insaner <apacheSSI-PLEASE-NOSPAM@insaner.com>, (rewrite of eval engine and original fork), All Rights Reserved.

This is free software. You may copy and/or modify it under the terms of the GPL.
USE AT YOUR OWN RISK.
If your server explodes and invests all your money on penny stocks, don't blame me.
But if this module was of any use to you and you would like to show your gratitude
with a financial contribution, that would be most graciously received.

=head1 CREDITS

Many Thanks to all contributors to CGI::SSI, Apache::SSI and HTML::SimpleParse.