File Coverage

blib/lib/Catmandu/Fix/Condition/mab_match.pm
Criterion Covered Total %
statement 34 34 100.0
branch n/a
condition n/a
subroutine 8 8 100.0
pod 0 1 0.0
total 42 43 97.6


line stmt bran cond sub pod time code
1             package Catmandu::Fix::Condition::mab_match;
2              
3             our $VERSION = '0.23';
4              
5 1     1   29542 use Catmandu::Sane;
  1         2  
  1         6  
6 1     1   536 use Catmandu::Fix::mab_map;
  1         2  
  1         28  
7 1     1   387 use Catmandu::Fix::Condition::all_match;
  1         21653  
  1         8  
8 1     1   452 use Catmandu::Fix::set_field;
  1         3765  
  1         5  
9 1     1   431 use Catmandu::Fix::remove_field;
  1         3300  
  1         3  
10 1     1   32 use Moo;
  1         2  
  1         3  
11 1     1   256 use Catmandu::Fix::Has;
  1         2  
  1         3  
12              
13             with 'Catmandu::Fix::Condition';
14              
15             has mab_path => ( fix_arg => 1 );
16             has value => ( fix_arg => 1 );
17              
18             sub emit {
19 1     1 0 5114 my ( $self, $fixer, $label ) = @_;
20              
21 1         1 my $perl;
22              
23 1         37 my $tmp_var = '_tmp_' . int( rand(9999) );
24 1         8 my $mab_map
25             = Catmandu::Fix::mab_map->new( $self->mab_path, "$tmp_var.\$append" );
26 1         1347 $perl .= $mab_map->emit( $fixer, $label );
27              
28 1         7 my $all_match = Catmandu::Fix::Condition::all_match->new( "$tmp_var.*",
29             $self->value );
30 1         1686 my $remove_field = Catmandu::Fix::remove_field->new($tmp_var);
31              
32 1         1027 my $pass_fixes = $self->pass_fixes;
33 1         3 my $fail_fixes = $self->fail_fixes;
34              
35 1         5 $all_match->pass_fixes( [ $remove_field, @$pass_fixes ] );
36 1         3 $all_match->fail_fixes( [ $remove_field, @$fail_fixes ] );
37              
38 1         4 $perl .= $all_match->emit( $fixer, $label );
39              
40 1         11519 $perl;
41             }
42              
43              
44             1;
45              
46             __END__
47              
48             =pod
49              
50             =encoding UTF-8
51              
52             =head1 NAME
53              
54             Catmandu::Fix::Condition::mab_match - Conditionals on MAB2 fields
55              
56             =head1 SYNOPSIS
57              
58             # mab_match(PICA_PATH,REGEX)
59              
60             if mab_match('245','My funny title')
61             add_field('my.funny.title','true')
62             end
63              
64             =head1 DESCRIPTION
65              
66             Read our Wiki pages at L<https://github.com/LibreCat/Catmandu/wiki/Fixes>
67             for a complete overview of the Fix language.
68              
69             =head1 NAME
70              
71             Catmandu::Fix::Condition::mab_match - Conditionals on PICA fields
72              
73             =head1 SEE ALSO
74              
75             L<Catmandu::Fix>
76              
77             =head1 AUTHOR
78              
79             Johann Rolschewski <jorol@cpan.org>
80              
81             =head1 COPYRIGHT AND LICENSE
82              
83             This software is copyright (c) 2013 by Johann Rolschewski.
84              
85             This is free software; you can redistribute it and/or modify it under
86             the same terms as the Perl 5 programming language system itself.
87              
88             =cut