File Coverage

blib/lib/Locale/MO/File.pm

Criterion	Covered	Total	%
statement	102	102	100.0
branch	35	42	83.3
condition	9	15	60.0
subroutine	17	17	100.0
pod	1	1	100.0
total	164	177	92.6

package Locale::MO::File; ## no critic (TidyCode)

use strict;
use warnings;
use charnames qw(:full);
use namespace::autoclean;
use Carp qw(confess);
use Const::Fast qw(const);
use Encode qw(find_encoding);
use English qw(-no_match_vars $INPUT_RECORD_SEPARATOR $OS_ERROR);
require IO::File;
use Moo;
use MooX::StrictConstructor;
use MooX::Types::MooseLike::Base qw(Bool Str ArrayRef FileHandle);
use Params::Validate qw(validate_with SCALAR ARRAYREF);

our $VERSION = '0.08';

const my $INTEGER_LENGTH     => length pack 'N', 0;
const my $REVISION_OFFSET    => $INTEGER_LENGTH;
const my $MAPS_OFFSET        => $INTEGER_LENGTH * 7;
const my $MAGIC_NUMBER       => 0x95_04_12_DE;
const our $CONTEXT_SEPARATOR => "\N{END OF TRANSMISSION}";
const our $PLURAL_SEPARATOR  => "\N{NULL}";

has filename => (
    is      => 'rw',
    isa     => Str,
    reader  => 'get_filename',
    writer  => 'set_filename',
    clearer => 'clear_filename',
);
has file_handle => (
    is      => 'rw',
    isa     => FileHandle,
    reader  => 'get_file_handle',
    writer  => 'set_file_handle',
    clearer => 'clear_file_handle',
);
has encoding => (
    is      => 'rw',
    isa     => Str,
    reader  => 'get_encoding',
    writer  => 'set_encoding',
    clearer => 'clear_encoding',
);
has newline => (
    is      => 'rw',
    isa     => Str,
    reader  => 'get_newline',
    writer  => 'set_newline',
    clearer => 'clear_newline',
);
has is_big_endian => (
    is      => 'rw',
    isa     => Bool,
    reader  => 'is_big_endian',
    writer  => 'set_is_big_endian',
    clearer => 'clear_is_big_endian',
);
has messages => (
    is      => 'rw',
    isa     => ArrayRef,
    default => sub { return [] },
    lazy    => 1,
    reader  => 'get_messages',
    writer  => 'set_messages',
);

sub _encode_and_replace_newline {
    my ($self, $string) = @_;

    if ( $self->get_encoding ) {
        my $encoder = find_encoding( $self->get_encoding )
            or confess 'Can not find encoding for ', $self->get_encoding;
        $string = $encoder->encode($string);
    }
    if ( $self->get_newline ) {
        $string =~ s{ \r? \n }{ $self->get_newline }xmsge;
    }

    return $string;
}

sub _decode_and_replace_newline {
    my ($self, $string) = @_;

    if ( $self->get_encoding ) {
        my $encoder = find_encoding( $self->get_encoding )
            or confess 'Can not find encoding for ', $self->get_encoding;
        $string = $encoder->decode($string, Encode::FB_CROAK);
    }
    if ( $self->get_newline ) {
        $string =~ s{ \r? \n }{ $self->get_newline }xmsge;
    }

    return $string;
}

sub _pack_message {
    my ($self, $message) = @_;

    my ($msgid, $msgstr) = map {
        ( exists $message->{$_} && defined $message->{$_} )
        ? $message->{$_}
        : q{};
    } qw(msgid msgstr);

    # original
    $msgid = $self->_encode_and_replace_newline(
        (
            (
                exists $message->{msgctxt}
                && defined $message->{msgctxt}
                && length $message->{msgctxt}
            )
            ? $message->{msgctxt} . $CONTEXT_SEPARATOR . $msgid
            : $msgid
        )
        . (
            (
                exists $message->{msgid_plural}
                && defined $message->{msgid_plural}
                && length $message->{msgid_plural}
            )
            ? $PLURAL_SEPARATOR . $message->{msgid_plural}
            : q{}
        ),
    );

    # translation
    $msgstr = $self->_encode_and_replace_newline(
        length $msgstr
        ? $msgstr
        : join
            $PLURAL_SEPARATOR,
            map {
                defined $_ ? $_ : q{}
            } @{ $message->{msgstr_plural} || [] }
    );

    return {
        msgid  => $msgid,
        msgstr => $msgstr,
    };
}

sub _unpack_message {
    my ($self, $message) = @_;

    my ($msgid, $msgstr) = map {
        ( defined && length )
        ? $self->_decode_and_replace_newline($_)
        : q{};
    } @{$message}{qw(msgid msgstr)};

    # return value
    my %message;

    # split original
    my @strings = split m{ \Q$CONTEXT_SEPARATOR\E }xms, $msgid;
    if ( @strings > 1 ) {
        ( $message{msgctxt}, $msgid ) = @strings;
    }
    my @plurals = split m{ \Q$PLURAL_SEPARATOR\E }xms, $msgid;
    my $is_plural = @plurals > 1;
    if ( $is_plural ) {
        @message{qw(msgid msgid_plural)} = @plurals;
    }
    else {
        $message{msgid} = $msgid;
    }

    # split translation
    @plurals = split
        m{ \Q$PLURAL_SEPARATOR\E }xms,
        $msgstr,
        # get back also all hanging empty stings
        1 + do { my @separators = $msgstr =~ m{ \Q$PLURAL_SEPARATOR\E }xmsg };
    if ( $is_plural ) {
        $message{msgstr_plural} = \@plurals;
    }
    else {
        $message{msgstr} = $plurals[0];
    }

    return \%message;
}

