package File::Gettext::Storage::MO;
use namespace::autoclean;
use Encode qw( decode );
use File::DataClass::Constants qw( NUL );
use File::DataClass::Functions qw( extension_map throw );
use File::Gettext::Constants qw( MAGIC_N MAGIC_V PLURAL_SEP );
use Moo;
extension_map '+File::Gettext::Storage::MO' => '.mo';
extends q(File::DataClass::Storage);
has '+extn' => default => '.mo';
# Private subroutines
my $_decode = sub {
my ($charset, $text) = @_; defined $text or return;
$text = decode( $charset, $text );
$text =~ s{ [\\][\'] }{\'}gmsx; $text =~ s{ [\\][\"] }{\"}gmsx;
return $text;
};
# Private methods
my $_read_filter = sub {
my ($self, $rdr) = @_; my $path = $rdr->pathname; my $raw = $rdr->all;
my $size = length $raw; $size < 28 and throw 'Path [_1] corrupted', [ $path];
my %meta = (); my $unpack = 'N';
$meta{magic} = unpack $unpack, substr $raw, 0, 4;
if ($meta{magic} == MAGIC_V) { $unpack = 'V' }
elsif ($meta{magic} != MAGIC_N) { throw 'Path [_1] bad magic', [ $path ] }
@meta{ qw( revision num_strings msgids_off msgstrs_off hash_size hash_off ) }
= unpack( ($unpack x 6), substr $raw, 4, 24 );
$meta{revision} == 0 or throw 'Path [_1 ] invalid version', [ $path ];
my $nstrs = $meta{num_strings};
$meta{msgids_off} + 4 * $nstrs > $size and
throw 'Path [_1] bad msgid offset', [ $path ];
$meta{msgstrs_off} + 4 * $nstrs > $size and
throw 'Path [_1] bad msgstr offset', [ $path ];
my @orig_tab = unpack( ($unpack x (2 * $nstrs)),
substr $raw, $meta{msgids_off}, 8 * $nstrs );
my @trans_tab = unpack( ($unpack x (2 * $nstrs)),
substr $raw, $meta{msgstrs_off}, 8 * $nstrs );
my $sep = PLURAL_SEP;
my $messages = {};
for (my $count = 0; $count < 2 * $nstrs; $count += 2) {
my $orig_length = $orig_tab[ $count ];
my $orig_offset = $orig_tab[ $count + 1 ];
my $trans_length = $trans_tab[ $count ];
my $trans_offset = $trans_tab[ $count + 1 ];
$orig_offset + $orig_length > $size
and throw 'Path [_1] bad key length', [ $path ];
$trans_offset + $trans_length > $size
and throw 'Path [_1] bad text length', [ $path ];
my @origs = split m{ $sep }mx, substr $raw, $orig_offset, $orig_length;
my @trans = split m{ $sep }mx, substr $raw, $trans_offset, $trans_length;
my $msgs = { msgstr => [ @trans ] };
# The singular is the origs 0, the plural is origs 1
$messages->{ $origs[ 0 ] || NUL } = $msgs;
$origs[ 1 ] and $messages->{ $origs[ 1 ] } = $msgs;
}
my $header = {}; my $null_entry;
# Try to find po header information.
if ($null_entry = $messages->{ NUL() }->{msgstr}->[ 0 ]) {
for my $line (split m{ [\n] }msx, $null_entry) {
my ($k, $v) = split m{ [:] }msx, $line, 2;
$k =~ s{ [-] }{_}gmsx; $v =~ s{ \A \s+ }{}msx;
$header->{ lc $k } = $v;
}
}
if (exists $header->{content_type}) {
my $content_type = $header->{content_type};
$content_type =~ s{ .* = }{}msx and $header->{charset} = $content_type;
}
my $charset = exists $header->{charset}
? $header->{charset} : $self->schema->charset;
my $tmp = $messages; $messages = {};
for my $key (grep { $_ } keys %{ $tmp }) {
my $msg = $tmp->{ $key }; my $id = $_decode->( $charset, $key );
$messages->{ $id } = { msgstr => [ map { $_decode->( $charset, $_ ) }
@{ $msg->{msgstr} || [] } ] };
defined $msg->{msgid_plural}
and $messages->{ $id }->{msgid_plural}
= $_decode->( $charset, $msg->{msgid_plural} );
}
my $code = $header->{plural_forms} || NUL;
my $s = '[ \t\r\n\013\014]'; # Whitespace, locale-independent.
# Untaint the plural header. Keep line breaks as is Perl 5_005 compatibility
if ($code =~ m{ \A ($s* nplurals $s* = $s* [0-9]+ $s* ; $s*
plural $s* = $s*
(?:$s|[-\?\|\&=!<>+*/\%:;a-zA-Z0-9_\(\)])+ ) }msx) {
$header->{plural_forms} = $1;
}
else { $header->{plural_forms} = NUL }
return { meta => \%meta,
mo => $messages,
po_header => { msgid => NUL, msgstr => $header } };
};
# Public methods
sub read_from_file {
my ($self, $rdr) = @_; return $self->$_read_filter( $rdr );
}
sub write_to_file {
my ($self, $wtr, $data) = @_; return $data;
}
1;
__END__
=pod
=encoding utf-8
=head1 Name
File::Gettext::Storage::MO - Storage class for GNU gettext machine object format
=head1 Synopsis
=head1 Description
Storage class for GNU gettext machine object format
=head1 Configuration and Environment
Defines these attributes;
=over 3
=item C<extn>
=back
=head1 Subroutines/Methods
=head2 read_from_file
=head2 write_to_file
=head1 Diagnostics
None
=head1 Dependencies
=over 3
=item L<File::DataClass>
=item L<Moo>
=back
=head1 Incompatibilities
There are no known incompatibilities in this module
=head1 Bugs and Limitations
There are no known bugs in this module.
Please report problems to the address below.
Patches are welcome
=head1 Acknowledgements
Larry Wall - For the Perl programming language
=head1 Author
Peter Flanigan, C<< <pjfl@cpan.org> >>
=head1 License and Copyright
Copyright (c) 2016 Peter Flanigan. All rights reserved
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>
This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
=cut
# Local Variables:
# mode: perl
# tab-width: 3
# End: