File Coverage

blib/lib/MAB2/Parser/XML.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package MAB2::Parser::XML;
2              
3             our $VERSION = '0.21';
4              
5 6     6   280 use strict;
  6         11  
  6         153  
6 6     6   28 use warnings;
  6         9  
  6         160  
7 6     6   29 use Carp qw<croak>;
  6         28  
  6         232  
8 6     6   4008 use XML::LibXML::Reader;
  0            
  0            
9              
10              
11             sub new {
12             my $class = shift;
13             my $input = shift;
14              
15             my $self = {
16             filename => undef,
17             rec_number => 0,
18             xml_reader => undef,
19             };
20              
21             # check for file or filehandle
22             my $ishandle = eval { fileno($input); };
23             if ( !$@ && defined $ishandle ) {
24             binmode $input; # drop all PerlIO layers, as required by libxml2
25             my $reader = XML::LibXML::Reader->new( IO => $input )
26             or croak "cannot read from filehandle $input\n";
27             $self->{filename} = scalar $input;
28             $self->{xml_reader} = $reader;
29             }
30             elsif ( defined $input && $input !~ /\n/ && -e $input ) {
31             my $reader = XML::LibXML::Reader->new( location => $input )
32             or croak "cannot read from file $input\n";
33             $self->{filename} = $input;
34             $self->{xml_reader} = $reader;
35             }
36             elsif ( defined $input && length $input > 0 ) {
37             my $reader = XML::LibXML::Reader->new( string => $input )
38             or croak "cannot read XML string $input\n";
39             $self->{xml_reader} = $reader;
40             }
41             else {
42             croak "file, filehande or string $input does not exists";
43             }
44             return ( bless $self, $class );
45             }
46              
47              
48             sub next {
49             my $self = shift;
50             if ( $self->{xml_reader}->nextElement('datensatz') ) {
51             $self->{rec_number}++;
52             my $record = _decode( $self->{xml_reader} );
53             my ($id) = map { $_->[-1] } grep { $_->[0] =~ '001' } @{$record};
54             return { _id => $id, record => $record };
55             }
56             return;
57             }
58              
59              
60             sub _decode {
61             my $reader = shift;
62             my @record;
63              
64             # get all field nodes from MAB2 XML record;
65             foreach my $field_node (
66             $reader->copyCurrentNode(1)->getChildrenByTagName('feld') )
67             {
68             my @field;
69              
70             # get field tag number
71             my $tag = $field_node->getAttribute('nr');
72             my $ind = $field_node->getAttribute('ind') // '';
73            
74             # ToDo: textContent ignores </tf> and <ns>
75              
76             # Check for data or subfields
77             if ( my @subfields = $field_node->getChildrenByTagName('uf') ) {
78             push( @field, ( $tag, $ind ) );
79              
80             # get all subfield nodes
81             foreach my $subfield_node (@subfields) {
82             my $subfield_code = $subfield_node->getAttribute('code');
83             my $subfield_data = $subfield_node->textContent;
84             push( @field, ( $subfield_code, $subfield_data ) );
85             }
86             }
87             else {
88             my $data = $field_node->textContent();
89             push( @field, ( $tag, $ind, '_', $data ) );
90             }
91              
92             push( @record, [@field] );
93             }
94             return \@record;
95             }
96              
97              
98             1;
99              
100             __END__
101              
102             =pod
103              
104             =encoding UTF-8
105              
106             =head1 NAME
107              
108             MAB2::Parser::XML - MAB2 XML parser
109              
110             =head1 SYNOPSIS
111              
112             L<MAB2::Parser::XML> is a parser for MAB2 XML records.
113              
114             use MAB2::Parser::XML;
115              
116             my $parser = MAB2::Parser::XML->new( $filename );
117              
118             while ( my $record_hash = $parser->next() ) {
119             # do something
120             }
121              
122             =head1 Arguments
123              
124             =over
125              
126             =item C<file>
127              
128             Path to file with MAB2 XML records.
129              
130             =item C<fh>
131              
132             Open filehandle for file with MAB2 XML records.
133              
134             =item C<string>
135              
136             XML string with MAB2 XML records.
137              
138             =back
139              
140             =head1 METHODS
141              
142             =head2 new($filename | $filehandle | $string)
143              
144             =head2 next()
145              
146             Reads the next record from MAB2 XML input stream. Returns a Perl hash.
147              
148             =head2 _decode($record)
149              
150             Deserialize a MAB2 XML record to an an ARRAY of ARRAYs.
151              
152             =head1 SEEALSO
153              
154             L<Catmandu::Importer::MAB2>.
155              
156             =head1 AUTHOR
157              
158             Johann Rolschewski <jorol@cpan.org>
159              
160             =head1 COPYRIGHT AND LICENSE
161              
162             This software is copyright (c) 2013 by Johann Rolschewski.
163              
164             This is free software; you can redistribute it and/or modify it under
165             the same terms as the Perl 5 programming language system itself.
166              
167             =cut