File Coverage

lib/Locale/Maketext/Utils.pm

Criterion	Covered	Total	%
statement	605	730	82.8
branch	289	444	65.0
condition	76	157	48.4
subroutine	99	113	87.6
pod	61	89	68.5
total	1130	1533	73.7

package Locale::Maketext::Utils;

# these work fine, but are not used in production
# use strict;
# use warnings;
$Locale::Maketext::Utils::VERSION = '0.41';

use Locale::Maketext 1.21 ();
use Locales 0.26          ();
use Locales::DB::CharacterOrientation::Tiny ();
use Locales::DB::LocaleDisplayPattern::Tiny ();

@Locale::Maketext::Utils::ISA = qw(Locale::Maketext);

my %singleton_stash = ();

# This is necessary to support embedded arguments (e.g. '... [output,foo,bar _1 baz] ...') and not interpolate things in the arguments that look like embedded args (e.g. argument #1 is '_2')
sub _compile {
    my ( $lh, $string, @args ) = @_;
    $string =~ s/_TILDE_/~~/g;    # this helps make parsing easier (via code or visually)

    my $compiled = $lh->SUPER::_compile($string);
    return $compiled if ref($compiled) ne 'CODE';

    return sub {
        my ( $lh, @ref_args ) = @_;

        # Change embedded-arg-looking-string to a not-likley-to-exist-but-if-it-does-then-you-have-bigger-problems placeholder (i.e. '_1 -!-1-!-' would act wonky, so don't do that)
        @ref_args = map { s/\_(\-?[0-9]+|\*)/-!-$1-!-/g if defined; $_ } @ref_args;
        my $built = $compiled->( $lh, @ref_args );    # if an method that supported embedded args ever looked for /\_(\-?[0-9]+|\*)/ and acted upon it then it'd need to be aware of this convention and operate on /-!-(\-?[0-9]+|\*)-!-/ instead (or better yet don't have it look for an act upon things that look like bracket notation arguments)
        $built =~ s/-!-(\-?[0-9]+|\*)-!-/_$1/g;       # Change placeholders back to their original

        return $built;
    };
}

# surgically alter a part of L::M::_langtag_munging() that is buggy but cannot otherwise be overridden
no warnings 'redefine';
*I18N::LangTags::panic_languages = sub {              # make it CLDR based instead of arbitrary
    my (@languages) = @_;

    my @tags;

    for my $arg (@languages) {
        next if substr( $arg, 0, 2 ) =~ m/i[-_]/;

        my $loc = Locales->new($arg);
        next if !$loc;
        push @tags, $loc->get_fallback_list();
    }

    return @tags, @languages, 'en';    # same results but CLDR based instead of arbitrary (e.g. it falling back to es, whaaaa?)
};

sub get_handle {
    my ( $class, @langtags ) = @_;

    # order is important so we don't sort() in an attempt to normalize (i.e. fr, es is not the same as es, fr)
    my $args_sig = join( ',', @langtags ) || 'no_args';

    if ( exists $singleton_stash{$class}{$args_sig} ) {
        $singleton_stash{$class}{$args_sig}->{'_singleton_reused'}++;
    }
    else {
        $singleton_stash{$class}{$args_sig} = $class->SUPER::get_handle(@langtags);
    }

    return $singleton_stash{$class}{$args_sig};
}

sub get_locales_obj {
    my ( $lh, $tag ) = @_;
    $tag ||= $lh->get_language_tag();

    if ( !exists $lh->{'Locales.pm'}{$tag} ) {
        $lh->{'Locales.pm'}{$tag} =
             Locales->new($tag)
          || ( $tag ne substr( $tag, 0, 2 ) ? Locales->new( substr( $tag, 0, 2 ) ) : '' )
          || (
            $lh->{'fallback_locale'}
            ?        ( Locales->new( $lh->{'fallback_locale'} )
                  || ( $lh->{'fallback_locale'} ne substr( $lh->{'fallback_locale'}, 0, 2 ) ? Locales->new( substr( $lh->{'fallback_locale'}, 0, 2 ) ) : '' ) )
            : ''
          )
          || Locales->new('en');
    }

    return $lh->{'Locales.pm'}{$tag};
}

sub init {
    my ($lh) = @_;

    $ENV{'maketext_obj'} = $lh if !$ENV{'maketext_obj_skip_env'};

    $lh->SUPER::init();
    $lh->remove_key_from_lexicons('_AUTO');

    # use the base class if available, then the class itself if available
    no strict 'refs';
    for my $ns ( $lh->get_base_class(), $lh->get_language_class() ) {
        if ( defined ${ $ns . '::Encoding' } ) {
            $lh->{'encoding'} = ${ $ns . '::Encoding' } if ${ $ns . '::Encoding' };
        }
    }

    # This will happen on the first call to get_context() or context_is*() so we do not do it here to avoid doing the work unless we actually need it.
    # $lh->set_context();

    $lh->fail_with(
        sub {
            my ( $lh, $key, @args ) = @_;

            my $lookup;
            if ( exists $lh->{'_get_key_from_lookup'} ) {
                if ( ref $lh->{'_get_key_from_lookup'} eq 'CODE' ) {
                    $lookup = $lh->{'_get_key_from_lookup'}->( $lh, $key, @args );
                }
            }

            return $lookup if defined $lookup;

            if ( exists $lh->{'_log_phantom_key'} ) {
                if ( ref $lh->{'_log_phantom_key'} eq 'CODE' ) {
                    $lh->{'_log_phantom_key'}->( $lh, $key, @args );
                }
            }

            if ( $lh->{'use_external_lex_cache'} ) {
                local $lh->{'_external_lex_cache'}{'_AUTO'} = 1;

                # _AUTO does not short circuit _ keys so we can get a loop
                if ( $key =~ m/^_/s ) {
                    return $lh->{'_external_lex_cache'}{$key} = $key;
                }
                return $lh->maketext( $key, @args );
            }
            else {
                no strict 'refs';
                local ${ $lh->get_base_class() . '::Lexicon' }{'_AUTO'} = 1;

                # _AUTO does not short circuit _ keys so we can get a loop
                if ( $key =~ m/^_/s ) {
                    return ${ $lh->get_base_class() . '::Lexicon' }{$key} = $key;
                }

                return $lh->maketext( $key, @args );
            }
        }
    );
}

sub makevar {
    my ( $lh, $phrase, @args ) = @_;
    @_ = ( $lh, @{$phrase} ) if !@args && ref($phrase) eq 'ARRAY';    # Feature per rt 85588
    goto &Locale::Maketext::maketext;
}

# TODO Normalize White Space [into key form] (name? export, do meth/function or just funtion?, etc), needs POD and tests once finalized (update parser also: rt 80489)
# sub _NWS {
#
#     # $lh->_NWS($str) || _NWS($str)
#     my $string = @_ > 1 ? $_[1] : $_[0];
#
#     $string =~ s/\s+/ /g;
#     $string =~ s/\A(?:\x20|\xc2\xa0)+//g;      # remove leading white space
#     $string =~ s/(?:\x20|\xc2\xa0){2,}/ /g;    # collapse multiple internal white space
#     $string =~ s/(?:\x20|\xc2\xa0)+\z//g;      # remove trailing white space
#     if ( substr( $string, 0, 3 ) eq "\xE2\x80\xA6" ) {
#         $string = " $string";
#     }
#     return $string;
# }

