File Coverage

blib/lib/XML/Filter/Digest.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

# XML::Filter::Digest
#
# Copyright (c) 2000 Michael Koehne
#
# XML::Filter::Digest is free software. You can use and redistribute
# this copy under terms of GNU General Public license.

use strict;

#------------------------------------------------------------------------------#

package XML::Filter::Digest;

use XML::XPath;
use XML::XPath::Builder;
use XML::XPath::Node;
use XML::XPath::Node::Element;
use XML::Parser::PerlSAX;

use vars qw($VERSION @ISA $METHODS $DEBUG);

$VERSION="0.06";
@ISA = qw( XML::XPath::Builder );
$METHODS = {
    start_document => 1,
    end_document => 1,
    start_element => 1,
    end_element => 1,
    characters => 1
};
$DEBUG = 0;

sub new {
    my $proto = shift;
    my $self  = ($#_ == 0) ? { %{ (shift) } } : { @_ };
    my $class = ref($proto) || $proto;

    bless $self, $class;

    die "no Handler defined" unless $self->{'Handler'};

    return $self;
}

sub parse {
    my $self = shift;

    die "no Source defined" unless $self->{'Source'};

    my $parser = new XML::Parser::PerlSAX(
	    'Handler' => $self,
	    'Source'  => $self->{'Source'}
	    );
    $parser->parse();

    return $self;
}

sub start_document {
    my $self = shift;

    $self->{'Methods'} = {};
    foreach (keys %$METHODS) {
	$self->{'Methods'}{$_} = 1 if $self->{'Handler'}->can($_);
    }

    $self->{'Handler'}->start_document()
        if $self->{'Methods'}{'start_document'};

    XML::XPath::Builder::start_document($self);
}

sub end_document {
    my $self = shift;
    my $result;

    my $xp = XML::XPath->new( context => $self->{DOC_Node} );
    $self->{'xp'} = $xp;
    $self->recurse( $self->{'Script'}, $self->{DOC_Node} );
    $self->{'xp'} = undef;
    $xp->cleanup();

    delete $self->{Last};
    delete $self->{Current};

    $result = $self->{'Handler'}->end_document()
    	if $self->{'Methods'}{'end_document'};
    return $result;
}

sub recurse {
    my ($self,$script,$root) = @_;

    print STDERR "script ".$script->{'name'}."=".$script->{'node'}."\n"
        if $DEBUG;

    $self->{'Handler'}->start_element( { 'Name' => $script->{'name'} } )
	if $self->{'Methods'}{'start_element'} && $script->{'name'};

    foreach my $collect (@{$script->{'_'}}) {
        print STDERR "collect ".$collect->{'name'}."=".$collect->{'node'}."\n"
            if $DEBUG;
	foreach ($self->{'xp'}->findnodes($collect->{'node'},$root)) {
	    if ($#{$collect->{'_'}}>=0) {
		$self->recurse($collect,$_);
	    } else {
		$self->{'Handler'}->start_element( { 'Name' => $collect->{'name'} } )
		    if $self->{'Methods'}{'start_element'};

#		$self->{'Handler'}->characters( { 'Data' => XML::XPath::XMLParser::string_value($_) } )
#		    if $self->{'Methods'}{'characters'};

                print STDERR "node : ",ref($_),"\n"
                    if $DEBUG;

		$self->{'Handler'}->characters( { 'Data' => $_->string_value } )
		    if $self->{'Methods'}{'characters'};

		$self->{'Handler'}->end_element( { 'Name' => $collect->{'name'} } )
		    if $self->{'Methods'}{'end_element'};
	    }
	}
    }

    $self->{'Handler'}->end_element( { 'Name' => $script->{'name'} } )
	if $self->{'Methods'}{'start_element'} && $script->{'name'};
}

#------------------------------------------------------------------------------#

package XML::Script::Digest;

use XML::Parser::PerlSAX;

sub new {
    my $proto = shift;
    my $self  = ($#_ == 0) ? { %{ (shift) } } : { @_ };
    my $class = ref($proto) || $proto;

    bless $self, $class;

    return $self;
}

sub parse {
    my $self = shift;

    die "no Source defined" unless $self->{'Source'};

    my $parser = new XML::Parser::PerlSAX(
	    'Handler' => $self,
	    'Source'  => $self->{'Source'}
	    );
    $parser->parse;

    return $self;
}

sub start_document {
    my ($self, $element) = @_;

    $self->{'!'}       = [];
    $self->{'_'}       = [];
}

sub end_document {
    my ($self, $element) = @_;

    die "non wellformed".$#{$self->{'!'}} if $#{$self->{'!'}}>=0;

    delete $self->{'!'};
    return $self;
}

sub start_element {
    my ($self, $element) = @_;

    if ($element->{Name} eq "collect") {
	my $name = $element->{Attributes}{'name'};
	my $node = $element->{Attributes}{'node'};

        die "collect element requires node attribute" unless $node;
#       die "collect element requires name attribute" unless $name;

	my $coll = {};

    	$coll->{'name'}=$name;
    	$coll->{'node'}=$node;
    	$coll->{'_'}=[];

	push @{$self->{'_'}}, $coll;
	push @{$self->{'!'}}, $self->{'_'};

	$self->{'_'} = $coll->{'_'};
    }
    if ($element->{Name} eq "digest") {
	my $name = $element->{Attributes}{'name'};
        die "digest element requires name attribute" unless $name;
    	$self->{'name'}=$name;
    }
}

sub end_element {
    my ($self, $element) = @_;

    if ($element->{Name} eq "collect") {
	$self->{'_'} = pop @{$self->{'!'}};
    }
}

1;

__END__