libcipux-cat-web-perl 3.4.0.3-4.2 / usr / share / perl5 / CipUX / CAT / Web.pm

# +========================================================================+
# || Common subroutines for CipUX-CAT-Web.                                ||
# ||                                                                      ||
# || Copyright (C) 2006 - 2008 by Christian Kuelker                       ||
# ||                                                                      ||
# || License: GNU General Public License - GNU GPL - version 2            ||
# ||          or (at your opinion) any later version.                     ||
# +========================================================================+
#  ID:       $Id: Web.pm 4900 2010-07-03 13:27:21Z christian-guest $
#  Revision: $Revision: 4900 $
#  Head URL: $HeadURL: svn+ssh://christian-guest@svn.debian.org/svn/cipux/trunk/cipux-core/cat-web/lib/CipUX/CAT/Web.pm $
#  Date:     $Date: 2010-07-03 15:27:21 +0200 (Sat, 03 Jul 2010) $
#  Source:   $Source$

package CipUX::CAT::Web;

use 5.008000;
use strict;
use warnings;
use CGI::Carp qw(carpout fatalsToBrowser warningsToBrowser);
use CGI qw(-cookie);
use CipUX::CAT::Web::Controller;
use Class::Std;
use Data::Dumper;
use English qw( -no_match_vars);
use Log::Log4perl qw(get_logger :levels);
use POSIX;
use Readonly;

use base qw(CipUX);
{

    use version; our $VERSION = qv('3.4.0.3');
    use re 'taint';    # Keep data captured by parens tainted

    # CONST
    Readonly::Scalar my $EMPTY_STRING => q{};
    Readonly::Scalar my $CACHE_DIR    => '/var/cache/cipux-cat-web';

    # GLOBAL
    my $cfg_hr = $EMPTY_STRING;    # from $CFG

    sub get_cat_web_cfg {

        my ( $self, $arg_r ) = @_;
        my $cd
            = ( exists $arg_r->{cache_dir} )
            ? $self->l( $arg_r->{cache_dir} )
            : $CACHE_DIR;

        $cfg_hr = $self->cfg(
            { 'pkg' => 'cipux', 'sub' => 'cat-web', cache_dir => $cd } );

        return $cfg_hr;
    }

    sub run {

        my ( $self, $arg_r ) = @_;
        my $cd
            = ( exists $arg_r->{cache_dir} )
            ? $self->l( $arg_r->{cache_dir} )
            : $CACHE_DIR;

        my $cfg_hr = $self->get_cat_web_cfg($arg_r);

        my $debugconf = q(
        log4perl.category.CipUX = DEBUG, F
        log4perl.appender.F          = Log::Log4perl::Appender::File
        log4perl.appender.F.filename = /var/log/cipux-cat-web/cipux-cat-web.log
        log4perl.appender.F.stderr   = 0
        log4perl.appender.F.layout   = Log::Log4perl::Layout::PatternLayout
        log4perl.appender.F.layout.ConversionPattern=%d{yyyy-MM-dd+HH:mm:ss} %M <%L>: %m%n
        );

        if (    exists $cfg_hr->{base}->{catweb_l4pconf}
            and defined $cfg_hr->{base}->{catweb_l4pconf}
            and -e $cfg_hr->{base}->{catweb_l4pconf} )
        {
            Log::Log4perl::init_once( $cfg_hr->{base}->{catweb_l4pconf} );
        }
        else {

            # Catch-22
            Log::Log4perl::init_once( \$debugconf );
        }
        my $l = get_logger(__PACKAGE__);
        $l->debug( 'cfg_hr: ', { filter => \&Dumper, value => $cfg_hr } );

        my $cat = CipUX::CAT::Web::Controller->new;
        $cat->set_cfg_hr( { cfg_hr => $cfg_hr } );

        $l->debug('get_cgi_obj');
        my $cgi = $cat->get_cgi_obj;

        $l->debug('exract_url_from_obj');
        my $url_hr = $self->exract_url_from_obj( { obj => $cgi } );
        my $m = $url_hr->{module};

        $l->debug('get a list of all modules');
        my $v_hr = $self->module_list;
        if ( $l->is_debug() ) {
            foreach my $v ( sort keys %{$v_hr} ) {
                $l->debug("got [$v]");
            }
        }

        # cat module 'index'
        # perl module load 'CipUX::CAT::Web::Module::Index'
        # for 'index.cgi'
        $l->debug('require a module');
        $self->load_module(
            { cat_module => $m, perl_module => $v_hr->{ $m . '.cgi' } } );

        $l->debug("set module [$m.cgi]");
        $cat->set_module( $v_hr->{ $m . '.cgi' } );

        #my $v = $cat->get_module();
        #die "VIEW [$v] [".$v_hr->{$m.'.cgi'}."]";
        $l->debug('dispatch');
        $cat->dispatch( { name => $url_hr->{module} } );

        return;

    }

    sub exract_url_from_obj {

        my ( $self, $arg_r ) = @_;

        my $obj
            = ( exists $arg_r->{obj} and ref $arg_r->{obj} )
            ? $arg_r->{obj}
            : $self->perr('obj');

        my $l = get_logger(__PACKAGE__);

        my $url_hr = {};
        $url_hr->{module}
            = ( defined $obj->param('module') )
            ? $self->l( $obj->param('module') )
            : 'index';
        $url_hr->{module} =~ s{\.cgi$}{}smx;
        $l->debug( 'extracted module [' . $url_hr->{module} . ']' );

        return $url_hr;
    }

    sub module_list {

        my ( $self, $arg_r ) = @_;

        my $l = get_logger(__PACKAGE__);

        my $plugin = CipUX::CAT::Web::Plugin->new();
        $plugin->init();

        #  MODULE $module povided by $v_hr->{$module}
        #  EG: index.cgi -> CipUX::CAT::Web::Module::Index
        my $module_hr = $plugin->get_module_name_register();

        return $module_hr;

    }

    sub load_module {

        my ( $self, $arg_r ) = @_;

        my $cat_module
            = ( exists $arg_r->{cat_module} )
            ? $self->l( $arg_r->{cat_module} )
            : $self->perr('cat_module');

        my $perl_module
            = ( exists $arg_r->{perl_module}
                and defined $arg_r->{perl_module} )
            ? $self->l( $arg_r->{perl_module} )
            : 'CipUX::CAT::Web::Module::Index';

        my $l = get_logger(__PACKAGE__);

        $l->debug("evaluate [$perl_module]");

        my $return = eval { require $perl_module };

        if ($EVAL_ERROR) {
            my $msg = "EXCEPTION: perl_module [$perl_module] not available!";
            $msg .= " $EVAL_ERROR";

         # MAIBE TOODO: we gota always an eval error here. Why taht? Since the
         # module load just fine.
         #$l->debug($msg);
         #confess $msg;
        }
        else {
            $l->debug("successfully load [$perl_module]");
        }

        eval { $perl_module->new; };
        if ($EVAL_ERROR) {
            my $msg
                = "EXCEPTION during perl_module [$perl_module] init! $EVAL_ERROR";
            $l->debug($msg);
            confess $msg;
        }
        else {
            $l->debug("successfully init [$perl_module]");
        }

        return;
    }
}

1;

__END__