File Coverage

blib/lib/XML/Filter/Hekeln.pm

Criterion	Covered	Total	%
statement	9	131	6.8
branch	0	56	0.0
condition	0	12	0.0
subroutine	3	17	17.6
pod	0	13	0.0
total	12	229	5.2

# XML::Filter::Hekeln
#      (c) 1999 GNU General Public License
#      Michael Koehne [e-mail]
# ---------------------------------------------------------------------------- #

package XML::Filter::Hekeln;
use UNIVERSAL;

use strict;
use vars qw($VERSION $METHODS);

$VERSION = '0.06';
$METHODS = {
	start_document => 1,
	end_document => 1,
	doctype_decl => 1,
	processing_instruction => 1,
	start_element => 1,
	end_element => 1,
	start_cdata => 1,
	end_cdata => 1,
	characters => 1
	};

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

sub new {
	my $proto = shift;
	my $self  = {};
	my $class = ref($proto) || $proto;
	bless($self, $class);

	my $args = ($#_ == 0) ? { %{ (shift) } } : { @_ };

	foreach (keys %$args) { $self->{$_}=$args->{$_}; }

	$self->{'Action'} = $self->script($self->{'Script'})
		if $self->{'Script'} && !$self->{'Action'};

	$self->{'Action'} = {} unless ref($self->{'Action'}) eq 'HASH';
	$self->{'Methods'} = {};
	$self->{'Stack'} = [];

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

	return $self;
}

sub script {
	my ($self,$script) = @_;
	my $hash = {};
	my ($key,$val,$str);
	my (@v, $o, $p);
	my $action;

	local $SIG{__WARN__} = sub { die $_[0] };

	foreach (split /\n\n/, $script) {
		if ($_ !~ /^#/) {
			($key,$val) = split /\n/, $_, 2;
			if ($key =~ /^[^:]+:[^:]+$/) {

				$str = 'sub {'."\n\t";
				$str .= 'my ($self,$param) = @_;'."\n\t";
				$str .= 'my ($hash) = {};'."\n\t";

				$val =~ s/\~(\w+)\~/\$param->{$1}/g;

				SCRIPT_TO_SUB_SW: foreach (split /\n/, $val) {
					@v = split /\t/, $_;
					$o = shift @v;
					$p = shift @v;

					if ($o eq '<') {
						$str .= '$hash->{Name}="'.$p.'"; ';
						$str .= '$self->handle("start_element", $hash);';
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}

					if ($o eq '
						$str .= '$hash->{Name}="'.$p.'"; ';
						$str .= '$self->handle("end_element", $hash);';
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}

					if ($o eq '') {
						$str .= '$hash->{Data}="'.$p.'"; ';
						$str .= '$self->handle("characters", $hash);';
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}

					if ($o eq '!') {
						$str .= $p;
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}

					if ($o eq '+') {
						$str .= '$self->{Flag}{'.$p.'}=1;';
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}
					if ($o eq '++') {
						$str .= '$self->{Flag}{'.$p.'}=1;';
						$str .= 'unshift @{$self->{Stack}}, "'.$p.'";';
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}
					if ($o eq '-') {
						$str .= '$self->{Flag}{'.$p.'}=0;';
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}
					if ($o eq '--') {
						$str .= '$self->{Flag}{'.$p.'}=0;';
						$str .= 'shift @{$self->{Stack}} if $self->{Stack}[0] eq "'.$p.'";';
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}
					if ($o eq '?{') {
						$str .= 'if ($self->{Flag}{'.$p.'}) {';
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}
					if ($o eq '?}') {
						$str .= '}';
						$str .= "\n\t";
						next SCRIPT_TO_SUB_SW;
					}
				}
				$str.= '}';
				print STDERR '$hash->{'.$key.'}=eval "'.$str.'";'."\n\n"
					if $self->{'Debug'};
				$action = eval $str;
				if ($@) {
					print STDERR "Error: $key: "; die $@
				}
				$hash->{$key}=$action;
			}
		}
	}
	return $hash;
}

sub start_document		{ my ($self, $param) = @_; $self->style('start_document',$param); }
sub end_document		{ my ($self, $param) = @_; $self->style('end_document',$param); }
sub doctype_decl		{ my ($self, $param) = @_; $self->style('doctype_decl',$param); }
sub processing_instruction	{ my ($self, $param) = @_; $self->style('processing_instruction',$param); }
sub start_element		{ my ($self, $param) = @_; $self->style('start_element',$param); }
sub end_element			{ my ($self, $param) = @_; $self->style('end_element',$param); }
sub start_cdata			{ my ($self, $param) = @_; $self->style('start_cdata',$param); }
sub end_cdata			{ my ($self, $param) = @_; $self->style('end_cdata',$param); }
sub characters			{ my ($self, $param) = @_; $self->style('characters',$param); }

sub style {
	my ($self,$event,$param) = @_;

	return unless $param;
	return unless $event;
	return unless $METHODS->{$event};

	my $target = "*";
	   $target = $param->{'Name'}   if $param->{'Name'};
	   $target = $param->{'Target'} if $param->{'Target'};
	   $target = $self->{Stack}[0]  if ( $event eq 'characters' or
					     $event eq 'start_cdata' or
					     $event eq 'end_cdata' ) and
					     $self->{Flag}{$self->{Stack}[0]};

	my $action = $self->{'Action'}{$event.':'.$target};
	return undef unless $action;

	my $hash = $param;
	   $hash = $param->{'Attributes'} if $event eq 'start_element';

	return &$action($self,$hash);
}

sub handle {
	my ($self,$event,$param) = @_;

	return $self->{'Handler'}->$event($param)
		if ($self->{'Methods'}{$event}>1);
	return undef;
}

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

1;
__END__