sub makethis {
    my ( $lh, $phrase, @phrase_args ) = @_;

    $lh->{'cache'}{'makethis'}{$phrase} ||= $lh->_compile($phrase);

    my $type = ref( $lh->{'cache'}{'makethis'}{$phrase} );

    if ( $type eq 'SCALAR' ) {
        return ${ $lh->{'cache'}{'makethis'}{$phrase} };
    }
    elsif ( $type eq 'CODE' ) {
        return $lh->{'cache'}{'makethis'}{$phrase}->( $lh, @phrase_args );
    }
    else {

        # ? carp() ?
        return $lh->{'cache'}{'makethis'}{$phrase};
    }
}

# We do this because we do not want the language semantics of $lh
sub makethis_base {
    my ($lh) = @_;
    $lh->{'cache'}{'makethis_base'} ||= $lh->get_base_class()->get_handle( $lh->{'fallback_locale'} || 'en' );    # this allows to have a seperate cache of compiled phrases (? get_handle() explicit or base_locales() (i.e. en en_us i_default || L::M->fallback_languages) ?)
    return $lh->{'cache'}{'makethis_base'}->makethis( @_[ 1 .. $#_ ] );
}

sub make_alias {
    my ( $lh, $pkgs, $is_base_class ) = @_;

    my $ns = $lh->get_language_class();
    return if $ns !~ m{ \A \w+ (::\w+)* \z }xms;
    my $base = $is_base_class ? $ns : $lh->get_base_class();

    no strict 'refs';
    for my $pkg ( ref $pkgs ? @{$pkgs} : $pkgs ) {
        next if $pkg !~ m{ \A \w+ (::\w+)* \z }xms;
        *{ $base . '::' . $pkg . '::VERSION' }  = *{ $ns . '::VERSION' };
        *{ $base . '::' . $pkg . '::Encoding' } = *{ $ns . '::Encoding' };
        *{ $base . '::' . $pkg . '::Lexicon' }  = *{ $ns . '::Lexicon' };
        @{ $base . '::' . $pkg . '::ISA' }      = ($ns);
    }
}

sub remove_key_from_lexicons {
    my ( $lh, $key ) = @_;
    my $idx = 0;

    for my $lex_hr ( @{ $lh->_lex_refs() } ) {
        $lh->{'_removed_from_lexicons'}{$idx}{$key} = delete $lex_hr->{$key} if exists $lex_hr->{$key};
        $idx++;
    }
}

sub get_base_class {
    my $ns = shift->get_language_class();
    $ns =~ s{::\w+$}{};
    return $ns;
}

sub append_to_lexicons {
    my ( $lh, $appendage ) = @_;
    return if ref $appendage ne 'HASH';

    no strict 'refs';
    for my $lang ( keys %{$appendage} ) {
        my $ns = $lh->get_base_class() . ( $lang eq '_' ? '' : "::$lang" ) . '::Lexicon';
        %{$ns} = ( %{$ns}, %{ $appendage->{$lang} } );
    }
}

sub langtag_is_loadable {
    my ( $lh, $wants_tag ) = @_;
    $wants_tag = Locale::Maketext::language_tag($wants_tag);

    # why doesn't this work ?
    # no strict 'refs';
    # my $tag_obj = ${ $lh->get_base_class() }->get_handle( $wants_tag );
    my $tag_obj = eval $lh->get_base_class() . q{->get_handle( $wants_tag );};

    my $has_tag = $tag_obj->language_tag();
    return $wants_tag eq $has_tag ? $tag_obj : 0;
}

sub get_language_tag {
    return ( split '::', shift->get_language_class() )[-1];
}

sub print {
    local $Carp::CarpLevel = 1;
    print shift->maketext(@_);
}

sub fetch {
    local $Carp::CarpLevel = 1;
    return shift->maketext(@_);
}

sub say {
    local $Carp::CarpLevel = 1;
    my $text = shift->maketext(@_);
    local $/ = !defined $/ || !$/ ? "\n" : $/;    # otherwise assume they are not stupid
    print $text . $/ if $text;
}

sub get {
    local $Carp::CarpLevel = 1;
    my $text = shift->maketext(@_);
    local $/ = !defined $/ || !$/ ? "\n" : $/;    # otherwise assume they are not stupid
    return $text . $/ if $text;
    return;
}

sub get_language_tag_name {
    my ( $lh, $tag, $in_locale_tongue ) = @_;
    $tag ||= $lh->get_language_tag();

    my $loc_obj = $lh->get_locales_obj( $in_locale_tongue ? () : ($tag) );

    return $loc_obj->get_language_from_code($tag);
}

sub get_html_dir_attr {
    my ( $lh, $raw_cldr, $is_tag ) = @_;

    if ($is_tag) {
        $raw_cldr = $lh->get_language_tag_character_orientation($raw_cldr);
    }
    else {
        $raw_cldr ||= $lh->get_language_tag_character_orientation();
    }

    if ( $raw_cldr eq 'left-to-right' ) {
        return 'ltr';
    }
    elsif ( $raw_cldr eq 'right-to-left' ) {
        return 'rtl';
    }

    return;
}

sub get_locale_display_pattern {

    # my ( $lh, $tag ) = @_;
    # $tag ||= $lh->get_language_tag();

    return Locales::DB::LocaleDisplayPattern::Tiny::get_locale_display_pattern( $_[1] || $_[0]->{'fallback_locale'} || $_[0]->get_language_tag() );
}

sub get_language_tag_character_orientation {

    # my ( $lh, $tag ) = @_;
    # $tag ||= $lh->get_language_tag();

    return Locales::DB::CharacterOrientation::Tiny::get_orientation( $_[1] || $_[0]->{'fallback_locale'} || $_[0]->get_language_tag() );
}

sub text {
    require Carp;
    Carp::carp('text() is deprecated, use lextext() instead');
    goto &lextext;
}

sub lextext {

    require Carp;

    # Remember, this can fail.  Failure is controllable many ways.
    Carp::croak 'lextext() requires a single parameter' unless @_ == 2;

    my ( $handle, $phrase ) = splice( @_, 0, 2 );
    Carp::confess('No handle/phrase') unless ( defined($handle) && defined($phrase) );

    if ( !$handle->{'use_external_lex_cache'} ) {
        Carp::carp("lextext() requires you to have 'use_external_lex_cache' enabled.");
        return;
    }

    # backup $@ in case it is still being used in the calling code.
    # If no failures, we'll re-set it back to what it was later.
    my $at = $@;

    # Copy @_ case one of its elements is $@.
    @_ = @_;

    # Look up the value:

    my $value;
    foreach my $h_r ( @{ $handle->_lex_refs } ) {    # _lex_refs() caches itself

        # DEBUG and warn "* Looking up \"$phrase\" in $h_r\n";
        if ( exists $h_r->{$phrase} ) {

            if ( ref( $h_r->{$phrase} ) ) {
                Carp::carp("Previously compiled phrase ('use_external_lex_cache' enabled after phrase was compiled?)");
            }

            # DEBUG and warn "  Found \"$phrase\" in $h_r\n";
            $value = $h_r->{$phrase};
            last;
        }

        # extending packages need to be able to localize _AUTO and if readonly can't "local $h_r->{'_AUTO'} = 1;"
        # but they can "local $handle->{'_external_lex_cache'}{'_AUTO'} = 1;"
        elsif ( $phrase !~ m/^_/s and $h_r->{'_AUTO'} ) {

            # it is an auto lex, and this is an autoable key!
            # DEBUG and warn "  Automaking \"$phrase\" into $h_r\n";
            $value = $phrase;
            last;
        }

        # DEBUG > 1 and print "  Not found in $h_r, nor automakable\n";

        # else keep looking
    }

    unless ( defined($value) ) {

        # DEBUG and warn "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle, " fails.\n";
    }

    $@ = $at;    # Put $@ back in case we altered it along the way.
    return $value;
}

sub lang_names_hashref {
    my ( $lh, @langcodes ) = @_;

    if ( !@langcodes ) {    # they havn't specified any langcodes...
        require File::Spec;    # only needed here, so we don't use() it

        my @search;
        my $path = $lh->get_base_class();
        $path =~ s{::}{/}g;    # !!!! make this File::Spec safe !! File::Spec->separator() !-e

        if ( ref $lh->{'_lang_pm_search_paths'} eq 'ARRAY' ) {
            @search = @{ $lh->{'_lang_pm_search_paths'} };
        }

        @search = @INC if !@search;    # they havn't told us where they are specifically

      DIR:
        for my $dir (@search) {
            my $lookin = File::Spec->catdir( $dir, $path );
            next DIR if !-d $lookin;
            if ( opendir my $dh, $lookin ) {
              PM:
                for my $pm ( grep { /^\w+\.pm$/ } grep !/^\.+$/, readdir($dh) ) {
                    $pm =~ s{\.pm$}{};
                    next PM if !$pm;
                    next PM if $pm eq 'Utils';
                    push @langcodes, $pm;
                }
                closedir $dh;
            }
        }
    }

    # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
    # method call if we already have the Locales object that belongs to the handle's locale.
    $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();

    my $langname  = {};
    my $native    = wantarray && $Locales::VERSION > 0.06 ? {} : undef;
    my $direction = wantarray && $Locales::VERSION > 0.09 ? {} : undef;

    for my $code ( 'en', @langcodes ) {    # en since it is "built in"

        $langname->{$code} = $lh->{'Locales.pm'}{'_main_'}->get_language_from_code( $code, 1 );

        if ( defined $native ) {
            $native->{$code} = $lh->{'Locales.pm'}{'_main_'}->get_native_language_from_code( $code, 1 );
        }

        if ( defined $direction ) {
            $direction->{$code} = $lh->{'Locales.pm'}{'_main_'}->get_character_orientation_from_code_fast($code);
        }
    }

    return wantarray ? ( $langname, $native, $direction ) : $langname;
}

sub loadable_lang_names_hashref {
    my ( $lh, @langcodes ) = @_;

    my $langname = $lh->lang_names_hashref(@langcodes);

    for my $tag ( keys %{$langname} ) {
        delete $langname->{$tag} if !$lh->langtag_is_loadable($tag);
    }

    return $langname;
}

sub add_lexicon_override_hash {
    my ( $lh, $langtag, $name, $hr ) = @_;
    if ( @_ == 3 ) {
        $hr      = $name;
        $name    = $langtag;
        $langtag = $lh->get_language_tag();
    }

    my $ns = $lh->get_language_tag() eq $langtag ? $lh->get_language_class() : $lh->get_base_class();

    no strict 'refs';
    if ( my $ref = tied( %{ $ns . '::Lexicon' } ) ) {
        return 1 if $lh->{'add_lex_hash_silent_if_already_added'} && exists $ref->{'hashes'} && exists $ref->{'hashes'}{$name};
        if ( $ref->can('add_lookup_override_hash') ) {
            return $ref->add_lookup_override_hash( $name, $hr );
        }
    }

    my $cur_errno = $!;
    if ( eval { require Sub::Todo } ) {
        goto &Sub::Todo::todo;
    }
    else {
        $! = $cur_errno;
        return;
    }
}

sub add_lexicon_fallback_hash {
    my ( $lh, $langtag, $name, $hr ) = @_;
    if ( @_ == 3 ) {
        $hr      = $name;
        $name    = $langtag;
        $langtag = $lh->get_language_tag();
    }

    my $ns = $lh->get_language_tag() eq $langtag ? $lh->get_language_class() : $lh->get_base_class();

    no strict 'refs';
    if ( my $ref = tied( %{ $ns . '::Lexicon' } ) ) {
        return 1 if $lh->{'add_lex_hash_silent_if_already_added'} && exists $ref->{'hashes'} && exists $ref->{'hashes'}{$name};
        if ( $ref->can('add_lookup_fallback_hash') ) {
            return $ref->add_lookup_fallback_hash( $name, $hr );
        }
    }

    my $cur_errno = $!;
    if ( eval { require Sub::Todo } ) {
        goto &Sub::Todo::todo;
    }
    else {
        $! = $cur_errno;
        return;
    }
}

sub del_lexicon_hash {
    my ( $lh, $langtag, $name ) = @_;

    if ( @_ == 2 ) {
        return if $langtag eq '*';
        $name    = $langtag;
        $langtag = '*';
    }

    return if !$langtag;

    my $count = 0;
    if ( $langtag eq '*' ) {
        no strict 'refs';
        for my $ns ( $lh->get_base_class(), $lh->get_language_class() ) {
            if ( my $ref = tied( %{ $ns . '::Lexicon' } ) ) {
                if ( $ref->can('del_lookup_hash') ) {
                    $ref->del_lookup_hash($name);
                    $count++;
                }
            }
        }

        return 1 if $count;

        my $cur_errno = $!;
        if ( eval { require Sub::Todo } ) {
            goto &Sub::Todo::todo;
        }
        else {
            $! = $cur_errno;
            return;
        }
    }
    else {
        my $ns = $lh->get_language_tag() eq $langtag ? $lh->get_language_class() : $lh->get_base_class();

        no strict 'refs';
        if ( my $ref = tied( %{ $ns . '::Lexicon' } ) ) {
            if ( $ref->can('del_lookup_hash') ) {
                return $ref->del_lookup_hash($name);
            }
        }

        my $cur_errno = $!;
        if ( eval { require Sub::Todo } ) {
            goto &Sub::Todo::todo;
        }
        else {
            $! = $cur_errno;
            return;
        }
    }
}

sub get_language_class {
    my ($lh) = @_;
    return ( ref($lh) || $lh );
}

# $Autoalias is a bad idea, if we did this method we'd need to do a proper symbol/ISA traversal
# sub get_alias_list {
#    my ($lh, $ns) = @_;
#    $ns ||= $lh->get_base_class();
#
#    no strict 'refs';
#    if (defined @{ $ns . "::Autoalias"}) {
#        return @{ $ns . "::Autoalias"};
#    }
#
#    return;
# }

sub get_base_class_dir {
    my ($lh) = @_;
    if ( !exists $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'} ) {
        $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'} = undef;

        my $inc_key = $lh->get_base_class();

        # require File::Spec;  # only needed here, so we don't use() it
        $inc_key =~ s{::}{/}g;    # TODO make portable via File::Spec
        $inc_key .= '.pm';
        if ( exists $INC{$inc_key} ) {
            if ( -e $INC{$inc_key} ) {
                $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'} = $INC{$inc_key};
                $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'} =~ s{\.pm$}{};
            }
        }
    }

    return $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'};
}

sub list_available_locales {
    my ($lh) = @_;

    # all comments in this function relate to get_alias_list() above
    # my ($lh, $include_fileless_aliases) = @_;

    # my $base;
    # if ($include_fileless_aliases) {
    #     $base = $lh->get_base_class_dir();
    # }

    my $main_ns_dir = $lh->get_base_class_dir() || return;

    # glob() is disabled in some environments
    my @glob;
    if ( opendir my $dh, $main_ns_dir ) {
        @glob = map { ( m{([^/]+)\.pm$} && $1 ne 'Utils' ) ? $1 : () } readdir($dh);    #de-taint
        closedir $dh;
    }

    # return ($lh->get_alias_list($base)), grep { $_ ne 'Utils' }
    return sort @glob;
}

sub get_asset {
    my ( $lh, $code, $tag ) = @_;                                                       # No caching since $code can do anything.

    my $loc_obj = $lh->get_locales_obj($tag);

    my $ret;
    my $loc;                                                                            # buffer
    for $loc ( $loc_obj->get_fallback_list( $lh->{'Locales.pm'}{'get_fallback_list_special_lookup_coderef'} ) ) {

        # allow $code to be a soft ref?
        # no strict 'refs';
        $ret = $code->($loc);
        last if defined $ret;
    }

    return $ret if defined $ret;
    return;
}

sub get_asset_file {
    my ( $lh, $find, $return ) = @_;
    $return = $find if !defined $return;

    return $lh->{'cache'}{'get_asset_file'}{$find}{$return} if exists $lh->{'cache'}{'get_asset_file'}{$find}{$return};

    $lh->{'cache'}{'get_asset_file'}{$find}{$return} = $lh->get_asset(
        sub {
            return sprintf( $return, $_[0] ) if -f sprintf( $find, $_[0] );
            return;
        }
    );

    return $lh->{'cache'}{'get_asset_file'}{$find}{$return} if defined $lh->{'cache'}{'get_asset_file'}{$find}{$return};
    return;
}

sub get_asset_dir {
    my ( $lh, $find, $return ) = @_;
    $return = $find if !defined $return;

    return $lh->{'cache'}{'get_asset_dir'}{$find}{$return} if exists $lh->{'cache'}{'get_asset_dir'}{$find}{$return};

    $lh->{'cache'}{'get_asset_dir'}{$find}{$return} = $lh->get_asset(
        sub {
            return sprintf( $return, $_[0] ) if -d sprintf( $find, $_[0] );
            return;
        }
    );

    return $lh->{'cache'}{'get_asset_dir'}{$find}{$return} if defined $lh->{'cache'}{'get_asset_dir'}{$find}{$return};
    return;
}

sub delete_cache {
    my ( $lh, $which ) = @_;
    if ( defined $which ) {
        return delete $lh->{'cache'}{$which};
    }
    else {
        return delete $lh->{'cache'};
    }
}

#### CLDR aware quant()/numerate ##

sub quant {
    my ( $handle, $num, @forms ) = @_;

    my $max_decimal_places = 3;

    if ( ref($num) eq 'ARRAY' ) {
        $max_decimal_places = $num->[1];
        $num                = $num->[0];
    }

    # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
    # method call if we already have the Locales object that belongs to the handle's locale.
    $handle->{'Locales.pm'}{'_main_'} ||= $handle->get_locales_obj();

    # numerate() is scalar context get_plural_form(), we need array context get_plural_form() here
    my ( $string, $spec_zero ) = $handle->{'Locales.pm'}{'_main_'}->get_plural_form( $num, @forms );

    # If you find a need for more than 1 %s please submit an rt w/ details
    if ( $string =~ m/%s\b/ ) {
        return sprintf( $string, $handle->numf( $num, $max_decimal_places ) );
    }
    elsif ( $num == 0 && $spec_zero ) {
        return $string;
    }
    else {
        $handle->numf( $num, $max_decimal_places ) . " $string";
    }
}

sub numerate {
    my ( $handle, $num, @forms ) = @_;

    # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
    # method call if we already have the Locales object that belongs to the handle's locale.
    $handle->{'Locales.pm'}{'_main_'} ||= $handle->get_locales_obj();

    return scalar( $handle->{'Locales.pm'}{'_main_'}->get_plural_form( $num, @forms ) );
}

#### CLDR aware quant()/numerate ##

#### CLDR aware numf() w/ decimal ##

sub numf {
    my ( $handle, $num, $max_decimal_places ) = @_;

    # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
    # method call if we already have the Locales object that belongs to the handle's locale.
    $handle->{'Locales.pm'}{'_main_'} ||= $handle->get_locales_obj();

    return $handle->{'Locales.pm'}{'_main_'}->get_formatted_decimal( $num, $max_decimal_places );
}

#### / CLDR aware numf() w/ decimal/formatter ##

#### more BN methods ##

# W1301 revision 1:
#   [value] was a proposed way to avoid ambiguous '_thisthing' keys by "tagging" a phrase
#   as having a value different from the key while keeping it self-documenting:
#     '[value] Description of foo, arguments are …'
# sub value {
#      my ($lh, @contexts) = @_;
#
#      return '' if !@contexts; # must be for all contexts, cool
#
#      my $context = $lh->get_context();
#
#      if (!grep { $context eq $_ } @contexts) {
#          require Carp;
#          local $Carp::CarpLevel = 1;
#          my $context_csv = join(',',@contexts);
#          Carp::carp("The current context “$context” is not supported by the phrase ([value,$context_csv])");
#      }
#      return '';
# }

sub join {
    shift;
    return CORE::join( shift, map { ref($_) eq 'ARRAY' ? @{$_} : $_ } @_ );
}

sub list_and {
    my $lh = shift;

    # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
    # method call if we already have the Locales object that belongs to the handle's locale.
    $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();
    return $lh->{'Locales.pm'}{'_main_'}->get_list_and( map { ref($_) eq 'ARRAY' ? @{$_} : $_ } @_ );
}

sub list_or {
    my $lh = shift;

    # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
    # method call if we already have the Locales object that belongs to the handle's locale.
    $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();
    return $lh->{'Locales.pm'}{'_main_'}->get_list_or( map { ref($_) eq 'ARRAY' ? @{$_} : $_ } @_ );
}

sub list_and_quoted {
    my ( $lh, @args ) = @_;

    $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();
    local $lh->{'Locales.pm'}{'_main_'}{'misc'}{'list_quote_mode'} = 'all';
    return $lh->list_and(@args);
}

sub list_or_quoted {
    my ( $lh, @args ) = @_;

    $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();
    local $lh->{'Locales.pm'}{'_main_'}{'misc'}{'list_quote_mode'} = 'all';
    return $lh->list_or(@args);
}

sub list {
    require Carp;
    Carp::carp('list() is deprecated, use list_and() or list_or() instead');

    my $lh      = shift;
    my $com_sep = ', ';
    my $oxford  = ',';
    my $def_sep = '&';

    if ( ref($lh) ) {
        $com_sep = $lh->{'list_separator'}   if exists $lh->{'list_separator'};
        $oxford  = $lh->{'oxford_separator'} if exists $lh->{'oxford_separator'};
        $def_sep = $lh->{'list_default_and'} if exists $lh->{'list_default_and'};
    }

    my $sep = shift || $def_sep;
    return if !@_;

    my @expanded = map { ref($_) eq 'ARRAY' ? @{$_} : $_ } @_;
    if ( @expanded == 1 ) {
        return $expanded[0];
    }
    elsif ( @expanded == 2 ) {
        return CORE::join( " $sep ", @expanded );
    }
    else {
        my $last = pop @expanded;
        return CORE::join( $com_sep, @expanded ) . "$oxford $sep $last";
    }
}

sub output_asis {
    return $_[1];
}

sub asis {
    return $_[0]->output( 'asis', $_[1] );    # this allows for embedded methods but still called via [asis,...] instead of [output,asis,...]
}

sub comment {
    return '';
}

sub is_future {
    my ( $lh, $dt, $future, $past, $current, $current_type ) = @_;

    if ( $dt !~ m/\A[0-9]+\z/ ) {
        $dt = __get_dt_obj_from_arg( $dt, 0 );
        $dt = $dt->epoch();
    }

    if ($current) {
        if ( !ref $dt ) {
            $dt = __get_dt_obj_from_arg( $dt, 0 );
        }
        $current_type ||= 'hour';

        if ( $current_type eq 'day' ) {

            # TODO implement
        }
        elsif ( $current_type eq 'minute' ) {

            # TODO implement
        }
        else {

            # TODO implement
        }
    }

    return ref $dt ? $dt->epoch() : $dt > time() ? $future : $past;
}

sub __get_dt_obj_from_arg {
    require DateTime;
    return
       !defined $_[0] || $_[0] eq '' ? DateTime->now()
      : ref $_[0] eq 'HASH' ? DateTime->new( %{ $_[0] } )
      : $_[0] =~ m{ \A (\d+ (?: [.] \d+ )? ) (?: [:] (.*) )? \z }xms ? DateTime->from_epoch( 'epoch' => $1, 'time_zone' => ( $2 || 'UTC' ) )
      : !ref $_[0] ? DateTime->now( 'time_zone' => ( $_[0] || 'UTC' ) )
      : $_[1]      ? $_[0]->clone()
      :              $_[0];
}

sub current_year {
    $_[0]->datetime( '', 'YYYY' );
}

sub datetime {
    my ( $lh, $dta, $str ) = @_;
    my $dt = __get_dt_obj_from_arg( $dta, 1 );

    $dt->{'locale'} = DateTime::Locale->load( $lh->language_tag() );
    my $format = ref $str eq 'CODE' ? $str->($dt) : $str;
    if ( defined $format ) {
        if ( $dt->{'locale'}->can($format) ) {
            $format = $dt->{'locale'}->$format();
        }
    }

    $format = '' if !defined $format;
    return $dt->format_cldr( $dt->{'locale'}->format_for($format) || $format || $dt->{'locale'}->date_format_long() );
}

sub output_amp  { return $_[0]->output_chr(38) }    # TODO: ? make the rest of these embeddable like amp() ?
sub output_lt   { return $_[0]->output_chr(60) }
sub output_gt   { return $_[0]->output_chr(62) }
sub output_apos { return $_[0]->output_chr(39) }
sub output_quot { return $_[0]->output_chr(34) }
sub output_shy  { return $_[0]->output_chr(173) }

# sub output_codepoint {
#     my $cp = $_[1];
#     $cp =~ s/[^0-9a-fA-F]+//g;
#     return if !$cp;
#     return "U+$cp";
# }
#
# my %latin = (
#     'etc'   => 'etc.',            # et cetera: And [more|the rest|so on]
#     'ie'    => 'i.e.',            # id est: that is
#     'eg'    => 'e.g.',            # exempli gratia: for the sake of example
#     'ps'    => 'p.s.',            # after what has been written
#     'pps'   => 'p.p.s.',          # post post scriptum
#     'etal'  => 'et al.',          # et alii: and others
#     'cf'    => 'cf.',             # compare to
#     'vs'    => 'vs',              # versus
#     'v'     => 'v.',              # shorter version of vs
#     'adhoc' => 'ad hoc',          # for this (improvised or made for a specific, immediate purpose)
#     'adinf' => 'ad infinitum',    # to infinity
#     'adint' => 'ad interim',      # or the meantime
#     're'    => 'Re',              # by the thing, in the matter of
#     'rip'   => 'R.I.P.',          # requiescat in pace
#     'qv'    => 'q.v.',            # quod vide
# );
#
# sub output_latin {
#    return if !exists $latin{$_[1]};
#    return $_[0]->makethis($latin{$_[1]}); # makethis() would allow for [output,abbr,…] and [output,acronym,…]
# }

sub output_nbsp {

    # Use grapheme here since the NO-BREAK SPACE is visually ambiguous when typed (e.g. OSX option-space)

    # The character works the same as the entity so checking the context doesn't gain us much.
    # Any interest in being able to specify a mode that you might want the entity under HTML mode?
    # my ($lh, $context_aware) = @_;
    # if ($context_aware) {
    #     return $lh->context_is_html() ? ' ' : "\xC2\xA0";
    # }
    # else {
    #     return "\xC2\xA0";
    # }
    # or simply do the entity:
    # return $_[0]->context_is_html() ? ' ' : "\xC2\xA0";

    return "\xC2\xA0";
}

my $space;

sub format_bytes {
    my ( $lh, $bytes, $max_decimal_place ) = @_;
    $bytes ||= 0;

    if ( !defined $max_decimal_place ) {
        $max_decimal_place = 2;
    }
    else {
        $max_decimal_place = int( abs($max_decimal_place) );
    }

    my $absnum = abs($bytes);

    $space ||= $lh->output_nbsp();    # avoid method call if we already have it

    # override if you want different behavior or more flexibility, as-is these are the ideas behind it:
    #     * Calculate via 1024's not 1000's
    #     * Max decimals set to 2 (this is for human consumption not math operation)
    #     * Either 'n byte/n bytes' (since there is no good universal suffix for "byte")
    #       or 'n . non-breaking-space . SI-SUFFIX' (Yes technically MiB is more accurate
    #         here than MB, but for now it has to remain this way for legacy reasons)
    #     * simple math/logic is done here so that there is no need to bring in a module
    if ( $absnum < 1024 ) {

        # This is a special, internal-to-format_bytes, phrase: developers will not have to deal with this phrase directly.
        return $lh->maketext( '[quant,_1,%s byte,%s bytes]', [ $bytes, $max_decimal_place ] );    # the space between the '%s' and the 'b' is a non-break space (e.g. option-spacebar, not spacebar)
                                                                                                    # We do not use $space or \xC2\xA0 since:
                                                                                                    #   * parsers would need to know how to interpolate them in order to work with the phrase in the context of the system
                                                                                                    #   * the non-breaking space character behaves as you'd expect its various representations to.
                                                                                                    # Should a second instance of this sort of thing happen we can revisit the idea of adding [comment] in the phrase itself or perhaps supporting an embedded call to [output,nbsp].
    }
    elsif ( $absnum < 1048576 ) {
        return $lh->numf( ( $bytes / 1024 ), $max_decimal_place ) . $space . 'KB';
    }
    elsif ( $absnum < 1073741824 ) {
        return $lh->numf( ( $bytes / 1048576 ), $max_decimal_place ) . $space . 'MB';
    }
    elsif ( $absnum < 1099511627776 ) {
        return $lh->numf( ( $bytes / 1073741824 ), $max_decimal_place ) . $space . 'GB';
    }
    elsif ( $absnum < 1125899906842624 ) {
        return $lh->numf( ( $bytes / 1099511627776 ), $max_decimal_place ) . $space . 'TB';
    }
    elsif ( $absnum < ( 1125899906842624 * 1024 ) ) {
        return $lh->numf( ( $bytes / 1125899906842624 ), $max_decimal_place ) . $space . 'PB';
    }
    elsif ( $absnum < ( 1125899906842624 * 1024 * 1024 ) ) {
        return $lh->numf( ( $bytes / ( 1125899906842624 * 1024 ) ), $max_decimal_place ) . $space . 'EB';
    }
    elsif ( $absnum < ( 1125899906842624 * 1024 * 1024 * 1024 ) ) {
        return $lh->numf( ( $bytes / ( 1125899906842624 * 1024 * 1024 ) ), $max_decimal_place ) . $space . 'ZB';
    }
    else {

        # any reason to do the commented out code? if so please rt w/ details!
        # elsif ( $absnum < ( 1125899906842624 * 1024 * 1024 * 1024 * 1024 ) ) {
        return $lh->numf( ( $bytes / ( 1125899906842624 * 1024 * 1024 * 1024 ) ), $max_decimal_place ) . $space . 'YB';

        # }
        # else {
        #
        #    # This should never happen but just in case lets show something:
        #    return $lh->maketext( '[quant,_1,%s byte,%s bytes]', $bytes ); # See info about this above/incorporate said info should this ever be uncommented
    }
}

sub convert {
    shift;
    require Math::Units;
    return Math::Units::convert(@_);
}

sub is_defined {
    my ( $lh, $value, $is_defined, $not_defined, $is_defined_but_false ) = @_;

    return __proc_string_with_embedded_under_vars($not_defined) if !defined $value;

    if ( defined $is_defined_but_false && !$value ) {
        return __proc_string_with_embedded_under_vars($is_defined_but_false);
    }
    else {
        return __proc_string_with_embedded_under_vars($is_defined);
    }
}

sub boolean {
    my ( $lh, $boolean, $true, $false, $null ) = @_;
    if ($boolean) {
        return __proc_string_with_embedded_under_vars($true);
    }
    else {
        if ( !defined $boolean && defined $null ) {
            return __proc_string_with_embedded_under_vars($null);
        }
        return __proc_string_with_embedded_under_vars($false);
    }
}

sub __proc_string_with_embedded_under_vars {
    my $str = $_[0];
    return if !defined $str;

    return $str if $str !~ m/\_(\-?[0-9]+)/;
    my @args = __caller_args( $_[1] );    # this way be dragons
    $str =~ s/\_(\-?[0-9]+)/$args[$1]/g;
    return $str;
}

# sweet sweet magic stolen from Devel::Caller
sub __caller_args {

    package DB;
    () = caller( $_[0] + 3 );
    return @DB::args;
}

sub __proc_emb_meth {
    my ( $lh, $str ) = @_;

    return if !defined $str;

    $str =~ s/(su[bp])\(((?:\\\)|[^\)])+?)\)/my $s=$2;my $m="output_$1";$s=~s{\\\)}{\)}g;$lh->$m($s)/eg;
    $str =~ s/chr\(((?:\d+|[\S]))\)/$lh->output_chr($1)/eg;
    $str =~ s/numf\((\d+(?:\.\d+)?)\)/$lh->numf($1)/eg;
    $str =~ s/amp\(\)/$lh->output_amp()/eg;

    return $str;
}

sub output {
    my ( $lh, $output_function, $string, @output_function_args ) = @_;

    if ( defined $string && $string ne '' && $string =~ tr/(// ) {
        $string = __proc_emb_meth( $lh, $string );
    }

    if ( my $cr = $lh->can( 'output_' . $output_function ) ) {
        return $cr->( $lh, $string, @output_function_args );
    }
    else {
        my $cur_errno = $!;
        if ( eval { require Sub::Todo } ) {
            $! = Sub::Todo::get_errno_func_not_impl();
        }
        else {
            $! = $cur_errno;
        }
        return $string;
    }
}

sub output_encode_puny {
    my ( $lh, $utf8 ) = @_;    # ? TODO or YAGNI ? accept either unicode ot utf8 string (i.e. via String::UnicodeUTF8 instead of utf8::- if so, use in output_decode_puny also)
    return $utf8 if $utf8 =~ m/xn--/;    # do not encode it if it is already punycode

    require Net::IDN::Encode;

    my $res;
    if ( $utf8 =~ m/(?:\@|\xef\xbc\xa0|\xef\xb9\xab)/ ) {    # \x{0040}, \x{FF20}, \x{FE6B} no need for \x{E0040} right?
        my ( $nam, $dom ) = split( /(?:\@|\xef\xbc\xa0|\xef\xb9\xab)/, $utf8, 2 );

        # TODO: ? multiple @ signs ...
        # my ($dom,$nam) = split(/\@/,reverse($_[1]),2);
        #        $dom = reverse($dom);
        #        $nam = reverse($nam);
        utf8::decode($nam);    # turn utf8 bytes into a unicode string
        utf8::decode($dom);    # turn utf8 bytes into a unicode string

        eval { $res = Net::IDN::Encode::domain_to_ascii($nam) . '@' . Net::IDN::Encode::domain_to_ascii($dom); };
        return 'Error: invalid string for punycode' if $@;
    }
    else {
        utf8::decode($utf8);    # turn utf8 bytes into a unicode string
        eval { $res = Net::IDN::Encode::domain_to_ascii($utf8); };
        return 'Error: invalid string for punycode' if $@;
    }

    return $res;
}

sub output_decode_puny {
    my ( $lh, $puny ) = @_;
    return $puny if $puny !~ m/xn--/;    # do not decode it if it isn't punycode

    require Net::IDN::Encode;

    my $res;
    if ( $puny =~ m/\@/ ) {
        my ( $nam, $dom ) = split( /@/, $puny, 2 );

        # TODO: ? multiple @ signs ...
        # my ($dom,$nam) = split(/\@/,reverse($_[1]),2);
        #        $dom = reverse($dom);
        #        $nam = reverse($nam);
        eval { $res = Net::IDN::Encode::domain_to_unicode($nam) . '@' . Net::IDN::Encode::domain_to_unicode($dom); };
        return "Error: invalid punycode" if $@;
    }
    else {
        eval { $res = Net::IDN::Encode::domain_to_unicode($puny); };
        return "Error: invalid punycode" if $@;
    }

    utf8::encode($res);    # turn unicode string back into utf8 bytes
    return $res;
}

my $has_encode;            # checking for Encode this way facilitates only checking @INC once for the module on systems that do not have Encode

sub output_chr {
    my ( $lh, $chr_num ) = @_;

    if ( $chr_num !~ m/\A\d+\z/ ) {
        return if length($chr_num) != 1;
        return $chr_num if !$lh->context_is_html();

        return
            $chr_num eq '"' ? '"'
          : $chr_num eq '&' ? '&'
          : $chr_num eq "'" ? '''
          : $chr_num eq '<' ? '<'
          : $chr_num eq '>' ? '>'
          :                   $chr_num;
    }
    return if $chr_num !~ m/\A\d+\z/;
    my $chr = chr($chr_num);

    # perldoc chr: Note that characters from 128 to 255 (inclusive) are by default internally not encoded as UTF-8 for backward compatibility reasons.
    if ( $chr_num > 127 ) {

        # checking for Encode this way facilitates only checking @INC once for the module on systems that do not have Encode
        if ( !defined $has_encode ) {
            $has_encode = 0;
            eval { require Encode; $has_encode = 1; };
        }

        # && $chr_num < 256) { # < 256 still needs Encode::encode()d in order to avoid "Wide character" warning
        if ($has_encode) {
            $chr = Encode::encode( $lh->encoding(), $chr );
        }

        # elsif (defined &utf8::???) { ??? }
        else {

            # This binmode trick can cause chr() to render and not have a "Wide character" warning but ... yikes ...:
            #     eval { binmode(STDOUT, ":utf8") } - eval beacuse perl 5.6 "Unknown discipline ':utf8' at ..." which means this would be pointless in addition to scary

            # warn "Encode.pm is not available so chr($chr_num) may or may not be encoded properly.";

            # chr() has issues (e.g. display problems) on any perl with or without Encode.pm (esspecially when $chr_num is 128 .. 255).
            # On 5.6 perl (i.e. no Encode.pm) \x{00AE} works so:
            #    sprintf('%04X', $chr_num); # e.g. turn '174' into '00AE'
            # It could be argued that this only needs done when $chr_num < 256 but it works so leave it like this for consistency and in case it is needed under specific circumstances

            $chr = eval '"\x{' . sprintf( '%04X', $chr_num ) . '}"';
        }
    }

    if ( !$lh->context_is_html() ) {
        return $chr;
    }
    else {
        return
            $chr_num == 34 || $chr_num == 147 || $chr_num == 148 ? '"'
          : $chr_num == 38 ? '&'
          : $chr_num == 39 || $chr_num == 145 || $chr_num == 146 ? '''
          : $chr_num == 60  ? '<'
          : $chr_num == 62  ? '>'
          : $chr_num == 173 ? '­'
          :                   $chr;
    }
}

sub output_class {
    my ( $lh, $string, @classes ) = @_;
    $string = __proc_string_with_embedded_under_vars( $string, 1 );
    return $string if $lh->context_is_plain();

    # my $class_str = join(' ', @classes); # in case $" is hosed?
    # TODO maybe: use @classes to get ANSI color map of some sort
    return $lh->context_is_ansi() ? "\e[1m$string\e[0m" : qq{$string};
}

sub output_asis_for_tests {
    my ( $lh, $string ) = @_;
    $string = __proc_string_with_embedded_under_vars( $string, 1 );
    return $string;
}

sub __make_attr_str_from_ar {
    my ( $attr_ar, $strip_hr, $addin ) = @_;
    if ( ref($attr_ar) eq 'HASH' ) {
        $strip_hr = $attr_ar;
        $attr_ar  = [];
    }

    my $attr = '';
    my $general_hr = ref( $attr_ar->[-1] ) eq 'HASH' ? pop( @{$attr_ar} ) : undef;

    my $idx    = 0;
    my $ar_len = @{$attr_ar};

    $idx = 1 if $ar_len % 2;    # handle “Odd number of elements” …

    my $did_addin;

    while ( $idx < $ar_len ) {
        if ( exists $strip_hr->{ $attr_ar->[$idx] } ) {
            $idx += 2;
            next;
        }
        my $atr = $attr_ar->[$idx];
        my $val = $attr_ar->[ ++$idx ];
        if ( exists $addin->{$atr} ) {
            $val = "$addin->{$atr} $val";
            $did_addin->{$atr}++;
        }

        $attr .= qq{ $atr="$val"};
        $idx++;
    }

    if ($general_hr) {
        for my $k ( keys %{$general_hr} ) {
            next if exists $strip_hr->{$k};
            if ( exists $addin->{$k} ) {
                $general_hr->{$k} = "$addin->{$k} $general_hr->{$k}";
                $did_addin->{$k}++;
            }
            $attr .= qq{ $k="$general_hr->{$k}"};
        }
    }

    for my $r ( keys %{$addin} ) {
        if ( !exists $did_addin->{$r} ) {
            $attr .= qq{ $r="$addin->{$r}"};
        }
    }

    return $attr;
}

sub output_inline {
    my ( $lh, $string, @attrs ) = @_;
    $string = __proc_string_with_embedded_under_vars( $string, 1 );
    return $string if !$lh->context_is_html();

    my $attr = __make_attr_str_from_ar( \@attrs );
    return qq{$string};
}

*output_attr = \&output_inline;

sub output_block {
    my ( $lh, $string, @attrs ) = @_;
    $string = __proc_string_with_embedded_under_vars( $string, 1 );
    return $string if !$lh->context_is_html();

    my $attr = __make_attr_str_from_ar( \@attrs );
    return qq{$string};
}

sub output_img {
    my ( $lh, $src, $alt, @attrs ) = @_;

    if ( !defined $alt || $alt eq '' ) {
        $alt = $src;
    }
    else {
        $alt = __proc_string_with_embedded_under_vars( $alt, 1 );
    }

    return $alt if !$lh->context_is_html();

    my $attr = __make_attr_str_from_ar( \@attrs, { 'alt' => 1, 'src' => 1 } );
    return qq{};
}

sub output_abbr {
    my ( $lh, $abbr, $full, @attrs ) = @_;
    return !$lh->context_is_html()
      ? "$abbr ($full)"
      : qq{ 1 } ) . qq{>$abbr};
}

