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

# $Id: XMLApplication.pm,v 1.19 2004/03/10 17:55:00 c102mk Exp $

package CGI::XMLApplication;

# ################################################################
# $Revision: 1.19 $
# $Author: c102mk $
#
# (c) 2001 Christian Glahn
# All rights reserved.
#
# This code is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# ################################################################

##
# CGI::XMLApplication - Application Module for CGI scripts

# ################################################################
# module loading and global variable initializing
# ################################################################
use strict;

use CGI;
use Carp;
#use Data::Dumper;

# ################################################################
# inheritance
# ################################################################
@CGI::XMLApplication::ISA = qw( CGI );

# ################################################################

$CGI::XMLApplication::VERSION = "1.1.3";

# ################################################################
# general configuration
# ################################################################

# some hardcoded error messages, the application has always, e.g.
# to tell that a stylesheet is missing
@CGI::XMLApplication::panic = (
          'No Stylesheet specified! ',
          'Stylesheet is not available! ',
          'Event not implemented',
          'Application Error',
         );

# The Debug Level for verbose error messages
$CGI::XMLApplication::DEBUG = 0;

# ################################################################
# methods
# ################################################################
sub new {
    my $class = shift;
    my $self = $class->SUPER::new( @_ );
    bless $self, $class;

    $self->{XML_CGIAPP_HANDLER_}    = [$self->registerEvents()];
    $self->{XML_CGIAPP_STYLESHEET_} = [];
    $self->{XML_CGIAPP_STYLESDIR_}  = '';

    return $self;
}

# ################################################################
# straight forward coded methods

# application related ############################################
# both functions are only for backward compatibilty with older scripts
sub debug_msg {
    my $level = shift;
    if ( $level <= $CGI::XMLApplication::DEBUG && scalar @_ ) {
        my ($module, undef, $line) = caller(1);
        warn "[$module; line: $line] ", join(' ', @_) , "\n";
    }
}

##
# dummy functions
#
# each function is required to be overwritten by any class inheritated
sub registerEvents   { return (); }

# all following function will recieve the context, too
sub getDOM           { return undef; }
sub requestDOM       { return undef; }  # old style use getDOM!

sub getStylesheetString { return ""; }     # return a XSL String
sub getStylesheet       { return ""; }     # returns either name of a stylesheetfile or the xsl DOM
sub selectStylesheet    { return ""; }     # old style getStylesheet

sub getXSLParameter  { return (); }  # should return a plain hash of parameters passed to xsl
sub setHttpHeader    { return (); }  # should return a hash of header

sub skipSerialization{
    my $self = shift;
    $self->{CGI_XMLAPP_SKIP_TRANSFORM} = shift if scalar @_;
    return $self->{CGI_XMLAPP_SKIP_TRANSFORM};
}

# returns boolean
sub passthru {
    my $self = shift;
    if ( scalar @_ ) {
        $self->{CGI_XMLAPP_PASSXML} = shift;
        $self->delete( 'passthru' ); # delete any passthru parameter
    }
    elsif ( defined $self->param( "passthru" ) ) {
        $self->{CGI_XMLAPP_PASSXML} = 1    ;
        $self->delete( 'passthru' );
    }
    return $self->{CGI_XMLAPP_PASSXML};
}

sub redirectToURI {
    my $self = shift;
    $self->{CGI_XMLAPP_REDIRECT} = shift if scalar @_;
    return $self->{CGI_XMLAPP_REDIRECT};
}

# ################################################################
# content related functions

# stylesheet directory information ###############################
sub setStylesheetDir  { $_[0]->{XML_CGIAPP_STYLESDIR_} = $_[1];}
sub setStylesheetPath { $_[0]->{XML_CGIAPP_STYLESDIR_} = $_[1];}
sub getStylesheetDir  { $_[0]->{XML_CGIAPP_STYLESDIR_}; }
sub getStylesheetPath { $_[0]->{XML_CGIAPP_STYLESDIR_}; }

# event control ###################################################

sub addEvent          { my $s=shift; push @{$s->{XML_CGIAPP_HANDLER_}}, @_;}

sub getEventList      { @{ $_[0]->{XML_CGIAPP_HANDLER_} }; }
sub testEvent         { return $_[0]->checkPush( $_[0]->getEventList() ); }

sub deleteEvent       {
    my $self = shift;
    if ( scalar @_ ){ # delete explicit events
        foreach ( @_ ) {
            debug_msg( 8, "[XML::CGIApplication] delete event $_" );
            $self->delete( $_ );
            $self->delete( $_.'.x' );
            $self->delete( $_.'.y' );
        }
    }
    else { # delete all
        foreach ( @{ $self->{XML_CGIAPP_HANDLER_} } ){
            debug_msg( 8, "delete event $_" );
            $self->delete( $_ );
            $self->delete( $_.'.x' );
            $self->delete( $_.'.y' );
        }
    }
}

