File Coverage

blib/lib/Catmandu/Fix/marc_cut.pm
Criterion Covered Total %
statement 12 31 38.7
branch n/a
condition n/a
subroutine 4 6 66.6
pod 0 1 0.0
total 16 38 42.1


line stmt bran cond sub pod time code
1             package Catmandu::Fix::marc_cut;
2              
3 1     1   313695 use Catmandu::Sane;
  1         13  
  1         11  
4 1     1   760 use Catmandu::MARC;
  1         3  
  1         33  
5 1     1   6 use Moo;
  1         2  
  1         4  
6 1     1   555 use Catmandu::Fix::Has;
  1         773  
  1         6  
7              
8             with 'Catmandu::Fix::Base';
9              
10             our $VERSION = '1.13';
11              
12             has marc_path => (fix_arg => 1);
13             has path => (fix_arg => 1);
14             has equals => (fix_opt => 1);
15              
16             sub emit {
17 0     0 0   my ($self,$fixer) = @_;
18 0           my $path = $fixer->split_path($self->path);
19 0           my $key = $path->[-1];
20 0           my $marc_obj = Catmandu::MARC->instance;
21              
22             # Precompile the marc_path to gain some speed
23 0           my $marc_context = $marc_obj->compile_marc_path($self->marc_path, subfield_wildcard => 0);
24 0           my $marc = $fixer->capture($marc_obj);
25 0           my $marc_path = $fixer->capture($marc_context);
26 0           my $equals = $fixer->capture($self->equals);
27              
28 0           my $var = $fixer->var;
29 0           my $result = $fixer->generate_var;
30 0           my $current_value = $fixer->generate_var;
31              
32 0           my $perl = "";
33 0           $perl .= $fixer->emit_declare_vars($current_value, "[]");
34 0           $perl .=<<EOF;
35             if (my ${result} = ${marc}->marc_copy(
36             ${var},
37             ${marc_path},
38             ${equals},1) ) {
39             ${result} = ref(${result}) ? ${result} : [${result}];
40             for ${current_value} (\@{${result}}) {
41             EOF
42              
43             $perl .= $fixer->emit_create_path(
44             $var,
45             $path,
46             sub {
47 0     0     my $var2 = shift;
48 0           "${var2} = ${current_value}"
49             }
50 0           );
51              
52 0           $perl .=<<EOF;
53             }
54             }
55             EOF
56 0           $perl;
57             }
58              
59             1;
60              
61             __END__
62              
63             =head1 NAME
64              
65             Catmandu::Fix::marc_cut - cut marc data in a structured way to a new field
66              
67             =head1 SYNOPSIS
68              
69             # Cut the 001 field out of the MARC record into the fixed001
70             marc_cut(001, fixed001)
71              
72             # Cut all 650 fields out of the MARC record into the subjects array
73             marc_cut(650, subjects)
74              
75             =head1 DESCRIPTION
76              
77             This Fix work like L<Catmandu::Fix::marc_copy> except it will also remove all
78             mathincg fields from the MARC record
79              
80             =head1 METHODS
81              
82             =head2 marc_cut(MARC_PATH, JSON_PATH, [equals: REGEX])
83              
84             Cut this MARC fields referred by a MARC_PATH to a JSON_PATH.
85              
86             # Cut all the 300 fields
87             marc_cut(300,tmp)
88              
89             # Cut all the 300 fields with indicator 1 = 1
90             marc_cut(300[1],tmp)
91              
92             # Cut all the 300 fields which have subfield c
93             marc_cut(300c,tmp)
94              
95             # Cut all the 300 fields which have subfield c equal to 'ABC'
96             marc_cut(300c,tmp,equal:"^ABC")
97              
98             The JSON_PATH C<tmp> will contain an array with one item per field that was cut.
99             Each item is a hash containing the following fields:
100              
101             tmp.*.tag - The names of the MARC field
102             tmp.*.ind1 - The value of the first indicator
103             tmp.*.ind2 - The value of the second indicator
104             tmp.*.subfields - An array of subfield item. Each subfield item is a
105             hash of the subfield code and subfield value
106              
107             E.g.
108              
109             tmp:
110             - tag: '300'
111             ind1: ' '
112             ind2: ' '
113             subfields:
114             - a: 'blabla:'
115             - v: 'test123'
116             - c: 'ok123'
117              
118             These JSON paths can be used like:
119              
120             # Set the first indicator of all 300 fields
121             do marc_each()
122             if marc_has(300)
123             marc_cut(300,tmp)
124              
125             # Set the first indicator to 1
126             # We only check the first item in tmp because the march_each
127             # binder can contain only one MARC field at a time
128             set_field(tmp.0.ind1,1)
129              
130             marc_paste(tmp)
131             end
132             end
133              
134             # Capitalize all the v subfields of 300
135             do marc_each()
136             if marc_has(300)
137             marc_cut(300,tmp)
138              
139             do list(path:tmp.0.subfields, var:loop)
140             if (exists(loop.v))
141             upcase(loop.v)
142             end
143             end
144              
145             marc_paste(tmp)
146             end
147             end
148              
149             =head1 INLINE
150              
151             This Fix can be used inline in a Perl script:
152              
153             use Catmandu::Fix::marc_copy as => 'marc_cut';
154              
155             my $data = { record => ['650', ' ', 0, 'a', 'Perl'] };
156              
157             $data = marc_cut($data,'650','subject');
158              
159             print $data->{subject}->[0]->{tag} , "\n"; # '650'
160             print $data->{subject}->[0]->{ind1} , "\n"; # ' '
161             print $data->{subject}->[0]->{ind2} , "\n"; # 0
162             print $data->{subject}->[0]->{subfields}->[0]->{a} , "\n"; # 'Perl'
163              
164             =head1 SEE ALSO
165              
166             =over
167              
168             =item * L<Catmandu::Fix::marc_copy>
169              
170             =item * L<Catmandu::Fix::marc_paste>
171              
172             =back
173              
174             =head1 LICENSE AND COPYRIGHT
175              
176             This program is free software; you can redistribute it and/or modify it
177             under the terms of either: the GNU General Public License as published
178             by the Free Software Foundation; or the Artistic License.
179              
180             See http://dev.perl.org/licenses/ for more information.
181              
182             =cut