File Coverage

blib/lib/Locale/VersionedMessages.pm

Criterion	Covered	Total	%
statement	273	319	85.5
branch	108	150	72.0
condition	14	24	58.3
subroutine	26	27	96.3
pod	12	12	100.0
total	433	532	81.3

package Locale::VersionedMessages;
# Copyright (c) 2010-2014 Sullivan Beck. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

########################################################################

require 5.008;
use strict;
use warnings;

our $VERSION;
$VERSION='0.94';

########################################################################
# METHODS
########################################################################

sub new {
  my($class) = @_;

  my $self = {
              'err'    => '',
              'set'    => {},
              'mess'   => {},
              'search' => [],
             };

  bless $self, $class;

  return $self;
}

sub version {
  my($self) = @_;
  return $VERSION;
}

sub err {
   my($self) = @_;
   return $$self{'err'};
}

no strict 'refs';
sub set {
   my($self,@set) = @_;

   $$self{'err'} = '';
   if (! @set) {
      return sort keys %{ $$self{'set'} };
   }

   foreach my $set (@set) {
      if ($set !~ /^[a-zA-Z0-9_]+$/) {
         $$self{'err'} = "Set must be alphanumeric/underscore: $set";
         return;
      }

      my $m = "Locale::VersionedMessages::Sets::$set";
      eval "require $m";
      if ($@) {
         chomp($@);
         $$self{'err'} = "Unable to load set: $set: $@";
         return;
      }

      my $def_locale   = ${ "${m}::DefaultLocale" };
      my @all_locale   = @{ "${m}::AllLocale" };
      my %messages     = %{ "${m}::Messages" };

      $$self{'set'}{$set} = { 'def_loc'  => $def_locale,
                              'all_loc'  => { map {$_,1} @all_locale },
                              'messages' => \%messages,
                              'search'   => [],
                            };
   }

   return;
}
use strict 'refs';

sub query_set_default {
   my($self,$set) = @_;
   $$self{'err'} = '';

   if (! exists $$self{'set'}{$set}) {
      $$self{'err'} = "Set not loaded: $set";
      return;
   }

   return $$self{'set'}{$set}{'def_loc'};
}

sub query_set_locales {
   my($self,$set) = @_;
   $$self{'err'} = '';

   if (! exists $$self{'set'}{$set}) {
      $$self{'err'} = "Set not loaded: $set";
      return;
   }

   return sort keys %{ $$self{'set'}{$set}{'all_loc'} };
}

sub query_set_msgid {
   my($self,$set) = @_;
   $$self{'err'} = '';

   if (! exists $$self{'set'}{$set}) {
      $$self{'err'} = "Set not loaded: $set";
      return;
   }

   return sort keys %{ $$self{'set'}{$set}{'messages'} };
}

sub search {
   my($self,@locale) = @_;
   $$self{'err'} = '';

   my $set;
   if (@locale  &&  exists $$self{'set'}{$locale[0]}) {
      $set = shift(@locale);
   }

   if ($set  &&  @locale) {
      $$self{'set'}{$set}{'search'} = [@locale];

   } elsif (@locale) {
      $$self{'search'} = [@locale];

   } elsif ($set) {
      $$self{'set'}{$set}{'search'} = [];

   } else {
      $$self{'search'} = [];
   }

   return;
}

sub query_search {
   my($self,$set) = @_;
   $$self{'err'} = '';

   if ($set) {
      if (! exists $$self{'set'}{$set}) {
         $$self{'err'} = "Set not loaded: $set";
         return;
      }

      return @{ $$self{'set'}{$set}{'search'} };
   }

   return @{ $$self{'search'} };
}

no strict 'refs';
sub _load_lexicon {
   my($self,$set,$locale) = @_;
   return  if (exists $$self{'mess'}{$set}{$locale});

      if ($set !~ /^[a-zA-Z0-9_]+$/) {
         $$self{'err'} = "Set must be alphanumeric/underscore: $set";
         return;
      }

   my $m = "Locale::VersionedMessages::Sets::${set}::${locale}";
   eval "require $m";
   if ($@) {
      chomp($@);
      $$self{'err'} = "Unable to load lexicon: $set [$locale]: $@";
      return;
   }

   $$self{'mess'}{$set}{$locale} = { %{ "${m}::Messages" } };

   foreach my $msgid (sort keys %{ $$self{'mess'}{$set}{$locale} }) {
      if (! exists $$self{'set'}{$set}{'messages'}{$msgid}) {
         $$self{'err'} = "Undefined message ID in lexicon: $set [$locale $msgid]";
         return;
      }
   }
}
use strict 'refs';

