File Coverage

blib/lib/BW/Include.pm

Criterion	Covered	Total	%
statement	18	125	14.4
branch	0	60	0.0
condition	0	33	0.0
subroutine	6	21	28.5
pod	5	14	35.7
total	29	253	11.4

# BW::Include.pm
# Template support for BW::* (esp BW::CGI)
#
# by Bill Weinman - http://bw.org/
# Copyright (c) 1995-2010 The BearHeart Group, LLC
#
# See POD for History

# Important note:
# This is a bona-fide kludge. I've been using it, or some version of it,
# for so many years that it works well for me. YMMV.

package BW::Include;
use strict;
use warnings;

use IO::File;
use IO::Pipe;
use BW::Constants;
use base qw( BW::Base );

our $VERSION = "1.0.2";

sub _init
{
    my $self = shift;
    $self->SUPER::_init(@_);

    $self->self( $ENV{SCRIPT_NAME} || EMPTY ) unless $self->{self};
    $self->{dir} = $self->{DIR} if $self->{DIR};
    $self->{filename} = $self->{FILENAME} if $self->{FILENAME};

    return SUCCESS;
}

# _setter_getter entry points
sub self     { BW::Base::_setter_getter(@_); }    # self-reference URI
sub dir      { BW::Base::_setter_getter(@_); }    # base dir -- must be absolute
sub DIR      { BW::Base::_setter_getter(@_); }    # for backward compatibility
sub filename { BW::Base::_setter_getter(@_); }    # filename for preloading
sub FILENAME { BW::Base::_setter_getter(@_); }    # for backward compatibility
sub QUIET    { BW::Base::_setter_getter(@_); }    # for quiet mode

sub version
{
    return $VERSION;
}

# set or get quiet mode
sub quiet
{
    my $self = shift;
    $self->{QUIET} = shift if @_;
    return $self->{QUIET};
}

# set and get vars
sub var
{
    my $self  = shift;
    my $name  = shift or return '';
    my $value = shift;

    if ( defined($value) ) {
        $self->{VARS}{$name} = $value;
    }

    return $self->{VARS}{$name};
}

# wrapper for print self->spf
sub pf
{
    my $self = shift;
    my $filename = shift || $self->{filename};
    return $self->_error( "pf: No filename" ) unless $filename;
    STDOUT->autoflush(1);
    print $self->spf($filename);
}

# expand from a string to a string
sub sps
{
    my ( $self, $string ) = @_;
    return $string unless $string;

    $string =~ s|\$([a-z0-9_:]+)\$|$self->var($1)|gei;
    $string =~ s||$self->var($1)|ge;
    return $string;
}

# main routine -- recursively builds a string from file with includes
sub spf
{
    my $self = shift;

    my $filename = shift || $self->{filename};
    return $self->_error( "No filename" ) unless $filename;

    # create the filename
    if ( substr( $filename, 1, 1 ) eq '/' and $ENV{DOCUMENT_ROOT} ) {
        $filename = $ENV{DOCUMENT_ROOT} . $filename;
    } elsif ( $self->{dir} ) {
        $filename = "$self->{dir}/$filename";
    }

    my $s = '';

    # this alows arbitrary perl code in the included file
    sub expand
    {
        my $self = shift;
        my $v    = shift;
        my $x;
        if    ( $x = $self->var($v)     or defined $x ) { $x }
        elsif ( $x = eval("\$main::$v") or defined $x ) { $x }
        elsif ( $x = eval("\$$v")       or defined $x ) { $x }
        elsif ( $x = eval("\$ENV{$v}")  or defined $x ) { $x }
        else { $self->{QUIET} ? '' : "Undefined Variable ($v)" }
    }

    # include virtual for running CGI ...
    sub runprog
    {
        my $self = shift;
        my $_qs  = '';
        my $x    = '';
        my $pn   = shift || '';

        # $pn =~ m|^/| or $pn = '/' . $pn;  # imply the leading / if missing
        my $progpath = '';
        if ( $pn =~ m|^/| ) {
            $progpath = "$ENV{DOCUMENT_ROOT}$pn";
        } else {
            if ( $ENV{SCRIPT_FILENAME} ) {    # derive the current directory if possible
                $ENV{SCRIPT_FILENAME} =~ m|(.*[\\/])|;
                $progpath = $1 || '';
            } else {
                $progpath = "./";             # a unixish guess
            }
            $progpath .= $pn;
        }

        ( $progpath, $_qs ) = split( /\?/, $progpath, 2 );
        if ( -f $progpath ) {
            if ( -x $progpath ) {             # run it as CGI
                                              # save the environment
                my $sn = $ENV{SCRIPT_NAME};
                my $qs = $ENV{QUERY_STRING};
                my $cl = $ENV{CONTENT_LENGTH} if $ENV{CONTENT_LENGTH};
                my $ct = $ENV{CONTENT_TYPE} if $ENV{CONTENT_TYPE};
                my $rm = $ENV{REQUEST_METHOD} || 'GET';

                # set up the CGI environment
                $pn =~ /(.*)\?/ and $pn = $1;    # SCRIPT_NAME has no query
                $ENV{SCRIPT_NAME} = $pn;
                $ENV{QUERY_STRING} = $_qs || '';

                # post method is always invalid for included CGI . . .
                delete $ENV{CONTENT_LENGTH} if $ENV{CONTENT_LENGTH};
                delete $ENV{CONTENT_TYPE}   if $ENV{CONTENT_TYPE};
                $ENV{REQUEST_METHOD} = 'GET';

                # make the path safe for the -T switch
                my $env_path = $ENV{PATH} || '';
                $ENV{PATH} = '';

                # makesure the progpath string is safe
                if ( $progpath =~ /^([-\/\\\@\w.]+)$/ ) {
                    $progpath = $1;

                    # run it
                    my $p = new IO::Pipe;
                    $p->reader($progpath);
                    while (<$p>) { $x .= $_ }
                    $p->close;

                    # can't use the mime header
                    $x =~ s/^content-type:.*//i if $x;
                }

                else {
                    $x = 'unsafe characters in exec';
                }

                # restore the environment
                $ENV{PATH}           = $env_path;
                $ENV{SCRIPT_NAME}    = $sn;
                $ENV{QUERY_STRING}   = $qs;
                $ENV{CONTENT_LENGTH} = $cl if $cl;
                $ENV{CONTENT_TYPE}   = $ct if $ct;
                $ENV{REQUEST_METHOD} = $rm;
                return $x;
            } else {    # display it
                return $self->spf($progpath);
            }
        } else {
            return "$progpath: $!";
        }
    }

    my $fh = IO::File->new("<$filename") or return $self->_error( "spf: cannot open $filename ($!)" );

    while (<$fh>) {
        $_ =~ s|\$([a-z0-9_:]+)\$|expand($self, $1)|gei;
        $_ =~ s||expand($self, $1)|ge;
        $_ =~ s||runprog($self, $1)|ge;
        $s .= $_;
    }
    close $fh;

    return $s;
}

return 1;


__END__