File Coverage

blib/lib/CXC/Exporter/Util.pm

Criterion	Covered	Total	%
statement	134	138	97.1
branch	27	34	79.4
condition	27	36	75.0
subroutine	22	23	95.6
pod	4	4	100.0
total	214	235	91.0

package CXC::Exporter::Util;

# ABSTRACT: Tagged Based Exporting

use v5.22;

use strict;
use warnings;

our $VERSION = '0.08';

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

use Exporter 'import';

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

our %HOOK;

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 $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}->@* );
            }
        }
    }

    # 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->%*;
}





























































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' ) {
        my @copy = $constants->@*;
        while ( my ( $name ) = splice( @copy, 0, 2 ) ) {
            push @names, $name;
        }
        $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 );

    $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 );
    };

    $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 );

    };

}












































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 );
}

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__