sub message {
   my($self,$set,$msgid,@args) = @_;
   $$self{'err'} = '';

   # Parse arguments

   my($locale,%vals);
   if (@args  &&  @args % 2) {
      $locale = shift(@args);
      %vals   = @args;
      if (! exists $$self{'set'}{$set}{'all_loc'}{$locale}) {
         $$self{'err'} = "Set not defined in locale: $set [ $locale ]";
         return '';
      }

   } else {
      %vals  = @args;
   }

   # Look up the message.

   my @locale;
   if ($locale) {
      @locale = ($locale);

   } elsif (exists $$self{'set'}{$set}{'search'}  &&
            @{ $$self{'set'}{$set}{'search'} }) {
      @locale = @{ $$self{'set'}{$set}{'search'} };

   } elsif (exists $$self{'search'}  &&
            @{ $$self{'search'} }) {
      @locale = (@{ $$self{'search'} }, $$self{'set'}{$set}{'def_loc'});

   } else {
      @locale = ($$self{'set'}{$set}{'def_loc'});
   }

   my $message;

   foreach my $l (@locale) {
      next  if (! exists $$self{'set'}{$set}{'all_loc'}{$l});

      if (! exists $$self{'mess'}{$set}{$l}) {
         $self->_load_lexicon($set,$l);
         if ($$self{'err'}) {
            if (wantarray) {
               return ('');
            } else {
               return '';
            }
         }
      }

      if (exists $$self{'mess'}{$set}{$l}{$msgid}) {
         $locale  = $l;
         $message = $$self{'mess'}{$set}{$l}{$msgid}{'text'};
         last;
      }
   }

   if (! $message) {
      $$self{'err'} = "Message not found in specified lexicons: $msgid";
      return;
   }

   $message = $self->_fix_message($set,$msgid,$message,$locale,%vals);

   if (wantarray) {
      return ($message,$locale);
   } else {
      return $message;
   }
}

sub query_msg_locales {
   my($self,$set,$msgid) = @_;
   $$self{'err'} = '';

   if (! exists $$self{'set'}{$set}) {
      $$self{'err'} = "Set not loaded: $set";
      return ();
   }
   if (! exists $$self{'set'}{$set}{'messages'}{$msgid}) {
      $$self{'err'} = "Message ID not defined in set: $set [$msgid]";
      return ();
   }

   my %all_loc = %{ $$self{'set'}{$set}{'all_loc'} };
   my $def_loc = $$self{'set'}{$set}{'def_loc'};
   delete $all_loc{$def_loc};

   my @locale = ($def_loc);
   foreach my $locale (sort keys %all_loc) {
      $self->_load_lexicon($set,$locale);
      return ()  if ($$self{'err'});
      if (exists $$self{'mess'}{$set}{$locale}{$msgid}) {
         push(@locale,$locale);
      }
   }

   return @locale;
}

sub query_msg_vers {
   my($self,$set,$msgid,$locale) = @_;
   $$self{'err'} = '';

   if (! exists $$self{'set'}{$set}) {
      $$self{'err'} = "Set not loaded: $set";
      return '';
   }
   if (! exists $$self{'set'}{$set}{'messages'}{$msgid}) {
      $$self{'err'} = "Message ID not defined in set: $set [$msgid]";
      return '';
   }

   $locale = $$self{'set'}{$set}{'def_loc'}  if (! $locale);

   if (! exists $$self{'set'}{$set}{'all_loc'}{$locale}) {
      $$self{'err'} = "Lexicon not available for set: $set [$locale]";
      return '';
   }

   if (exists $$self{'mess'}{$set}{$locale}{$msgid}) {
      return $$self{'mess'}{$set}{$locale}{$msgid}{'vers'};
   }
   return 0;
}

