DBD::PO::Locale::PO - Perl module for manipulating .po entries from GNU gettext

    require DBD::PO::Locale::PO;

    $po = DBD::PO::Locale::PO->new([eol => $eol, ['-option' => 'value', ...]])
    [$string =] $po->comment(['new string']);
    [$string =] $po->automatic(['new string']);
    [$string =] $po->reference(['new string']);
    [$string =] $po->msgctxt(['new string']);
    [$string =] $po->previous_msgctxt(['new string']);
    [$string =] $po->msgid(['new string']);
    [$string =] $po->previous_msgid(['new string']);
    [$string =] $po->msgid_plural(['new string']);
    [$string =] $po->previous_msgid_plural(['new string']);
    [$string =] $po->msgstr(['new string']);
    [$string =] $po->msgstr_n([{0 => 'new string', 1 => ...}]);
    [$boolean =] $po->obsolete([$boolean]);
    [$value =] $po->fuzzy([value]);
    [$value =] $po->add_flag('c-format');
    [$value =] $po->add_flag('...-format');
    print $po->dump();

    $quoted_string = $po->quote($string);
    $string = $po->dequote($quoted_string);
    $string = DBD::PO::Locale::PO->dequote($quoted_string, $eol);

    $aref = DBD::PO::Locale::PO->load_file_asarray(<filename>);
    $href = DBD::PO::Locale::PO->load_file_ashash(<filename>);
    DBD::PO::Locale::PO->save_file_fromarray(<filename>, $aref);
    DBD::PO::Locale::PO->save_file_fromhash(<filename>, $href);

package DBD::PO::Locale::PO;

use strict;
use warnings;

use version; our $VERSION = qv('0.21.5');

use Carp qw(croak);
use English qw(-no_match_vars $EVAL_ERROR $OS_ERROR);

use parent qw(Exporter);
our @EXPORT_OK = qw(
    @FORMAT_FLAGS
    $ALLOW_LOST_BLANK_LINES
);

our @FORMAT_FLAGS = qw(
    c-format
    objc-format
    sh-format
    python-format
    lisp-format
    elisp-format
    librep-format
    scheme-format
    smalltalk-format
    java-format
    csharp-format
    awk-format
    object-pascal-format
    ycp-format
    tcl-format
    perl-format
    perl-brace-format
    php-format
    gcc-internal-format
    qt-format
    kde-format
    boost-format
);

our $ALLOW_LOST_BLANK_LINES = 1;

sub new {
    my ($this, %options) = @_;

    my $class = ref $this || $this;
    my $self = bless {}, $class;
    $self->eol( $options{eol} );
    $self->_flags({});
    for (qw(
        msgctxt          msgid          msgid_plural
        previous_msgctxt previous_msgid previous_msgid_plural
        msgstr msgstr_n
        comment automatic reference fuzzy obsolete
        loaded_line_number
    )) {
        if ( defined $options{"-$_"} ) {
            $self->$_( $options{"-$_"} );
        }
    }
    for my $format (@FORMAT_FLAGS) {
        if ( defined $options{"-$format"} ) {
            $self->format_flag($format => 1);
        }
        if ( defined $options{"-no-$format"} ) {
            $self->format_flag($format => 0);
        }
    }

    return $self;
}

sub eol {
    my ($self, @params) = @_;

    if (@params) {
        my $eol = shift @params;
        $self->{eol} = $eol;
    }

    return defined $self->{eol}
           ? $self->{eol}
           : "\n";
}

# create methods
for (qw(
    msgctxt          msgid          msgid_plural
    previous_msgctxt previous_msgid previous_msgid_plural
    msgstr
    comment automatic reference obsolete
    _flags loaded_line_number
)) {
    my $name = $_;
    no strict 'refs'; ## no critic (NoStrict)
    *{$name} = sub {
    my ($self, @params) = @_;

    return @params
           ? $self->{$name} = shift @params
           : $self->{$name};
    };
}

sub msgstr_n {
    my ($self, @params) = @_;

    if (@params) {
        my $hashref = shift @params;

        # check that we have a hashref.
        ref $hashref eq 'HASH'
            or croak 'Argument to msgstr_n must be a hashref: { n => "string n", ... }.';

        # Check that the keys are all numbers.
        for ( keys %{$hashref} ) {
            croak 'Keys to msgstr_n hashref must be numbers'
                if ! defined $_ || m{\D}xms;
        }

        # Write all the values in the hashref.
        @{ $self->{msgstr_n} }{ keys %{$hashref} } = values %{$hashref};
    }

    return $self->{msgstr_n};
}

sub add_flag {
    my ($self, $flag_name) = @_;

    $self->_flags()->{$flag_name} = 1;

    return $self;
}

