################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2015 Gerald Richter # Embperl - Copyright (c) 2015-2023 actevy.io # # 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. # ################################################################################### package Embperl::App ; use strict ; use vars qw{%Recipes} ; no warnings "uninitialized" ; # --------------------------------------------------------------------------------- # # Get/create named recipe # # --------------------------------------------------------------------------------- sub get_recipe { my ($self, $r, $name) = @_ ; $name ||= 'Embperl' ; my @names = split (/\s/, $name) ; foreach my $recipe (@names) { my $mod ; $recipe =~ /([a-zA-Z0-9_:]*)/ ; $recipe = $1 ; if (!($mod = $Recipes{$recipe})) { $mod = ($name =~ /::/)?$recipe:'Embperl::Recipe::'. $recipe ; if (!defined (&{$mod . '::get_recipe'})) { eval "require $mod" ; if ($@) { warn $@ ; return undef ; } } $Recipes{$recipe} = $mod ; } print Embperl::LOG "[$$] Use Recipe $recipe\n" if ($r -> component -> config -> debug) ; my $obj = $mod -> get_recipe ($r, $recipe) ; return $obj if ($obj) ; } return undef ; } # --------------------------------------------------------------------------------- # # send error page # # --------------------------------------------------------------------------------- sub send_error_page { my ($self, $r) = @_ ; local $SIG{__WARN__} = 'Default' ; my $virtlog = '' ; # $r -> VirtLogURI || '' ; my $logfilepos = $r -> log_file_start_pos ; my $url = '' ; # $Embperl::dbgLogLink?"Logfile":'' ; my $req_rec = $r -> apache_req ; my $status = $req_rec?$req_rec -> status:0 ; my $err ; my $cnt = 0 ; local $Embperl::escmode = 0 ; my $time = localtime ; my $mail = $req_rec -> server -> server_admin if (defined ($req_rec)) ; $mail ||= '' ; $req_rec -> content_type('text/html') if (defined ($req_rec)) ; # don't use method call to avoid trouble with overloading Embperl::Req::output ($r,"
\r\n") ; Embperl::Req::output ($r,"Please contact the server administrator, $mail and inform them of the time the error occurred, and anything you might have done that may have caused the error.
\r\n") ;
my $errors = $r -> errors ;
if ($virtlog ne '' && $Embperl::dbgLogLink)
{
foreach $err (@$errors)
{
Embperl::Req::output ($r,"") ; #") ;
$Embperl::escmode = 3 ;
$err =~ s|\\|\\\\|g;
$err =~ s|\n|\n\\
\\ \\ \\ \\ |g;
$err =~ s|(Line [0-9]*:)|$1\\|;
Embperl::Req::output ($r,$err) ;
$Embperl::escmode = 0 ;
Embperl::Req::output ($r,"
\r\n") ; #Embperl::Req::output ($r,"
\r\n") ; $cnt++ ; } } else { $Embperl::escmode = 3 ; Embperl::Req::output ($r,"\\
\r\n\\ |