File Coverage

lib/File/Gettext/Storage/PO.pm

Criterion	Covered	Total	%
statement	33	33	100.0
branch	3	4	75.0
condition			n/a
subroutine	11	11	100.0
pod	4	4	100.0
total	51	52	98.0

package File::Gettext::Storage::PO;

use namespace::autoclean;

use Date::Format                 ( );
use Encode                     qw( decode encode );
use File::DataClass::Constants qw( NUL SPC );
use File::DataClass::Functions qw( extension_map );
use File::Gettext::Constants   qw( CONTEXT_SEP );
use Moo;

extension_map '+File::Gettext::Storage::PO' => '.po';

extends q(File::DataClass::Storage);

has '+extn' => default => '.po';

# Private functions
my $_comment_field = sub {
   return { '#'  => q(translator_comment),
            '# ' => q(translator_comment),
            '#.' => q(extracted_comment),
            '#:' => q(reference),
            '#,' => q(flags),
            '#|' => q(previous), }->{ $_[ 0 ] };
};

my $_comment_prefix = sub {
   return { 'translator_comment' => '# ',
            'extracted_comment'  => '#.',
            'reference'          => '#:',
            'flags'              => '#,',
            'previous'           => '#|', }->{ $_[ 0 ] };
};

my $_decode_hash; $_decode_hash = sub {
   my ($charset, $in) = @_; my $out = {};

   for my $k (grep { defined } keys %{ $in }) {
      my $values = $in->{ $k }; defined $values or next;

      if (ref $values eq 'HASH') {
         $out->{ $k } = $_decode_hash->( $charset, $values );
      }
      elsif (ref $values eq 'ARRAY') {
         $out->{ $k } = [ map { decode( $charset, $_ ) } @{ $values } ];
      }
      else { $out->{ $k } = decode( $charset, $values ) }
   }

   return $out;
};

my $_header_inflate = sub {
   my $data = shift; my $header = (delete $data->{ NUL() }) || { msgstr => [] };

   my $null_entry = $header->{msgstr}->[ 0 ]; $header->{msgstr} = {};

   $null_entry or return $header;

   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->{msgstr}->{ lc $k } = $v;
   }

   return $header;
};

my $_original_order = sub {
   my ($hash, $lhs, $rhs) = @_;

   # New elements will be  added at the end
   exists $hash->{ $lhs }->{_order} or return  1;
   exists $hash->{ $rhs }->{_order} or return -1;
   return $hash->{ $lhs }->{_order} <=> $hash->{ $rhs }->{_order};
};