sub remove_flag {
    my ($self, $flag_name) = @_;

    delete $self->_flags()->{$flag_name};

    return $self;
}

sub has_flag {
    my ($self, $flag_name) = @_;

    my $flags = $self->_flags();
    exists $flags->{$flag_name}
        or return;

    return $flags->{$flag_name};
}

sub fuzzy {
    my ($self, @params) = @_;

    if (@params) {
        my $value = shift @params;
        return
            $value
            ? $self->add_flag('fuzzy')
            : $self->remove_flag('fuzzy');
    }

    return $self->has_flag('fuzzy');
}

sub format_flag {
    my ($self, $flag_name, @params) = @_;

    if (@params) { # set or clear the flags
        my $value = shift @params;
        if (! defined($value) || ! length $value) {
            $self->remove_flag($flag_name);
            $self->remove_flag("no-$flag_name");
            return;
        }
        elsif ($value) {
            $self->add_flag($flag_name);
            $self->remove_flag("no-$flag_name");
            return 1;
        }
        else {
            $self->add_flag("no-$flag_name");
            $self->remove_flag($flag_name);
            return 0;
        }
    }
    # check the flags
    return 1 if $self->has_flag($flag_name);
    return 0 if $self->has_flag("no-$flag_name");

    return;
}

sub dump { ## no critic (BuiltinHomonyms)
    my $self = shift;

    my $obsolete = $self->obsolete() ? '#~ ' : q{};
    my $dump = q{};
    if ( defined $self->comment() ) {
        $dump .= $self->_dump_multi_comment( $self->comment(), '# ' );
    }
    if ( defined $self->automatic() ) {
        $dump .= $self->_dump_multi_comment( $self->automatic(), '#. ' );
    }
    if ( defined $self->reference() ) {
        $dump .= $self->_dump_multi_comment( $self->reference(), '#: ' );
    }
    my $flags = join q{}, map {", $_"} sort keys %{ $self->_flags() };
    if ($flags) {
        $dump .= "#$flags"
                 . $self->eol();
    }
    if ( defined $self->previous_msgctxt() ) {
        $dump .= '#| msgctxt '
                 . $self->quote( $self->previous_msgctxt() );
    }
    if ( defined $self->previous_msgid() ) {
        $dump .= '#| msgid '
                 . $self->quote( $self->previous_msgid() );
    }
    if ( defined $self->previous_msgid_plural() ) {
        $dump .= '#| msgid_plural '
                 . $self->quote( $self->previous_msgid_plural() );
    }
    if ( defined $self->msgctxt() ) {
        $dump .= "${obsolete}msgctxt "
                 . $self->quote( $self->msgctxt() );
    }
    $dump .= "${obsolete}msgid "
             . $self->quote( $self->msgid() );
    if ( defined $self->msgid_plural() ) {
        $dump .= "${obsolete}msgid_plural "
                 . $self->quote( $self->msgid_plural() );
    }
    if ( defined $self->msgstr() ) {
        $dump .= "${obsolete}msgstr "
                 . $self->quote( $self->msgstr() );
    }
    if ( my $msgstr_n = $self->msgstr_n() ) {
        $dump .= join
            q{},
            map {
                "${obsolete}msgstr[$_] "
                . $self->quote( $msgstr_n->{$_} );
            } sort {
                $a <=> $b
            } keys %{$msgstr_n};
    }

    $dump .= $self->eol();

    return $dump;
}

sub _dump_multi_comment {
    my $self    = shift;
    my $comment = shift;
    my $leader  = shift;

    my $eol = $self->eol();

    return join q{}, map {
        "$leader$_$eol";
    } split m{\Q$eol\E}xms, $comment;
}

