File Coverage

blib/lib/Locale/TextDomain/OO/Extract/Process.pm
Criterion Covered Total %
statement 33 136 24.2
branch 0 50 0.0
condition 0 7 0.0
subroutine 11 20 55.0
pod 7 7 100.0
total 51 220 23.1


line stmt bran cond sub pod time code
1             package Locale::TextDomain::OO::Extract::Process; ## no critic (TidyCode)
2            
3 1     1   8970 use strict;
  1         4  
  1         41  
4 1     1   8 use warnings;
  1         4  
  1         45  
5 1     1   8 use Carp qw(confess);
  1         4  
  1         81  
6 1     1   7 use Clone qw(clone);
  1         4  
  1         46  
7 1     1   365 use Class::Load qw(load_class);
  1         9098  
  1         65  
8 1     1   8 use Locale::TextDomain::OO::Util::JoinSplitLexiconKeys;
  1         3  
  1         21  
9 1     1   5 use Moo;
  1         1  
  1         8  
10 1     1   302 use MooX::StrictConstructor;
  1         2  
  1         10  
11 1     1   1127 use MooX::Types::MooseLike::Base qw(HashRef Str);
  1         3  
  1         50  
12 1     1   315 use Set::Scalar;
  1         8017  
  1         43  
13 1     1   8 use namespace::autoclean;
  1         2  
  1         10  
