################################################################################### # # Embperl - Copyright (c) 1997-2004 Gerald Richter / ecos gmbh www.ecos.de # # 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,v 1.200 2005/06/17 21:14:28 richter Exp $ # ################################################################################### 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.0rc4' ; 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 ; $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) ; local $req_rec ; if ($modperl) { if ($modperlapi < 2) { $req_rec = Apache -> request ; } else { $req_rec = Apache2::RequestUtil -> request ; } } my $rc ; if (!ref $_ep_param) { $rc = Embperl::Req::ExecuteRequest (undef, { inputfile => $_ep_param, param => [@_]}) ; } else { $rc = Embperl::Req::ExecuteRequest (undef, $_ep_param) ; } return $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); } ####################################################################################### 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( $_ ) ; $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->header_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 ;