Wrote LangFile module to handle lang.txt files

Figured I'd need to do some automated processing on that file in the
future, and considering the format was made to be easy to handle for
humans (and not computers), this module will come in handy.

I wrote that small POD for brainstorming the API, before typing even a
single line of code.

2 files changed, 152 insertions, 43 deletions

diff --git a/lib/LangFile.pm b/lib/LangFile.pm
new file mode 100644
index 00000000..3c5ab1e2
--- /dev/null
+++ b/lib/LangFile.pm
@@ -0,0 +1,139 @@
+
+
+package LangFile;
+
+
+sub new {
+  my($class, $action, $file) = @_;
+  open my $F, $action eq 'read' ? '<:utf8' : '>:utf8', $file or die "Opening $file: $!";
+  return bless {
+    act => $action,
+    FH => $F,
+    # status vars for reading
+    intro => 1,
+    last => [],
+  }, $class;
+}
+
+
+sub read {
+  my $self = shift;
+  my $FH = $self->{FH};
+  my @lines;
+  my $state = '';
+  my($lang, $sync);
+
+  while((my $l = shift(@{$self->{last}}) || <$FH>)) {
+    $l =~ s/[\r\n\t\s]+$//;
+
+    # header
+    if($self->{intro}) {
+      push @lines, $l;
+      next if $l ne '/intro';
+      $self->{intro} = 0;
+      return [ 'space', @lines ];
+    }
+
+    # key
+    if(!$state && $l =~ /^:(.+)$/) {
+      return [ 'key', $1 ];
+    }
+
+    # space
+    if((!$state || $state eq 'space') && ($l =~ /^#/ || $l eq '')) {
+      $state = 'space';
+      push @lines, $l;
+    } elsif($state eq 'space') {
+      push @{$self->{last}}, "$l\n";
+      return [ 'space', @lines ];
+    }
+
+    # tl
+    if(!$state && $l =~ /^([a-z_-]{2})([ *]):(?: (.+)|)$/) {
+      $lang = $1;
+      $sync = $2 eq '*' ? 0 : 1;
+      push @lines, $3||'';
+      $state = 'tl';
+    } elsif($state eq 'tl' && $l =~ /^\s{5}(.+)$/) {
+      push @lines, $1;
+    } elsif($state eq 'tl' && $l eq '') {
+      push @lines, $l;
+    } elsif($state eq 'tl') {
+      my $trans = join "\n", @lines;
+      push @{$self->{last}}, "\n" while $trans =~ s/\n$//;
+      push @{$self->{last}}, $l;
+      return [ 'tl', $lang, $sync, $trans ];
+    }
+
+    die "Don\'t know what to do with \"$l\"" if !$state;
+  }
+  if($state eq 'space') {
+    return [ 'space', @lines ];
+  }
+  if($state eq 'tl') {
+    my $trans = join "\n", @lines;
+    push @{$self->{last}}, "\n" while $trans =~ s/\n$//;
+    return [ 'tl', $lang, $sync, $trans ];
+  }
+  return undef;
+}
+
+
+sub write {
+  my($self, @line) = @_;
+  my $FH = $self->{FH};
+
+  my $t = shift @line;
+
+  if($t eq 'space') {
+    print $FH "$_\n" for @line;
+  }
+
+  if($t eq 'key') {
+    print $FH ":$line[0]\n";
+  }
+
+  if($t eq 'tl') {
+    my($lang, $sync, $text) = @line;
+    $text =~ s/\n([^\n])/\n     $1/g;
+    $text = " $text" if $text ne '';
+    printf $FH "%s%s:%s\n", $lang, $sync ? ' ' : '*', $text;
+  }
+}
+
+
+sub close {
+  my $self = shift;
+  close $self->{FH};
+}
+
+1;
+
+__END__
+=pod
+
+=head1 NAME
+
+LangFile - Simple object oriented interface for the parsing and creation of lang.txt
+
+=head1 USAGE
+
+  use LangFile;
+  my $read = LangFile->new(read => "data/lang.txt");
+  my $write = LangFile->new(write => "lang-copy.txt");
+
+  while((my $line = $read->read())) {
+    # $line is an arrayref in one of the following formats:
+    # [ 'space', @lines ]
+    #   unparsed lines, like the header, newlines and comments
+    # [ 'key', $key ]
+    #   key line, $key is key name
+    # [ 'tl', $lang, $sync, $text ]
+    #   translation line(s), $lang = language tag, $sync = 1/0, $text = translation (can include newlines)
+    # $line is undef on EOF, $read->next() die()s on a parsing error
+
+    # create an identical copy of $read in $write
+    $write->write(@$line);
+  }
+  $write->close;
+
diff --git a/lib/VNDB/L10N.pm b/lib/VNDB/L10N.pm
index d4ff872c..c2423f53 100644
--- a/lib/VNDB/L10N.pm
+++ b/lib/VNDB/L10N.pm
@@ -5,6 +5,7 @@ use warnings;
 {
   package VNDB::L10N;
   use base 'Locale::Maketext';
+  use LangFile;
 
   sub fallback_languages { ('en') };
 
@@ -25,51 +26,20 @@ use warnings;
       en => \%VNDB::L10N::en::Lexicon,
       ru => \%VNDB::L10N::ru::Lexicon,
     );
-
-    open my $F, '<:utf8', $VNDB::ROOT.'/data/lang.txt' or die "Opening language file: $!\n";
-    my($empty, $line, $key, $lang) = (0, 0);
-    while(<$F>) {
-      chomp;
-      $line++;
-
-      # ignore intro
-      if(!defined $key) {
-        $key = 0 if /^\/intro$/;
-        next;
-      }
-      # ignore comments
-      next if /^#/;
-      # key
-      if(/^:(.+)$/) {
-        $key = $1;
-        $lang = undef;
-        $empty = 0;
-        next;
-      }
-      # locale string
-      if(/^([a-z_-]{2,7})[ *]: (.+)$/) {
-        $lang = $1;
-        die "Unknown language on #$line: $lang\n" if !$lang{$lang};
-        die "Unknown key for locale on #$line\n" if !$key;
-        $lang{$lang}{$key} = $2;
-        $empty = 0;
-        next;
-      }
-      # multi-line locale string
-      if($lang && /^\s+([^\s].*)$/) {
-        $lang{$lang}{$key} .= ''.("\n"x$empty)."\n$1";
-        $empty = 0;
-        next;
-      }
-      # empty string (count them in case they're part of a multi-line locale string)
-      if(/^\s*$/) {
-        $empty++;
-        next;
+    my $r = LangFile->new(read => "$VNDB::ROOT/data/lang.txt");
+    my $key;
+    while(my $l = $r->read) {
+      my($t, @l) = @$l;
+      $key = $l[0] if $t eq 'key';
+      if($t eq 'tl') {
+        my($lang, undef, $text) = @l;
+        next if !$text;
+        die "Unknown language \"$l->[1]\"\n" if !$lang{$lang};
+        die "Unknown key for translation \"$lang: $text\"\n" if !$key;
+        $lang{$lang}{$key} = $text;
       }
-      # something we didn't expect
-      die "Don't know what to do with line $line\n" unless /^([a-z_-]{2,7})[ *]:/;
     }
-    close $F;
+    $r->close;
   }
 }