blib/lib/CGI/XMLApplication.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 17 | 218 | 7.8 |
branch | 0 | 80 | 0.0 |
condition | 0 | 26 | 0.0 |
subroutine | 5 | 36 | 13.8 |
pod | 23 | 33 | 69.7 |
total | 45 | 393 | 11.4 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # $Id: XMLApplication.pm,v 1.19 2004/03/10 17:55:00 c102mk Exp $ | ||||||
2 | |||||||
3 | package CGI::XMLApplication; | ||||||
4 | |||||||
5 | # ################################################################ | ||||||
6 | # $Revision: 1.19 $ | ||||||
7 | # $Author: c102mk $ | ||||||
8 | # | ||||||
9 | # (c) 2001 Christian Glahn |
||||||
10 | # All rights reserved. | ||||||
11 | # | ||||||
12 | # This code is free software; you can redistribute it and/or | ||||||
13 | # modify it under the same terms as Perl itself. | ||||||
14 | # | ||||||
15 | # ################################################################ | ||||||
16 | |||||||
17 | ## | ||||||
18 | # CGI::XMLApplication - Application Module for CGI scripts | ||||||
19 | |||||||
20 | # ################################################################ | ||||||
21 | # module loading and global variable initializing | ||||||
22 | # ################################################################ | ||||||
23 | 1 | 1 | 7554 | use strict; | |||
1 | 2 | ||||||
1 | 38 | ||||||
24 | |||||||
25 | 1 | 1 | 2101 | use CGI; | |||
1 | 48078 | ||||||
1 | 7 | ||||||
26 | 1 | 1 | 50 | use Carp; | |||
1 | 6 | ||||||
1 | 3647 | ||||||
27 | #use Data::Dumper; | ||||||
28 | |||||||
29 | # ################################################################ | ||||||
30 | # inheritance | ||||||
31 | # ################################################################ | ||||||
32 | @CGI::XMLApplication::ISA = qw( CGI ); | ||||||
33 | |||||||
34 | # ################################################################ | ||||||
35 | |||||||
36 | $CGI::XMLApplication::VERSION = "1.1.3"; | ||||||
37 | |||||||
38 | # ################################################################ | ||||||
39 | # general configuration | ||||||
40 | # ################################################################ | ||||||
41 | |||||||
42 | # some hardcoded error messages, the application has always, e.g. | ||||||
43 | # to tell that a stylesheet is missing | ||||||
44 | @CGI::XMLApplication::panic = ( | ||||||
45 | 'No Stylesheet specified! ', | ||||||
46 | 'Stylesheet is not available! ', | ||||||
47 | 'Event not implemented', | ||||||
48 | 'Application Error', | ||||||
49 | ); | ||||||
50 | |||||||
51 | # The Debug Level for verbose error messages | ||||||
52 | $CGI::XMLApplication::DEBUG = 0; | ||||||
53 | |||||||
54 | # ################################################################ | ||||||
55 | # methods | ||||||
56 | # ################################################################ | ||||||
57 | sub new { | ||||||
58 | 1 | 1 | 1 | 80 | my $class = shift; | ||
59 | 1 | 11 | my $self = $class->SUPER::new( @_ ); | ||||
60 | 1 | 4919 | bless $self, $class; | ||||
61 | |||||||
62 | 1 | 7 | $self->{XML_CGIAPP_HANDLER_} = [$self->registerEvents()]; | ||||
63 | 1 | 4 | $self->{XML_CGIAPP_STYLESHEET_} = []; | ||||
64 | 1 | 3 | $self->{XML_CGIAPP_STYLESDIR_} = ''; | ||||
65 | |||||||
66 | 1 | 49 | return $self; | ||||
67 | } | ||||||
68 | |||||||
69 | # ################################################################ | ||||||
70 | # straight forward coded methods | ||||||
71 | |||||||
72 | # application related ############################################ | ||||||
73 | # both functions are only for backward compatibilty with older scripts | ||||||
74 | sub debug_msg { | ||||||
75 | 0 | 0 | 0 | 0 | my $level = shift; | ||
76 | 0 | 0 | 0 | 0 | if ( $level <= $CGI::XMLApplication::DEBUG && scalar @_ ) { | ||
77 | 0 | 0 | my ($module, undef, $line) = caller(1); | ||||
78 | 0 | 0 | warn "[$module; line: $line] ", join(' ', @_) , "\n"; | ||||
79 | } | ||||||
80 | } | ||||||
81 | |||||||
82 | ## | ||||||
83 | # dummy functions | ||||||
84 | # | ||||||
85 | # each function is required to be overwritten by any class inheritated | ||||||
86 | 1 | 1 | 1 | 5 | sub registerEvents { return (); } | ||
87 | |||||||
88 | # all following function will recieve the context, too | ||||||
89 | 0 | 0 | 1 | sub getDOM { return undef; } | |||
90 | 0 | 0 | 0 | sub requestDOM { return undef; } # old style use getDOM! | |||
91 | |||||||
92 | 0 | 0 | 0 | sub getStylesheetString { return ""; } # return a XSL String | |||
93 | 0 | 0 | 1 | sub getStylesheet { return ""; } # returns either name of a stylesheetfile or the xsl DOM | |||
94 | 0 | 0 | 1 | sub selectStylesheet { return ""; } # old style getStylesheet | |||
95 | |||||||
96 | 0 | 0 | 0 | sub getXSLParameter { return (); } # should return a plain hash of parameters passed to xsl | |||
97 | 0 | 0 | 1 | sub setHttpHeader { return (); } # should return a hash of header | |||
98 | |||||||
99 | sub skipSerialization{ | ||||||
100 | 0 | 0 | 1 | my $self = shift; | |||
101 | 0 | 0 | $self->{CGI_XMLAPP_SKIP_TRANSFORM} = shift if scalar @_; | ||||
102 | 0 | return $self->{CGI_XMLAPP_SKIP_TRANSFORM}; | |||||
103 | } | ||||||
104 | |||||||
105 | # returns boolean | ||||||
106 | sub passthru { | ||||||
107 | 0 | 0 | 1 | my $self = shift; | |||
108 | 0 | 0 | if ( scalar @_ ) { | ||||
0 | |||||||
109 | 0 | $self->{CGI_XMLAPP_PASSXML} = shift; | |||||
110 | 0 | $self->delete( 'passthru' ); # delete any passthru parameter | |||||
111 | } | ||||||
112 | elsif ( defined $self->param( "passthru" ) ) { | ||||||
113 | 0 | $self->{CGI_XMLAPP_PASSXML} = 1 ; | |||||
114 | 0 | $self->delete( 'passthru' ); | |||||
115 | } | ||||||
116 | 0 | return $self->{CGI_XMLAPP_PASSXML}; | |||||
117 | } | ||||||
118 | |||||||
119 | sub redirectToURI { | ||||||
120 | 0 | 0 | 0 | my $self = shift; | |||
121 | 0 | 0 | $self->{CGI_XMLAPP_REDIRECT} = shift if scalar @_; | ||||
122 | 0 | return $self->{CGI_XMLAPP_REDIRECT}; | |||||
123 | } | ||||||
124 | |||||||
125 | # ################################################################ | ||||||
126 | # content related functions | ||||||
127 | |||||||
128 | # stylesheet directory information ############################### | ||||||
129 | 0 | 0 | 1 | sub setStylesheetDir { $_[0]->{XML_CGIAPP_STYLESDIR_} = $_[1];} | |||
130 | 0 | 0 | 1 | sub setStylesheetPath { $_[0]->{XML_CGIAPP_STYLESDIR_} = $_[1];} | |||
131 | 0 | 0 | 0 | sub getStylesheetDir { $_[0]->{XML_CGIAPP_STYLESDIR_}; } | |||
132 | 0 | 0 | 1 | sub getStylesheetPath { $_[0]->{XML_CGIAPP_STYLESDIR_}; } | |||
133 | |||||||
134 | # event control ################################################### | ||||||
135 | |||||||
136 | 0 | 0 | 0 | sub addEvent { my $s=shift; push @{$s->{XML_CGIAPP_HANDLER_}}, @_;} | |||
0 | |||||||
0 | |||||||
137 | |||||||
138 | 0 | 0 | 0 | sub getEventList { @{ $_[0]->{XML_CGIAPP_HANDLER_} }; } | |||
0 | |||||||
139 | 0 | 0 | 1 | sub testEvent { return $_[0]->checkPush( $_[0]->getEventList() ); } | |||
140 | |||||||
141 | sub deleteEvent { | ||||||
142 | 0 | 0 | 0 | my $self = shift; | |||
143 | 0 | 0 | if ( scalar @_ ){ # delete explicit events | ||||
144 | 0 | foreach ( @_ ) { | |||||
145 | 0 | debug_msg( 8, "[XML::CGIApplication] delete event $_" ); | |||||
146 | 0 | $self->delete( $_ ); | |||||
147 | 0 | $self->delete( $_.'.x' ); | |||||
148 | 0 | $self->delete( $_.'.y' ); | |||||
149 | } | ||||||
150 | } | ||||||
151 | else { # delete all | ||||||
152 | 0 | foreach ( @{ $self->{XML_CGIAPP_HANDLER_} } ){ | |||||
0 | |||||||
153 | 0 | debug_msg( 8, "delete event $_" ); | |||||
154 | 0 | $self->delete( $_ ); | |||||
155 | 0 | $self->delete( $_.'.x' ); | |||||
156 | 0 | $self->delete( $_.'.y' ); | |||||
157 | } | ||||||
158 | } | ||||||
159 | } | ||||||
160 | |||||||
161 | sub sendEvent { | ||||||
162 | 0 | 0 | 1 | debug_msg( 10, "send event " . $_[1] ); | |||
163 | 0 | $_[0]->deleteEvent(); | |||||
164 | 0 | $_[0]->param( -name=>$_[1] , -value=>1 ); | |||||
165 | } | ||||||
166 | |||||||
167 | # error handling ################################################# | ||||||
168 | # for internal use only ... | ||||||
169 | 0 | 0 | 1 | sub setPanicMsg { $_[0]->{XML_CGIAPP_PANIC_} = $_[1] } | |||
170 | 0 | 0 | 1 | sub getPanicMsg { $_[0]->{XML_CGIAPP_PANIC_} } | |||
171 | |||||||
172 | # ################################################################ | ||||||
173 | # predefined events | ||||||
174 | |||||||
175 | # default event handler prototypes | ||||||
176 | 0 | 0 | 1 | sub event_init {} | |||
177 | 0 | 0 | 1 | sub event_exit {} | |||
178 | 0 | 0 | 1 | sub event_default { return 0 } | |||
179 | |||||||
180 | # ################################################################ | ||||||
181 | # CGI specific helper functions | ||||||
182 | |||||||
183 | # this is required by the eventhandling | ||||||
184 | sub checkPush { | ||||||
185 | 0 | 0 | 1 | my $self = shift; | |||
186 | 0 | 0 | my ( $pushed ) = grep { | ||||
187 | 0 | defined $self->param( $_ ) || defined $self->param( $_.'.x') | |||||
188 | } @_; | ||||||
189 | 0 | 0 | $pushed =~ s/\.x$//i if defined $pushed; | ||||
190 | 0 | return $pushed; | |||||
191 | } | ||||||
192 | |||||||
193 | # helper functions which were missing in CGI.pm | ||||||
194 | sub checkFields{ | ||||||
195 | 0 | 0 | 1 | my $self = shift; | |||
196 | 0 | 0 | my @missing = grep { | ||||
197 | 0 | not length $self->param( $_ ) || $self->param( $_ ) =~ /^\s*$/ | |||||
198 | } @_; | ||||||
199 | 0 | 0 | return wantarray ? @missing : ( scalar(@missing) > 0 ? undef : 1 ); | ||||
0 | |||||||
200 | } | ||||||
201 | |||||||
202 | sub getParamHash { | ||||||
203 | 0 | 0 | 1 | my $self = shift; | |||
204 | 0 | my $ptrHash = $self->Vars; | |||||
205 | 0 | my $ptrRV = {}; | |||||
206 | |||||||
207 | 0 | foreach my $k ( keys( %{$ptrHash} ) ){ | |||||
0 | |||||||
208 | 0 | 0 | 0 | next unless exists $ptrHash->{$_} && $ptrHash->{$_} !~ /^[\s\0]*$/; | |||
209 | 0 | $ptrRV->{$k} = $ptrHash->{$k}; | |||||
210 | } | ||||||
211 | |||||||
212 | 0 | 0 | return wantarray ? %{$ptrRV} : $ptrRV; | ||||
0 | |||||||
213 | } | ||||||
214 | |||||||
215 | # ################################################################ | ||||||
216 | # application related methods | ||||||
217 | # ################################################################ | ||||||
218 | # algorithm should be | ||||||
219 | # event registration | ||||||
220 | # app init | ||||||
221 | # event handling | ||||||
222 | # app exit | ||||||
223 | # serialization and output | ||||||
224 | # error handling | ||||||
225 | sub run { | ||||||
226 | 0 | 0 | 1 | my $self = shift; | |||
227 | 0 | my $sid = -1; | |||||
228 | 0 | 0 | 0 | my $ctxt = (!@_ or scalar(@_) > 1) ? {@_} : shift; # nothing, hash or context object | |||
229 | |||||||
230 | 0 | $self->event_init($ctxt); | |||||
231 | |||||||
232 | 0 | 0 | if ( my $n = $self->testEvent($ctxt) ) { | ||||
233 | 0 | 0 | if ( my $func = $self->can('event_'.$n) ) { | ||||
234 | 0 | $sid = $self->$func($ctxt); | |||||
235 | } | ||||||
236 | else { | ||||||
237 | 0 | $sid = -3; | |||||
238 | } | ||||||
239 | } | ||||||
240 | |||||||
241 | 0 | 0 | if ( $sid == -1 ){ | ||||
242 | 0 | $sid = $self->event_default($ctxt); | |||||
243 | } | ||||||
244 | |||||||
245 | 0 | $self->event_exit($ctxt); | |||||
246 | |||||||
247 | # if we allready panic, don't try to render | ||||||
248 | 0 | 0 | if ( $sid >= 0 ) { | ||||
249 | # check if we wanna redirect | ||||||
250 | 0 | 0 | if ( my $uri = $self->redirectToURI() ) { | ||||
0 | |||||||
251 | 0 | my %h = $self->setHttpHeader( $ctxt ); | |||||
252 | 0 | $h{-uri} = $uri; | |||||
253 | 0 | print $self->SUPER::redirect( %h ) . "\n\n"; | |||||
254 | } | ||||||
255 | elsif ( not $self->skipSerialization() ) { | ||||||
256 | # sometimes it is nessecary to skip the serialization | ||||||
257 | # eg. due passing binary data. | ||||||
258 | 0 | $sid = $self->serialization( $ctxt ); | |||||
259 | } | ||||||
260 | } | ||||||
261 | |||||||
262 | 0 | $self->panic( $sid, $ctxt ); | |||||
263 | } | ||||||
264 | |||||||
265 | sub serialization { | ||||||
266 | # i require both modules here, so one can implement his own | ||||||
267 | # serialization | ||||||
268 | 0 | 0 | 0 | require XML::LibXML; | |||
269 | 0 | require XML::LibXSLT; | |||||
270 | |||||||
271 | 0 | my $self = shift; | |||||
272 | 0 | my $ctxt = shift; | |||||
273 | 0 | my $id; | |||||
274 | |||||||
275 | 0 | my %header = $self->setHttpHeader( $ctxt ); | |||||
276 | |||||||
277 | 0 | my $xml_doc = $self->getDOM( $ctxt ); | |||||
278 | 0 | 0 | if ( not defined $xml_doc ) { | ||||
279 | 0 | debug_msg( 10, "use old style interface"); | |||||
280 | 0 | $xml_doc = $self->requestDOM( $ctxt ); | |||||
281 | } | ||||||
282 | # if still no document is available | ||||||
283 | 0 | 0 | if ( not defined $xml_doc ) { | ||||
284 | 0 | debug_msg( 10, "no DOM defined; use empty DOM" ); | |||||
285 | 0 | $xml_doc = XML::LibXML::Document->new; | |||||
286 | # the following line is to keep xpath.c quiet! | ||||||
287 | 0 | $xml_doc->setDocumentElement( $xml_doc->createElement( "dummy" ) ); | |||||
288 | } | ||||||
289 | |||||||
290 | 0 | 0 | 0 | if( defined $self->passthru() && $self->passthru() == 1 ) { | |||
291 | # this is a useful feature for DOM debugging | ||||||
292 | 0 | debug_msg( 10, "attempt to pass the DOM to the client" ); | |||||
293 | 0 | $header{-type} = 'text/xml'; | |||||
294 | 0 | print $self->header( %header ); | |||||
295 | 0 | print $xml_doc->toString(); | |||||
296 | 0 | return 0; | |||||
297 | } | ||||||
298 | |||||||
299 | 0 | my $stylesheet = $self->getStylesheet( $ctxt ); | |||||
300 | |||||||
301 | 0 | my ( $xsl_dom, $style, $res ); | |||||
302 | 0 | my $parser = XML::LibXML->new(); | |||||
303 | 0 | my $xslt = XML::LibXSLT->new(); | |||||
304 | |||||||
305 | 0 | 0 | 0 | if ( ref( $stylesheet ) ) { | |||
0 | |||||||
306 | 0 | debug_msg( 5, "stylesheet is reference" ); | |||||
307 | 0 | $xsl_dom = $stylesheet; | |||||
308 | } | ||||||
309 | elsif ( -f $stylesheet && -r $stylesheet ) { | ||||||
310 | 0 | debug_msg( 5, "filename is $stylesheet" ); | |||||
311 | 0 | eval { | |||||
312 | 0 | $xsl_dom = $parser->parse_file( $stylesheet ); | |||||
313 | }; | ||||||
314 | 0 | 0 | if ( $@ ) { | ||||
315 | 0 | debug_msg( 3, "Corrupted Stylesheet:\n broken XML\n". $@ ); | |||||
316 | 0 | $self->setPanicMsg( "Corrupted document:\n broken XML\n". $@ ); | |||||
317 | 0 | return -2; | |||||
318 | } | ||||||
319 | } | ||||||
320 | else { | ||||||
321 | # first test the new style interface | ||||||
322 | 0 | my $xslstring = $self->getStylesheetString( $ctxt ); | |||||
323 | 0 | 0 | if ( length $xslstring ) { | ||||
324 | 0 | debug_msg( 5, "stylesheet is xml string" ); | |||||
325 | 0 | eval { $xsl_dom = $parser->parse_string( $xslstring ); }; | |||||
0 | |||||||
326 | 0 | 0 | 0 | if ( $@ || not defined $xsl_dom ) { | |||
327 | # the parse failed !!! | ||||||
328 | 0 | debug_msg( 3, "Corrupted Stylesheet String:\n". $@ ."\n" ); | |||||
329 | 0 | $self->setPanicMsg( "Corrupted Stylesheet String:\n". $@ ); | |||||
330 | 0 | return -2; | |||||
331 | } | ||||||
332 | } | ||||||
333 | else { | ||||||
334 | # now test old style interface | ||||||
335 | # will be removed with the next major release | ||||||
336 | |||||||
337 | 0 | debug_msg( 5, "old style interface to select the stylesheet" ); | |||||
338 | 0 | $stylesheet = $self->selectStylesheet( $ctxt ); | |||||
339 | 0 | 0 | 0 | if ( ref( $stylesheet ) ) { | |||
0 | |||||||
340 | 0 | debug_msg( 5, "stylesheet is reference" ); | |||||
341 | 0 | $xsl_dom = $stylesheet; | |||||
342 | } | ||||||
343 | elsif ( -f $stylesheet && -r $stylesheet ) { | ||||||
344 | 0 | debug_msg( 5, "filename is $stylesheet" ); | |||||
345 | 0 | eval { | |||||
346 | 0 | $xsl_dom = $parser->parse_file( $stylesheet ); | |||||
347 | }; | ||||||
348 | 0 | 0 | if ( $@ ) { | ||||
349 | 0 | debug_msg( 3, "Corrupted Stylesheet:\n broken XML\n". $@ ); | |||||
350 | 0 | $self->setPanicMsg( "Corrupted document:\n broken XML\n". $@ ); | |||||
351 | 0 | return -2; | |||||
352 | } | ||||||
353 | } | ||||||
354 | else { | ||||||
355 | 0 | debug_msg( 2 , "panic stylesheet file $stylesheet does not exist" ); | |||||
356 | 0 | $self->setPanicMsg( "$stylesheet" ); | |||||
357 | 0 | 0 | return length $stylesheet ? -2 : -1 ; | ||||
358 | } | ||||||
359 | } | ||||||
360 | } | ||||||
361 | |||||||
362 | 0 | eval { | |||||
363 | 0 | $style = $xslt->parse_stylesheet( $xsl_dom ); | |||||
364 | # $style = $xslt->parse_stylesheet_file( $file ); | ||||||
365 | }; | ||||||
366 | 0 | 0 | if( $@ ) { | ||||
367 | 0 | debug_msg( 3, "Corrupted Stylesheet:\n". $@ ."\n" ); | |||||
368 | 0 | $self->setPanicMsg( "Corrupted Stylesheet:\n". $@ ); | |||||
369 | 0 | return -2; | |||||
370 | } | ||||||
371 | |||||||
372 | 0 | my %xslparam = $self->getXSLParameter( $ctxt ); | |||||
373 | 0 | eval { | |||||
374 | # first do special xpath encoding of the parameter | ||||||
375 | 0 | 0 | 0 | if ( %xslparam && scalar( keys %xslparam ) > 0 ) { | |||
376 | 0 | my @list; | |||||
377 | 0 | foreach my $key ( keys %xslparam ) { | |||||
378 | # check for multivalued parameters stored in a \0 separated string by CGI.pm :-/ | ||||||
379 | 0 | 0 | if ( $xslparam{$key} =~ /\0/ ) { | ||||
380 | 0 | push @list, $key, (split("\0",$xslparam{$key}))[-1]; | |||||
381 | } | ||||||
382 | else { | ||||||
383 | 0 | push @list, $key, $xslparam{$key}; | |||||
384 | } | ||||||
385 | } | ||||||
386 | 0 | $res = $style->transform( $xml_doc, | |||||
387 | XML::LibXSLT::xpath_to_string(@list) | ||||||
388 | ); | ||||||
389 | } | ||||||
390 | else { | ||||||
391 | 0 | $res = $style->transform( $xml_doc ); | |||||
392 | } | ||||||
393 | }; | ||||||
394 | 0 | 0 | if( $@ ) { | ||||
395 | 0 | debug_msg( 3, "Broken Transformation:\n". $@ ."\n" ); | |||||
396 | 0 | $self->setPanicMsg( "Broken Transformation:\n". $@ ); | |||||
397 | 0 | return -2; | |||||
398 | } | ||||||
399 | |||||||
400 | # override content-type with the correct content-type | ||||||
401 | # of the style (is this ok?) | ||||||
402 | 0 | $header{-type} = $style->media_type; | |||||
403 | 0 | $header{-charset} = $style->output_encoding; | |||||
404 | |||||||
405 | 0 | debug_msg( 10, "serialization do output" ); | |||||
406 | # we want nice xhtml and since the output_string does not the | ||||||
407 | # right job | ||||||
408 | 0 | my $out_string= undef; | |||||
409 | |||||||
410 | 0 | debug_msg( 9, "serialization get output string" ); | |||||
411 | 0 | eval { | |||||
412 | 0 | $out_string = $style->output_string( $res ); | |||||
413 | }; | ||||||
414 | 0 | debug_msg( 10, "serialization rendered output" ); | |||||
415 | 0 | 0 | if ( $@ ) { | ||||
416 | 0 | debug_msg( 3, "Corrupted Output:\n", $@ , "\n" ); | |||||
417 | 0 | $self->setPanicMsg( "Corrupted Output:\n". $@ ); | |||||
418 | 0 | return -2; | |||||
419 | } | ||||||
420 | else { | ||||||
421 | # do the output | ||||||
422 | 0 | print $self->header( %header ); | |||||
423 | 0 | print $out_string; | |||||
424 | 0 | debug_msg( 10, "output printed" ); | |||||
425 | } | ||||||
426 | |||||||
427 | 0 | return 0; | |||||
428 | } | ||||||
429 | |||||||
430 | sub panic { | ||||||
431 | 0 | 0 | 1 | my ( $self, $pid ) = @_; | |||
432 | 0 | 0 | return unless $pid < 0; | ||||
433 | 0 | $pid++; | |||||
434 | 0 | $pid*=-1; | |||||
435 | |||||||
436 | 0 | my $str = "Application Panic: "; | |||||
437 | 0 | $str = "PANIC $pid :" . $CGI::XMLApplication::panic[$pid] ; | |||||
438 | # this is nice for debugging from logfiles... | ||||||
439 | 0 | $str = $self->b( $str ) . " \n"; |
|||||
440 | 0 | $str .= $self->pre( $self->getPanicMsg() ); | |||||
441 | 0 | $str .= "Please Contact the Systemadminstrator \n"; |
|||||
442 | |||||||
443 | 0 | debug_msg( 1, "$str" ); | |||||
444 | |||||||
445 | 0 | 0 | if ( $CGI::XMLApplication::Quiet == 1 ) { | ||||
446 | 0 | $str = "Application Panic"; | |||||
447 | } | ||||||
448 | 0 | 0 | if ( $CGI::XMLApplication::Quiet == 2 ) { | ||||
449 | 0 | $str = ""; | |||||
450 | } | ||||||
451 | |||||||
452 | 0 | 0 | my $status = $pid < 3 ? 404 : 500; # default is the application error ... | ||||
453 | 0 | print $self->header( -status => $status ) , $str ,"\n"; | |||||
454 | |||||||
455 | } | ||||||
456 | |||||||
457 | 1; | ||||||
458 | # ################################################################ | ||||||
459 | __END__ |