File Coverage

blib/lib/MARC/Spec/Structure.pm
Criterion Covered Total %
statement 89 96 92.7
branch 41 48 85.4
condition 6 9 66.6
subroutine 13 14 92.8
pod 2 5 40.0
total 151 172 87.7


line stmt bran cond sub pod time code
1             package MARC::Spec::Structure;
2              
3 13     13   6974 use Moo;
  13         34  
  13         85  
4 13     13   4523 use Const::Fast;
  13         41  
  13         106  
5 13     13   972 use Carp qw(croak);
  13         40  
  13         621  
6 13     13   81 use namespace::clean;
  13         37  
  13         73  
7              
8             our $VERSION = '1.0.0';
9              
10             const my $NO_LENGTH => -1;
11             const my $LAST => '#';
12              
13             has base => (
14             is => 'rwp',
15             lazy => 1,
16             builder => '_base'
17             );
18              
19             sub _base {
20 122     122   724 my ($self) = @_;
21              
22 122 100       717 my $base = ($self->can('tag')) ? $self->tag : '$'.$self->code;
23              
24 122         2273 $base .= '['.$self->index_start;
25 122 100       2633 if($self->index_start ne $self->index_end) { $base .= '-'.$self->index_end }
  116         4774  
26 122         977 $base .= ']';
27              
28 122 100       2091 if(defined $self->char_start) {
29 34         828 my $char_start = $self->char_start;
30 34         788 my $char_end = $self->char_end;
31 34 100 100     355 unless($char_start eq '0' && $char_end eq '#') {
32 32         82 $base .= '/'.$char_start;
33 32 100       114 if($char_end ne $char_start) { $base .= '-'.$char_end }
  8         27  
34             }
35             }
36 122 100       1052 if($self->can('indicator1')) {
37 81 100       353 my $indicators = (defined $self->indicator1) ? $self->indicator1 : '_';
38 81 100       283 $indicators .= (defined $self->indicator2) ? $self->indicator2 : '';
39 81 100       261 if($indicators ne '_') { $base .= '_'.$indicators }
  9         29  
40             }
41              
42 122         676 return $base;
43             }
44              
45              
46             has index_start => (
47             is => 'rw',
48             default => sub {0},
49             trigger => sub {
50             my ($self, $index_start) = @_;
51             if ($LAST ne $self->index_end && $LAST ne $index_start && $self->index_end < $index_start) {
52             $self->index_end($index_start);
53             } else {
54             $self->_set_base( $self->_base() );
55             }
56             $self->_set_index_length( _calculate_length($index_start, $self->index_end) )
57             }
58             );
59              
60             has index_end => (
61             is => 'rw',
62             default => sub {$LAST},
63             trigger => sub {
64             my ($self, $index_end) = @_;
65             if ($LAST ne $self->index_start && $LAST ne $index_end && $self->index_start > $index_end) {
66             $self->index_start($index_end);
67             } else {
68             $self->_set_base( $self->_base() );
69             }
70             $self->_set_index_length( _calculate_length($self->index_start, $index_end) )
71             }
72             );
73            
74             has index_length => (
75             is => 'rwp',
76             default => sub {$NO_LENGTH}
77             );
78              
79             has char_start => (
80             is => 'rw',
81             trigger => sub {
82             my ($self, $char_start) = @_;
83             if(!defined $self->char_end) { $self->char_end($char_start) }
84             $self->_set_char_pos($self->char_start.'-'.$self->char_end);
85             $self->_set_char_length( _calculate_length($char_start, $self->char_end) );
86             $self->_set_base( $self->_base() )
87             },
88             predicate => 1
89             );
90              
91             has char_end => (
92             is => 'rw',
93             trigger => sub {
94             my ($self, $char_end) = @_;
95             if(!defined $self->char_start) { $self->char_start($char_end) }
96             $self->_set_char_pos($self->char_start.'-'.$self->char_end);
97             $self->_set_char_length( _calculate_length($self->char_start, $char_end) );
98             $self->_set_base( $self->_base() )
99             },
100             predicate => 1
101             );
102              
103             has char_pos => (
104             is => 'rwp',
105             predicate => 1
106             );
107              
108             has char_length => (
109             is => 'rwp',
110             lazy => 1,
111             builder => sub {
112 0     0   0 my ($self) = @_;
113 0         0 return _calculate_length($self->char_start, $self->char_end)
114             }
115             );
116              
117             has subspecs => (
118             is => 'rwp',
119             isa => sub {
120             foreach my $and (@{$_[0]}) {
121             if(ref $and eq 'ARRAY') {
122             foreach my $or (@{$and}) {
123             croak('Subspec is not an instance of MARC::Spec::Subspec.')
124             if(ref $or ne 'MARC::Spec::Subspec')
125             }
126             } else {
127             croak('Subspec is not an instance of MARC::Spec::Subspec.')
128             if(ref $and ne 'MARC::Spec::Subspec')
129             }
130             }
131             },
132             predicate => 1
133             );
134              
135             sub set_index_start_end {
136 13     13 1 41 my ($self, $indizes) = @_;
137 13         47 my @pos = _validate_pos($indizes);
138 13         279 $self->index_start($pos[0]);
139 13 50       251 defined $pos[1] ? $self->index_end($pos[1]) : $self->index_end($pos[0])
140             }
141              
142             sub set_char_start_end {
143 9     9 1 1556 my ($self, $charpos) = @_;
144 9         43 my @pos = _validate_pos($charpos);
145 9         215 $self->char_start($pos[0]);
146 9 50       206 defined $pos[1] ? $self->char_end($pos[1]) : $self->char_end($pos[0])
147             }
148              
149             sub add_subspec {
150 34     34 0 86 my ($self, $subspec) = @_;
151 34 100       151 if(!$self->has_subspecs) {
152 6         138 $self->_set_subspecs([$subspec]);
153             } else {
154 28         41 my @subspecs = ( @{$self->subspecs}, $subspec );
  28         87  
155 28         428 $self->_set_subspecs( \@subspecs )
156             }
157             }
158              
159             sub add_subspecs {
160 33     33 0 178 my ($self, $subspecs) = @_;
161 33 50       124 if (ref $subspecs ne 'ARRAY') {
162 0         0 croak('Subspecs is not an ARRAYRef!')
163             }
164 33 100       117 if(!$self->has_subspecs) {
165 29         498 $self->_set_subspecs($subspecs)
166             } else {
167 4         9 my @merged = @{$self->subspecs};
  4         35  
168 4         13 push @merged, @{$subspecs};
  4         14  
169 4         110 $self->_set_subspecs( \@merged )
170             }
171             }
172              
173             sub to_string {
174 21     21 0 6913 my ($self) = @_;
175 21         319 my $string = $self->base;
176 21 100       180 if($self->has_subspecs) {
177 2         5 my @outer = ();
178 2         3 foreach my $ss (@{$self->subspecs}) {
  2         6  
179 3 100       9 if(ref $ss eq 'ARRAY') {
180 1         3 my $inner = join '|', map {$_->to_string()} @{$ss};
  2         6  
  1         2  
181 1         5 push @outer, $inner;
182             } else {
183 2         8 push @outer, $ss->to_string();
184             }
185             }
186 2         7 my $joined = join '}{', @outer;
187 2         7 $string .= '{'. $joined .'}';
188             }
189 21         85 return $string;
190             }
191              
192             sub _calculate_length {
193 69     69   572 my ($start, $end) = @_;
194              
195             # start eq end
196 69 100       252 if ($start eq $end) { return 1 }
  31         174  
197              
198             # start = #, end != #
199 38 50 33     152 if($LAST eq $start && $LAST ne $end) { return $end + 1 }
  0         0  
200              
201             # start != #, end = #
202 38 100 66     283 if($LAST ne $start && $LAST eq $end) { return $NO_LENGTH }
  29         186  
203              
204 9         43 my $length = $end - $start + 1;
205              
206 9 100       41 if(1 > $length) {
207 1         6 _throw("Ending character or index position must be equal or higher than starting character or index position.", "$start-$end");
208             }
209              
210 8         55 return $length;
211             }
212              
213             sub _validate_pos {
214 22     22   60 my ($charpos) = @_;
215              
216 22 50       102 if($charpos =~ /[^0-9\-#]/s) {
217 0         0 _throw("Assuming index or character position or range. Only digits, the character '#' and one '-' is allowed.", $charpos);
218             }
219              
220             # something like 123- is not valid
221 22 50       100 if('-' eq substr $charpos, -1) {
222 0         0 _throw("Assuming index or character range. At least two digits or the character '#' must be present." ,$charpos);
223             }
224              
225             # something like -123 is not valid
226 22 50       92 if('-' eq substr $charpos, 0, 1) {
227 0         0 _throw("Assuming index or character position or range. First character must not be '-'.", $charpos);
228             }
229              
230 22         107 my @pos = split /\-/, $charpos, 2;
231              
232             # set end pos to start pos if no end pos
233 22 100       93 if(!defined $pos[1]) { push (@pos, $pos[0]) }
  6         20  
234              
235 22         100 return @pos;
236             }
237              
238             sub _throw {
239 1     1   3 my ($message, $hint) = @_;
240 1         13 croak 'MARCspec Parser exception. '.$message.' Tried to parse: '.$hint;
241             }
242             1;
243             __END__