File Coverage

blib/lib/CXC/Exporter/Util.pm

Criterion	Covered	Total	%
statement	238	240	99.1
branch	36	46	78.2
condition	43	64	67.1
subroutine	37	37	100.0
pod	4	4	100.0
total	358	391	91.5

package CXC::Exporter::Util;

# ABSTRACT: Tagged Based Exporting

use v5.22;

use strict;
use warnings;

#<<<
our $VERSION = '0.09'; # TRIAL
#>>>

use Scalar::Util 'reftype';
use List::Util 1.45 'uniqstr';
use Import::Into;
use experimental 'signatures', 'postderef', 'lexical_subs';

use constant HAVE_EXPORTER_TINY => eval { require Exporter::Tiny; 1; };    ## no critic ( ReturnValueOfEval )
use if HAVE_EXPORTER_TINY,  parent   => 'Exporter::Tiny';
use if !HAVE_EXPORTER_TINY, Exporter => 'import';

use constant UI_HELPERS => 'ui_helpers';

our %EXPORT_TAGS;

BEGIN {

    %EXPORT_TAGS = (
        default   => [qw( install_EXPORTS  )],
        constants => [qw( install_CONSTANTS )],
        utils     => [qw( install_constant_tag install_constant_func )],
    );

    if ( HAVE_EXPORTER_TINY ) {
        $EXPORT_TAGS{ +UI_HELPERS }
          = [qw( ui_list_constants ui_coerce_constant ui_assert_coerce_constant )];
    }

}

my %REGISTRY = (
    HOOK           => {},
    CONSTANTS_TAGS => {},
    UI             => {},
);

install_EXPORTS();

my sub _croak {
    require Carp;
    goto \&Carp::croak;
}


my sub _EXPORT_TAGS ( $caller = scalar caller ) {
    no strict 'refs';    ## no critic (TestingAndDebugging::ProhibitNostrict)
    *${ \"${caller}::EXPORT_TAGS" }{HASH} // \%{ *${ \"${caller}::EXPORT_TAGS" } = {} };
}

my sub _EXPORT_OK ( $caller = scalar caller ) {
    no strict 'refs';    ## no critic (TestingAndDebugging::ProhibitNostrict)
    *${ \"${caller}::EXPORT_OK" }{ARRAY} // \@{ *${ \"${caller}::EXPORT_OK" } = [] };
}

my sub _EXPORT ( $caller = scalar caller ) {
    no strict 'refs';    ## no critic (TestingAndDebugging::ProhibitNostrict)
    *${ \"${caller}::EXPORT" }{ARRAY} // \@{ *${ \"${caller}::EXPORT" } = [] };
}

my sub add_constant_to_tag;





























































