File Coverage

blib/lib/Embperl.pm

Criterion	Covered	Total	%
statement	63	171	36.8
branch	10	80	12.5
condition	3	39	7.6
subroutine	16	25	64.0
pod	0	4	0.0
total	92	319	28.8

###################################################################################
#
#   Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh  www.ecos.de
#   Embperl - Copyright (c) 2008-2014 Gerald Richter
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.
#
#   THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
#   IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
#   WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
#   $Id: Embperl.pm 1578075 2014-03-16 14:01:14Z richter $
#
###################################################################################


package Embperl;

require Cwd ;

require Exporter;
require DynaLoader;

use Embperl::Syntax ;
use Embperl::Recipe ;
use Embperl::Constant ;
use Embperl::Util ;
use Embperl::Out ;
use Embperl::Log ;
use Embperl::App ;

use strict ;
use vars qw(
    @ISA
    $VERSION
    $cwd
    $req_rec
    $srv_rec
    $importno
    %initparam
    $modperl
    $modperl2
    $modperlapi
    $req
    $app
    ) ;


@ISA = qw(Exporter DynaLoader);

$VERSION = '2.5.0' ;


if ($modperl  = $ENV{MOD_PERL})
    {
    $modperl  =~ m#/(\d+)\.(\d+)# ;
    $modperl2 = 1 if ($1 == 2 || ($1 == 1 && $2 >= 99)) ;
    $modperlapi = $ENV{MOD_PERL_API_VERSION} || 1 ;
    }

if ($ENV{PERL_DL_NONLAZY}
	&& substr($ENV{GATEWAY_INTERFACE} || '', 0, 8) ne 'CGI-Perl'
	&& defined &DynaLoader::boot_DynaLoader)
    {
    $ENV{PERL_DL_NONLAZY} = '0';
    DynaLoader::boot_DynaLoader ('DynaLoader');
    }

if ($modperl2)
    {
    if ($modperlapi >= 2)
        {
        require Apache2::ServerRec ;
        require Apache2::ServerUtil ;
        require Apache2::RequestRec ;
        require Apache2::RequestUtil ;
        require Apache2::SubRequest ;
        require APR::Table ;
        $srv_rec = Apache2::ServerUtil -> server ;
        }
    else
        {
        if (($modperl =~ /_(\d+)/) && $1 < 15)
	    {
            require Apache::Server ;
	    }
        else
	    {
            require Apache::ServerRec ;
	    }
        require Apache::ServerUtil ;
        require Apache::RequestRec ;
        require Apache::RequestUtil ;
        require Apache::SubRequest ;
        $srv_rec = Apache -> server ;
        }
    }
elsif ($modperl)
    {
    require Apache ;
    $srv_rec = Apache -> server ;
    }

if (!defined(&Embperl::Init))
    {
    bootstrap Embperl $VERSION  ;
    Boot ($VERSION) ;
    Init ($srv_rec, \%initparam) ;
    }


$cwd       = Cwd::fastcwd();

tie *Embperl::LOG, 'Embperl::Log' ;


1 ;

#######################################################################################

sub Execute

    {
    my $_ep_param = shift ;

    local $SIG{__WARN__} = \&Warn ;

    # when called inside a Embperl Request, Execute the component only
    return Embperl::Req::ExecuteComponent ($_ep_param, @_) if ($req) ;

    $_ep_param = { inputfile => $_ep_param, param => [@_]} if (!ref $_ep_param) ;

    local $req_rec ;
    if ($modperl && !exists ($_ep_param -> {req_rec}))
        {
        eval
            {
            if ($modperlapi < 2)
                {
                $req_rec = Apache -> request  ;
                }
            else
                {
                $req_rec = Apache2::RequestUtil -> request  ;
                }
            } ;
        }
    elsif (exists ($_ep_param -> {req_rec}) && defined ($_ep_param -> {req_rec}))
        {
        $req_rec = $_ep_param -> {req_rec} ;
        }

    my $_ep_rc ;
        {
        $_ep_rc = Embperl::Req::ExecuteRequest (undef, $_ep_param)  ;
        }

    return $_ep_rc ;
    }

#######################################################################################

sub handler

    {
    local $SIG{__WARN__} = \&Warn ;
    $req_rec = $_[0] ;
    if ($modperlapi < 2)
        {
        Apache -> request ($req_rec) ;
        }
    else
        {
        Apache2::RequestUtil -> request ($req_rec) ;
        }

    my $rc = Embperl::Req::ExecuteRequest ($_[0]) ;
    return $rc ;
    }

#######################################################################################