########################################################################
# MESSAGE SUBSTITUTIONS
########################################################################

# This takes a message and performs substitutions for each of
# the different substitution values.
#
sub _fix_message {
   my($self,$set,$msgid,$message,$locale,%vals) = @_;

   # No substitutions.

   my @vals;
   if (exists $$self{'set'}{$set}{'messages'}{$msgid}{'vals'}) {
      @vals = @{ $$self{'set'}{$set}{'messages'}{$msgid}{'vals'} };
   }
   if (! @vals) {
      if (%vals) {
         $$self{'err'} = "Message does not contain substitutions, but " .
                         "values were supplied: $msgid";
         return '';
      }
      return $message;
   }

   # Check each substitution.

   foreach my $val (sort @vals) {
      my $done;
      if (! exists $vals{$val}) {
         $$self{'err'} = "A required substitution value was not passed in: " .
                         "$msgid [$val]";
         return '';
      }
      ($message,$done) = $self->_substitute($set,$msgid,$locale,
                                            $message,$val,$vals{$val});
      return ''  if ($$self{'err'});
      if (! $done) {
         $$self{'err'} = "The message in a lexicon does not contain a required " .
                         "substitution: $msgid [$locale $val]";
         return '';
      }
      delete $vals{$val};
   }
   foreach my $val (sort keys %vals) {
      $$self{'err'} = "An invalid value was passed in: $msgid [$val]";
      return '';
   }

   return $message;
}

# This does the acutal substitution for a single substitution value.
#
# If the substitution is found, $done = 1 will be returned.
#
sub _substitute {
   my($self,$set,$msgid,$locale,$message,$var,$val) = @_;
   my $done     = 0;

   # Simple substitutions: [foo]

   if ($message =~ s/\[\s*$var\s*\]/$val/sg) {
      $done = 1;
   }

   # Formatted substitutions: [ foo : FORMAT ]

   my $fmt_re = qr/\s*:\s*(%.*?)/;

   while ($message =~ s/\[\s*$var$fmt_re\s*\]/__L_M_TMP__/s) {
      my $fmt = $1;

      no warnings;
      $val = sprintf($fmt,$val);
      use warnings;
      if ($val eq $fmt) {
         $$self{'err'} = "Invalid sprintf format: $msgid [$locale $var]";
         return;
      }
      $message =~ s/__L_M_TMP__/$val/s;
      $done    = 1;
   }

   # Quant substitutions: [ foo : quant [ : FORMAT ] ... ]

   my ($msg,$d) = $self->_quant($set,$msgid,$locale,$message,$var,$val);
   return       if ($$self{'err'});
   $message     = $msg;
   $done        = $d  if ($d);

   return ($message,$done);
}

# This tests a string for any quant substitutions and returns the
# string.
#
sub _quant {
   my($self,$set,$msgid,$locale,$mess,$var,$val) = @_;

   my $val_orig = $val;
   my $fmt_re   = qr/\s*:\s*(%.*?)/;
   my $brack_re = qr/\s+\[([^]]*?)\]/;
   my $sq_re    = qr/\s+'([^']*?)'/;
   my $dq_re    = qr/\s+"([^"]*?)"/;
   my $ws_re    = qr/\s+(\S*)/;
   my $tok_re   = qr/(?:$brack_re|$sq_re|$dq_re|$ws_re)/;
   my $tmp      = '__L_M_TMP__';
   my $done     = 0;

   SUBST:
   while ($mess =~ s/\[\s*$var\s*:\s*quant\s*(?:$fmt_re)?($tok_re+)\s*\]/$tmp/s) {
      my $fmt   = $1;
      my $tokens= $2;

      if ($fmt) {
         no warnings;
         $val = sprintf($fmt,$val);
         use warnings;
         if ($val eq $fmt) {
            $$self{'err'} = "Invalid sprintf format: $msgid [$locale $var]";
            return;
         }
      }

      my @tok;
      while ($tokens =~ s/^$tok_re//) {
         push(@tok, $1 || $2 || $3 || $4);
      }

      if (@tok % 2 == 0) {
         $$self{'err'} = "Default string required in quant substitution: " .
                         "$msgid [$locale $var]";
         return;
      }

      # @tok is (TEST, STRING, TEST, STRING, ..., DEFAULT_STRING)

      while (@tok) {
         my $ele = shift(@tok);

         # DEFAULT_STRING

         if (! @tok) {
            $ele  =~ s/_$var/$val/g;
            $mess =~ s/$tmp/$ele/s;
            $done = 1;
            next SUBST;
         }

         # TEST, STRING

         my $flag = $self->_test($set,$msgid,$locale,$var,$val_orig,$ele);
         return  if ($$self{'err'});

         $ele     = shift(@tok);
         if ($flag) {
            $ele  =~ s/_$var/$val/g;
            $mess =~ s/$tmp/$ele/s;
            $done = 1;
            next SUBST;
         }
      }
   }

   return($mess,$done);
}