sub install_EXPORTS {

    my $export_tags = ( reftype( $_[0] )  // q{} ) eq 'HASH' ? shift : undef;
    my $u_opts      = ( reftype( $_[-1] ) // q{} ) eq 'HASH' ? shift : {};

    my %options = (
        overwrite => 0,
        all       => 'auto',
        package   => shift // scalar caller,
        %$u_opts,
    );

    _croak( 'too many arguments to INSTALL_EXPORTS' ) if @_;

    my $package     = delete $options{package};
    my $install_all = delete $options{all};

    # run hooks.
    if ( defined( my $hooks = delete $REGISTRY{HOOK}{$package}{pre} ) ) {
        $_->() for values $hooks->%*;
    }

    my $EXPORT_TAGS = _EXPORT_TAGS( $package );

    if ( defined $export_tags ) {

        if ( delete $options{overwrite} ) {
            $EXPORT_TAGS->%* = $export_tags->%*;
        }

        else {
            # cheap one layer deep hash merge
            for my $tag ( keys $export_tags->%* ) {
                push( ( $EXPORT_TAGS->{$tag} //= [] )->@*, $export_tags->{$tag}->@* );
            }
        }
    }

    if ( defined( my $hooks = delete $REGISTRY{HOOK}{$package}{post} ) ) {
        $_->() for values $hooks->%*;
    }

    # Exporter::Tiny handles the 'all' tag, as does Sub::Exporter, but
    # I don't know how to detect when the latter is being used.
    $install_all = !$package->isa( 'Exporter::Tiny' )
      if $install_all eq 'auto';

    if ( $install_all ) {
        # Assign the all tag in two steps to avoid the situation
        # where $EXPORT_TAGS->{all} is created with an undefined value
        # before running values on $EXPORT_TAGS->%*;

        my @all = map { $_->@* } values $EXPORT_TAGS->%*;
        $EXPORT_TAGS->{all} //= \@all;
    }

    _EXPORT( $package )->@*    = ( $EXPORT_TAGS->{default} // [] )->@*;
    _EXPORT_OK( $package )->@* = uniqstr map { $_->@* } values $EXPORT_TAGS->%*;

    delete $REGISTRY{HOOK}{$package};
}





























































sub install_CONSTANTS {
    my $package = !defined reftype( $_[-1] ) ? pop : scalar caller;

    for my $spec ( @_ ) {
        my $type = reftype( $spec );

        if ( 'HASH' eq $type ) {
            install_constant_tag( $_, $spec->{$_}, $package ) for keys $spec->%*;
        }

        elsif ( 'ARRAY' eq $type ) {
            my $idx = $spec->@*;
            _croak( 'constant spec passed as array has an odd number of elements' )
              unless 0 == $idx % 2;

            while ( $idx ) {
                my $hash = $spec->[ --$idx ];
                my $id   = $spec->[ --$idx ];
                install_constant_tag( $id, $hash, $package );
            }
        }

        else {
            _croak( 'expect a HashRef or an ArrayRef' );
        }
    }
}



































































































































































































sub install_constant_tag ( $id, $constants, $package = scalar caller ) {

    # caller may specify distinct tag and enumeration function names.
    my ( $tag, $fn_values, $fn_names )
      = 'ARRAY' eq ( reftype( $id ) // q{} )
      ? ( $id->@* )
      : ( lc( $id ), $id );

    $fn_values //= uc( $tag );
    $fn_names  //= $fn_values . '_NAMES';

    my ( @names );
    if ( reftype( $constants ) eq 'HASH' ) {
        @names = keys $constants->%*;
    }
    elsif ( reftype( $constants ) eq 'ARRAY' ) {
        # the list of names must be returned in the order specified,
        # hence this bizzarity
        @names     = $constants->@[ map { $_ * 2 } 0 .. $constants->$#* / 2 ];
        $constants = { $constants->@* };
    }
    else {
        _croak( '$constants argument should be either a hashref or an arrayref' );
    }

    constant->import::into( $package, $constants );

    push( ( _EXPORT_TAGS( $package )->{$tag} //= [] )->@*, @names );

    $REGISTRY{HOOK}{$package}{pre}{$fn_values} //= sub {
        my $fqdn = join q{::}, $package, $fn_values;
        _croak( "Error: attempt to redefine enumerating function $fqdn" )
          if exists &{$fqdn};
        no strict 'refs';    ## no critic (TestingAndDebugging::ProhibitNostrict)
        my @values
          = map { &{"${package}::${_}"} } _EXPORT_TAGS( $package )->{$tag}->@*;
        install_constant_func( $fn_values, \@values, $package );
    };

    $REGISTRY{HOOK}{$package}{pre}{$fn_names} //= sub {
        my $fqdn = join q{::}, $package, $fn_names;
        _croak( "Error: attempt to redefine enumerating function $fqdn" )
          if exists &{$fqdn};
        add_constant_to_tag( 'constant_name_funcs', $fn_names,
            [ _EXPORT_TAGS( $package )->{$tag}->@* ], $package );

    };

    $REGISTRY{HOOK}{$package}{pre}{"register_tag:$tag"} //= sub {
        ( $REGISTRY{CONSTANTS_TAGS}{$package} //= {} )->{$tag} = $fn_names;
    };

}












































sub install_constant_func ( $tag, $values, $caller = scalar caller ) {
    add_constant_to_tag( 'constant_funcs', $tag, $values, $caller );
    # for backwards compatibility
    _EXPORT_TAGS( $caller )->{constants_funcs} = _EXPORT_TAGS( $caller )->{constant_funcs};
}















































sub add_constant_to_tag ( $tag, $name, $values, $caller = scalar caller ) {
    constant->import::into( $caller, $name => $values->@* );
    push( ( _EXPORT_TAGS( $caller )->{$tag} //= [] )->@*, $name );
}

my sub ui_entry ( $target, $tag, $pfx ) {

    my $tags = $REGISTRY{CONSTANTS_TAGS}{$target}
      // _croak( "Can't find any constant tags associated with '$target'" );

    my $names = $tags->{$tag} // _croak( "unknown constant tag '$tag'" );

    exists $REGISTRY{UI}{$target}{$tag}{$pfx}
      and return $REGISTRY{UI}{$target}{$tag}{$pfx};

    my $entry = $REGISTRY{UI}{$target}{$tag}{$pfx} = {};

    my $sub = $target->can( $names )
      or die( "internal error: Can't find subroutine ${target}::$names" )
      ;    # yes, die. so error points to this line.

    my %values;
    my %valsubs;
    my @names;

    # Copy each returned name before mutation; $sub is generated by
    # the 'constant' pragma, and may return aliases to the actual
    # constants, which cannot be mutated.
    for my $const_name ( $sub->() ) {
        my $name = $const_name;

        my $valsub = $valsubs{$name} //= do {
            my $coderef = $target->can( $name )
              or die( "internal error: Can't find subroutine ${target}::$name" );
            sub { $coderef->() };
        };

        defined $pfx
          and length $pfx
          and $name =~ s/^\Q${pfx}\E_?//;

        my %names;
        $name = lc $name;
        @names{$name} = ();
        $name =~ s/_/-/g;
        @names{$name} = ();
        my @lnames = keys %names;
        push @names, @lnames;
        @values{@lnames} = ( $valsub ) x @lnames;
    }
    $entry->{names}  = [ sort @names ];
    $entry->{values} = \%values;

    return $entry;
}

sub _exporter_expand_tag ( $class, $name, $value, $globals ) {

    if ( $name eq UI_HELPERS or $name eq 'all' ) {
        my $target = $globals->{into};
        $REGISTRY{HOOK}{$target}{post}{add_helpers} //= sub {
            _EXPORT_TAGS( $target )->{ +UI_HELPERS } = [ $EXPORT_TAGS{ +UI_HELPERS }->@* ];
        };
    }
    $class->SUPER::_exporter_expand_tag( $name, $value, $globals );
}















sub _generate_ui_list_constants ( $class, $name, $args, $globals ) {
    my $target = $globals->{into};
    sub ( $tag, $pfx = q{} ) {
        return ui_entry( $target, $tag, $pfx )->{names}->@*;
    }
}












sub _generate_ui_coerce_constant ( $class, $name, $args, $globals ) {
    my $target = $globals->{into};
    sub ( $name, $tag, $pfx = q{} ) {
        my $valsub = ui_entry( $target, $tag, $pfx )->{values}{$name} // return $name;
        return $valsub->();
    }
}












sub _generate_ui_assert_coerce_constant ( $class, $name, $args, $globals ) {
    my $target = $globals->{into};
    sub ( $name, $tag, $pfx = q{} ) {
        my $valsub = ui_entry( $target, $tag, $pfx )->{values}{$name}
          // _croak( "unknown constant $tag: $name" );
        return $valsub->();
    }
}

1;

#
# This file is part of CXC-Exporter-Util
#
# This software is Copyright (c) 2022 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__