File Coverage

blib/lib/XML/Filter/Conditional.pm

Criterion	Covered	Total	%
statement	110	110	100.0
branch	47	52	90.3
condition	42	42	100.0
subroutine	16	16	100.0
pod	7	8	87.5
total	222	228	97.3

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2007,2009 -- [e-mail]

package XML::Filter::Conditional;

use strict;
use warnings;
use base qw( XML::SAX::Base );

use Carp;

our $VERSION = '0.05';

=head1 NAME

C - an XML SAX filter for conditionally ignoring XML
content

=head1 SYNOPSIS

CODE:

 package My::XML::Filter;
 use base qw( XML::Filter::Conditional );

 sub store_switch
 {
    my $self = shift;
    my ( $e ) = @_;

    my $ename = $e->{Attributes}{'{}env'}{Value};
    return $ENV{$ename};
 }

 sub eval_case
 {
    my $self = shift;
    my ( $value, $e ) = @_;

    return $value eq $e->{Attributes}{'{}value'}{Value};
 }

XML:



     Hello there, root user
     Hello there, mail user
     Hello, whoever you are



=head1 DESCRIPTION

This module provides an abstract base class to implement a PerlSAX filter
which conditionally ignores part of the XML content. The base class provides
the implememtation of actually surpressing SAX events for filtering purposes,
and delegates the evaluation of matches to the subclassed instance.

The evaluation of the matches is performed by the abstract methods
C and C; see their detail below.

=cut

=head1 CONSTRUCTOR

=cut

=head2 $filter = XML::Filter::Conditional->new( %opts )

Takes the following options:

=over 8

=item Handler => OBJECT

The PerlSAX handler (or another filter) that will receive the PerlSAX events
from this filter.

=item SwitchTag => STRING or REGEXP

=item CaseTag => STRING or REGEXP

=item OtherwiseTag => STRING or REGEXP

Changes the tag names used for the C, C and C
elements. Can be precompiled regexp values instead of literal strings. The
values will be matched against the local name of the tag only, ignoring any
namespace prefix.

=item NamespaceURI => STRING

If present, the tags will only be recognised if they are part of the given
namespace. Defaults to the empty string, meaning tags will only be recognised
if they do not have a namespace prefix, and no default namespace was defined
for the document.

=item MatchAll => BOOLEAN

Determines whether all of the matching C<<  >> elements will be used, or
only the first one that matches. By default, only the first matching one will
be used.

=back

=cut

sub new
{
   my $class = shift;
   my %opts = @_;

   # Check that the abstract methods are implemented

   $class->can( "store_switch" ) or
      croak "$class must provide ->store_switch()";
   $class->can( "eval_case" ) or
      croak "$class must provide ->eval_case()";

   my $switchtag    = delete $opts{SwitchTag}    || "switch";
   my $casetag      = delete $opts{CaseTag}      || "case";
   my $otherwisetag = delete $opts{OtherwiseTag} || "otherwise";

   $opts{NamespaceURI} ||= "";

   my $self = $class->SUPER::new( %opts );

   $self->{switch_stack} = [];

   $self->{switchre}    = ref($switchtag) eq "Regexp" ?
                             $switchtag :
                             qr/^\Q$switchtag\E$/;

   $self->{casere}      = ref($casetag) eq "Regexp" ?
                             $switchtag :
                             qr/^\Q$casetag\E$/;

   $self->{otherwisere} = ref($otherwisetag) eq "Regexp" ?
                             $otherwisetag :
                             qr/^\Q$otherwisetag\E$/;

   return $self;
}

# We'll keep a little state machine
#
#   outside
#    in hot
#    in cold
#

use constant STATE_SWITCH_OUTSIDE => 1;
use constant STATE_SWITCH_INHOT   => 2;
use constant STATE_SWITCH_INCOLD  => 3;

# Define an exception subclass
@XML::Filter::Conditional::Exception::ISA = qw( XML::SAX::Exception );

sub throw_exception
{
   my $self = shift;
   my ( $message ) = @_;

   my %args = ( Message => $message );

   if( defined( my $locator = $self->{Locator} ) ) {
      $args{$_} = $locator->{$_} for (qw( LineNumber ColumnNumber ));
   }

   XML::Filter::Conditional::Exception->throw( %args );
}