sub sendEvent         {
    debug_msg( 10, "send event " . $_[1] );
    $_[0]->deleteEvent();
    $_[0]->param( -name=>$_[1] , -value=>1 );
}

# error handling #################################################
# for internal use only ...
sub setPanicMsg       { $_[0]->{XML_CGIAPP_PANIC_} = $_[1] }
sub getPanicMsg       { $_[0]->{XML_CGIAPP_PANIC_} }

# ################################################################
# predefined events

# default event handler prototypes
sub event_init    {}
sub event_exit    {}
sub event_default { return 0 }

# ################################################################
# CGI specific helper functions

# this is required by the eventhandling
sub checkPush {
    my $self = shift;
    my ( $pushed ) = grep {
        defined $self->param( $_ ) ||  defined $self->param( $_.'.x')
    } @_;
    $pushed =~ s/\.x$//i if defined $pushed;
    return $pushed;
}

# helper functions which were missing in CGI.pm
sub checkFields{
    my $self = shift;
    my @missing = grep {
        not length $self->param( $_ ) || $self->param( $_ ) =~ /^\s*$/
    } @_;
    return wantarray ? @missing : ( scalar(@missing) > 0 ? undef : 1 );
}

sub getParamHash {
    my $self = shift;
    my $ptrHash = $self->Vars;
    my $ptrRV   = {};

    foreach my $k ( keys( %{$ptrHash} ) ){
        next unless exists $ptrHash->{$_} && $ptrHash->{$_} !~ /^[\s\0]*$/;
        $ptrRV->{$k} = $ptrHash->{$k};
    }

    return wantarray ? %{$ptrRV} : $ptrRV;
}

# ################################################################
# application related methods
# ################################################################
# algorithm should be
# event registration
# app init
# event handling
# app exit
# serialization and output
# error handling
sub run {
    my $self = shift;
    my $sid = -1;
    my $ctxt = (!@_ or scalar(@_) > 1) ? {@_} : shift; # nothing, hash or context object

    $self->event_init($ctxt);

    if ( my $n = $self->testEvent($ctxt) ) {
        if ( my $func = $self->can('event_'.$n) ) {
            $sid = $self->$func($ctxt);
        }
        else {
            $sid = -3;
        }
    }

    if ( $sid == -1 ){
        $sid = $self->event_default($ctxt);
    }

    $self->event_exit($ctxt);

    # if we allready panic, don't try to render
    if ( $sid >= 0 ) {
        # check if we wanna redirect
        if ( my $uri = $self->redirectToURI() ) {
            my %h = $self->setHttpHeader( $ctxt );
            $h{-uri} = $uri;
            print $self->SUPER::redirect( %h ) . "\n\n";
        }
        elsif ( not $self->skipSerialization() ) {
            # sometimes it is nessecary to skip the serialization
            # eg. due passing binary data.
            $sid = $self->serialization( $ctxt );
        }
    }

    $self->panic( $sid, $ctxt );
}

