File Coverage

blib/lib/Translate/Fluent/ResourceGroup.pm

Criterion	Covered	Total	%
statement	109	129	84.5
branch	37	64	57.8
condition	19	34	55.8
subroutine	12	12	100.0
pod	5	6	83.3
total	182	245	74.2

package Translate::Fluent::ResourceGroup;

use Moo;

has sets => (
  is => 'rw',
  default => sub { {} },
);

has fallback_order  => (
  is => 'ro',
  default => sub { ['language' ] },
);

has default_language => (
  is      => 'ro',
  default => sub { 'en' },
);

use Translate::Fluent::ResourceGroup::Context;
use Translate::Fluent::ResourceSet;

sub __build_self {
  my ($class, $context) = @_;

  my %params = ();
  if ($context->{default_language}) {
    $params{default_language} = delete $context->{default_language};
  }
  if ($context->{fallback_order}) {
    $params{fallback_order} = delete $context->{fallback_order};
  }

  return $class->new( %params );
}

sub slurp_file {
  my ($self, $fname, $context) = @_;

  $self = $self->__build_self( $context )
    unless ref $self;

  local $/ = undef;
  open my $fh, $fname or do {
    warn "Error opening file '$fname'";
    next;
  };

  my $fluent = <$fh>;
  next unless $fluent; # is the file empty?

  if (my ($ctx) = $fluent =~ m{ \A\#\s*context:\s*([^\n]+)\n }x) {
    my %fcontext;

    my @fcontext = map { split /\s*[:=]\s*/, $_, 2 } split /\s*[:=]\s/, $ctx;

    if ( !( scalar @fcontext % 2) ) {
      %fcontext = @fcontext;

      $context->{ $_ } //= $fcontext{ $_ }
        for keys %fcontext;
    } else {
      print STDERR "invalid context: '$ctx'\n";
      warn "Invalid context in fluent file '$fname' - ignoring";
    }
  }

  my $resset =  Translate::Fluent::Parser::parse_string( $fluent );
  if ($resset) {
    $self->add_resource_set( $resset, $context );
  }

  return $self if defined wantarray;

  return;
}

sub slurp_directory {
  my ($self, $directory, $context) = @_;

  $self = $self->__build_self( $context )
    unless ref $self;

  for my $k (qw(default_language fallback_order)) {
    die "'$k' is invalid when adding resources to a resource group"
      if $context->{$k};
  }

  my $recursive = delete $context->{recursive} // 0;

  $directory .='/' unless substr($directory, -1) eq '/';

  opendir my $dh, $directory or die "Can't open $directory: $!";
  my @all = readdir( $dh );
  my @files = grep { m{ \.flt\z }xi } @all;
  closedir( $dh );

  # first we slurp the subdirectories, so that the files
  # on the top directories override the files in the sub directories
  # I could go both ways, but I think it is more intuitive this way
  # TODO: add directory priority to the docs of slurp_directory
  if ($recursive) {
    my @dirs = grep { !m{\A\.} and -d "$directory$_" } @all;

    for my $dir ( @dirs ) {
      $self->slurp_directory( "$directory$dir", $context );
    }
  }

  for my $fname ( @files ) {
    my %context = %{$context};

    my $fname = "$directory$fname";
    $self->slurp_file( $fname, \%context );
  }

  return $self;
}

#TODO: add override priority to add_resource_set docs.
sub add_resource_set {
  my ($self, $resource_set, $context ) = @_;

  my @kv  = ();
  for my $fbo (@{ $self->fallback_order }) {
    my $fbok = $context->{ $fbo }
      || ($fbo eq 'language' ? 'dev' : 'default');

    push @kv, $fbok;
  }

  my $key = join '>', @kv;

  my $reset = $self->sets->{ $key };
  if ( $reset ) {
    for my $k (keys %{ $resource_set->resources }) {
      $reset->add_resource( $resource_set->resources->{ $k } );
    }

  } else {
    $self->sets->{ $key } = $resource_set;

  }

  return;
}

sub translate {
  my ($self, $res_id, $variables, $context) = @_;

  $context = $variables->{__context}
    if !$context and $variables->{__context};

  my $_ctx;
  if (ref $context eq 'Translate::Fluent::ResourceGroup::Context') {
    $_ctx = $context;
    $context = $_ctx->context;
  }

  my $res = $self->_find_resource( $res_id, $context );

  return unless $res and $res->isa("Translate::Fluent::Elements::Message");

  $_ctx ||= Translate::Fluent::ResourceGroup::Context->new(
                context   => $context,
                resgroup  => $self,
              );

  return $res->translate({ %{$variables//{}}, __resourceset => $_ctx });
}

sub get_term {
  my ($self, $term_id, $context) = @_;

  my $term = $self->_find_resource( $term_id, $context );

  return unless $term->isa("Translate::Fluent::Elements::Term");

  return $term;
}

sub get_message {
  my ($self, $message_id, $context) = @_;

  my $res = $self->_find_resource( $message_id, $context );

  return unless $res->isa("Translate::Fluent::Elements::Message");

  return $res;
}

sub _find_resource {
  my ($self, $res_id, $context) = @_;

  my $lang = $context->{language} || $self->default_language;
  my %ctx = ();
  my @fborder = @{ $self->fallback_order };
  for my $fb ( @fborder ) {
    $ctx{ $fb } = $context->{ $fb }
                || (($fb eq 'language') ? $lang : 'default');
  }
  my %fbnext  = map { $fborder[$_-1] => $fborder[$_] } 1..$#fborder;
  my $fbnext  = ($fborder[0]);

  my $res;

  RESSET:
  while (!$res) {
    my $key = join '>', map { $ctx{$_} } @fborder;
#    use Data::Dumper;
#    print STDERR "checking '$key' => ", Dumper( \%ctx );

    if ( my $rset = $self->sets->{ $key }) {
      last RESSET if $res = $rset->resources->{ $res_id };
    }

    my $fbnext_default = $fbnext eq 'language' ? 'dev' : 'default';
    if ($ctx{ $fbnext } eq $fbnext_default) {
      do {
        last RESSET
          unless $fbnext{ $fbnext }; #no where else to look for

        $ctx{ $fbnext } = $context->{ $fbnext }
                        || $fbnext eq 'language' ? $lang : 'default';

        $fbnext = $fbnext{ $fbnext };

      } until $ctx{ $fbnext } ne $fbnext_default;

      $ctx{ $fbnext } = $fbnext eq 'language'
        ? ( $self->__fallback_languages( $ctx{language} ) )[1]
        : 'default';
      $fbnext = $fborder[0];

    } else {
      $ctx{ $fbnext } = $fbnext eq 'language'
        ? ( $self->__fallback_languages( $ctx{language} ) )[1]
        : 'default';
    }
  };

  return $res;
}

sub __fallback_languages {
  my ($self, $lang, $default_lang) = @_;

  $default_lang ||= $self->default_language;

  my @langs = ($lang) if $lang;

  while ($lang and $lang=~m{\-}) {
    $lang =~ s{-\w+\z}{};
    push @langs, $lang;
  }
  unless ($lang eq $default_lang) {
    push @langs, $default_lang;
  }

  push @langs, 'dev' unless $default_lang eq 'dev';

  return @langs;
}

1;

__END__