sub Warn
    {
    local $^W = 0 ;
    my $msg = $_[0] ;
    chop ($msg) ;

    my $lineno = getlineno () ;
    my $Inputfile = Sourcefile () ;
    if ($msg =~ /Embperl\.pm/)
        {
        $msg =~ s/at (.*?) line (\d*)/at $Inputfile in block starting at line $lineno/ ;
        }
    logerror (Embperl::Constant::rcPerlWarn, $msg);
    }

#######################################################################################


sub PreLoadFiles

    {
    my $files = $initparam{preloadfiles} ;
    delete $initparam{preloadfiles} ;

    if ($files && ref $files eq 'ARRAY')
        {
        foreach my $file (@$files)
            {
            if (ref $file)
                {
                Execute ({%$file, import => 0}) ;
                }
            else
                {
                Execute ({inputfile => $file, import => 0}) ;
                }
            }
        }
    }

#######################################################################################

package Embperl::Req ;

#######################################################################################

use strict ;

if ($Embperl::modperl)
    {
    if (!$Embperl::modperl2)
        {
        eval 'use Apache::Constants qw(&OPT_EXECCGI &DECLINED &OK &FORBIDDEN)' ;
        die "use Apache::Constants failed: $@" if ($@);
        }
    elsif ($Embperl::modperlapi >= 2)
        {
        eval 'use Apache2::Const qw(&OPT_EXECCGI &DECLINED &OK &FORBIDDEN)' ;
        die "use Apache2::Const failed: $@" if ($@);
        }
    else
        {
        eval 'use Apache::Const qw(&OPT_EXECCGI &DECLINED &OK &FORBIDDEN)' ;
        die "use Apache::Const failed: $@" if ($@);
        }
    }

#######################################################################################

sub ExecuteComponent

    {
    my $_ep_param = shift ;
    my $rc ;

    if (!ref $_ep_param)
        {
        $rc = $Embperl::req -> execute_component ({ inputfile => $_ep_param, param => [@_]}) ;
        }
    elsif ($_ep_param -> {object})
        {
        my $c = $Embperl::req -> setup_component ($_ep_param) ;
        my $rc = $c -> run ;
        my $package = $c -> curr_package ;
        $c -> cleanup ;
        if (!$rc)
            {
            my $object = {} ;
            bless $object, $package ;
            return $object ;
            }
        return undef ;
        }
    else
        {
        $rc = $Embperl::req -> execute_component ($_ep_param) ;
        }
    Embperl::exit() if ($Embperl::req -> had_exit) ;

    return $rc ;
    }

#######################################################################################