sub serialization {
    # i require both modules here, so one can implement his own
    # serialization
    require XML::LibXML;
    require XML::LibXSLT;

    my $self = shift;
    my $ctxt = shift;
    my $id;

    my %header = $self->setHttpHeader( $ctxt );

    my $xml_doc = $self->getDOM( $ctxt );
    if ( not defined $xml_doc ) {
        debug_msg( 10, "use old style interface");
        $xml_doc = $self->requestDOM( $ctxt );
    }
    # if still no document is available
    if ( not defined $xml_doc ) {
        debug_msg( 10, "no DOM defined; use empty DOM" );
        $xml_doc = XML::LibXML::Document->new;
        # the following line is to keep xpath.c quiet!
        $xml_doc->setDocumentElement( $xml_doc->createElement( "dummy" ) );
    }

    if( defined $self->passthru() && $self->passthru() == 1 ) {
        # this is a useful feature for DOM debugging
        debug_msg( 10, "attempt to pass the DOM to the client" );
        $header{-type} = 'text/xml';
        print $self->header( %header  );
        print $xml_doc->toString();
        return 0;
    }

    my $stylesheet = $self->getStylesheet( $ctxt );

    my ( $xsl_dom, $style, $res );
    my $parser = XML::LibXML->new();
    my $xslt   = XML::LibXSLT->new();

    if ( ref( $stylesheet ) ) {
        debug_msg( 5, "stylesheet is reference"  );
        $xsl_dom = $stylesheet;
    }
    elsif ( -f $stylesheet && -r $stylesheet ) {
        debug_msg( 5, "filename is $stylesheet" );
        eval {
            $xsl_dom  = $parser->parse_file( $stylesheet );
        };
        if ( $@ ) {
            debug_msg( 3, "Corrupted Stylesheet:\n broken XML\n". $@ );
            $self->setPanicMsg( "Corrupted document:\n broken XML\n". $@ );
            return -2;
        }
    }
    else {
        # first test the new style interface
        my $xslstring = $self->getStylesheetString( $ctxt );
        if ( length $xslstring ) {
            debug_msg( 5, "stylesheet is xml string"  );
            eval { $xsl_dom = $parser->parse_string( $xslstring ); };
            if ( $@ || not defined $xsl_dom ) {
                # the parse failed !!!
                debug_msg( 3, "Corrupted Stylesheet String:\n". $@ ."\n" );
                $self->setPanicMsg( "Corrupted Stylesheet String:\n". $@ );
                return -2;
            }
        }
        else {
            # now test old style interface
            # will be removed with the next major release

            debug_msg( 5, "old style interface to select the stylesheet"  );
            $stylesheet = $self->selectStylesheet( $ctxt );
            if ( ref( $stylesheet ) ) {
                debug_msg( 5, "stylesheet is reference"  );
                $xsl_dom = $stylesheet;
            }
            elsif ( -f $stylesheet && -r $stylesheet ) {
                debug_msg( 5, "filename is $stylesheet" );
                eval {
                    $xsl_dom  = $parser->parse_file( $stylesheet );
                };
                if ( $@ ) {
                    debug_msg( 3, "Corrupted Stylesheet:\n broken XML\n". $@ );
                    $self->setPanicMsg( "Corrupted document:\n broken XML\n". $@ );
                    return -2;
                }
            }
            else {
                debug_msg( 2 , "panic stylesheet file $stylesheet does not exist" );
                $self->setPanicMsg( "$stylesheet" );
                return length $stylesheet ? -2 : -1 ;
            }
        }
    }

    eval {
        $style = $xslt->parse_stylesheet( $xsl_dom );
        # $style = $xslt->parse_stylesheet_file( $file );
    };
    if( $@ ) {
        debug_msg( 3, "Corrupted Stylesheet:\n". $@ ."\n" );
        $self->setPanicMsg( "Corrupted Stylesheet:\n". $@ );
        return -2;
    }

    my %xslparam = $self->getXSLParameter( $ctxt );
    eval {
        # first do special xpath encoding of the parameter
        if ( %xslparam && scalar( keys %xslparam ) > 0 ) {
            my @list;
            foreach my $key ( keys %xslparam ) {
                # check for multivalued parameters stored in a \0 separated string by CGI.pm :-/
                if ( $xslparam{$key} =~ /\0/ ) {
                    push @list, $key, (split("\0",$xslparam{$key}))[-1];
                }
                else {
                        push @list, $key, $xslparam{$key};
                }
            }
            $res = $style->transform( $xml_doc,
                                      XML::LibXSLT::xpath_to_string(@list)
                                    );
        }
        else {
            $res = $style->transform( $xml_doc );
        }
    };
    if( $@ ) {
        debug_msg( 3, "Broken Transformation:\n". $@ ."\n" );
        $self->setPanicMsg( "Broken Transformation:\n". $@ );
        return -2;
    }

    # override content-type with the correct content-type
    # of the style (is this ok?)
    $header{-type}    = $style->media_type;
    $header{-charset} = $style->output_encoding;

    debug_msg( 10, "serialization do output" );
    # we want nice xhtml and since the output_string does not the
    # right job
    my $out_string= undef;

    debug_msg( 9, "serialization get output string" );
    eval {
        $out_string =  $style->output_string( $res );
    };
    debug_msg( 10, "serialization rendered output" );
    if ( $@ ) {
        debug_msg( 3, "Corrupted Output:\n", $@ , "\n" );
        $self->setPanicMsg( "Corrupted Output:\n". $@ );
        return -2;
    }
    else {
        # do the output
        print $self->header( %header );
        print $out_string;
        debug_msg( 10, "output printed" );
    }

    return 0;
}

sub panic {
    my ( $self, $pid ) = @_;
    return unless $pid < 0;
    $pid++;
    $pid*=-1;

    my $str = "Application Panic: ";
    $str = "PANIC $pid :" .  $CGI::XMLApplication::panic[$pid] ;
    # this is nice for debugging from logfiles...
    $str  = $self->b( $str ) . "\n";
    $str .= $self->pre( $self->getPanicMsg() );
    $str .= "Please Contact the Systemadminstrator\n";

    debug_msg( 1, "$str" );

    if ( $CGI::XMLApplication::Quiet == 1 ) {
        $str = "Application Panic";
    }
    if ( $CGI::XMLApplication::Quiet == 2 ) {
        $str = "";
    }

    my $status = $pid < 3 ? 404 : 500; # default is the application error ...
    print $self->header( -status => $status ) , $str ,"\n";

}

1;
# ################################################################
__END__