before 'write_file' => sub {
    my $self = shift;

    my $index = 0;
    my $chars_callback = sub {
        my $string = shift;
        STRING: for ( ref $string ? @{$string} : $string ) {
            defined
                or next STRING;
            m{ \Q$CONTEXT_SEPARATOR\E | \Q$PLURAL_SEPARATOR\E }xmso
                and return;
        }
        return 1;
    };
    for my $message ( @{ $self->get_messages } ) {
        validate_with(
            params => (
                ref $message eq 'HASH'
                ? $message
                : confess "messages[$index] is not a hash reference"
            ),
            spec => {
                msgctxt => {
                    type      => SCALAR,
                    optional  => 1,
                    callbacks => {
                        'no control chars' => $chars_callback,
                    },
                },
                msgid => {
                    type      => SCALAR,
                    optional  => 1,
                    callbacks => {
                        'no control chars' => $chars_callback,
                    },
                },
                msgid_plural => {
                    type      => SCALAR,
                    optional  => 1,
                    callbacks => {
                        'no control chars' => $chars_callback,
                    },
                },
                msgstr => {
                    type      => SCALAR,
                    optional  => 1,
                    callbacks => {
                        'no control chars' => $chars_callback,
                    },
                },
                msgstr_plural => {
                    type      => ARRAYREF,
                    optional  => 1,
                    callbacks => {
                        'msgstr not set' => sub {
                            return ! (
                                exists $message->{msgstr_plural}
                                && exists $message->{msgstr}
                            );
                        },
                        'no control chars' => $chars_callback,
                    },
                },
            },
            called => "messages[$index]",
        );
        ++$index;
    }

    return $self;
};

sub write_file {
    my $self = shift;

    my $messages = [
        sort {
            $a->{msgid} cmp $b->{msgid};
        }
        map {
            $self->_pack_message($_);
        } @{ $self->get_messages }
    ];

    my $number_of_strings = @{$messages};

    # Set the byte order of the MO file creator
    my $template = $self->is_big_endian ? q{N} : q{V};

    my $maps    = q{};
    my $strings = q{};
    my $current_offset
        = $MAPS_OFFSET
        # length of map
        + $INTEGER_LENGTH * 4 * $number_of_strings; ## no critic (MagicNumbers)
    for my $key (qw(msgid msgstr)) {
        for my $message ( @{$messages} ) {
            my $string = $message->{$key};
            my $length = length $string;
            my $map = pack $template x 2, $length, $current_offset;
            $maps    .= $map;
            $string  .= $PLURAL_SEPARATOR;
            $strings .= $string;
            $current_offset += length $string;
        }
    }

    my $offset_original
        = $MAPS_OFFSET;
    my $offset_translated
        = $MAPS_OFFSET
        + $INTEGER_LENGTH * 2 * $number_of_strings;
    my $content
        = (
            pack $template x 7, ## no critic (MagicNumbers)
            $MAGIC_NUMBER,
            0, # revision
            $number_of_strings,
            $offset_original,
            $offset_translated,
            0, # hash size
            0, # hash offset
        )
        . $maps
        . $strings;

    my $filename = $self->get_filename;
    defined $filename
        or confess 'Filename not set';
    my $file_handle
        = $self->get_file_handle
        || IO::File->new($filename, '> :raw')
        || confess "Can not open mo file $filename $OS_ERROR";
    $file_handle->print($content)
        or confess "Can not write mo file $filename $OS_ERROR";
    if ( ! $self->get_file_handle ) {
        $file_handle->close
            or confess "Can not close mo file $filename $OS_ERROR";
    }

    return $self;
}

sub read_file {
    my $self = shift;

    my $filename = $self->get_filename;
    defined $filename
        or confess 'filename not set';
    my $file_handle
        = $self->get_file_handle
        || IO::File->new($filename, '< :raw')
        || confess "Can not open mo file $filename $OS_ERROR";
    my $content = do {
        local $INPUT_RECORD_SEPARATOR = ();
        <$file_handle>;
    };
    if ( ! $self->get_file_handle ) {
        $file_handle->close;
    }

    # Find the byte order of the MO file creator
    my $magic_number = substr $content, 0, $INTEGER_LENGTH;
    my $template =
        ( $magic_number eq pack 'V', $MAGIC_NUMBER )
        # Little endian
        ? q{V}
        : ( $magic_number eq pack 'N', $MAGIC_NUMBER )
        # Big endian
        ? q{N}
        # Wrong magic number. Not a valid MO file.
        : confess "MO file expected: $filename";

    my ($revision, $number_of_strings, $offset_original, $offset_translated)
        = unpack
            $template x 4, ## no critic (MagicNumbers)
            substr
                $content,
                $REVISION_OFFSET,
                $INTEGER_LENGTH * 4; ## no critic (MagicNumbers)
    $revision > 0
        and confess "Revision > 0 is unknown: $revision";

    $self->set_messages(\my @messages);
    for my $index (0 .. $number_of_strings - 1) {
        my $key = 'msgid';
        my $message;
        for my $offset ($offset_original, $offset_translated) {
            my ($string_length, $string_offset)
                = unpack
                    $template x 2,
                    substr
                        $content,
                        $offset + $index * $INTEGER_LENGTH * 2,
                        $INTEGER_LENGTH * 2;
            $message->{$key}
                = substr $content, $string_offset, $string_length;
            $key = 'msgstr';
        }
        $messages[$index] = $self->_unpack_message($message);
    }

    return $self;
}

__PACKAGE__->meta->make_immutable;

1;

__END__