sub set_document_locator
{
   my $self = shift;
   my ( $locator ) = @_;

   $self->{Locator} = $locator;

   $self->SUPER::set_document_locator( $locator );
}

sub start_element
{
   my $self = shift;
   my ( $e ) = @_;

   my $name = $e->{LocalName};

   my $right_namespace = ( ($e->{NamespaceURI}||"") eq $self->{NamespaceURI} );

   if( $right_namespace and $name =~ $self->{switchre} ) {
      push @{ $self->{switch_stack} },
         {
            state   => STATE_SWITCH_OUTSIDE,
            didcase => 0,
         };

      $self->{switch_state} = $self->{switch_stack}[-1];

      $self->{switch_state}{cond} = $self->store_switch( $e );

      return; # EAT
   }
   elsif( $right_namespace and $name =~ $self->{casere} ) {
      my $state = $self->{switch_state}{state};

      defined $state or
         $self->throw_exception( "Found a <$name> element outside of a containing switch" );

      $state == STATE_SWITCH_OUTSIDE or
         $self->throw_exception( "Found a <$name> element nested within another" );

      if( $self->{MatchAll} or !$self->{switch_state}{didcase} ) {
         if( $self->eval_case( $self->{switch_state}{cond}, $e ) ) {
            $self->{switch_state}{state} = STATE_SWITCH_INHOT;
            return; # EAT
         }
      }

      $self->{switch_state}{state} = STATE_SWITCH_INCOLD;
      return; # EAT
   }
   elsif( $right_namespace and $name =~ $self->{otherwisere} ) {
      my $state = $self->{switch_state}{state};

      defined $state or
         $self->throw_exception( "Found a <$name> element outside of a containing switch" );

      $state == STATE_SWITCH_OUTSIDE or
         $self->throw_exception( "Found a <$name> element nested within another" );

      # Treat it like a case which might be true

      if( !$self->{switch_state}{didcase} ) {
         $self->{switch_state}{state} = STATE_SWITCH_INHOT;
         return; # EAT
      }

      $self->{switch_state}{state} = STATE_SWITCH_INCOLD;
      return; # EAT
   }
   else {
      my $state = $self->{switch_state}{state};
      if( defined $state and $state == STATE_SWITCH_INCOLD ) {
         return; # EAT
      }
   }

   return $self->SUPER::start_element( $e );
}

sub end_element
{
   my $self = shift;
   my ( $e ) = @_;

   my $name = $e->{LocalName};

   my $right_namespace = ( ($e->{NamespaceURI}||"") eq $self->{NamespaceURI} );

   my $state = $self->{switch_state}{state};

   if( $right_namespace and $name =~ $self->{switchre} ) {
      pop @{ $self->{switch_stack} };
      $self->{switch_state} = $self->{switch_stack}[-1];

      return; # EAT
   }
   elsif( $right_namespace and $name =~ $self->{casere} ) {
      if( $state == STATE_SWITCH_INHOT ) {
         $self->{switch_state}{didcase} = 1;
      }

      $self->{switch_state}{state} = STATE_SWITCH_OUTSIDE;

      return; # EAT
   }
   elsif( $right_namespace and $name =~ $self->{otherwisere} ) {
      return; # EAT
   }
   else {
      return if( defined $state and $state == STATE_SWITCH_INCOLD );
   }

   return $self->SUPER::end_element( $e );
}

sub _surpress
{
   my $self = shift;

   my $state = $self->{switch_state}{state};

   if( defined $state and $state == STATE_SWITCH_INCOLD ) {
      return 1;
   }

   return 0;
}

sub characters
{
   my $self = shift;
   my ( $e ) = @_;

   return if $self->_surpress;

   return $self->SUPER::characters( $e );
}

sub comment
{
   my $self = shift;
   my ( $e ) = @_;

   return if $self->_surpress;

   return $self->SUPER::comment( $e );
}

sub processing_instruction
{
   my $self = shift;
   my ( $e ) = @_;

   return if $self->_surpress;

   return $self->SUPER::processing_instruction( $e );
}

# Keep perl happy; keep Britain tidy
1;

__END__