# Quote a string properly
sub quote {
    my $self   = shift;
    my $string = shift;

    if (! defined $string) {
        return q{""};
    }
    my %named = (
        ## no critic (InterpolationOfLiterals)
        #qq{\a} => qq{\\a}, # BEL
        #qq{\b} => qq{\\b}, # BS
        #qq{\t} => qq{\\t}, # TAB
        qq{\n}  => qq{\\n}, # LF
        #qq{\f} => qq{\\f}, # FF
        #qq{\r} => qq{\\r}, # CR
        qq{"}   => qq{\\"},
        qq{\\}  => qq{\\\\},
        ## use critic (InterpolationOfLiterals)
    );
    $string =~ s{
                ( [^ !#$%&'()*+,\-.\/0-9:;<=>?@A-Z\[\]\^_`a-z{|}~] )
        }{
                ord $1 < 0x80
                ? (
                        exists $named{$1}
                        ? $named{$1}
                        : sprintf '\x%02x', ord $1
                )
                : $1;
        }xmsge;
    $string = qq{"$string"};
    # multiline
    my $eol = $self->eol();
    if ($string =~ s{\A ( " .*? \\n )}{""$eol$1}xms) {
        $string =~ s{\\n}{\\n"$eol"}xmsg;
    }

    return "$string$eol";
}

sub dequote {
    my $self   = shift;
    my $string = shift;
    my $eol    = shift || $self->eol();

    if (! defined $string) {
        $string = q{};
    }
    # multiline
    if ($string =~ s{\A "" \Q$eol\E}{}xms) {
        $string =~ s{\\n"\Q$eol\E"}{\\n}xmsg;
    }
    $string =~ s{( [\$\@] )}{\\$1}xmsg; # make uncritical
    ($string) = $string =~ m{
                \A
                (
                        "
                        (?: \\\\ | \\" | [^"] )*
                        "
                        # eol
                )
        }xms; # check the quoted string and untaint
    return q{} if ! defined $string;
    my $dequoted = eval $string; ## no critic (StringyEval)
    croak qq{Can not eval string "$string": $EVAL_ERROR} if $EVAL_ERROR;

    return $dequoted;
}

sub save_file_fromarray {
    my ($self, @params) = @_;

    return $self->_save_file(@params, 0);
}

sub save_file_fromhash {
    my ($self, @params) = @_;

    return $self->_save_file(@params, 1);
}

sub _save_file {
    my $self     = shift;
    my $file     = shift;
    my $entries  = shift;
    my $as_hash  = shift;

    open my $out, '>', $file ## no critic (BriefOpen)
        or croak "Open $file: $OS_ERROR";
    if ($as_hash) {
        for (sort keys %{$entries}) {
            print {$out} $entries->{$_}->dump()
                or croak "Print $file: $OS_ERROR";
        }
    }
    else {
        for (@{$entries}) {
            print {$out} $_->dump()
                or croak "Print $file: $OS_ERROR";
        }
    }
    close $out
        or croak "Close $file $OS_ERROR";

    return $self;
}

sub load_file_asarray {
    my $self = shift;
    my $file = shift;
    my $eol  = shift || "\n";

    if (ref $file) {
        return $self->_load_file($file, $file, $eol, 0);
    }
    open my $in, '<', $file
        or croak "Open $file: $OS_ERROR";
    my $array_ref = $self->_load_file($file, $in, $eol, 0);
    close $in
        or croak "Close $file: $OS_ERROR";

    return $array_ref;
}

sub load_file_ashash {
    my $self = shift;
    my $file = shift;
    my $eol  = shift || "\n";

    if (ref $file) {
        return $self->_load_file($file, $file, $eol, 1);
    }
    open my $in, '<', $file
        or croak "Open $file: $OS_ERROR";
    my $hash_ref = $self->_load_file($file, $in, $eol, 1);
    close $in
        or croak "Close $file: $OS_ERROR";

    return $hash_ref;
}

sub _load_file {
    my $self        = shift;
    my $file_name   = shift;
    my $file_handle = shift;
    my $eol         = shift;
    my $ashash      = shift;

    my $line_number = 0;
    my (@entries, %entries);
    while (
        my $po = $self->load_entry(
            $file_name,
            $file_handle,
            \$line_number,
            $eol,
        )
    ) {
        # ashash
        if ($ashash) {
            if ( $po->_hash_key_ok(\%entries) ) {
                $entries{ $po->msgid() } = $po;
            }
        }
        # asarray
        else {
            push @entries, $po;
        }
    }

    return $ashash
           ? \%entries
           : \@entries;
}

sub load_entry { ## no critic (ExcessComplexity)
    my $self            = shift;
    my $file_name       = shift;
    my $file_handle     = shift;
    my $line_number_ref = shift;
    my $eol             = shift || "\n";

    my $class = ref $self || $self;
    my %last_line_of_section; # to find the end of an entry
    my $current_section_key;  # to add lines

    my ($current_line_number, $current_pos);
    my $safe_current_position = sub {
        # safe information to can roll back
        $current_line_number = ${$line_number_ref};
        $ALLOW_LOST_BLANK_LINES
            or return;
        $current_pos         = tell $file_handle;
        defined $current_pos
            or croak "Can not tell file pointer of file $file_name: $OS_ERROR";
    };
    $safe_current_position->();

    my $is_new_entry = sub {
        $current_section_key = shift;
        if (
            $ALLOW_LOST_BLANK_LINES
            && exists $last_line_of_section{ $current_section_key }
            && $last_line_of_section{ $current_section_key }
               != ${$line_number_ref} - 1
        ) {
            # roll back
            ${$line_number_ref} = $current_line_number;
            seek $file_handle, $current_pos, 0
                or croak "Can not seek file pointer of file $file_name: $OS_ERROR";
            return 1; # this is a new entry
        }
        $last_line_of_section{ $current_section_key } = ${$line_number_ref};
        return;
    };

    my $po;             # build an object during read an entry
    my %buffer;         # find the different msg...
    my $current_buffer; # to add lines
    LINE:
    while (my $line = <$file_handle>) {
        $line =~ s{\Q$eol\E \z}{}xms;
        my $line_number = ++${$line_number_ref};
        my ($obsolete, $key, $value);
        # Empty line. End of an entry.
        if ( $line =~ m{\A \s* \z}xms ) { ## no critic (CascadingIfElse)
            last LINE if $po;
        }
        # strings
        elsif (
            ($obsolete, $key, $value)
                = $line =~ m{\A ( \# ~ \s+ )? ( msgctxt | msgid | msgid_plural | msgstr ) \s+ (.*)}xms
        ) {
            last LINE if $is_new_entry->($key);
            $po ||= $class->new(eol => $eol, -loaded_line_number => $line_number);
            $buffer{$key} = $self->dequote($value, $eol);
            $current_buffer = \$buffer{$key};
            if ($obsolete) {
                $po->obsolete(1);
            }
        }
        # contined string
        elsif ( $line =~ m{\A (?: \# ~ \s+ )? "}xms ) {
            ${$current_buffer} .= $self->dequote($line, $eol);
            $last_line_of_section{ $current_section_key } = $line_number;
        }
        # translated string, plural
        elsif (
            ($obsolete, $key, $value)
                = $line =~  m{\A ( \# ~ \s+ )? msgstr \[ (\d+) \] \s+ (.*)}xms
        ) {
            last LINE if $is_new_entry->('msgstr_n');
            $buffer{msgstr_n}->{$key} = $self->dequote($value, $eol);
            $current_buffer = \$buffer{msgstr_n}->{$key};
            if ($obsolete) {
                $po->obsolete(1);
            }
        }
        # reference
        elsif ( ($value) = $line =~ m{\A \# : \s+ (.*)}xms ) {
            last LINE if $is_new_entry->('comment');
            $po ||= $class->new(eol => $eol, -loaded_line_number => $line_number);
            # maybe more in 1 line
            $value = join $eol, split m{\s+}xms, $value;
            $po->reference(
                defined $po->reference()
                ? $po->reference() . "$eol$value"
                : $value
            );
        }
        # flags
        elsif ( ($value) = $line =~ m{\A \# , \s+ (.*)}xms) {
            last LINE if $is_new_entry->('comment');
            $po ||= $class->new(eol => $eol, -loaded_line_number => $line_number);
            for my $flag ( split m{\s* , \s*}xms, $value ) {
                $po->add_flag($flag);
            }
        }
        # Translator comments
        elsif (
            $line =~ m{\A \# \s+ (.*)}xms
            || $line =~ m{\A \# ()\z}xms
        ) {
            $value = $1;
            last LINE if $is_new_entry->('comment');
            $po ||= $class->new(eol => $eol, -loaded_line_number => $line_number);
            $po->comment(
                defined $po->comment()
                ? $po->comment() . "$eol$value"
                : $value
            );
        }
        # Automatic comments
        elsif ( ($value) = $line =~ m{\A \# \. \s* (.*)}xms ) {
            last LINE if $is_new_entry->('comment');
            $po ||= $class->new(eol => $eol, -loaded_line_number => $line_number);
            $po->automatic(
                defined $po->automatic()
                ? $po->automatic() . "$eol$value"
                : $value
            );
        }
        # previous
        elsif (
            ($key, $value)
                = $line =~ m{\A \# \| \s+ ( msgctxt | msgid | msgid_plural ) \s+ (.*)}xms
        ) {
            last LINE if $is_new_entry->('comment');
            $po ||= $class->new(eol => $eol, -loaded_line_number => $line_number);
            $key = "previous_$key";
            $buffer{$key} = $self->dequote($value, $eol);
            $current_buffer = \$buffer{$key};
        }
        else {
            warn "Strange line at $file_name line $line_number: $line\n";
        }
        $safe_current_position->();
    }
    if ($po) {
        for my $key (qw(
            msgctxt msgid msgid_plural
            previous_msgctxt previous_msgid previous_msgid_plural
            msgstr msgstr_n
        )) {
            if ( defined $buffer{$key} ) {
                $po->$key( $buffer{$key} );
            }
        }
        return $po;
    }

    return; # no entry found
}

sub _hash_key_ok {
    my ($self, $entries) = @_;

    my $key = $self->msgid();

    if ($entries->{$key}) {
        # don't overwrite non-obsolete entries with obsolete ones
        return if $self->obsolete() && ! $entries->{$key}->obsolete();
        # don't overwrite translated entries with untranslated ones
        return if $self->msgstr() !~ m{\w}xms
                  && $entries->{$key}->msgstr() =~ m{\w}xms;
    }

    return 1;
}

1;

__END__