File Coverage

blib/lib/Catmandu/Fix/marc_copy.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_copy;
2              
3 1     1   255349 use Catmandu::Sane;
  1         9  
  1         7  
4 1     1   527 use Catmandu::MARC;
  1         3  
  1         31  
5 1     1   6 use Moo;
  1         1  
  1         4  
6 1     1   521 use Catmandu::Fix::Has;
  1         754  
  1         8  
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}) ) {
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_copy - copy 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_copy(001, fixed001)
71              
72             # Cut all 650 fields out of the MARC record into the subjects array
73             marc_copy(650, subjects)
74              
75              
76             =head1 DESCRIPTION
77              
78             Copy MARC data referred by MARC_TAG in a structured way to JSON path.
79              
80             In contrast to L<Catmandu::Fix::marc_map> and L<Catmandu::Fix::marc_spec>
81             marc_copy will not only copy data content (values) but also all data elements
82             like tag, indicators and subfield codes into a nested data structure.
83              
84             =head1 METHODS
85              
86             =head2 marc_copy(MARC_PATH, JSON_PATH, [equals: REGEX])
87              
88             Copy this MARC fields referred by a MARC_PATH to a JSON_PATH.
89              
90             # Copy all the 300 fields
91             marc_copy(300,tmp)
92              
93             # Copy all the 300 fields with indicator 1 = 1
94             marc_copy(300[1],tmp)
95              
96             # Copy all the 300 fields which have subfield c
97             marc_copy(300c,tmp)
98              
99             # Copy all the 300 fields which have subfield c equal to 'ABC'
100             marc_copy(300c,tmp,equal:"^ABC")
101              
102             The JSON_PATH C<tmp> will contain an array with one item per field that was copied.
103             Each item is a hash containing the following fields:
104              
105             tmp.*.tag - The names of the MARC field
106             tmp.*.ind1 - The value of the first indicator
107             tmp.*.ind2 - The value of the second indicator
108             tmp.*.subfields - An array of subfield item. Each subfield item is a
109             hash of the subfield code and subfield value
110              
111             E.g.
112              
113             tmp:
114             - tag: '300'
115             ind1: ' '
116             ind2: ' '
117             subfields:
118             - a: 'blabla:'
119             - v: 'test123'
120             - c: 'ok123'
121              
122             These JSON paths can be used like:
123              
124             # Set the first indicator of all 300 fields
125             do marc_each()
126             if marc_has(300)
127             marc_copy(300,tmp)
128              
129             # Set the first indicator to 1
130             # We only check the first item in tmp because the march_each
131             # binder can contain only one MARC field at a time
132             set_field(tmp.0.ind1,1)
133              
134             marc_paste(tmp)
135             end
136             end
137              
138             # Capitalize all the v subfields of 300
139             do marc_each()
140             if marc_has(300)
141             marc_copy(300,tmp)
142              
143             do list(path:tmp.0.subfields, var:loop)
144             if (exists(loop.v))
145             upcase(loop.v)
146             end
147             end
148              
149             marc_paste(tmp)
150             end
151             end
152              
153              
154             =head1 INLINE
155              
156             This Fix can be used inline in a Perl script:
157              
158             use Catmandu::Fix::marc_copy as => 'marc_copy';
159              
160             my $data = { record => ['650', ' ', 0, 'a', 'Perl'] };
161              
162             $data = marc_copy($data,'650','subject');
163              
164             print $data->{subject}->[0]->{tag} , "\n"; # '650'
165             print $data->{subject}->[0]->{ind1} , "\n"; # ' '
166             print $data->{subject}->[0]->{ind2} , "\n"; # 0
167             print $data->{subject}->[0]->{subfields}->[0]->{a} , "\n"; # 'Perl'
168              
169             =head1 SEE ALSO
170              
171             =over
172              
173             =item * L<Catmandu::Fix::marc_cut>
174              
175             =item * L<Catmandu::Fix::marc_paste>
176              
177             =back
178              
179             =head1 LICENSE AND COPYRIGHT
180              
181             This program is free software; you can redistribute it and/or modify it
182             under the terms of either: the GNU General Public License as published
183             by the Free Software Foundation; or the Artistic License.
184              
185             See http://dev.perl.org/licenses/ for more information.
186              
187             =cut