File Coverage

blib/lib/PICA/Path.pm
Criterion Covered Total %
statement 79 95 83.1
branch 47 58 81.0
condition 15 29 51.7
subroutine 8 11 72.7
pod 4 6 66.6
total 153 199 76.8


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__