view release on metacpan or  search on metacpan

lib/DBD/PO/Text/PO.pm  view on Meta::CPAN

package DBD::PO::Text::PO;

use strict;
use warnings;

our $VERSION = '2.08';

use Carp qw(croak);
use English qw(-no_match_vars $OS_ERROR);
use Params::Validate qw(:all);
use DBD::PO::Locale::PO qw(@FORMAT_FLAGS $ALLOW_LOST_BLANK_LINES);
use Socket qw($CRLF);
use Set::Scalar;

use parent qw(Exporter);
our @EXPORT_OK = qw(
    $EOL_DEFAULT
    $SEPARATOR_DEFAULT
    $CHARSET_DEFAULT
    @COL_NAMES
);

our $EOL_DEFAULT       = $CRLF;
our $SEPARATOR_DEFAULT = "\n";
our $CHARSET_DEFAULT   = 'iso-8859-1';

our @COL_NAMES;
my  @COL_PARAMETERS;
my  @COL_METHODS;
our $LOST_BLANK_LINES;

sub init {
    my (undef, @config) = @_;

    my $config = Set::Scalar->new(@config);
    my $allowed = Set::Scalar->new(
        qw( :all :plural :previous :format allow_lost_blank_lines ),
        @FORMAT_FLAGS,
    );
    my $not_allowed = $config - $allowed;
    if ( ! $not_allowed->is_empty() ) {
        croak 'Unkonwn config parameter: ', join ', ', $not_allowed->elements();
    }
    if ( $config->has(':all') ) {
        $config->delete(':all');
        $config->insert(qw(:plural :previous :format allow_lost_blank_lines));
    }
    my $has_plural = $config->has(':plural');
    $config->delete(':plural');
    my $has_previous = $config->has(':previous');
    $config->delete(':previous');
    if ( $config->has(':format') ) {
        $config->delete(':format');
        $config->insert(@FORMAT_FLAGS);
    }
    $ALLOW_LOST_BLANK_LINES = $config->has('allow_lost_blank_lines');
    $config->delete('allow_lost_blank_lines');

    my @cols = (
        # typical
        [ qw( msgid     -msgid     msgid     ) ], # original text
        [ qw( msgstr    -msgstr    msgstr    ) ], # translation
        [ qw( comment   -comment   comment   ) ], # translater comment
        [ qw( automatic -automatic automatic ) ], # automatic comment
        [ qw( reference -reference reference ) ],
        [ qw( msgctxt   -msgctxt   msgctxt   ) ], # context
        # flags
        [ qw( fuzzy     -fuzzy     fuzzy     ) ],
        # switch to ignore
        [ qw( obsolete  -obsolete  obsolete  ) ],
        # plural only
        (
            $has_plural
            ? (
                [ qw( msgid_plural -msgid_plural msgid_plural ) ],
                                   # dummy       # dummy
                [ qw( msgstr_0     -msgstr_0     msgstr_0     ) ], # singular or zero
                [ qw( msgstr_1     -msgstr_1     msgstr_1     ) ], # plural   or singular
                [ qw( msgstr_2     -msgstr_2     msgstr_2     ) ], # plural
                [ qw( msgstr_3     -msgstr_3     msgstr_3     ) ], # plural
                [ qw( msgstr_4     -msgstr_4     msgstr_4     ) ], # plural
                [ qw( msgstr_5     -msgstr_5     msgstr_5     ) ], # plural
            )
            : ()
        ),
        # prevoius
        (
            $has_previous
            ? (
                [ qw( previous_msgctxt      -previous_msgctxt      previous_msgctxt      ) ],
                [ qw( previous_msgid        -previous_msgid        previous_msgid        ) ],
                [ qw( previous_msgid_plural -previous_msgid_plural previous_msgid_plural ) ],
            )
            : ()
        ),
        # format-flags
        (
            map { ## no critic (ComplexMappings)
                (my $col_name = $_) =~ tr{-}{_};
                                     # dummy
                ([ $col_name, "-$_", $_ ]);
            } $config->elements()
        ),
    );

    @COL_NAMES       = map {$_->[0]} @cols; # for SQL
    @COL_PARAMETERS  = map {$_->[1]} @cols; # for DBD::PO::Locale::PO->new(...)
    @COL_METHODS     = map {$_->[2]} @cols; # it is the method for the $po object

    return;
}
init();

my $dequote = sub {
    my $string = shift;

    return if $string eq 'NULL';
    if ($string =~ s{\A _Q_U_O_T_E_D_:}{}xms) {
        $string =~ s{\\\\}{\\}xmsg;
    }

    return $string;
};

