File Coverage

lib/File/Gettext/Storage/PO.pm
Criterion Covered Total %
statement 33 33 100.0
branch 3 4 75.0
condition n/a
subroutine 11 11 100.0
pod 4 4 100.0
total 51 52 98.0


line stmt bran cond sub pod time code
1             package File::Gettext::Storage::PO;
2              
3 2     2   3043 use namespace::autoclean;
  2         3  
  2         16  
4              
5 2     2   1089 use Date::Format ( );
  2         10677  
  2         47  
6 2     2   1098 use Encode qw( decode encode );
  2         13390  
  2         134  
7 2     2   13 use File::DataClass::Constants qw( NUL SPC );
  2         3  
  2         82  
8 2     2   7 use File::DataClass::Functions qw( extension_map );
  2         4  
  2         65  
9 2     2   20 use File::Gettext::Constants qw( CONTEXT_SEP );
  2         2  
  2         60  
10 2     2   7 use Moo;
  2         3  
  2         20  
11              
12             extension_map '+File::Gettext::Storage::PO' => '.po';
13              
14             extends q(File::DataClass::Storage);
15              
16             has '+extn' => default => '.po';
17              
18             # Private functions
19             my $_comment_field = sub {
20             return { '#' => q(translator_comment),
21             '# ' => q(translator_comment),
22             '#.' => q(extracted_comment),
23             '#:' => q(reference),
24             '#,' => q(flags),
25             '#|' => q(previous), }->{ $_[ 0 ] };
26             };
27              
28             my $_comment_prefix = sub {
29             return { 'translator_comment' => '# ',
30             'extracted_comment' => '#.',
31             'reference' => '#:',
32             'flags' => '#,',
33             'previous' => '#|', }->{ $_[ 0 ] };
34             };
35              
36             my $_decode_hash; $_decode_hash = sub {
37             my ($charset, $in) = @_; my $out = {};
38              
39             for my $k (grep { defined } keys %{ $in }) {
40             my $values = $in->{ $k }; defined $values or next;
41              
42             if (ref $values eq 'HASH') {
43             $out->{ $k } = $_decode_hash->( $charset, $values );
44             }
45             elsif (ref $values eq 'ARRAY') {
46             $out->{ $k } = [ map { decode( $charset, $_ ) } @{ $values } ];
47             }
48             else { $out->{ $k } = decode( $charset, $values ) }
49             }
50              
51             return $out;
52             };
53              
54             my $_header_inflate = sub {
55             my $data = shift; my $header = (delete $data->{ NUL() }) || { msgstr => [] };
56              
57             my $null_entry = $header->{msgstr}->[ 0 ]; $header->{msgstr} = {};
58              
59             $null_entry or return $header;
60              
61             for my $line (split m{ [\n] }msx, $null_entry) {
62             my ($k, $v) = split m{ [:] }msx, $line, 2;
63              
64             $k =~ s{ [-] }{_}gmsx; $v =~ s{ \A \s+ }{}msx;
65             $header->{msgstr}->{ lc $k } = $v;
66             }
67              
68             return $header;
69             };
70              
71             my $_original_order = sub {
72             my ($hash, $lhs, $rhs) = @_;
73              
74             # New elements will be added at the end
75             exists $hash->{ $lhs }->{_order} or return 1;
76             exists $hash->{ $rhs }->{_order} or return -1;
77             return $hash->{ $lhs }->{_order} <=> $hash->{ $rhs }->{_order};
78             };
79              
80             my $_quote = sub {
81             my $text = shift;
82              
83             $text =~ s{ \A [\"] }{\\\"}msx; $text =~ s{ ([^\\])[\"] }{$1\\\"}gmsx;
84              
85             return '"'.$text.'\n"';
86             };
87              
88             my $_store_comment = sub {
89             my ($rec, $line, $attr) = @_;
90              
91             my $value = length $line > 1 ? substr $line, 2 : NUL;
92              
93             if ($attr eq q(flags)) {
94             push @{ $rec->{ $attr } }, map { s{ \s+ }{}msx; $_ }
95             split m{ [,] }msx, $value;
96             }
97             else { $rec->{ $attr } .= $rec->{ $attr } ? "\n${value}" : $value }
98              
99             return;
100             };
101              
102             my $_time2str = sub {
103             my ($format, $time) = @_;
104              
105             defined $format or $format = '%Y-%m-%d %H:%M:%S';
106             defined $time or $time = time;
107              
108             return Date::Format::Generic->time2str( $format, $time );
109             };
110              
111             my $_unquote = sub {
112             my $text = shift;
113              
114             $text =~ s{ [\\][n] \z }{\n}msx; $text =~ s{ [\\][\"] }{\"}gmsx;
115              
116             return $text;
117             };
118              
119             my $_append_msgtext = sub {
120             my ($rec, $key, $last, $text) = @_;
121              
122             if (ref $rec->{ $key } ne 'ARRAY') { $rec->{ $key } .= $_unquote->( $text ) }
123             else { $rec->{ $key }->[ $last || 0 ] .= $_unquote->( $text ) }
124              
125             return;
126             };
127              
128             my $_store_msgtext = sub {
129             my ($rec, $line, $last_ref) = @_; my $key;
130              
131             if ($line =~ m{ \A msgctxt \s+ [\"] (.*) [\"] \z }msx) {
132             $key = q(msgctxt); $rec->{ $key } = $_unquote->( $1 );
133             }
134             elsif ($line =~ m{ \A msgid \s+ [\"] (.*) [\"] \z }msx) {
135             $key = q(msgid); $rec->{ $key } = $_unquote->( $1 );
136             }
137             elsif ($line =~ m{ \A msgid_plural \s+ [\"] (.*) [\"] \z }msx) {
138             $key = q(msgid_plural); $rec->{ $key } = $_unquote->( $1 );
139             }
140             elsif ($line =~ m{ \A msgstr \s+ [\"] (.*) [\"] \z }msx) {
141             $key = q(msgstr); $rec->{ $key } ||= [];
142             $rec->{ $key }->[ ${ $last_ref } = 0 ] .= $_unquote->( $1 );
143             }
144             elsif ($line =~ m{ \A msgstr\[\s*(\d+)\s*\] \s+ [\"](.*)[\"] \z }msx) {
145             $key = q(msgstr); $rec->{ $key } ||= [];
146             $rec->{ $key }->[ ${ $last_ref } = $1 ] .= $_unquote->( $2 );
147             }
148              
149             return $key;
150             };
151              
152             # Private common methods
153             my $_get_charset = sub {
154             my ($self, $po_header) = @_; my $charset = $self->schema->charset;
155              
156             my $msgstr = $po_header->{msgstr} || {};
157             my $content_type = $msgstr->{content_type} || NUL;
158              
159             $content_type =~ s{ .* = }{}msx and $charset = $content_type;
160              
161             return $charset;
162             };
163              
164             # Private read methods
165             my $_inflate_and_decode = sub {
166             my ($self, $data) = @_;
167              
168             my $po_header = $_header_inflate->( $data );
169             my $charset = $self->$_get_charset( $po_header );
170             my $tmp = $data; $data = {};
171              
172             # Decode all keys and values using the charset from the header
173             for my $k (grep { $_ and defined $tmp->{ $_ } } keys %{ $tmp }) {
174             my $rec = $tmp->{ $k }; my $id = decode( $charset, $k );
175              
176             $data->{ $id } = $_decode_hash->( $charset, $rec );
177             }
178              
179             return { po => $data, po_header => $_decode_hash->( $charset, $po_header ) };
180             };
181              
182             my $_store_record = sub {
183             my ($self, $data, $rec, $order_ref) = @_; exists $rec->{msgid} or return;
184              
185             my @ctxt = split m{ [\.] }msx, ($rec->{msgctxt} || NUL), 2;
186              
187             $ctxt[ 0 ] = $ctxt[ 0 ] ? $ctxt[ 0 ].SPC : 'messages ';
188             $ctxt[ 1 ] = $ctxt[ 1 ] ? SPC.$ctxt[ 1 ] : NUL;
189             $rec->{labels} = $ctxt[ 0 ].$rec->{msgid}.$ctxt[ 1 ];
190             $rec->{_order} = ${ $order_ref }++;
191             $data->{ $self->make_key( $rec ) } = $rec;
192             return;
193             };
194              
195             my $_read_filter = sub {
196             my ($self, $buf) = @_; $buf ||= [];
197              
198             my ($data, $order, $rec, $key, $last) = ({}, 0, {});
199              
200             for my $line (grep { defined } @{ $buf }) {
201             # Lines beginning with a hash are comments
202             if ('#' eq substr $line, 0, 1) {
203             my $field = $_comment_field->( substr $line, 0, 2 );
204              
205             $field and $_store_comment->( $rec, $line, $field );
206             }
207             # Field names all begin with the prefix msg
208             elsif ('msg' eq substr $line, 0, 3) {
209             $key = $_store_msgtext->( $rec, $line, \$last );
210             }
211             # Match any continuation lines
212             elsif ($line =~ m{ \A \s* [\"] (.+) [\"] \z }msx and defined $key) {
213             $_append_msgtext->( $rec, $key, $last, $1 );
214             }
215             # A blank line ends the record
216             elsif ($line =~ m{ \A \s* \z }msx) {
217             $self->$_store_record( $data, $rec, \$order );
218             $key = undef; $last = undef; $rec = {};
219             }
220             }
221              
222             $self->$_store_record( $data, $rec, \$order ); # If the last line isn't blank
223              
224             return $self->$_inflate_and_decode( $data );
225             };
226              
227             # Private write methods
228             my $_default_po_header = sub {
229             my $self = shift;
230             my $charset = $self->schema->charset;
231             my $defaults = $self->schema->default_po_header;
232             my $appname = $defaults->{appname };
233             my $company = $defaults->{company };
234             my $email = $defaults->{email };
235             my $lang = $defaults->{lang };
236             my $team = $defaults->{team };
237             my $translator = $defaults->{translator};
238             my $rev_date = $_time2str->( '%Y-%m-%d %H:%M%z' );
239             my $year = $_time2str->( '%Y' );
240              
241             return {
242             'translator_comment' => join "\n", ( '@(#)$Id'.'$',
243             'GNU Gettext Portable Object.',
244             "Copyright (C) ${year} ${company}.",
245             "${translator} ${email}, ${year}.",
246             '', ),
247             flags => [ 'fuzzy', ],
248             msgstr => {
249             'project_id_version' => "${appname} ${File::Gettext::VERSION}",
250             'po_revision_date' => $rev_date,
251             'last_translator' => "${translator} ${email}",
252             'language_team' => "${team} ${email}",
253             'language' => $lang,
254             'mime_version' => '1.0',
255             'content_type' => 'text/plain; charset='.$charset,
256             'content_transfer_encoding' => '8bit',
257             'plural_forms' => 'nplurals=2; plural=(n != 1);', }, };
258             };
259              
260             my $_get_comment_lines = sub {
261             my ($self, $attr_name, $values, $prefix) = @_; my $lines = [];
262              
263             $attr_name eq 'flags' and return [ $prefix.SPC.(join ', ', @{ $values }) ];
264              
265             $values =~ m{ [\n] \z }msx and $values .= SPC;
266              
267             for my $line (map { $prefix.$_ } split m{ [\n] }msx, $values) {
268             $line =~ s{ \# \s+ \z }{\#}msx; push @{ $lines }, $line;
269             }
270              
271             return $lines;
272             };
273              
274             my $_get_po_header_key = sub {
275             my ($self, $k) = @_; my $key_table = $self->schema->header_key_table;
276              
277             defined $key_table->{ $k } and return $key_table->{ $k };
278              
279             my $po_key = join q(-), map { ucfirst $_ } split m{ [_] }msx, $k;
280              
281             return [ 1 + keys %{ $key_table }, $po_key ];
282             };
283              
284             my $_split_on_nl = sub {
285             my ($self, $attr_name, $value) = @_;
286              
287             $value ||= NUL; my $last_char = substr $value, -1; chomp $value;
288              
289             my @lines = split m{ [\n] }msx, $value; my $lines = [];
290              
291             if (@lines < 2) { push @{ $lines }, "${attr_name} ".$_quote->( $value ) }
292             else {
293             push @{ $lines }, $attr_name.' ""';
294             push @{ $lines }, map { $_quote->( $_ ) } @lines;
295             }
296              
297             $last_char ne "\n" and $lines->[ -1 ] =~ s{ [\\][n][\"] \z }{\"}msx;
298             return $lines;
299             };
300              
301             my $_array_split_on_nl = sub {
302             my ($self, $attr, $values) = @_; my $index = 0; my $lines = [];
303              
304             for my $value (@{ $values }) {
305             push @{ $lines }, @{ $self->$_split_on_nl( "${attr}[${index}]", $value )};
306             $index++;
307             }
308              
309             return $lines;
310             };
311              
312             my $_header_deflate = sub {
313             my ($self, $po_header) = @_; my $msgstr_ref = $po_header->{msgstr} || {};
314              
315             my $header = { %{ $po_header || {} } }; my $msgstr;
316              
317             for my $k (sort { $self->$_get_po_header_key( $a )->[ 0 ]
318             <=> $self->$_get_po_header_key( $b )->[ 0 ] }
319             keys %{ $msgstr_ref }) {
320             $msgstr .= $self->$_get_po_header_key( $k )->[ 1 ];
321              
322             # if ($k eq q(po_revision_date)) {
323             # $msgstr .= ': '.$_time2str->( "%Y-%m-%d %H:%M%z" )."\n";
324             # }
325             # else { $msgstr .= ': '.($msgstr_ref->{ $k } || NUL)."\n" }
326             $msgstr .= ': '.($msgstr_ref->{ $k } || NUL)."\n";
327             }
328              
329             $header->{_order} = 0;
330             $header->{msgid } = NUL;
331             $header->{msgstr} = [ $msgstr ];
332             return $header;
333             };
334              
335             my $_get_lines = sub {
336             my ($self, $attr_name, $values) = @_; my ($cpref, $lines);
337              
338             if ($cpref = $_comment_prefix->( $attr_name )) {
339             $lines = $self->$_get_comment_lines( $attr_name, $values, $cpref );
340             }
341             elsif (ref $values eq 'ARRAY') {
342             if (@{ $values } > 1) {
343             $lines = $self->$_array_split_on_nl( $attr_name, $values );
344             }
345             else { $lines = $self->$_split_on_nl( $attr_name, $values->[ 0 ] ) }
346             }
347             else { $lines = $self->$_split_on_nl( $attr_name, $values ) }
348              
349             return $lines;
350             };
351              
352             my $_write_filter = sub {
353             my ($self, $data) = @_; my $buf ||= [];
354              
355             my $po = $data->{po } || {};
356             my $po_header = $data->{po_header} || $self->$_default_po_header;
357             my $charset = $self->$_get_charset( $po_header );
358             my $attrs = $self->schema->source->attributes;
359              
360             $po->{ NUL() } = $self->$_header_deflate( $po_header );
361              
362             for my $key (sort { $_original_order->( $po, $a, $b ) } keys %{ $po }) {
363             my $rec = $po->{ $key };
364              
365             $rec->{name} and not $rec->{msgid}
366             and $rec->{msgid} = delete $rec->{name};
367              
368             for my $attr_name (grep { exists $rec->{ $_ } } @{ $attrs }) {
369             my $values = $rec->{ $attr_name }; defined $values or next;
370              
371             ref $values eq 'ARRAY' and @{ $values } < 1 and next;
372             push @{ $buf }, map { encode( $charset, $_ ) }
373             @{ $self->$_get_lines( $attr_name, $values ) };
374             }
375              
376             push @{ $buf }, NUL;
377             }
378              
379             pop @{ $buf };
380             return $buf;
381             };
382              
383             # Public methods
384             sub read_from_file {
385 7     7 1 50260 my ($self, $rdr) = @_;
386              
387 7         31 return $self->$_read_filter( [ $rdr->chomp->getlines ] );
388             };
389              
390             sub write_to_file {
391 8     8 1 22434 my ($self, $wtr, $data) = @_;
392              
393 8         12 $wtr->println( @{ $self->$_write_filter( $data ) } );
  8         20  
394 8         9671 return $data;
395             }
396              
397             sub decompose_key {
398 3     3 1 19 my ($self, $key) = @_; my $sep = CONTEXT_SEP;
  3         7  
399              
400 3 50       15 0 >= index $key, $sep and return (NUL, $key);
401              
402 3         31 return split m{ $sep }msx, $key, 2;
403             }
404              
405             sub make_key {
406 76     76 1 361 my ($self, $rec) = @_;
407              
408             return (exists $rec->{msgctxt}
409 76 100       244 ? $rec->{msgctxt}.CONTEXT_SEP : NUL).$rec->{msgid};
410             }
411              
412             1;
413              
414             __END__