File Coverage

blib/lib/Embperl/App.pm
Criterion Covered Total %
statement 58 146 39.7
branch 15 92 16.3
condition 4 26 15.3
subroutine 4 6 66.6
pod 4 4 100.0
total 85 274 31.0


line stmt bran cond sub pod time code
1              
2             ###################################################################################
3             #
4             # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de
5             # Embperl - Copyright (c) 2008-2014 Gerald Richter
6             #
7             # You may distribute under the terms of either the GNU General Public
8             # License or the Artistic License, as specified in the Perl README file.
9             #
10             # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
11             # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
12             # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
13             #
14             # $Id: App.pm 1578075 2014-03-16 14:01:14Z richter $
15             #
16             ###################################################################################
17            
18              
19              
20             package Embperl::App ;
21              
22 1     1   5 use strict ;
  1         3  
  1         38  
23 1     1   6 use vars qw{%Recipes} ;
  1         1  
  1         5861  
24              
25             # ---------------------------------------------------------------------------------
26             #
27             # Get/create named recipe
28             #
29             # ---------------------------------------------------------------------------------
30              
31              
32             sub get_recipe
33              
34             {
35 100     100 1 280 my ($self, $r, $name) = @_ ;
36              
37 100   50     278 $name ||= 'Embperl' ;
38 100         492 my @names = split (/\s/, $name) ;
39              
40 100         426 foreach my $recipe (@names)
41             {
42 100         133 my $mod ;
43 100         419 $recipe =~ /([a-zA-Z0-9_:]*)/ ;
44 100         440 $recipe = $1 ;
45 100 100       2565 if (!($mod = $Recipes{$recipe}))
46             {
47 1 50       8 $mod = ($name =~ /::/)?$recipe:'Embperl::Recipe::'. $recipe ;
48 1 50       2 if (!defined (&{$mod . '::get_recipe'}))
  1         10  
49             {
50 1         82 eval "require $mod" ;
51 1 50       12 if ($@)
52             {
53 0         0 warn $@ ;
54 0         0 return undef ;
55             }
56             }
57 1         128 $Recipes{$recipe} = $mod ;
58             }
59 100 100       3633 print Embperl::LOG "[$$] Use Recipe $recipe\n" if ($r -> component -> config -> debug) ;
60 100         1035 my $obj = $mod -> get_recipe ($r, $recipe) ;
61 100 50       21218 return $obj if ($obj) ;
62             }
63            
64 0         0 return undef ;
65             }
66              
67              
68             # ---------------------------------------------------------------------------------
69             #
70             # send error page
71             #
72             # ---------------------------------------------------------------------------------
73              
74              
75             sub send_error_page
76              
77             {
78 12     12 1 251 my ($self, $r) = @_ ;
79              
80 12         83 local $SIG{__WARN__} = 'Default' ;
81 12         23 my $virtlog = '' ; # $r -> VirtLogURI || '' ;
82 12         64 my $logfilepos = $r -> log_file_start_pos ;
83 12         21 my $url = '' ; # $Embperl::dbgLogLink?"Logfile":'' ;
84 12         51 my $req_rec = $r -> apache_req ;
85 12 50       37 my $status = $req_rec?$req_rec -> status:0 ;
86 12         25 my $err ;
87 12         19 my $cnt = 0 ;
88 12         53 local $Embperl::escmode = 0 ;
89 12         382 my $time = localtime ;
90 12 50       39 my $mail = $req_rec -> server -> server_admin if (defined ($req_rec)) ;
91 12   50     82 $mail ||= '' ;
92 12 50       34 $req_rec -> content_type('text/html') if (defined ($req_rec)) ;
93              
94             # don't use method call to avoid trouble with overloading
95 12         83 Embperl::Req::output ($r,"Embperl Error\r\n$url") ;
96 12 50       52 if ($status == 403)
    50          
97             {
98 0         0 Embperl::Req::output ($r,"

Forbidden

\r\n") ;
99             }
100             elsif ($status == 404)
101             {
102 0         0 Embperl::Req::output ($r,"

Not Found

\r\n") ;
103             }
104             else
105             {
106 12         38 Embperl::Req::output ($r,"

Internal Server Error

\r\n") ;
107             }
108 12         35 Embperl::Req::output ($r,"The server encountered an internal error or misconfiguration and was unable to complete your request.

\r\n") ;

109 12         53 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") ;

110              
111 12         50 my $errors = $r -> errors ;
112 12 50 33     48 if ($virtlog ne '' && $Embperl::dbgLogLink)
113             {
114 0         0 foreach $err (@$errors)
115             {
116 0         0 Embperl::Req::output ($r,"") ; #") ;
117 0         0 $Embperl::escmode = 3 ;
118 0         0 $err =~ s|\\|\\\\|g;
119 0         0 $err =~ s|\n|\n\\\\ \\ \\ \\ |g;
120 0         0 $err =~ s|(Line [0-9]*:)|$1\\|;
121 0         0 Embperl::Req::output ($r,$err) ;
122 0         0 $Embperl::escmode = 0 ;
123 0         0 Embperl::Req::output ($r,"

\r\n") ;

124             #Embperl::Req::output ($r,"

\r\n") ;

125 0         0 $cnt++ ;
126             }
127             }
128             else
129             {
130 12         30 $Embperl::escmode = 3 ;
131 12         53 Embperl::Req::output ($r,"\\\r\n") ; \\\r\n\\
132 12         28 foreach $err (@$errors)
133             {
134 34         58 $err =~ s|\\|\\\\|g;
135 34         84 $err =~ s|\n|\n\\\\ \\ \\ \\ |g;
136 34         114 Embperl::Req::output ($r,"\\