line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package PICA::Path; |
2
|
5
|
|
|
5
|
|
26656
|
use strict; |
|
5
|
|
|
|
|
16
|
|
|
5
|
|
|
|
|
167
|
|
3
|
5
|
|
|
5
|
|
29
|
use warnings; |
|
5
|
|
|
|
|
12
|
|
|
5
|
|
|
|
|
425
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.33'; |
6
|
|
|
|
|
|
|
|
7
|
5
|
|
|
5
|
|
38
|
use Carp qw(confess); |
|
5
|
|
|
|
|
12
|
|
|
5
|
|
|
|
|
340
|
|
8
|
5
|
|
|
5
|
|
40
|
use Scalar::Util qw(reftype); |
|
5
|
|
|
|
|
21
|
|
|
5
|
|
|
|
|
420
|
|
9
|
|
|
|
|
|
|
|
10
|
5
|
|
|
5
|
|
4612
|
use overload '""' => \&stringify; |
|
5
|
|
|
|
|
4249
|
|
|
5
|
|
|
|
|
57
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub new { |
13
|
16
|
|
|
16
|
1
|
10963
|
my ($class, $path) = @_; |
14
|
|
|
|
|
|
|
|
15
|
16
|
100
|
|
|
|
947
|
confess "invalid pica path" if $path !~ / |
16
|
|
|
|
|
|
|
([012*.][0-9*.][0-9*.][A-Z@*.]) # tag |
17
|
|
|
|
|
|
|
(\[([0-9*.]{2})\])? # occurence |
18
|
|
|
|
|
|
|
(\$?([_A-Za-z0-9]+))? # subfields |
19
|
|
|
|
|
|
|
(\/(\d+)?(-(\d+)?)?)? # position |
20
|
|
|
|
|
|
|
/x; |
21
|
|
|
|
|
|
|
|
22
|
13
|
|
|
|
|
56
|
my $field = $1; |
23
|
13
|
|
|
|
|
38
|
my $occurrence = $3; |
24
|
13
|
100
|
|
|
|
61
|
my $subfield = defined $5 ? "[$5]" : "[_A-Za-z0-9]"; |
25
|
|
|
|
|
|
|
|
26
|
13
|
|
|
|
|
29
|
my @position; |
27
|
13
|
100
|
|
|
|
53
|
if (defined $6) { # from, to |
28
|
8
|
|
|
|
|
33
|
my ($from, $dash, $to, $length) = ($7, $8, $9, 0); |
29
|
|
|
|
|
|
|
|
30
|
8
|
100
|
|
|
|
29
|
if ($dash) { |
31
|
6
|
100
|
66
|
|
|
279
|
confess "invalid pica path" unless defined($from // $to); # /- |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
7
|
100
|
|
|
|
21
|
if (defined $to) { |
35
|
2
|
50
|
33
|
|
|
17
|
if (!$from and $dash) { # /-X |
36
|
0
|
|
|
|
|
0
|
$from = 0; |
37
|
|
|
|
|
|
|
} |
38
|
2
|
|
|
|
|
10
|
$length = $to - $from + 1; |
39
|
|
|
|
|
|
|
} else { |
40
|
5
|
100
|
|
|
|
27
|
if ($8) { |
41
|
3
|
|
|
|
|
11
|
$length = undef; |
42
|
|
|
|
|
|
|
} else { |
43
|
2
|
|
|
|
|
16
|
$length = 1; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
7
|
50
|
66
|
|
|
41
|
if (!defined $length or $length >= 1) { |
48
|
7
|
100
|
100
|
|
|
38
|
unless (!$from and !defined $length) { # /0- |
49
|
6
|
|
|
|
|
26
|
@position = ($from, $length); |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
12
|
|
|
|
|
58
|
$field =~ s/\*/./g; |
55
|
12
|
|
|
|
|
167
|
$field = qr{$field}; |
56
|
|
|
|
|
|
|
|
57
|
12
|
100
|
|
|
|
49
|
if (defined $occurrence) { |
58
|
1
|
|
|
|
|
7
|
$occurrence =~ s/\*/./g; |
59
|
1
|
|
|
|
|
13
|
$occurrence = qr{$occurrence}; |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
|
62
|
12
|
|
|
|
|
186
|
$subfield = qr{$subfield}; |
63
|
|
|
|
|
|
|
|
64
|
12
|
|
|
|
|
99
|
bless [ $field, $occurrence, $subfield, @position ], $class; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
sub match_field { |
68
|
0
|
|
|
0
|
1
|
0
|
my ($self, $field) = @_; |
69
|
|
|
|
|
|
|
|
70
|
0
|
0
|
0
|
|
|
0
|
if ( $field->[0] =~ $self->[0] && |
|
|
|
0
|
|
|
|
|
71
|
|
|
|
|
|
|
(!$self->[1] || (defined $field->[1] && $field->[1] =~ $self->[1])) ) { |
72
|
0
|
|
|
|
|
0
|
return $field; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
return |
76
|
0
|
|
|
|
|
0
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub match_subfields { |
79
|
3
|
|
|
3
|
1
|
11
|
my ($self, $field) = @_; |
80
|
|
|
|
|
|
|
|
81
|
3
|
|
|
|
|
8
|
my $subfield_regex = $self->[2]; |
82
|
3
|
|
|
|
|
7
|
my $from = $self->[3]; |
83
|
3
|
|
|
|
|
6
|
my $length = $self->[4]; |
84
|
|
|
|
|
|
|
|
85
|
3
|
|
|
|
|
7
|
my @values; |
86
|
|
|
|
|
|
|
|
87
|
3
|
|
|
|
|
12
|
for (my $i = 2; $i < @$field; $i += 2) { |
88
|
3
|
50
|
|
|
|
22
|
if ($field->[$i] =~ $subfield_regex) { |
89
|
3
|
|
|
|
|
9
|
my $value = $field->[$i + 1]; |
90
|
3
|
100
|
|
|
|
8
|
if (defined $from) { |
91
|
2
|
100
|
|
|
|
11
|
$value = $length ? substr($value, $from, $length) : |
92
|
|
|
|
|
|
|
substr($value, $from); |
93
|
2
|
50
|
50
|
|
|
10
|
next if '' eq ($value // ''); |
94
|
|
|
|
|
|
|
} |
95
|
3
|
|
|
|
|
13
|
push @values, $value; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
3
|
|
|
|
|
17
|
return @values; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
sub record_fields { |
103
|
0
|
|
|
0
|
0
|
0
|
my ($self, $record) = @_; |
104
|
|
|
|
|
|
|
|
105
|
0
|
0
|
|
|
|
0
|
$record = $record->{record} if reftype $record eq 'HASH'; |
106
|
0
|
|
|
|
|
0
|
return [ grep { $self->match_field($_) } @$record ]; |
|
0
|
|
|
|
|
0
|
|
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub record_subfields { |
110
|
0
|
|
|
0
|
0
|
0
|
my ($self, $record) = @_; |
111
|
|
|
|
|
|
|
|
112
|
0
|
0
|
|
|
|
0
|
$record = $record->{record} if reftype $record eq 'HASH'; |
113
|
|
|
|
|
|
|
|
114
|
0
|
|
|
|
|
0
|
my @values; |
115
|
|
|
|
|
|
|
|
116
|
0
|
|
|
|
|
0
|
foreach my $field (grep { $self->match_field($_) } @$record) { |
|
0
|
|
|
|
|
0
|
|
117
|
0
|
|
|
|
|
0
|
push @values, $self->match_subfields($field); |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
0
|
|
|
|
|
0
|
return @values; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub stringify { |
124
|
9
|
|
|
9
|
1
|
16266
|
my ($self, $short) = @_; |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
my ($field, $occurrence, $subfields) = map { |
127
|
9
|
100
|
|
|
|
37
|
defined $_ ? do { |
|
27
|
|
|
|
|
82
|
|
128
|
19
|
|
|
|
|
188
|
s/^\(\?[^:]*:(.*)\)$/$1/; |
129
|
19
|
|
|
|
|
93
|
s/\./*/g; |
130
|
19
|
|
|
|
|
84
|
$_ } : undef |
131
|
|
|
|
|
|
|
} ($self->[0], $self->[1], $self->[2]); |
132
|
|
|
|
|
|
|
|
133
|
9
|
|
|
|
|
26
|
my $str = $field; |
134
|
|
|
|
|
|
|
|
135
|
9
|
100
|
|
|
|
36
|
if (defined $occurrence) { |
136
|
1
|
|
|
|
|
5
|
$str .= "[$occurrence]"; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
9
|
100
|
66
|
|
|
63
|
if (defined $subfields and $subfields ne '[_A-Za-z0-9]') { |
140
|
4
|
|
|
|
|
36
|
$subfields =~ s/\[|\]//g; |
141
|
4
|
100
|
66
|
|
|
21
|
unless( $short and $subfields !~ /^\$/ ) { |
142
|
3
|
|
|
|
|
8
|
$str .= '$'; |
143
|
|
|
|
|
|
|
} |
144
|
4
|
|
|
|
|
8
|
$str .= $subfields; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
9
|
|
|
|
|
32
|
my ($from, $length, $pos) = ($self->[3], $self->[4]); |
148
|
9
|
100
|
|
|
|
31
|
if (defined $from) { |
149
|
4
|
100
|
|
|
|
14
|
if ($from) { |
150
|
3
|
|
|
|
|
9
|
$pos = $from; |
151
|
|
|
|
|
|
|
} |
152
|
4
|
100
|
66
|
|
|
33
|
if (!defined $length) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
153
|
1
|
50
|
|
|
|
8
|
if ($from) { |
154
|
1
|
|
|
|
|
5
|
$pos = "$from-"; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
} elsif ($length > 1) { |
157
|
1
|
|
|
|
|
18
|
$pos .= '-' . ($from + $length - 1); |
158
|
|
|
|
|
|
|
} elsif ($length == 1 && !$from) { |
159
|
1
|
|
|
|
|
4
|
$pos = 0; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
9
|
100
|
|
|
|
32
|
$str .= "/$pos" if defined $pos; |
164
|
|
|
|
|
|
|
|
165
|
9
|
|
|
|
|
47
|
$str; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
1; |
169
|
|
|
|
|
|
|
__END__ |