sub output_acronym {
    my ( $lh, $acronym, $full, @attrs ) = @_;

    # ala bootstrap: class="initialism"
    return !$lh->context_is_html()
      ? "$acronym ($full)"
      : qq{ 1 }, { 'class' => 'initialism' } ) . qq{>$acronym};
}

sub output_sup {
    my ( $lh, $string, @attrs ) = @_;
    $string = __proc_string_with_embedded_under_vars( $string, 1 );
    return !$lh->context_is_html() ? $string : qq{$string};
}

sub output_sub {
    my ( $lh, $string, @attrs ) = @_;
    $string = __proc_string_with_embedded_under_vars( $string, 1 );
    return !$lh->context_is_html() ? $string : qq{$string};
}

sub output_underline {
    my ( $lh, $string, @attrs ) = @_;

    $string = __proc_string_with_embedded_under_vars( $string, 1 );
    return $string if $lh->context_is_plain();
    return $lh->context_is_ansi() ? "\e[4m$string\e[0m" : qq{$string};
}

sub output_strong {
    my ( $lh, $string, @attrs ) = @_;

    $string = __proc_string_with_embedded_under_vars( $string, 1 );
    return $string if $lh->context_is_plain();
    return $lh->context_is_ansi() ? "\e[1m$string\e[0m" : '$string";
}

