File Coverage

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__