sub get_multipart_formdata
    {
    my ($self) = @_ ;

    my $dbgForm = $self -> config -> debug & Embperl::Constant::dbgForm ;

    # just let CGI.pm read the multipart form data, see cgi docu
    if ($Embperl::modperl2)
        {
        if ($Embperl::modperlapi < 2)
            {
            require Apache::compat  # Apache::compat is needed for CGI.pm
            }
        else
            {
            require Apache2::compat  # Apache::compat is needed for CGI.pm
            }
        }
    require CGI ;

    my $cgi = new CGI ;
    my $fdat = $self -> thread -> form_hash ;
    $self -> param -> cgi ($cgi) ;       # keep it until then end of the request
					 # otherwsie templ files be
					 # destroyed in CGI.pm 3.01+
    my $ffld = $self -> thread -> form_array ;
    @$ffld = $cgi->param;

    $self -> log ("[$$]FORM: Read multipart formdata, length=$ENV{CONTENT_LENGTH}\n") if ($dbgForm) ;
    my $params ;
    foreach ( @$ffld )
	{
    	# the param_fetch needs CGI.pm 2.43
	$params = $cgi->param_fetch( -name => $_ ) ;
    	#$params = $cgi->{$_} ;
	if ($#$params > 0)
	    {
	    $fdat->{ $_ } = join ("\t", @$params) ;
	    }
	else
	    {
	    $fdat->{ $_ } = $params -> [0] ;
	    }

	$self -> log ("[$$]FORM: $_=$fdat->{$_}\n") if ($dbgForm) ;

	if (ref($fdat->{$_}) eq 'Fh')
	    {
	    $fdat->{"-$_"} = $cgi -> uploadInfo($fdat->{$_}) ;
	    }
        }
    }



#######################################################################################

sub SetupSession

    {
    my ($req_rec, $uid, $sid, $appparam) = @_ ;

    my ($rc, $thread, $app) = Embperl::InitAppForRequest ($req_rec, $appparam) ;

    my $cookie_name = $app -> config -> cookie_name ;
    my $debug = $appparam?$appparam -> {debug} & Embperl::Constant::dbgSession:0 ;
    if (!$uid)
        {
        my $cookie_val  = $ENV{HTTP_COOKIE} || ($req_rec?$req_rec->headers_in -> {'Cookie'}:undef) ;

	if ((defined ($cookie_val) && ($cookie_val =~ /$cookie_name=(.*?)(\;|\s|$)/)) || ($ENV{QUERY_STRING} =~ /$cookie_name=.*?:(.*?)(\;|\s|&|$)/) || $ENV{EMBPERL_UID} )
	    {
	    $uid = $1 ;
	    print Embperl::LOG "[$$]SES:  Received user session id $1\n" if ($debug) ;
            }

        }

    if (!$sid)
        {
	if (($ENV{QUERY_STRING} =~ /${cookie_name}=(.*?)(\;|\s|&|:|$)/))
	    {
	    $sid = $1 ;
	    print Embperl::LOG "[$$]SES:  Received state session id $1\n" if ($debug) ;
            }
        }

    $app -> user_session -> setid ($uid) if ($uid) ;
    $app -> state_session -> setid ($sid) if ($sid) ;

    return wantarray?($app -> udat, $app -> mdat, $app -> sdat):$app -> udat ;
    }


#######################################################################################

sub GetSession

    {
    my $r = shift || Embperl::CurrReq () ;

    if ($r -> session_mgnt)
	{
        return wantarray?($r -> app -> udat, $r -> app -> mdat, $r -> app -> sdat):$r -> app -> udat ;
	}
    else
        {
        return undef ; # No session Management
        }
    }

#######################################################################################

sub DeleteSession

    {
    my $r = shift || Embperl::CurrReq () ;
    my $disabledelete = shift ;

    my $udat = $r -> app -> user_session ;
    if (!$disabledelete)  # Delete session data
        {
        $udat -> delete  ;
        }
    else
        {
        $udat-> {data} = {} ; # for make test only
        $udat->{initial_session_id} = "!DELETE" ;
        }
    $udat->{status} = 0;
    }


#######################################################################################

sub RefreshSession

    {
    my $r = shift || Embperl::CurrReq () ;

    $r -> session_mgnt ($r -> session_mgnt | 4) if ($r -> session_mgnt) ; # resend cookie
    }

#######################################################################################

sub CleanupSession

    {
    my ($req_rec, $appparam) = @_ ;

    my ($rc, $thread, $app) = Embperl::InitAppForRequest ($req_rec, $appparam) ;

    foreach my $obj ($app -> user_session, $app -> state_session, $app -> app_session)
        {
        $obj -> cleanup if ($obj) ;
        }

    }


#######################################################################################

sub SetSessionCookie

    {
    my ($req_rec, $appparam) = @_ ;

    my ($rc, $thread, $app) = Embperl::InitAppForRequest ($req_rec, $appparam) ;
    my $udat    = $app -> user_session ;
    $req_rec ||= Apache -> request ;

    if ($udat && $req_rec)
        {
        my ($initialid, $id, $modified)  = $udat -> getids ;

        my $name     = $app -> config -> cookie_name ;
        my $domain   = $app -> config -> cookie_domain ;
        my $path     = $app -> config -> cookie_path ;
        my $expires  = $app -> config -> cookie_expires ;
        my $secure   = $app -> config -> cookie_secure ;
        my $domainstr  = $domain?"; domain=$domain":'';
        my $pathstr    = $path  ?"; path=$path":'';
        my $expiresstr = $expires?"; expires=$expires":'' ;
        my $securestr  = $secure?"; secure":'' ;

        if ($id || $initialid)
            {
            $req_rec -> header_out ("Set-Cookie" => "$name=$id$domainstr$pathstr$expiresstr$securestr") ;
            }
        }
    }



#######################################################################################

sub export

    {
    my ($r, $caller) = @_ ;

    my $package = $r -> component -> curr_package ;
    no strict ;
    my $exports = \%{"$package\:\:_ep_exports"} ;

    print Embperl::LOG  "[$$]IMP:  Create Imports for $caller from $package\n" ;

    foreach $k (keys %$exports)
	{
        *{"$caller\:\:$k"}    = $exports -> {$k} ; #\&{"$package\:\:$k"} ;
        print Embperl::LOG  "[$$]IMP:  Created Import for $package\:\:$k -> $caller\n" ;
        }

    use strict ;
    }


#######################################################################################

package Apache::Embperl;

*handler2 = \&Embperl::handler ;

package HTML::Embperl;

*handler2 = \&Embperl::handler ;

package XML::Embperl;

*handler2 = \&Embperl::handler ;

1 ;