sub output_em {
    my ( $lh, $string, @attrs ) = @_;

    $string = __proc_string_with_embedded_under_vars( $string, 1 );
    return $string if $lh->context_is_plain();

    # italic code 3 is specified in ANSI X3.64 and ECMA-048 but are not commonly supported by most displays and emulators, but we can try!
    return $lh->context_is_ansi() ? "\e[3m$string\e[0m" : '$string";
}

# output,del output,strike (ick):
#     strike-though code 9 is specified in ANSI X3.64 and ECMA-048 but are not commonly supported by most displays and emulators, but we can try!

sub output_url {
    my ( $lh, $url, @args ) = @_;
    $url ||= '';    # carp() ?

    my $arb_args_hr = ref $args[-1] eq 'HASH' ? pop(@args) : {};
    my ( $url_text, %output_config ) = @args % 2 ? @args : ( undef, @args );

    my $return = $url;

    if ( !$lh->context_is_html() ) {
        if ($url_text) {
            $url_text = __proc_emb_meth( $lh, $url_text );
            $url_text = __proc_string_with_embedded_under_vars( $url_text, 1 );
            return "$url_text ($url)";
        }

        if ( exists $output_config{'plain'} ) {
            $output_config{'plain'} ||= $url;
            my $orig = $output_config{'plain'};
            $output_config{'plain'} = __proc_emb_meth( $lh, $output_config{'plain'} );
            $output_config{'plain'} = __proc_string_with_embedded_under_vars( $output_config{'plain'}, 1 );

            $return = $orig ne $output_config{'plain'} && $output_config{'plain'} =~ m/\Q$url\E/ ? $output_config{'plain'} : "$output_config{'plain'} $url";
        }
    }
    else {
        if ( exists $output_config{'html'} ) {
            $output_config{'html'} = __proc_emb_meth( $lh, $output_config{'html'} );
            $output_config{'html'} = __proc_string_with_embedded_under_vars( $output_config{'html'}, 1 );
        }

        if ( !$output_config{'html'} ) {
            $url_text = __proc_emb_meth( $lh, $url_text );
            $url_text = __proc_string_with_embedded_under_vars( $url_text, 1 );
        }

        $output_config{'html'} ||= $url_text || $url;

        my $attr = __make_attr_str_from_ar(
            [ @args, $arb_args_hr ],
            {
                'html'  => 1,
                'href'  => 1,
                'plain' => 1,
                '_type' => 1,
            }
        );

        $return = exists $output_config{'_type'}
          && $output_config{'_type'} eq 'offsite' ? qq{$output_config{'html'}} : qq{$output_config{'html'}};
    }

    return $return;
}

