File Coverage

blib/lib/Embperl/Object.pm

Criterion	Covered	Total	%
statement	48	230	20.8
branch	1	134	0.7
condition	0	58	0.0
subroutine	16	21	76.1
pod	0	5	0.0
total	65	448	14.5

###################################################################################
#
#   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: Object.pm 1578075 2014-03-16 14:01:14Z richter $
#
###################################################################################


package Embperl::Object ;

require Cwd ;
require File::Basename ;

require Exporter;
require DynaLoader;

use Embperl ;
use Embperl::Constant ;

use constant OK => 0  ;
use constant NOT_FOUND => 404 ;
use constant FORBIDDEN => 403 ;
use constant DECLINED  => $ENV{MOD_PERL}?-1:403 ;


use File::Spec ;
use File::Basename ;

use strict ;
use vars qw(
    @ISA
    $VERSION
    $volume
    $fsignorecase
    %packages
    ) ;


@ISA = qw(Exporter DynaLoader);


$VERSION = '2.4.0';


$volume = (File::Spec -> splitpath ($Embperl::cwd))[0] ;
$fsignorecase = File::Spec->case_tolerant ;

1 ;

#############################################################################
#
# Normalize path into filesystem
#
#   in	$path	path to normalize
#   ret		normalized path
#


sub norm_path

    {
    my $path = shift ;
    return '' if (!$path) ;

    # remove spaces
    $path = $1 if ($path =~ /^\s*(.*?)\s*$/) ;

    if (File::Spec->file_name_is_absolute ($path))
        {
        $path = File::Spec -> canonpath ($path) ;
        if (!$_[0])
            {
            my ($volume, $dir, $file) = File::Spec -> splitpath ($path) ;
            $_[0] = File::Spec -> catdir ($volume, $dir) ;
            }
        }
    else
        {
        $_[0] ||= Cwd::fastcwd ;
        # make absolute path
        $path = File::Spec -> rel2abs ($path, $_[0]) ;
        }
    # Use always forward slashes
    $path =~ s/\\/\//g ;
    # Add volume (i.e. drive on Windows) if not exists
    $path = $volume . $path if ($path =~ /^\//) ;
    # Make lower case if filesystem doesn't cares about case
    $path = lc ($path) if ($fsignorecase) ;

    return $path ;
    }


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

sub handler_dmalloc
    {
    my %req ;

    $req{'req_rec'} = $_[0] ;

    my $n = Embperl::dmalloc_mark () ;
    my $rc = Execute (\%req) ;
    Embperl::dmalloc_check ($n, "Embperl::Object") ;
    return $rc ;
    }

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

sub handler
    {
    my %req ;

    $req{'req_rec'} = $_[0] ;

    Execute (\%req) ;
    }



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

sub run
    {
    $_[0] -> run ;
    }

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

sub Execute

    {
    my $req = shift ;

    local $SIG{__WARN__} = \&Embperl::Warn ;

    $Embperl::req_rec = $req -> {req_rec} ;
    my ($rc, $r) = Embperl::Req::InitRequest ($req -> {req_rec}, $req) ;
    my $debug     = $r && ($r -> config -> debug & Embperl::Constant::dbgObjectSearch) ;

    if ($rc)
        {
        print Embperl::LOG "[$$]Embperl::Object InitRequest returns $rc\n"  if ($debug);
        return $rc ;
        }


    if (exists $req -> {fdat} && ref ($req -> {fdat}) eq 'HASH')
        {
        %Embperl::fdat = %{$req -> {fdat}} ;
        if (ref $req -> {ffld} eq 'ARRAY')
            {
            @Embperl::ffld = @%{$req -> {ffld}};
            }
        else
            {
            @Embperl::ffld = keys %Embperl::fdat ;
            }
        delete $req -> {fdat};
        delete $req -> {ffld} ;
        }


    my $app    = $r -> app ;
    my $appcfg = $app -> config;

    my $cwd ;
    my $filename = norm_path ($r -> param -> filename, $cwd) ;
    my $apr        ;
    $apr = $req -> {req_rec} if ($req -> {req_rec}) ;

    my $basename  = $appcfg -> object_base || '_base.epl' ;
    ##$basename     =~ s/%modifier%/$req->{object_base_modifier}/ ;
    my $addpath   = $appcfg -> object_addpath ;
    my $reqpath   = $appcfg -> object_reqpath ;
    my $directory ;
    my $rootdir   = $apr?norm_path ($apr -> document_root, $cwd):"$volume/" ;
    my $stopdir   = norm_path ($appcfg -> object_stopdir, $cwd) ;

    if (-d $filename)
        {
        $directory = $filename ;
        }
    else
        {
        $directory = dirname ($filename) ;
        }

    my @searchpath  ;

    print Embperl::LOG "[$$]Embperl::Object Request Filename: $filename\n" if ($debug);
    print Embperl::LOG "[$$]Embperl::Object basename: $basename\n"  if ($debug);

    my $fn ;
    my $ap ;
    my $ldir  = '' ;
    my $found = 0 ;
    my $fallback = 0 ;

    do
        {
        $fn = "$directory/$basename" ;
        push @searchpath, $directory ;
        print Embperl::LOG "[$$]Embperl::Object Check for base: $fn\n"  if ($debug);
        if (-e $fn)
            {
            $apr -> filename ($fn) if ($apr) ;
            $found = 1 ;
            }
        else
            {
	    $ldir      = $directory ;
            $directory = dirname ($directory) ;
            }
        }
    while (!$found && $ldir ne $rootdir && $ldir ne $stopdir && $directory ne '/' && $directory ne '.' && $directory ne $ldir) ;

    while ($found && $stopdir && $stopdir ne $directory && $directory ne '/' && $directory ne '.' && $directory ne $ldir)
        {
	$ldir      = $directory ;
        $directory = dirname ($directory) ;
        push @searchpath, $directory ;
        }

    push @searchpath, @$addpath if ($addpath) ;
    if (!$found)
        {
        foreach $ap (@$addpath)
            {
            next if (!$ap) ;
            $fn = "$ap/$basename" ;
            print Embperl::LOG "[$$]Embperl::Object Check for base: $fn\n"  if ($debug);
            if (-e $fn)
                {
                $apr -> filename ($fn) if ($apr) ;
                $found = 1 ;
                last ;
                }

            }
        }


    if ($found)
        {
        print Embperl::LOG "[$$]Embperl::Object Found Base: $fn\n"  if ($debug);
        print Embperl::LOG "[$$]Embperl::Object path: @searchpath\n"  if ($debug);


        my $basepackage = $packages{$fn} ;
        my $package     = $packages{$filename} ;

        if (!$basepackage)
            {
            print Embperl::LOG "[$$]Embperl::Object import new Base: $fn\n"  if ($debug);
            my $cparam = {%$req, inputfile => $fn, import => 0 } ;
            my $c = $r -> setup_component ($cparam) ;
            run($c) ;
            $basepackage = $packages{$fn} = $c -> curr_package if (!$r -> error) ;
            $c -> cleanup ;
            print Embperl::LOG "[$$]Embperl::Object import base ", ($r -> error?'with ERRORS ':'') . "finished: $fn, " . ($basepackage?"package = $basepackage \n":"\n")  if ($debug);

            if (!$r -> error)
                {
                local $^W = 0 ;
        no strict ;
                my $isa   = \@{"$package\:\:ISA"} ;
                my $class = $appcfg -> object_handler_class || 'Embperl::Req' ;
                if (!grep /^\Q$class\E$/, @$isa)
                    {
                    push @{"$basepackage\:\:ISA"}, $class ;
                    }
                }
        use strict ;
            }

        $r -> config -> path (\@searchpath) ;

        if ($appcfg -> object_app && !$r -> error)
            {
            my $appfn = $appcfg -> object_app ;

            print Embperl::LOG "[$$]Embperl::Object import new Application: $appfn\n"  if ($debug);

            my $cparam = {object => $appfn, syntax => 'Perl', debug => $req -> {debug}} ;
            my $c = $r -> setup_component ($cparam) ;
            my $app = run($c) ;
            my $package = $c -> curr_package  if (!$r -> error) ;
            $c -> cleanup ;
            print Embperl::LOG "[$$]Embperl::Object import new Application ", ($r -> error?'with ERRORS ':'') . "finished: $appfn, " . ($package?"package = $package\n":"\n")  if ($debug);

            if (!$r -> error)
                {
                no strict ;
                my $isa = \@{"$package\:\:ISA"} ;
                if (!grep /^Embperl::App$/, @$isa)
                    {
                    push @{"$package\:\:ISA"}, 'Embperl::App'  ;
                    }
                use strict ;

                $app = $r -> app ;
                bless $app, $package ;

                my $status = eval { $app -> init ($r) ; } ;
                if ($@)
                    {
                    $r -> logerror (Embperl::Constant::rcEvalErr, $@, $apr) ;
                    }
                elsif ($status)
                    {
                    $r -> send_http_header ;
                    $r -> cleanup ;
                    print Embperl::LOG "[$$]Embperl::Object Application -> init had returned $status\n"  if ($debug);
                    return $status ;
                    }
                $filename = norm_path ($r -> param -> filename, $cwd) ;
                }
            }



        my $file_not_found = 0 ;
        if (!-f $filename)
            {
            $file_not_found = 1 ;
            if ($reqpath)
                {
                my $file = basename ($filename) ;
                foreach my $path (@$reqpath)
                    {
                    my $testfn = "$path/$file" ;
                    print Embperl::LOG "[$$]Embperl::Object Search for request file $file in $path\n"  if ($debug);
                    if (-f $testfn)
                        {
                        $filename = $testfn ;
                        $file_not_found = 0 ;
                        last ;
                        }
                    }
                }
            }

        if ($file_not_found)
            {
            if ($appcfg -> object_fallback)
                {
                $fallback = 1 ;
                $filename = $appcfg -> object_fallback ;
                print Embperl::LOG "[$$]Embperl::Object use fallback: $filename\n"  if ($debug);
                }
            else
                {
                print Embperl::LOG "[$$]Embperl::Object $filename not found, no fallback\n"  if ($debug);
                return NOT_FOUND ;
                }
            }

        if ($fn eq $filename)
            {
            $r -> logerror (Embperl::Constant::rcForbidden, $filename, $apr) ;
            $r -> cleanup ;
            return FORBIDDEN ;
            }


        if ((!$package || $fallback) && !$r -> error)
            {
            print Embperl::LOG "[$$]Embperl::Object import new file: $filename\n"  if ($debug && !$fallback);

            my $cparam = {%$req, inputfile => $filename, import => 0 } ;
            my $c = $r -> setup_component ($cparam) ;
            run($c) ;
            $package = $packages{$filename} = $c -> curr_package if (!$r -> error);
            $c -> cleanup ;
            print Embperl::LOG "[$$]Embperl::Object import file ", ($r -> error?'with ERRORS ':'') , "finished: $filename, package = $package\n"  if ($debug);

            if (!$r -> error && $package ne $basepackage)
                {
        no strict ;
                my $isa   = \@{"$package\:\:ISA"} ;
                if (!grep /^\Q$basepackage\E$/, @$isa)
                    {
                    push @{"$package\:\:ISA"}, $basepackage ;
                    }
                }
        use strict ;

            }

        if (!$r -> error)
            {
            $r -> param -> filename ($filename) if ($filename ne $fn) ;
            bless $r, $package ;
            }

        my $cparam = {%$req, inputfile => $fn } ;
        my $c = $r -> setup_component ($cparam) ;

        $rc = run($r) ;

        $r -> cleanup ;

        return $rc ;
        }


    $r -> logerror (Embperl::Constant::rcNotFound, $basename, $apr) ;
    $apr -> log_error ("Embperl::Object base $basename not found. Searched '@searchpath'" . ($addpath?" and '@$addpath' ":''))  if ($apr) ;
    $r -> cleanup ;

    return &NOT_FOUND ;
    }


__END__