# This parses a condition string and returns 1 if the condition is true for
# this value.
#
sub _test {
   my($self,$set,$msgid,$locale,$var,$n,$test) = @_;

   # $n must be an unsigned integer

   if ($n !~ /^\d+$/) {
      $$self{'err'} = "Quantity test requires an unsigned integer: " .
                      "$msgid [$locale $var]";
      return;
   }

   # Currently, test can only have:
   #   whitespace
   #   _VAR
   #   ( ) && || < <= == != >= >
   #   DIGITS
   # in them.

   my $tmp = $test;
   $tmp    =~ s/(?:\s|\d|_$var|[()&|<=!>])//g;
   if ($tmp) {
      $$self{'err'} = "Quantity test contains invalid characters: " .
                      "$msgid [$locale $var]";
      return;
   }

   # Parse the tests.

   #  1) _VAR => $n

   $test =~ s/\s*_$var\s*/ $n /g;

   #  2) DIGITS % DIGITS => DIGITS

   while ($test =~ s/\s*(\d+)\s*%\s*(\d+)\s*/__L_M_TMP__/) {
      my $m = $1 % $2;
      $test =~ s/__L_M_TMP__/ $m /;
   }

   #  3) DIGITS OP DIGITS => 0 or 1

   while ($test =~ s/\s*(\d+)\s*(==|>=|<=|!=|>|<)\s*(\d+)\s*/__L_M_TMP__/) {
      my($m,$op,$n) = ($1,$2,$3);
      my $x;
      if      ($op eq '==') {
         $x = ($m==$n ? 1 : 0);
      } elsif ($op eq '!=') {
         $x = ($m!=$n ? 1 : 0);
      } elsif ($op eq '>=') {
         $x = ($m>=$n ? 1 : 0);
      } elsif ($op eq '<=') {
         $x = ($m<=$n ? 1 : 0);
      } elsif ($op eq '>') {
         $x = ($m>$n ? 1 : 0);
      } elsif ($op eq '<') {
         $x = ($m<$n ? 1 : 0);
      }
      $test =~ s/__L_M_TMP__/$x/;
   }

   #  Repeat until done:
   #  4) (DIGITS) => DIGITS
   #  5) DIGITS BOP DIGITS => 0 or 1

   while (1) {
      my $done = 1;
      if ($test =~ s/\s*\(\s*(\d+)\s*\)\s*/$1/g) {
         $done = 0;
      }
      while ($test =~ s/\s*(\d+)\s*(\|\||&&)\s*(\d+)\s*/__L_M_TMP__/) {
         my($m,$op,$n) = ($1,$2,$3);
         my $x;
         if      ($op eq '&&') {
            $x = ($m && $n ? 1 : 0);
         } elsif ($op eq '||') {
            $x = ($m || $n ? 1 : 0);
         }
         $test =~ s/__L_M_TMP__/$x/;
         $done = 0;
      }
      last  if ($done);
   }

   # Final check:
   #   6) DIGITS => 0 or 1

   if ($test =~ /^\s*(\d+)\s*$/) {
      return ($1 ? 1 : 0);
   }

   $$self{'err'} = "Quantity test malformed: $msgid [$locale $var]";
   return;
}

1;
# Local Variables:
# mode: cperl
# indent-tabs-mode: nil
# cperl-indent-level: 3
# cperl-continued-statement-offset: 2
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
# cperl-label-offset: 0
# End: