###################################################################################
#
# Embperl - Copyright (c) 1997-2005 Gerald Richter / ECOS
#
# 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$
#
###################################################################################
package Embperl::App ;
use strict ;
use vars qw{%Recipes} ;
# ---------------------------------------------------------------------------------
#
# 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,"Embperl Error\r\n$url") ;
if ($status == 403)
{
Embperl::Req::output ($r,"Forbidden
\r\n") ;
}
elsif ($status == 404)
{
Embperl::Req::output ($r,"Not Found
\r\n") ;
}
else
{
Embperl::Req::output ($r,"Internal Server Error
\r\n") ;
}
Embperl::Req::output ($r,"The server encountered an internal error or misconfiguration and was unable to complete your request.\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") ;
foreach $err (@$errors)
{
$err =~ s|\\|\\\\|g;
$err =~ s|\n|\n\\\\ \\ \\ \\ |g;
Embperl::Req::output ($r,"\\\\\r\n\\