#### / more BN methods ##

#### output context methods ##

sub set_context_html {
    my ( $lh, $empty ) = @_;
    my $cur = $lh->get_context();
    $lh->set_context('html');
    return if !$lh->context_is_html();
    return $empty ? '' : $cur;
}

sub set_context_ansi {
    my ( $lh, $empty ) = @_;
    my $cur = $lh->get_context();
    $lh->set_context('ansi');
    return if !$lh->context_is_ansi();
    return $empty ? '' : $cur;
}

sub set_context_plain {
    my ( $lh, $empty ) = @_;
    my $cur = $lh->get_context();
    $lh->set_context('plain');
    return if !$lh->context_is_plain();
    return $empty ? '' : $cur;
}

my %contexts = (
    'plain' => undef(),
    'ansi'  => 1,
    'html'  => 0,
);

sub set_context {
    my ( $lh, $context, $empty ) = @_;

    if ( !$context ) {
        require Web::Detect;
        if ( Web::Detect::detect_web_fast() ) {
            $lh->{'-t-STDIN'} = 0;
        }
        else {
            require IO::Interactive::Tiny;
            $lh->{'-t-STDIN'} = IO::Interactive::Tiny::is_interactive() ? 1 : undef();
        }
    }
    elsif ( exists $contexts{$context} ) {
        $lh->{'-t-STDIN'} = $contexts{$context};
    }
    else {
        require Carp;
        local $Carp::CarpLevel = 1;
        Carp::carp("Given context '$context' is unknown.");
        $lh->{'-t-STDIN'} = $context;
    }

    return
        $empty ? ''
      : defined $context && exists $contexts{$context} ? $context
      :                                                  $lh->{'-t-STDIN'};
}

