File Coverage

blib/lib/Mojolicious/Plugin/Localize.pm

Criterion	Covered	Total	%
statement	178	190	93.6
branch	92	106	86.7
condition	50	62	80.6
subroutine	17	18	94.4
pod	1	1	100.0
total	338	377	89.6

package Mojolicious::Plugin::Localize;
use Mojo::Base 'Mojolicious::Plugin';
use Mojo::Util qw/decode/;
use Mojo::File qw/path/;
use Mojolicious::Plugin::Config;
use File::Spec::Functions 'file_name_is_absolute';
use List::MoreUtils 'uniq';

# TODO:
#   Wrap http://search.cpan.org/~reneeb/Mojolicious-Plugin-I18NUtils-0.05/lib/Mojolicious/Plugin/I18NUtils.pm
# TODO:
#   do not backtrack on upper case dictionary keys
# TODO:
#   Support prefixes in dictionary
# TODO:
#   Support locale sub in dictionary
# TODO:
#   'd' is probably better than 'loc'
#   'd' for dictionary lookup
# TODO:
#   use Hash::Merge or Hash::Merge::Small
# TODO:
#   Use Mojo::Template directly
# TODO:
#   deal with:
#   <%= numsep $g_count %> <%= quant $g_count, 'guest', 'guests' %> online.'
# TODO:
#   Deal with bidirectional text

use constant DEBUG => $ENV{MOJO_LOCALIZE_DEBUG} || 0;
our $VERSION = '0.23';

has 'log';

# Warning: This only works for default EP templates
our $TEMPLATE_INDICATOR = qr/(?:^\s*\%)|<\%/m;

