File Coverage

blib/lib/Net/OAI/Record/NamespaceFilter.pm

Criterion	Covered	Total	%
statement	135	169	79.8
branch	56	90	62.2
condition	5	11	45.4
subroutine	12	17	70.5
pod	12	14	85.7
total	220	301	73.0

package Net::OAI::Record::NamespaceFilter;

use strict;
use base qw( XML::SAX::Base );
use Storable;
our $VERSION = 'v1.016.10';

our $AUTOLOAD;

=head1 NAME

Net::OAI::Record::NamespaceFilter - general filter class

=head1 SYNOPSIS

=head1 DESCRIPTION

It will forward any element belonging to a namespace from this list
to the associated SAX filter and all of the element's children
(regardless of their respective namespace) to the same one. It can be used either as a
C or C.

This SAX filter takes a hashref C as argument, with namespace
URIs for keys ('*' for "any") and either

over 4

=item undef

Matching elements and their subelements are suppressed.

If the list of namespaces ist empty or C is connected to
the filter, it effectively acts as a plug to Net::OAI::Harvester. This
might come handy if you are planning to get to the raw result by other
means, e.g. by tapping the user agent or accessing the result's xml() method:

 $plug = Net::OAI::Harvester::Record::NamespaceFilter();
 $harvester = Net::OAI::Harvester->new( [
     baseURL => ...,
     recordHandler => $plug,
     ] );

 my $unparsed;
 open (my $TAP, ">", \$unparsed);
 $harvester->userAgent()->add_handler(response_data => sub {
        my($response, $ua, $h, $data) = @_;
        print $TAP $data;
     });

 $list = $harvester->listRecords(
    metadataPrefix  => 'a_strange_one',
    recordHandler => $plug,
  );

 print $unparsed;     # complete OAI response
 print $list->xml();  # should be the same


=item a class name of a SAX filter

For any record element of the OAI response a new instance
is created.


=item a code reference for an constructor

Must return a SAX filter ready to accept a new document.

The following example returns a text representation of each single
record:

 # end_document() events will return \$x
 my $constructor = sub { my $x = "";
                         return XML::SAX::Writer->new(Output => \$x);
                       };
 $my harvester = Net::OAI::Harvester->new( [
     baseURL => ...,
     ] );

 my $filter = Net::OAI::Harvester::Record::NamespaceFilter(
      '*' => $constructor);

 my $list = $harvester->listRecords(
     metadataPrefix  => 'oai_dc',
     recordHandler => $filter,
  );

 while( my $r = $list->next() ) {
     my $xmlstringref = $r->recorddata()->result('*');
     ...
  };

Note:


=item an already instantiated SAX filter

In this case C and C events are
E forwarded to the filter.

 open my $fh, ">", $some_file;
 $builder = XML::SAX::Writer->new(Output => $fh);
 $builder->start_document();
 my $rootEL = { Name => 'collection',
           LocalName => 'collection',
        NamespaceURI => "http://www.loc.gov/MARC21/slim",
              Prefix => "",
          Attributes => {}
              };
 $builder->start_element( $rootEL );

 # filter for OAI-Namespace in records: forward all
 my $filter = Net::OAI::Harvester::Record::NamespaceFilter(
      'http://www.loc.gov/MARC21/slim' => $builder);

 my $harvester = Net::OAI::Harvester->new( [
     baseURL => ...,
     ] );

 my $list = $harvester->listRecords(
     metadataPrefix  => 'a_strange_one',
     metadataHandler => $filter,
  );
 # handle resumption tokens if more than the first
 # chunk shall be stored into $fh ....

 $builder->end_element( $rootEL );
 $builder->end_document();
 close($fh);

=back


=head1 METHODS


=head2 new( [%namespaces] )

=cut

sub new {
    my ( $class, %opts ) = @_;
    my $self = bless { namespaces => {%opts} }, ref( $class ) || $class;
    $self->{ _activeStack } = [];
    $self->{ _tagStack } = [];
    $self->{ _result } = [];
    $self->{ _prefixmap } = {};
    $self->set_handler( undef );
    delete $self->{ _noHandler };  # follows set_handler()
    $self->{ _handlers } = {};
    $self->{ _performing } = {};
    while ( my ($key, $value) = each %{$self->{ namespaces }} ) {
        if ( ! defined $value ) {   # no handler
#warn "new(): case 1 for $key";
          }
        elsif ( ! ref($value) ) {    # class name
#warn "new(): case 2 for $key";
            Net::OAI::Harvester::_verifyHandler( $value );
          }
        elsif ( ref($value) eq "CODE" ) {    # constructor
#warn "new(): case 3 for $key";
            # can't verify now
          }
        else {    # active instance
#warn "new(): case 4 for $key";
            $self->{ _handlers }->{ $key } = $value;
            $self->{ _performing }->{ $value }--;
          }
      };
    return( $self );
}

=head2 result ( [namespace] )

If called with a I, it returns the result of the handler,
i.e. what C returned for the record in question.
Otherwise it returns a hashref for all the results with the
corresponding namespaces as keys.

=cut

sub result {
    my ( $self, $ns ) = @_;
    if ( defined $ns ) {
      return $self->{ _result }->{$ns} || undef}
    else {
      return $self->{ _result }}
}


## Storable hooks

sub STORABLE_freeze {
  my ($obj, $cloning) = @_;
  return if $cloning;
  return "", $obj->{ _result };   # || undef;
}

sub STORABLE_thaw {
  my ($obj, $cloning, $serialized, $listref) = @_;
  return if $cloning;
  $obj->{ _result } = $listref;
#warn "thawed @$listref";
}


## SAX handlers

sub start_document {
  my ($self, $document) = @_;
die "start_document()";
warn "\t\t_activeStack: @{$self->{ _activeStack }}\n";
warn "\t\t_tagStack: @{$self->{ _tagStack }}\n";
  $self->SUPER::start_document( $document );
}
sub end_document {
  my ($self, $document) = @_;
die "end_document()";
warn "\t\t_activeStack: @{$self->{ _activeStack }}\n";
warn "\t\t_tagStack: @{$self->{ _tagStack }}\n";
  $self->SUPER::end_document( $document );
}

sub start_prefix_mapping {
  my ($self, $mapping) = @_;
#warn "NamespaceFilter: deferred prefix mapping for @{[%$mapping]}\n";
  $self->SUPER::start_prefix_mapping( $mapping ) unless $self->{ _noHandler };
  return if $self->{ _activeStack }->[0];
#warn ">>>possibly deferred prefix mapping for @{[%$mapping]}\n";
  $self->{ _prefixmap }->{ $mapping->{Prefix} } = $mapping;
  my $activehdl = $self->get_handler();
die "wrong assumption" unless (! defined $activehdl) or $self->{ _performing }->{ $activehdl };
  my $switched;
  foreach my $hdl ( keys %{$self->{ _performing }} ) {
#warn "\t-->forwarding prefix mapping @{[%$mapping]}\n\t\tto $hdl at @{$self->{ _tagStack }}\n";
      $self->set_handler( $hdl );
      $self->SUPER::start_prefix_mapping( $mapping );
      $switched = 1;
    }
  $self->set_handler( $activehdl ) if $switched;
}

sub end_prefix_mapping {
  my ($self, $mapping) = @_;
  $self->SUPER::end_prefix_mapping( $mapping ) unless $self->{ _noHandler };
  return if $self->{ _activeStack }->[0];
#warn "<<{ _tagStack }}\n";
die "mapping @{[%$mapping]} already removed" unless $self->{ _prefixmap }->{ $mapping->{Prefix} };
  my $activehdl = $self->get_handler();   # always undef
die "wrong assumption" unless (! defined $activehdl) or $self->{ _performing }->{ $activehdl };
  my $switched;
  foreach my $hdl ( keys %{$self->{ _performing }} ) {
#warn "\t--->forwarding removed mapping to $hdl";
      $self->set_handler( $hdl );
      $self->SUPER::end_prefix_mapping( $mapping );
      $switched = 1;
    }
  delete $self->{ _prefixmap }->{ $mapping->{Prefix} };
  $self->set_handler( $activehdl ) if $switched;
}