sub context_is_html {
    return $_[0]->get_context() eq 'html';
}

sub context_is_ansi {
    return $_[0]->get_context() eq 'ansi';
}

sub context_is_plain {
    return $_[0]->get_context() eq 'plain';
}

sub context_is {
    return $_[0]->get_context() eq $_[1];
}

sub get_context {
    my ($lh) = @_;

    if ( !exists $lh->{'-t-STDIN'} ) {
        $lh->set_context();
    }

    return 'plain' if !defined $lh->{'-t-STDIN'};
    return 'ansi'  if $lh->{'-t-STDIN'} eq "1";
    return 'html'  if $lh->{'-t-STDIN'} eq "0";

    # We don't carp "Given context '...' is unknown." here since we assume if they explicitly set it then they have a good reason to.
    # If it was an accident the set_contex() will have carp()'d already, if they set the variable directly then they're doing it wrong ;)
    return $lh->{'-t-STDIN'};
}

sub maketext_html_context {
    my ( $lh, @mt_args ) = @_;
    my $cur = $lh->set_context_html();
    my $res = $lh->maketext(@mt_args);
    $lh->set_context($cur);
    return $res;
}

sub maketext_ansi_context {
    my ( $lh, @mt_args ) = @_;
    my $cur = $lh->set_context_ansi();
    my $res = $lh->maketext(@mt_args);
    $lh->set_context($cur);
    return $res;
}

sub maketext_plain_context {
    my ( $lh, @mt_args ) = @_;
    my $cur = $lh->set_context_plain();
    my $res = $lh->maketext(@mt_args);
    $lh->set_context($cur);
    return $res;
}

# TODO: how crazy do we want to go with context specific versions of maketext()ish methods?
# *makevar_html_context = \&maketext_html_context;
# *makevar_ansi_context = \&maketext_ansi_context;
# *makeavr_plain_context = \&maketext_plain_context;
#
# sub makethis_html_context {};
# sub makethis_ansi_context {};
# sub makethis_plain_context {};
#
# sub makethis_base_html_context {};
# sub makethis_base_ansi_context {};
# sub makethis_base_plain_context {};

#### / output context methods ###

1;