line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package PICA::Parser::XML; |
2
|
4
|
|
|
4
|
|
29
|
use strict; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
121
|
|
3
|
4
|
|
|
4
|
|
23
|
use warnings; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
194
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.33'; |
6
|
|
|
|
|
|
|
|
7
|
4
|
|
|
4
|
|
25
|
use Carp qw(croak); |
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
241
|
|
8
|
4
|
|
|
4
|
|
3633
|
use XML::LibXML::Reader; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
use parent 'PICA::Parser::Base'; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub new { |
13
|
|
|
|
|
|
|
my ($class, $input, %options) = @_; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
my $self = bless { |
16
|
|
|
|
|
|
|
bless => !!$options{bless}, |
17
|
|
|
|
|
|
|
}, $class; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# check for file or filehandle |
20
|
|
|
|
|
|
|
my $ishandle = eval { fileno($input); }; |
21
|
|
|
|
|
|
|
if ( !$@ && defined $ishandle ) { |
22
|
|
|
|
|
|
|
binmode $input; # drop all PerlIO layers, as required by libxml2 |
23
|
|
|
|
|
|
|
my $reader = XML::LibXML::Reader->new(IO => $input) |
24
|
|
|
|
|
|
|
or croak "cannot read from filehandle $input\n"; |
25
|
|
|
|
|
|
|
$self->{xml_reader} = $reader; |
26
|
|
|
|
|
|
|
} elsif ( defined $input && $input !~ /\n/ && -e $input ) { |
27
|
|
|
|
|
|
|
my $reader = XML::LibXML::Reader->new(location => $input) |
28
|
|
|
|
|
|
|
or croak "cannot read from file $input\n"; |
29
|
|
|
|
|
|
|
$self->{xml_reader} = $reader; |
30
|
|
|
|
|
|
|
} elsif ( defined $input && length $input > 0 ) { |
31
|
|
|
|
|
|
|
$input = ${$input} if (ref($input) // '' eq 'SCALAR'); |
32
|
|
|
|
|
|
|
my $reader = XML::LibXML::Reader->new( string => $input ) |
33
|
|
|
|
|
|
|
or croak "cannot read XML string $input\n"; |
34
|
|
|
|
|
|
|
$self->{xml_reader} = $reader; |
35
|
|
|
|
|
|
|
} else { |
36
|
|
|
|
|
|
|
croak "file, filehande or string $input does not exists"; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
$self; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub _next_record { |
43
|
|
|
|
|
|
|
my ($self) = @_; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
my $reader = $self->{xml_reader}; |
46
|
|
|
|
|
|
|
return unless $reader->nextElement('record'); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
my @record; |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
# get all field nodes from PICA record; |
51
|
|
|
|
|
|
|
foreach my $field_node ( $reader->copyCurrentNode(1)->getChildrenByTagName('*') ) { |
52
|
|
|
|
|
|
|
my @field; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# get field tag number |
55
|
|
|
|
|
|
|
my $tag = $field_node->getAttribute('tag'); |
56
|
|
|
|
|
|
|
my $occurrence = $field_node->getAttribute('occurrence') // ''; |
57
|
|
|
|
|
|
|
push(@field, ($tag, $occurrence)); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# get all subfield nodes |
60
|
|
|
|
|
|
|
foreach my $subfield_node ( $field_node->getChildrenByTagName('*') ) { |
61
|
|
|
|
|
|
|
my $subfield_code = $subfield_node->getAttribute('code'); |
62
|
|
|
|
|
|
|
my $subfield_data = $subfield_node->textContent; |
63
|
|
|
|
|
|
|
push(@field, ($subfield_code, $subfield_data)); |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
push(@record, [@field]); |
66
|
|
|
|
|
|
|
}; |
67
|
|
|
|
|
|
|
return \@record; |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
1; |
71
|
|
|
|
|
|
|
__END__ |