my $_quote = sub {
   my $text = shift;

   $text =~ s{ \A [\"] }{\\\"}msx; $text =~ s{ ([^\\])[\"] }{$1\\\"}gmsx;

   return '"'.$text.'\n"';
};

my $_store_comment = sub {
   my ($rec, $line, $attr) = @_;

   my $value = length $line > 1 ? substr $line, 2 : NUL;

   if ($attr eq q(flags)) {
      push @{ $rec->{ $attr } }, map    { s{ \s+ }{}msx; $_ }
                                 split m{ [,]      }msx, $value;
   }
   else { $rec->{ $attr } .= $rec->{ $attr } ? "\n${value}" : $value }

   return;
};

my $_time2str = sub {
   my ($format, $time) = @_;

   defined $format or $format = '%Y-%m-%d %H:%M:%S';
   defined $time   or $time   = time;

   return Date::Format::Generic->time2str( $format, $time );
};

my $_unquote = sub {
   my $text = shift;

   $text =~ s{ [\\][n] \z }{\n}msx; $text =~ s{ [\\][\"] }{\"}gmsx;

   return $text;
};

my $_append_msgtext = sub {
   my ($rec, $key, $last, $text) = @_;

   if (ref $rec->{ $key } ne 'ARRAY') { $rec->{ $key } .= $_unquote->( $text ) }
   else { $rec->{ $key }->[ $last || 0 ] .= $_unquote->( $text ) }

   return;
};

my $_store_msgtext = sub {
   my ($rec, $line, $last_ref) = @_; my $key;

   if ($line =~ m{ \A msgctxt \s+ [\"] (.*) [\"] \z }msx) {
      $key = q(msgctxt); $rec->{ $key } = $_unquote->( $1 );
   }
   elsif ($line =~ m{ \A msgid \s+ [\"] (.*) [\"] \z }msx) {
      $key = q(msgid); $rec->{ $key } = $_unquote->( $1 );
   }
   elsif ($line =~ m{ \A msgid_plural \s+ [\"] (.*) [\"] \z }msx) {
      $key = q(msgid_plural); $rec->{ $key } = $_unquote->( $1 );
   }
   elsif ($line =~ m{ \A msgstr \s+ [\"] (.*) [\"] \z }msx) {
      $key = q(msgstr); $rec->{ $key } ||= [];
      $rec->{ $key }->[ ${ $last_ref } = 0 ] .= $_unquote->( $1 );
   }
   elsif ($line =~ m{ \A msgstr\[\s*(\d+)\s*\] \s+ [\"](.*)[\"] \z }msx) {
      $key = q(msgstr); $rec->{ $key } ||= [];
      $rec->{ $key }->[ ${ $last_ref } = $1 ] .= $_unquote->( $2 );
   }

   return $key;
};

# Private common methods
my $_get_charset = sub {
   my ($self, $po_header) = @_; my $charset = $self->schema->charset;

   my $msgstr       = $po_header->{msgstr} || {};
   my $content_type = $msgstr->{content_type} || NUL;

   $content_type =~ s{ .* = }{}msx and $charset = $content_type;

   return $charset;
};

# Private read methods
my $_inflate_and_decode = sub {
   my ($self, $data) = @_;

   my $po_header = $_header_inflate->( $data );
   my $charset   = $self->$_get_charset( $po_header );
   my $tmp       = $data; $data = {};

   # Decode all keys and values using the charset from the header
   for my $k (grep { $_ and defined $tmp->{ $_ } } keys %{ $tmp }) {
      my $rec = $tmp->{ $k }; my $id = decode( $charset, $k );

      $data->{ $id } = $_decode_hash->( $charset, $rec );
   }

   return { po => $data, po_header => $_decode_hash->( $charset, $po_header ) };
};

my $_store_record = sub {
   my ($self, $data, $rec, $order_ref) = @_; exists $rec->{msgid} or return;

   my @ctxt = split m{ [\.] }msx, ($rec->{msgctxt} || NUL), 2;

   $ctxt[ 0 ] = $ctxt[ 0 ] ? $ctxt[ 0 ].SPC : 'messages ';
   $ctxt[ 1 ] = $ctxt[ 1 ] ? SPC.$ctxt[ 1 ] : NUL;
   $rec->{labels} = $ctxt[ 0 ].$rec->{msgid}.$ctxt[ 1 ];
   $rec->{_order} = ${ $order_ref }++;
   $data->{ $self->make_key( $rec ) } = $rec;
   return;
};

my $_read_filter = sub {
   my ($self, $buf) = @_; $buf ||= [];

   my ($data, $order, $rec, $key, $last) = ({}, 0, {});

   for my $line (grep { defined } @{ $buf }) {
      # Lines beginning with a hash are comments
      if ('#' eq substr $line, 0, 1) {
         my $field = $_comment_field->( substr $line, 0, 2 );

         $field and $_store_comment->( $rec, $line, $field );
      }
      # Field names all begin with the prefix msg
      elsif ('msg' eq substr $line, 0, 3) {
         $key = $_store_msgtext->( $rec, $line, \$last );
      }
      # Match any continuation lines
      elsif ($line =~ m{ \A \s* [\"] (.+) [\"] \z }msx and defined $key) {
         $_append_msgtext->( $rec, $key, $last, $1 );
      }
      # A blank line ends the record
      elsif ($line =~ m{ \A \s* \z }msx) {
         $self->$_store_record( $data, $rec, \$order );
         $key = undef; $last = undef; $rec = {};
      }
   }

   $self->$_store_record( $data, $rec, \$order ); # If the last line isn't blank

   return $self->$_inflate_and_decode( $data );
};

# Private write methods
my $_default_po_header = sub {
   my $self       = shift;
   my $charset    = $self->schema->charset;
   my $defaults   = $self->schema->default_po_header;
   my $appname    = $defaults->{appname   };
   my $company    = $defaults->{company   };
   my $email      = $defaults->{email     };
   my $lang       = $defaults->{lang      };
   my $team       = $defaults->{team      };
   my $translator = $defaults->{translator};
   my $rev_date   = $_time2str->( '%Y-%m-%d %H:%M%z' );
   my $year       = $_time2str->( '%Y' );

   return {
      'translator_comment' => join "\n", ( '@(#)$Id'.'$',
                                           'GNU Gettext Portable Object.',
                                           "Copyright (C) ${year} ${company}.",
                                           "${translator} ${email}, ${year}.",
                                           '', ),
      flags       => [ 'fuzzy', ],
      msgstr      => {
         'project_id_version'        => "${appname} ${File::Gettext::VERSION}",
         'po_revision_date'          => $rev_date,
         'last_translator'           => "${translator} ${email}",
         'language_team'             => "${team} ${email}",
         'language'                  => $lang,
         'mime_version'              => '1.0',
         'content_type'              => 'text/plain; charset='.$charset,
         'content_transfer_encoding' => '8bit',
         'plural_forms'              => 'nplurals=2; plural=(n != 1);', }, };
};

my $_get_comment_lines = sub {
   my ($self, $attr_name, $values, $prefix) = @_; my $lines = [];

   $attr_name eq 'flags' and return [ $prefix.SPC.(join ', ', @{ $values }) ];

   $values =~ m{ [\n] \z }msx and $values .= SPC;

   for my $line (map { $prefix.$_ } split m{ [\n] }msx, $values) {
      $line =~ s{ \# \s+ \z }{\#}msx; push @{ $lines }, $line;
   }

   return $lines;
};

my $_get_po_header_key = sub {
   my ($self, $k) = @_; my $key_table = $self->schema->header_key_table;

   defined $key_table->{ $k } and return $key_table->{ $k };

   my $po_key = join q(-), map { ucfirst $_ } split m{ [_] }msx, $k;

   return [ 1 + keys %{ $key_table }, $po_key ];
};

my $_split_on_nl = sub {
   my ($self, $attr_name, $value) = @_;

   $value ||= NUL; my $last_char = substr $value, -1; chomp $value;

   my @lines = split m{ [\n] }msx, $value; my $lines = [];

   if (@lines < 2) { push @{ $lines }, "${attr_name} ".$_quote->( $value ) }
   else {
      push @{ $lines }, $attr_name.' ""';
      push @{ $lines }, map { $_quote->( $_ ) } @lines;
   }

   $last_char ne "\n" and $lines->[ -1 ] =~ s{ [\\][n][\"] \z }{\"}msx;
   return $lines;
};

my $_array_split_on_nl = sub {
   my ($self, $attr, $values) = @_; my $index = 0; my $lines = [];

   for my $value (@{ $values }) {
      push @{ $lines }, @{ $self->$_split_on_nl( "${attr}[${index}]", $value )};
      $index++;
   }

   return $lines;
};

my $_header_deflate = sub {
   my ($self, $po_header) = @_; my $msgstr_ref = $po_header->{msgstr} || {};

   my $header = { %{ $po_header || {} } }; my $msgstr;

   for my $k (sort  { $self->$_get_po_header_key( $a )->[ 0 ]
                  <=> $self->$_get_po_header_key( $b )->[ 0 ] }
              keys %{ $msgstr_ref }) {
      $msgstr .= $self->$_get_po_header_key( $k )->[ 1 ];

#      if ($k eq q(po_revision_date)) {
#         $msgstr .= ': '.$_time2str->( "%Y-%m-%d %H:%M%z" )."\n";
#      }
#      else { $msgstr .= ': '.($msgstr_ref->{ $k } || NUL)."\n" }
      $msgstr .= ': '.($msgstr_ref->{ $k } || NUL)."\n";
   }

   $header->{_order} = 0;
   $header->{msgid } = NUL;
   $header->{msgstr} = [ $msgstr ];
   return $header;
};

my $_get_lines = sub {
   my ($self, $attr_name, $values) = @_; my ($cpref, $lines);

   if ($cpref = $_comment_prefix->( $attr_name )) {
      $lines = $self->$_get_comment_lines( $attr_name, $values, $cpref );
   }
   elsif (ref $values eq 'ARRAY') {
      if (@{ $values } > 1) {
         $lines = $self->$_array_split_on_nl( $attr_name, $values );
      }
      else { $lines = $self->$_split_on_nl( $attr_name, $values->[ 0 ] ) }
   }
   else { $lines = $self->$_split_on_nl( $attr_name, $values ) }

   return $lines;
};

my $_write_filter = sub {
   my ($self, $data) = @_; my $buf ||= [];

   my $po        = $data->{po       } || {};
   my $po_header = $data->{po_header} || $self->$_default_po_header;
   my $charset   = $self->$_get_charset( $po_header );
   my $attrs     = $self->schema->source->attributes;

   $po->{ NUL() } = $self->$_header_deflate( $po_header );

   for my $key (sort { $_original_order->( $po, $a, $b ) } keys %{ $po }) {
      my $rec = $po->{ $key };

      $rec->{name} and not $rec->{msgid}
         and $rec->{msgid} = delete $rec->{name};

      for my $attr_name (grep { exists $rec->{ $_ } } @{ $attrs }) {
         my $values = $rec->{ $attr_name }; defined $values or next;

         ref $values eq 'ARRAY' and @{ $values } < 1 and next;
         push @{ $buf }, map { encode( $charset, $_ ) }
                            @{ $self->$_get_lines( $attr_name, $values ) };
      }

      push @{ $buf }, NUL;
   }

   pop @{ $buf };
   return $buf;
};

# Public methods
sub read_from_file {
   my ($self, $rdr) = @_;

   return $self->$_read_filter( [ $rdr->chomp->getlines ] );
};

sub write_to_file {
   my ($self, $wtr, $data) = @_;

   $wtr->println( @{ $self->$_write_filter( $data ) } );
   return $data;
}

sub decompose_key {
   my ($self, $key) = @_; my $sep = CONTEXT_SEP;

   0 >= index $key, $sep and return (NUL, $key);

   return split m{ $sep }msx, $key, 2;
}

sub make_key {
   my ($self, $rec) = @_;

   return (exists $rec->{msgctxt}
           ? $rec->{msgctxt}.CONTEXT_SEP : NUL).$rec->{msgid};
}

1;

__END__