File Coverage

lib/File/Gettext/Storage/MO.pm
Criterion Covered Total %
statement 22 22 100.0
branch n/a
condition n/a
subroutine 8 8 100.0
pod 2 2 100.0
total 32 32 100.0


line stmt bran cond sub pod time code
1             package File::Gettext::Storage::MO;
2              
3 1     1   1932 use namespace::autoclean;
  1         3  
  1         14  
4              
5 1     1   213 use Encode qw( decode );
  1         4  
  1         178  
6 1     1   16 use File::DataClass::Constants qw( NUL );
  1         4  
  1         133  
7 1     1   8 use File::DataClass::Functions qw( extension_map throw );
  1         2  
  1         91  
8 1     1   10 use File::Gettext::Constants qw( MAGIC_N MAGIC_V PLURAL_SEP );
  1         3  
  1         139  
9 1     1   9 use Moo;
  1         3  
  1         13  
10              
11             extension_map '+File::Gettext::Storage::MO' => '.mo';
12              
13             extends q(File::DataClass::Storage);
14              
15             has '+extn' => default => '.mo';
16              
17             # Private subroutines
18             my $_decode = sub {
19             my ($charset, $text) = @_; defined $text or return;
20              
21             $text = decode( $charset, $text );
22             $text =~ s{ [\\][\'] }{\'}gmsx; $text =~ s{ [\\][\"] }{\"}gmsx;
23             return $text;
24             };
25              
26             # Private methods
27             my $_read_filter = sub {
28             my ($self, $rdr) = @_; my $path = $rdr->pathname; my $raw = $rdr->all;
29              
30             my $size = length $raw; $size < 28 and throw 'Path [_1] corrupted', [ $path];
31             my %meta = (); my $unpack = 'N';
32              
33             $meta{magic} = unpack $unpack, substr $raw, 0, 4;
34              
35             if ($meta{magic} == MAGIC_V) { $unpack = 'V' }
36             elsif ($meta{magic} != MAGIC_N) { throw 'Path [_1] bad magic', [ $path ] }
37              
38             @meta{ qw( revision num_strings msgids_off msgstrs_off hash_size hash_off ) }
39             = unpack( ($unpack x 6), substr $raw, 4, 24 );
40              
41             $meta{revision} == 0 or throw 'Path [_1 ] invalid version', [ $path ];
42              
43             my $nstrs = $meta{num_strings};
44              
45             $meta{msgids_off} + 4 * $nstrs > $size and
46             throw 'Path [_1] bad msgid offset', [ $path ];
47             $meta{msgstrs_off} + 4 * $nstrs > $size and
48             throw 'Path [_1] bad msgstr offset', [ $path ];
49              
50             my @orig_tab = unpack( ($unpack x (2 * $nstrs)),
51             substr $raw, $meta{msgids_off}, 8 * $nstrs );
52             my @trans_tab = unpack( ($unpack x (2 * $nstrs)),
53             substr $raw, $meta{msgstrs_off}, 8 * $nstrs );
54             my $sep = PLURAL_SEP;
55             my $messages = {};
56              
57             for (my $count = 0; $count < 2 * $nstrs; $count += 2) {
58             my $orig_length = $orig_tab[ $count ];
59             my $orig_offset = $orig_tab[ $count + 1 ];
60             my $trans_length = $trans_tab[ $count ];
61             my $trans_offset = $trans_tab[ $count + 1 ];
62              
63             $orig_offset + $orig_length > $size
64             and throw 'Path [_1] bad key length', [ $path ];
65             $trans_offset + $trans_length > $size
66             and throw 'Path [_1] bad text length', [ $path ];
67              
68             my @origs = split m{ $sep }mx, substr $raw, $orig_offset, $orig_length;
69             my @trans = split m{ $sep }mx, substr $raw, $trans_offset, $trans_length;
70             my $msgs = { msgstr => [ @trans ] };
71              
72             # The singular is the origs 0, the plural is origs 1
73             $messages->{ $origs[ 0 ] || NUL } = $msgs;
74             $origs[ 1 ] and $messages->{ $origs[ 1 ] } = $msgs;
75             }
76              
77             my $header = {}; my $null_entry;
78              
79             # Try to find po header information.
80             if ($null_entry = $messages->{ NUL() }->{msgstr}->[ 0 ]) {
81             for my $line (split m{ [\n] }msx, $null_entry) {
82             my ($k, $v) = split m{ [:] }msx, $line, 2;
83              
84             $k =~ s{ [-] }{_}gmsx; $v =~ s{ \A \s+ }{}msx;
85             $header->{ lc $k } = $v;
86             }
87             }
88              
89             if (exists $header->{content_type}) {
90             my $content_type = $header->{content_type};
91              
92             $content_type =~ s{ .* = }{}msx and $header->{charset} = $content_type;
93             }
94              
95             my $charset = exists $header->{charset}
96             ? $header->{charset} : $self->schema->charset;
97             my $tmp = $messages; $messages = {};
98              
99             for my $key (grep { $_ } keys %{ $tmp }) {
100             my $msg = $tmp->{ $key }; my $id = $_decode->( $charset, $key );
101              
102             $messages->{ $id } = { msgstr => [ map { $_decode->( $charset, $_ ) }
103             @{ $msg->{msgstr} || [] } ] };
104             defined $msg->{msgid_plural}
105             and $messages->{ $id }->{msgid_plural}
106             = $_decode->( $charset, $msg->{msgid_plural} );
107             }
108              
109             my $code = $header->{plural_forms} || NUL;
110             my $s = '[ \t\r\n\013\014]'; # Whitespace, locale-independent.
111              
112             # Untaint the plural header. Keep line breaks as is Perl 5_005 compatibility
113             if ($code =~ m{ \A ($s* nplurals $s* = $s* [0-9]+ $s* ; $s*
114             plural $s* = $s*
115             (?:$s|[-\?\|\&=!<>+*/\%:;a-zA-Z0-9_\(\)])+ ) }msx) {
116             $header->{plural_forms} = $1;
117             }
118             else { $header->{plural_forms} = NUL }
119              
120             return { meta => \%meta,
121             mo => $messages,
122             po_header => { msgid => NUL, msgstr => $header } };
123             };
124              
125             # Public methods
126             sub read_from_file {
127 1     1 1 12567 my ($self, $rdr) = @_; return $self->$_read_filter( $rdr );
  1         31  
128             }
129              
130             sub write_to_file {
131 1     1 1 3612 my ($self, $wtr, $data) = @_; return $data;
  1         19  
132             }
133              
134             1;
135              
136             __END__