sub start_element {
    my ( $self, $element ) = @_;
#warn "\t((( ".$element->{ Name }." (((";
#warn "\t\t_activeStack: @{$self->{ _activeStack }}\n";
#warn "\t\t_tagStack: @{$self->{ _tagStack }}\n";
    if ( $self->{ _activeStack }->[0] ) {   # handler already set up
      }
    else {
        unless ( $self->{ _tagStack }->[0] ) {      # should be the start of a new record
#warn "initializing for $element->{Name}\n";
            $self->{ _result } = {};
# start_document here for all defined handlers?
            my $activehdl = $self->get_handler();   # always undef
die "handler $activehdl already active" if defined $activehdl;
            my $switched;

            while ( my ($key, $value) = each %{$self->{ namespaces }} ) {
                $self->{ _result }->{ $key } = undef;
                my $hdl;
                if ( ! defined $value ) {   # no handler
#warn "start_element(): case 1 for $key";
                  }
                elsif ( ! ref($value) ) {    # class name
#warn "start_element(): case 2 for $key";
                    $hdl = $value->new();
                  }
                elsif ( ref($value) eq "CODE" ) {    # constructor
#warn "start_element(): case 3 for $key";
                    $hdl = &$value();
                    Net::OAI::Harvester::_verifyHandler( $hdl );
                  }
                else {    # always active instance
#warn "start_element(): case 4 for $key. Handler is $value";
# bugfix for XML::SAX::Writer?
                $switched = 1;
                $self->set_handler( $value );
                foreach my $mapping ( values %{$self->{ _prefixmap }} ) {
#warn "bugfix supply of deferred @{[%$mapping]}";
                    $self->SUPER::start_prefix_mapping( $mapping )}
                    next;
                  }

                $self->{ _handlers }->{ $key } = $hdl;
                next unless defined $hdl;
                next if $self->{ _performing }->{ $hdl }++;
                $switched = 1;
                $self->set_handler( $hdl );
#warn "dispatching start_document for $hdl";
                $self->SUPER::start_document({});
                foreach my $mapping ( values %{$self->{ _prefixmap }} ) {
#warn "supplying deferred @{[%$mapping]} for $hdl";
                    $self->SUPER::start_prefix_mapping( $mapping )}
              }
            $self->set_handler( $activehdl ) if $switched;
          };

        if ( exists $self->{ namespaces }->{$element->{ NamespaceURI }} ) {
            if ( defined (my $hdl = $self->{ _handlers }->{$element->{ NamespaceURI }}) ) {
                $self->set_handler( $hdl );
                $self->{ _noHandler } = 0;
              };
          }
        elsif ( exists $self->{ namespaces }->{'*'} ) {
            if ( defined (my $hdl = $self->{ _handlers }->{'*'}) ) {
                $self->set_handler( $hdl );
                $self->{ _noHandler } = 0;
              };
          }
        else {
            push (@{$self->{ _tagStack }}, $element->{ Name });
            return;
          };
      };

    push (@{$self->{ _activeStack }}, $element->{ Name });
    return if $self->{ _noHandler };
    $self->SUPER::start_element( $element );
}

sub end_element {
    my ( $self, $element ) = @_;
#warn "\t))) ".$element->{ Name }." )))";
#warn "\t\t_activeStack: @{$self->{ _activeStack }}\n";
#warn "\t\t_tagStack: @{$self->{ _tagStack }}\n";
    if ( $self->{ _activeStack }->[0] ) {
        unless ( $self->{ _noHandler } ) {
            $self->SUPER::end_element( $element );
          };
        pop (@{$self->{ _activeStack }});
        return if $self->{ _activeStack }->[0];
        unless ( $self->{ _noHandler } ) {
            $self->set_handler(undef);
            $self->{ _noHandler } = 1;
          }
      }
    elsif ( $self->{ _tagStack }->[0] ) {
        pop (@{$self->{ _tagStack }});
      }
    return if $self->{ _tagStack }->[0];
# create end_document() event here for all handlers?
#warn "finalizing for $element->{Name}";
    my $activehdl = $self->get_handler();   # always undef
die "handler $activehdl still active" if defined $activehdl;
    my $switched;
    while ( my ($key, $value) = each %{$self->{ namespaces }} ) {
        if ( ! defined $value ) {
#warn "end_element(): case 1 for $key";
            $self->{ _result }->{ $key } = "";
          }
        elsif ( my $hdl = $self->{ _handlers }->{ $key } ) {
            if ( ! $self->{ _performing }->{ $hdl } ) {
                warn "already(?) inactive handler $hdl for $key";
                delete $self->{ _handlers }->{ $key };
                next;
              }
            elsif ( $self->{ _performing }->{ $hdl } < 0 ) {      # always active handler
#warn "end_element(): case 4 for $key";
                $self->{ _result }->{ $key } = undef;
                next;
              };
#warn "end_element(): case 2/3 for $key";
            delete $self->{ _handlers }->{ $key };
            delete $self->{ _performing }->{ $hdl };
            $switched = 1;
            $self->set_handler( $hdl );
# revoke some stored namespace mappings, too?
            my $result = $self->SUPER::end_document({});
#warn "dispatching end_document for $hdl yielded $result";
            $self->{ _result }->{ $key } = $result;
          }
        else {
die " $key not listed as _handler";
          };
      };
    $self->set_handler( $activehdl ) if $switched;
}

sub characters {
    my ( $self, $characters ) = @_;
    return if $self->{ _noHandler };
    return $self->SUPER::characters( $characters );
}

sub ignorable_whitespace {
    my ( $self, $characters ) = @_;
    return if $self->{ _noHandler };
    return $self->SUPER::ignorable_whitespace( $characters );
}

sub comment {
    my ( $self, $comment ) = @_;
    return if $self->{ _noHandler };
    return $self->SUPER::comment( $comment );
}

sub processing_instruction {
    my ( $self, $pi ) = @_;
    return if $self->{ _noHandler };
    return $self->SUPER::processing_instruction( $pi );
}

1;