File Coverage

blib/lib/Time/Duration/LocaleObject.pm

Criterion	Covered	Total	%
statement	87	90	96.6
branch	30	38	78.9
condition	8	12	66.6
subroutine	19	20	95.0
pod	4	5	80.0
total	148	165	89.7

# Copyright 2009, 2010, 2011, 2013, 2016 Kevin Ryde

# This file is part of Time-Duration-Locale.
#
# Time-Duration-Locale is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# Time-Duration-Locale is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Time-Duration-Locale.  If not, see .

package Time::Duration::LocaleObject;
use 5.004;
use strict;
use Carp;
use Module::Load;
use vars qw($VERSION @ISA $AUTOLOAD);

use Class::Singleton;
@ISA = ('Class::Singleton');
*_new_instance = \&new;

$VERSION = 11;

# uncomment this to run the ### lines
#use Smart::Comments;

sub new {
  ### LocaleObject new(): @_
  my ($class, %self) = @_;
  my $self = bless \%self, $class;

  # Load language module now, if given.  You're not supposed to pass both
  # 'module' and 'language', but for now the latter has precedence.
  #
  if (my $module = delete $self{'module'}) {
    $self->module ($module);
  }
  if (my $lang = delete $self{'language'}) {
    $self->language ($lang);
  }

  return $self;
}

# don't go through AUTOLOAD
sub DESTROY {}

sub module {
  my $self = shift;
  ref $self or $self = $self->instance;
  if (@_) {
    # set
    my ($module) = @_;
    if (defined $module) {
      # guard against infinite recursion on Time::Duration::Locale
      # maybe should restrict to lower-case module names
      if ($module eq 'Time::Duration::Locale'
          || $module eq 'Time::Duration::LocaleObject') {
        croak 'Don\'t set module to Locale or LocaleObject';
      }
      Module::Load::load ($module);
    }
    $self->{'module'} = $module;
  }
  # get
  return $self->{'module'};
}

sub language {
  my $self = shift;
  ref $self or $self = $self->instance;
  if (@_) {
    # set
    my ($lang) = @_;
    $self->module (_language_to_module ($lang));
  }
  # get
  my $module = $self->{'module'};
  return (defined $module ? _module_to_language($module) : undef);
}

# maybe it'd be easier to create a Time::Duration::en than mangle the names
sub _language_to_module {
  my ($lang) = @_;
  return ($lang eq 'en' ? 'Time::Duration' : "Time::Duration::$lang");
}
sub _module_to_language {
  my ($module) = @_;
  return ($module eq 'Time::Duration' ? 'en'
          : $module =~ /^Time::Duration::(.*)/ ? $1
          : $module);
}

#------------------------------------------------------------------------------
# setlocale

sub setlocale {
  my ($self) = @_;
  ref $self or $self = $self->instance;
  ### TDLObj setlocale()

  # I18N::LangTags version 0.30 for implicate_supers_strictly(), don't worry
  # about a I18N::LangTags->VERSION(0.30), it'll bomb
  #
  require I18N::LangTags;
  require I18N::LangTags::Detect;

  # Prefer implicate_supers_strictly() over implicate_supers() since the
  # latter loses territory preferences when it converts
  #
  #    en-au, en-gb -> en-au, en, en-gb
  #
  # whereas implicate_supers_strictly() keeps gb ahead of generic en
  #
  #    en-au, en-gb -> en-au, en-gb, en
  #
  # Not that it makes a difference as of July 2010 since there's no
  # territory flavours (only the joke en_PIGLATIN).
  #
  # Chances are though that if you put in territory preferences in $LANGUAGE
  # you'll want to include generics explicitly at the desired points, and in
  # that case implicate_supers() and implicate_supers_strictly() come out
  # the same.
  #
  my %seen;
  my $error;
  foreach my $dashlang (I18N::LangTags::implicate_supers_strictly
                        (I18N::LangTags::Detect::detect()),
                        'en') {
    next if $seen{$dashlang}++;

    (my $lang = $dashlang) =~ s/-(.*)/_\U$1/g;
    ### $dashlang
    ### attempt lang: $lang

    if (eval { $self->language($lang); 1 }) {
      # return value not documented ... don't use it yet
      return $lang;
    }
    $error = $@;
    ### $error
  }
  croak "Time::Duration not available -- $error";
}

#------------------------------------------------------------------------------
# call-through
#
# ENHANCE-ME: Umm, like all AUTOLOAD for class methods this is slightly
# dangerous.  If the base Class::Singleton already has a method the same
# name as the Time::Duration function/method which is supposed to be created
# here then the AUTOLOAD here doesn't run.  Example in
# devel/autoload-singleton.pl.
#
# Should be ok in practice.  The trick would be to stub up funcs for the
# possible methods in the target module, except that's not done immediately
# in new(), and later is too late.  Maybe it'd be worth explicit stubs for
# the normal Time::Duration funcs at least ...
#

sub can {
  my ($self, $name) = @_;
  ### print "TDLObj can(): $name
  return $self->SUPER::can($name) || _make_dispatcher($self,$name);
}
sub AUTOLOAD {
  my $name = $AUTOLOAD;
  ### TDLObj AUTOLOAD(): $name
  $name =~ s/.*://;
  my $code = _make_dispatcher($_[0],$name)
    || croak "No such function $name()";
  goto $code;
}

use vars '$_make_dispatcher';
sub _make_dispatcher {
  my ($class_or_self, $name) = @_;
  ### TDLObj _make_dispatcher(): $class_or_self, $name

  # $_make_dispatcher is recursion protection against bad
  # language_preferences method, or any other undefined method module() or
  # setlocale() might accidentally call here.
  if ($_make_dispatcher
      || do {
        local $_make_dispatcher = 1;
        $class_or_self->module || $class_or_self->setlocale;
        my $module = $class_or_self->module;
        ### module exists: $module
        ### check can(): $name
        ! $module->can($name) }) {
    return undef;
  }

  my $subr = sub {
    #### TDLObj dispatch: $name

    my $self = shift;
    ref $self or $self = $self->instance;
    $self->{'module'} || $self->setlocale;

    my $target = "$self->{'module'}::$name";
    no strict 'refs';
    return &$target(@_);
  };
  { no strict 'refs'; *$name = $subr }
  return $subr;
}

1;
__END__