14            
15             our $VERSION = '2.014';
16            
17             has category => (
18             is => 'rw',
19             isa => Str,
20             lazy => 1,
21             default => q{},
22             );
23            
24             has domain => (
25             is => 'rw',
26             isa => Str,
27             lazy => 1,
28             default => q{},
29             );
30            
31             has language => (
32             is => 'rw',
33             isa => Str,
34             lazy => 1,
35             default => 'i-default',
36             );
37            
38             has project => (
39             is => 'rw',
40             isa => sub {
41             my $project = shift;
42             defined $project
43             or return;
44             return Str->($project);
45             },
46             );
47            
48             has lexicon_ref => (
49             is => 'rw',
50             isa => HashRef,
51             lazy => 1,
52             default => sub { {} },
53             );
54            
55             has plugin_ref => (
56             is => 'rw',
57             isa => HashRef,
58             lazy => 1,
59             default => sub { { po => 'PO' } },
60             );
61            
62             has _plugin_object_ref => (
63             is => 'ro',
64             init_arg => undef,
65             default => sub { {} },
66             );
67            
68             sub add_plugin {
69 0     0 1   my ( $self, $plugin_alias, $plugin ) = @_;
70            
71 0 0         $plugin_alias
72             or confess 'Plugin alias expected';
73 0 0         $plugin
74             or confess 'Plugin name expected';
75 0           delete $self->_plugin_object_ref->{$plugin_alias};
76 0           $self->plugin_ref->{$plugin_alias} = $plugin;
77            
78 0           return;
79             }
80            
81             sub _plugin {
82 0     0     my ( $self, $plugin_alias ) = @_;
83            
84 0 0         $plugin_alias
85             or confess 'Undef is not a plugin alias';
86 0           my $plugin_object_ref = $self->_plugin_object_ref;
87 0 0         if ( exists $plugin_object_ref->{$plugin_alias} ) {
88 0           my $object = $plugin_object_ref->{$plugin_alias};
89 0           $object->clear;
90             METHOD:
91 0           for my $method ( qw( category domain language lexicon_ref project ) ) {
92 0           my $value = $self->$method;
93 0 0         defined $value
94             or next METHOD;
95 0           $object->$method($value);
96             }
97 0           return $object;
98             }
99 0 0         my $plugin = $self->plugin_ref->{$plugin_alias}
100             or confess "Unknown plugin alias $plugin_alias";
101 0 0         my $class = $plugin =~ s{ \A [+] }{}xms
102             ? $plugin
103             : "Locale::TextDomain::OO::Extract::Process::Plugin::$plugin";
104             my $object = load_class($class)->new(
105             map {
106 0 0         defined $self->$_
  0            
107             ? ( $_ => $self->$_ )
108             : ();
109             }
110             qw( category domain language lexicon_ref project )
111             );
112 0           $plugin_object_ref->{$plugin_alias} = $object;
113            
114 0           return $object;
115             }
116            
117             sub slurp {
118 0     0 1   my ( $self, $plugin_alias, $filename ) = @_;
119            
120 0           $self->_plugin($plugin_alias)->slurp($filename);
121            
122 0           return;
123             }
124            
125             sub spew {
126 0     0 1   my ( $self, $plugin_alias, $filename ) = @_;
127            
128 0           $self->_plugin($plugin_alias)->spew($filename);
129            
130 0           return;
131             }
132            
133             sub remove_all_reference {
134 0     0 1   my $self = shift;
135            
136 0           my $lexicon_ref = $self->lexicon_ref;
137 0           for my $message_ref ( values %{$lexicon_ref} ) {
  0            
138 0           for my $value_ref ( values %{$message_ref} ) {
  0            
139 0           delete $value_ref->{reference};
140             }
141             }
142            
143 0           return;
144             }
145            
146             sub remove_all_automatic {
147 0     0 1   my $self = shift;
148            
149 0           my $lexicon_ref = $self->lexicon_ref;
150 0           for my $message_ref ( values %{$lexicon_ref} ) {
  0            
151 0           for my $value_ref ( values %{$message_ref} ) {
  0            
152 0           delete $value_ref->{automatic};
153             }
154             }
155            
156 0           return;
157             }
158            
159             sub remove_all_non_referenced {
160 0     0 1   my $self = shift;
161            
162 0           my $lexicon_ref = $self->lexicon_ref;
163 0           for my $message_ref ( values %{$lexicon_ref} ) {
  0            
164             MESSAGE_KEY:
165 0           for my $message_key ( keys %{$message_ref} ) {
  0            
166 0 0         length $message_key
167             or next MESSAGE_KEY; # skip header
168             my $has_reference
169             = exists $message_ref->{$message_key}->{reference}
170 0   0       && $message_ref->{$message_key}->{reference} =~ m{\S}xms;
171             $has_reference
172 0 0         or delete $message_ref->{$message_key};
173             }
174             }
175            
176 0           return;
177             }
178            
179             sub merge_extract {
180 0     0 1   my ( $self, $arg_ref ) = @_;
181            
182             my $extract_lexicon_ref = $arg_ref->{lexicon_ref}
183 0 0         or confess 'Parameter lexicon_ref expected';
184 0 0         ref $extract_lexicon_ref eq 'HASH'
185             or confess 'Parameter lexicon_ref is not a hash reference';
186            
187 0           my $key_util = Locale::TextDomain::OO::Util::JoinSplitLexiconKeys->instance;
188             # extracted to language i-default
189             my $extract_lexicon_key = $key_util->join_lexicon_key({(
190             map {
191 0           $_ => $arg_ref->{$_};
  0            
192             }
193             qw( category domain project )
194             )});
195             # merged to real language
196             my $lexicon_key = $key_util->join_lexicon_key({(
197             map {
198 0           $_ => $self->$_;
  0            
199             }
200             qw( category domain language project )
201             )});
202            
203 0   0       my $message_ref = $self->lexicon_ref->{$lexicon_key} ||= {};
204 0           my $message_keys = Set::Scalar->new( keys %{$message_ref} );
  0            
205 0           my $extract_message_ref = $extract_lexicon_ref->{$extract_lexicon_key};
206 0           my $extract_message_keys = Set::Scalar->new( keys %{$extract_message_ref} );
  0            
207 0           my $skip_new_messages = $arg_ref->{skip_new_messages};
208             my @new_message_keys
209             = ref $skip_new_messages ne 'HASH'
210             # simple
211             ? (
212             $skip_new_messages
213             # bool parameter true
214             ? ()
215             : $extract_message_keys->difference($message_keys)->elements
216             )
217             # extended
218             : ! $skip_new_messages->{on}
219             # hash parameter false
220             ? $extract_message_keys->difference($message_keys)->elements
221 0 0         : do {
    0          
    0          
222             my $to_regex = sub {
223 0     0     my $any = shift;
224             my @parts
225 0 0         = map { ref $_ eq 'Regex' ? $_ : qr{\Q$_\E}xmsi }
226 0 0         grep { defined && length }
227 0 0         ref $any eq 'ARRAY' ? @{$any} : $any;
  0            
228             return @parts
229 0 0         ? do {
230 0           my $joined = join ' | ', @parts;
231 0           qr{ $joined }xms;
232             }
233             : qr{ (?!) }xms;
234 0           };
235 0           my $regex = $to_regex->( $skip_new_messages->{no_skip_for} );
236 0           my $not_regex = $to_regex->( $skip_new_messages->{but_skip_for} );
237            
238 0 0         grep { $_ =~ $regex && $_ !~ $not_regex }
  0            
239             $extract_message_keys->difference($message_keys)->elements;
240             };
241 0           my @changed_message_keys = $extract_message_keys->intersection($message_keys)->elements;
242            
243             # merge header
244 0           my $header_arg_ref = $arg_ref->{header_ref};
245 0 0         if ($header_arg_ref) {
246             # overwrite them
247 0 0         if ( ref $arg_ref->{header_ref} eq 'HASH' ) {
    0          
248 0           $message_ref->{ q{} } = clone($header_arg_ref);
249             }
250             # manipulate them
251             elsif ( ref $header_arg_ref eq 'CODE' ) {
252 0   0       local $_ = $message_ref->{ q{} } || {};
253 0           $header_arg_ref->();
254 0           $message_ref->{ q{} } = clone($_);
255             }
256             }
257            
258             MESSAGE_KEY:
259 0           for my $message_key (@new_message_keys) {
260 0 0         length $message_key
261             or next MESSAGE_KEY;
262             $message_ref->{$message_key}
263 0           = clone( $extract_message_ref->{$message_key} );
264             }
265             MESSAGE_KEY:
266 0           for my $message_key (@changed_message_keys) {
267 0 0         length $message_key
268             or next MESSAGE_KEY;
269             my $extract_message_value_ref
270 0           = clone( $extract_message_ref->{$message_key} );
271 0           @{ $message_ref->{$message_key} }{ keys %{$extract_message_value_ref} }
  0            
272 0           = values %{ $extract_message_value_ref };
  0            
273             }
274            
275 0           return;
276             }
277            
278             __PACKAGE__->meta->make_immutable;
279            
280             1;
281            
282             __END__