# Register plugin
sub register {
  my ($self, $mojo, $param) = @_;

  my (@dict, @resources);
  @dict      = ($param->{dict})       if $param->{dict};      # Hashes
  @resources = @{$param->{resources}} if $param->{resources}; # File names

  $self->log($mojo->log);

  # Not yet initialized
  unless ($mojo->renderer->helpers->{loc}) {

    # Load parameter from config file
    if (my $c_param = $mojo->config('Localize')) {

      # Prefer the configuration dictionary
      push @dict, $c_param->{dict} if $c_param->{dict};

      # Prefer the configuration override parameter
      $param->{override} = $c_param->{override} if $c_param->{override};

      # Add configuration resources
      if ($c_param->{resources}) {
        unshift @resources, @{$c_param->{resources}};
      };
    };

    # Load default helper
    $mojo->plugin('Localize::Quantify');
    $mojo->plugin('Localize::Locale');

    # Add 'generate dictionary' command
    push @{$mojo->commands->namespaces}, __PACKAGE__ . '::Command';

    # Lookup a dictionary key and return the value
    $mojo->helper(
      loc => sub {
        my $c = shift;

        # Nothing to look up
        return ''  unless scalar @_ && $_[0];

        my $key = [split('_', shift)];

        if (DEBUG) {
          _debug($c->app, '[LOOKUP] Search for "' . join('_',  @$key) . '"');
        };

        # If a default entry is given, get it
        my $default_entry = shift if @_ && @_ % 2 != 0;

        # Store all other values in the stash
        my %stash = @_;

        # Return dictionary entry or default entry
        return _lookup($c, \%stash, $c->stash('localize.dict'), $key, 0) ||
          $default_entry // '';
      }
    );


    # Return the dictionary reference
    $mojo->helper(
      'localize.dictionary' => sub {
        # Return the complete dictionary in case no parameter is defined
        # This is not documented and may change in further versions
        return $_[0]->stash('localize.dict');
      }
    );

    # Return the prefered path
    $mojo->helper(
      'localize.preference' => sub {
        my $c = shift;

        my $stash = $c->stash;
        return $stash->{'localize.preference'} if $stash->{'localize.preference'};

        my $key = [split('_', shift // '')];
        my $dict = $c->stash('localize.dict');

        if (DEBUG) {
          _debug($c->app, '[PREF] Look for prefered key for "' . join('_', @$key) . '"');
        };

        # If a default entry is given, get it
        my $default_entry = shift;

        # Return dictionary key - so pass the "find_pref" parameter
        $stash->{'localize.preference'} = _lookup($c, {}, $c->stash('localize.dict'), $key, 0, 1) ||
          $default_entry // '';
        return $stash->{'localize.preference'};
      }
    );

    $mojo->defaults('localize.dict' => {});
  };

  # Merge dictionary resources
  if (@resources) {

    # Create config loader
    my $config_loader = Mojolicious::Plugin::Config->new;
    my $home = $mojo->home;

    # Load files
    foreach my $file (uniq @resources) {

      $file = $home->rel_file($file) unless file_name_is_absolute $file;

      if (DEBUG) {
        _debug($mojo, "Load dictionary $file");
      };

      if (-e $file) {
        if (my $dict = $config_loader->load($file, undef, $mojo)) {
          unshift @dict, [$dict, $file];
          _debug($mojo, qq!Successfully loaded dictionary "$file"!);
          next;
        };
      };
      $mojo->log->warn(qq!Unable to load dictionary file "$file"!);
    };
  };

  my $dict_global = $mojo->defaults('localize.dict');

  # Merge dictionary hashes
  foreach (@dict) {
    my $is_array = ref $_ && ref $_ eq 'ARRAY';

    if (DEBUG) {
      _debug(
        $mojo,
        '[MERGE] Start merging' .
          ($is_array ? (' of ' . $_->[1]) : '')
        );
    };

    # Merge to global dictionary
    $self->_merge($dict_global, $is_array ? $_->[0] : $_, $param->{override});
  };
};


# Unflatten short notation
sub _unflatten {
  my ($key, $dict) = @_;
  my $k = $$key;
  my $g_hash = $dict->{$k};

  # Check for preferred key
  if (substr($k, -1, 1) eq '_') {
    $g_hash = { _  => $g_hash };
    chop $k;
  };

  # Build verbose tree
  $g_hash = { $1 => $g_hash } while $k =~ s/_([^_]+)$//;

  # Set root key
  $$key = $k;
  $dict->{$k} = $g_hash;
};


# Store value as string or code reference
sub _store {
  my $value = $_[0];

  # Is template - store as reference
  return $value if ref $value || $value =~ $TEMPLATE_INDICATOR;
  return \$value;
};


# Merge dictionaries
sub _merge {
  my ($self, $dict_global, $dict, $override) = @_;

  # Iterate over all keys
  foreach my $k (keys %$dict) {

    # This is a short notation key
    if (index($k, '_') > 0) {
      _debug($self, qq![MERGE] Unflatten "$k"!) if DEBUG;

      # Unflatten short notation
      _unflatten(\$k, $dict);
    }

    # Set preferred key
    elsif ($k eq '_') {

      # If override or not set yet, set the new preferred key
      if ($override || !defined $dict_global->{_}) {

        _debug($self, qq![MERGE] Override "_"!) if DEBUG;
        $dict_global->{_} = $dict->{_};
      };

      next;
    };

    # This is a default key
    if (index($k, '-') == 0) {
      my $standalone = 0;

      _debug($self, qq![MERGE] Try to set default key with "$k"!) if DEBUG;

      # This is a prefixed default key
      if (length($k) > 1) {
        $k = substr($k, 1);
        $dict->{$k} = delete $dict->{"-$k"};
      }

      # This is a standalone default key
      else {
        $k = $dict->{'-'};
        $standalone = 1;
      };

      # If override or not set yet, set the new default key
      if ($override || !defined $dict_global->{'-'}) {

        _debug($self, qq![MERGE] Override default key with "$k"!) if DEBUG;
        $dict_global->{'-'} = $k;
      };

      next if $standalone;
    };

    # Insert key - if it not yet exists
    if (!$dict_global->{$k}) {

      # Merge the tree
      if (ref $dict->{$k} eq 'HASH') {
        $self->_merge($dict_global->{$k} = {}, $dict->{$k}, $override);
      }

      # Store the plain value
      else {
        $dict_global->{$k} = _store($dict->{$k});
      };
    }

    # Merge key, when both are hashes
    elsif (ref($dict_global->{$k}) eq ref($dict->{$k}) && ref($dict_global->{$k}) eq 'HASH') {
      $self->_merge($dict_global->{$k}, $dict->{$k}, $override);
    }

    # Override global and store the plain value
    elsif ($override) {
      $dict_global->{$k} = _store($dict->{$k});
    };
  };
};

sub _mark {
  my ($keys, $level) = @_;
  my @x = ();
  for (my $i = 0; $i <= $#$keys; $i++) {
    if ($i == $level) {
      push @x, '[' . $keys->[$i] . ']';
    }
    else {
      push @x, $keys->[$i];
    };
  };

  return join('_',@x);
};

# Lookup dictionary entry recursively
sub _lookup {
  my ($c, $stash, $dict, $key, $level, $find_pref) = @_;
  # $c         is the controller object
  # $stash     contains a hash reference of stash values
  # $dict      contains the dictionary at the current level
  # $key       is the key array passed to the resolver
  # $level     is the current position in the key
  # $find_pref is a boolean value indicating that no value is looked up

  # Get the current input element to consume
  my @keys;
  if (my $primary = $key->[$level]) {
    @keys = ($primary);

    if (DEBUG) {
      _debug($c->app, qq![LOOKUP] There is a primary key "$primary" at input level [$level]!);
      _debug($c->app, qq![LOOKUP] at "! . _mark($key, $level) . '"');
    };
  };

  # No primary key given

  # Check all possibilities
  my $pos = 0;
  my $lazy = 0;


  # Iterate over all possible key fragments
  while () {

    # No more keys
    if (!$keys[$pos]) {

      if (DEBUG) {
        _debug(
          $c->app,
          "[LOOKUP] There is no more key at position $pos on input level [$level]"
        );
      };

      if ($lazy && $find_pref && $level >= $#{$key}) {
        return $keys[$pos-1];
      };

      # Stop processing
      return if $lazy;

      # There is a stop value defined and no primary exists
      push @keys, '.' if $dict->{'.'} && !$keys[0];

      # Lazy load further keys
      # Add preferred keys
      if ($dict->{'_'}) {
        my @matches = _get_pref_keys($c, $dict->{'_'}, $stash);
        if ($matches[0]) {
          if (DEBUG) {
            _debug(
              $c->app,
              qq![LOOKUP] But there are preferred keys "@matches"!
            );
          };
          push @keys, @matches;
        };
      };

      # Add default key
      if ($dict->{'-'}) {
        my $match = $dict->{'-'};
        if (DEBUG) {
          _debug($c->app, qq![LOOKUP] But there is a default key "$match"!);
        };
        push @keys, $match if $match;
      };

      return unless $keys[$pos];

      # There may be items set multiple times
      @keys = uniq @keys;

      _debug($c->app, qq![LOOKUP] Check non-manual keys "@keys"!) if DEBUG;

      $lazy = 1;
    };

    # Key has a match
    if (my $match = $dict->{$keys[$pos]}) {

      # Debug information
      if (DEBUG) {
        _debug(
          $c->app,
          qq![LOOKUP] Found entry for "$keys[$pos]" on input level [$level]!
        );
      };

      # The match is final
      if ((!ref($match) || ref($match) eq 'SCALAR' || ref($match) eq 'CODE') && !$find_pref) {

        # Everything is cosumed - fine
        if ($level >= $#{$key}) {

          # Value is scalar
          if (ref $match eq 'SCALAR') {
            if (DEBUG) {
              _debug(
                $c->app,
                qq![LOOKUP] Found scalar value "$$match"!
              );
            };
            return $$match;
          }

          # Value is a subroutine
          elsif (ref $match eq 'CODE') {
            my $value = $match->($c, %$stash);
            if (DEBUG) {
              _debug(
                $c->app,
                qq![LOOKUP] Found subroutine value as "$value"!
              );
            };
            return $value;
          };

          # Value is a template
          my $value = $c->render_to_string(inline => $match, %$stash);
          chomp($value) unless delete $stash->{no_trim};
          if (DEBUG) {
            _debug(
              $c->app,
              qq![LOOKUP] Found template value as "$value"!
            );
          };
          return $value;
        };

        # Check another path
      }

      # Get the relevant key if everything is consumed
      elsif (ref($match) && $find_pref && $level > $#{$key}) {

        if (DEBUG) {
          _debug(
            $c->app,
            '[PREF] Found key "' . $keys[$pos] . '"'
          );
        };

        return $keys[$pos];
      }

      # No final match found - go on
      else {

        my $level_up = $level;

        # If the primary key was consumed or not given, level up
        if (!$pos || !$key->[$level]) {
          $level_up++;
          if (DEBUG) {
            _debug($c->app, "[LOOKUP] Forward to input level [$level_up]");
          };
        };

        # Call lookup recursively
        my $found = _lookup(
          $c, $stash, $match, $key, $level_up, $find_pref
        );

        # Found something
        return $found if $found;
      };
    };

    # Get next key
    $pos++;
    if (DEBUG) {
      _debug($c->app, "[LOOKUP] Forward to next key at position $pos");
    };
  };
};


# Debug messages
sub _debug {
  my ($app, $msg) = @_;

  # If the value is 2 - debug to stderr
  if (DEBUG == 2) {
    print STDERR "$msg\n";
  }

  # Otherwise debug to log
  else {
    $app->log->debug($msg);
  }
};


# Return preferred keys
sub _get_pref_keys {
  my ($c, $index, $stash) = @_;

  return unless $index;

  # Preferred key is a template
  unless (ref $index) {

    my $key = $c->render_to_string(inline => $index, %$stash);
    chomp($key) unless delete $stash->{no_trim};
    return $key;
  }

  # Preferred key is a subroutine
  elsif (ref $index eq 'CODE') {

    local $_ = $c->localize;
    my $pref = $index->($c);
    return ref $pref ? @$pref : ($pref);
  }

  # Preferred key is an array
  elsif (ref $index eq 'ARRAY') {
    return @{$index};
  };

  # No preferred keys or invalid notation
  return;
};


1;


__END__