my $array_from_anything = sub {
    my ($self, $anything) = @_;

    my @array = map { ## no critic (ComplexMappings)
        my $dequoted = $dequote->($_);
        split m{\Q$self->{separator}\E}xms, $dequoted;
    } ref $anything eq 'ARRAY'
      ? @{$anything}
      : defined $anything
        ? $anything
        : ();

    return \@array;
};

sub new { ## no critic (RequireArgUnpacking)
    my ($class, $options) = validate_pos(
        @_,
        {type => SCALAR},
        {type => HASHREF},
    );
    $options = validate_with(
        params => $options,
        spec   => {
            eol       => {type => SCALAR, default => $EOL_DEFAULT},
            separator => {type => SCALAR, default => $SEPARATOR_DEFAULT},
            charset   => {type => SCALAR | UNDEF, optional => 1},
        },
        called => "2nd parameter of new('$class', \$hash_ref)",
    );

    if ($options->{charset}) {
        $options->{encoding} = ":encoding($options->{charset})";
    }

    return bless $options, $class;
}

sub write_entry { ## no critic (ExcessComplexity)
    my ($self, $file_name, $file_handle, $col_ref) = @_;

    my %line;
    for my $index (0 .. $#COL_NAMES) {
        my $parameter = $COL_PARAMETERS[$index];
        my $values    = $array_from_anything->($self, $col_ref->[$index]);
        if ( ## no critic (CascadingIfElse)
            $parameter eq '-comment'
            || $parameter eq '-automatic'
            || $parameter eq '-reference'
        ) {
            if (@{$values}) {
                $line{$parameter} = join $self->{eol}, @{$values};
            }
        }
        elsif (
            $parameter eq '-obsolete'
            || $parameter eq '-fuzzy'
        ) {
            $line{$parameter} = $values->[0] ? 1 : 0;
        }
        elsif (
            my ($prefix) = $parameter =~ m{\A - ( [a-z-]+ ) -format \z}xms
        ) {
            my $flag = $values->[0];
            # translate:
            # perl_false => nothing set
            # -something => -no-flag = 1
            # something  => -flag = 1
            if ($flag) {
                $line{
                    (
                        $flag =~ m{\A -}xms
                        ? '-no'
                        : q{}
                    )
                    . "-$prefix-format"
                } = 1;
            }
        }
        elsif ( $parameter =~ m{\A -msgstr_ ( \d ) \z}xms ) {
            if ( @{$values} ) {
                $line{'-msgstr_n'}->{$1} = join "\n", @{$values};
            }
        }
        else {
            if ( @{$values} ) {
                $line{$parameter} = join "\n", @{$values};
                if (! tell $file_handle) {
                    if ($parameter eq '-msgid') {
                        croak 'A header has no msgid';
                    }
                    else { # -msgstr
                        if ($line{$parameter} !~ m{\b charset =}xms) { ## no critic (DeepNests)
                            croak 'This can not be a header';
                        }
                    }
                }
            }
            else {
                if ($parameter eq '-msgid' && tell $file_handle) {
                    croak 'A line has to have a msgid';
                }
                elsif ($parameter eq '-msgstr' && ! tell $file_handle) {
                    croak 'A header has to have a msgstr';
                }
            }
        }
        ++$index;
    }
    my $line = DBD::PO::Locale::PO->new(
        eol      => $self->{eol},
        '-msgid' => q{},
        (
            exists $line{'-msgid_plural'}
            ? ('-msgstr_n' => { 0 => q{} })
            : ('-msgstr'   => q{})
        ),
        %line,
    )->dump();
    print {$file_handle} $line
        or croak "Print $file_name: $OS_ERROR";

    return $self;
}

sub read_entry {
    my ($self, $file_name, $file_handle) = @_;

    if (! defined $self->{line_number}) {
        $self->{line_number} = 0;
    }
    my $po = DBD::PO::Locale::PO->load_entry(
        $file_name,
        $file_handle,
        \$self->{line_number},
        $self->{eol},
    );
    # EOF
    if (! $po) {
        delete $self->{line_number};
        return [];
    }
    # run a line, it is a po object
    my @cols;
    my $index = 0;
    METHOD:
    for my $method (@COL_METHODS) {
        if ( ## no critic (CascadingIfElse)
            $method eq 'comment'
            || $method eq 'automatic'
            || $method eq 'reference'
        ) {
            my $comment = $po->$method();
            $cols[$index]
                = defined $comment
                  ? (
                      join  $self->{separator},
                      split m{\Q$self->{eol}\E}xms,
                      $comment
                  )
                  : q{};
        }
        elsif (
            $method eq 'obsolete'
            || $method eq 'fuzzy'
        ) {
            $cols[$index] = $po->$method() ? 1 : 0;
        }
        elsif ( $method =~ m{\A [a-z-]+ -format \z}xms) {
            my $flag = $po->format_flag($method);
            # translate:
            # undef => 0
            # 0     => -1
            # 1     => 1