File Coverage

blib/lib/CXC/Exporter/Util.pm

Criterion	Covered	Total	%
statement	121	125	96.8
branch	26	32	81.2
condition	22	26	84.6
subroutine	20	21	95.2
pod	4	4	100.0
total	193	208	92.7

package CXC::Exporter::Util;

# ABSTRACT: Tagged Based Exporting

use v5.20;

use strict;
use warnings;

our $VERSION = '0.04'; # TRIAL

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

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

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

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

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

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





























































sub install_EXPORTS {

    my $export_tags = ( reftype( $_[0] )  // '' ) eq 'HASH' ? shift : undef;
    my $u_opts      = ( reftype( $_[-1] ) // '' ) 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 ) {

    my ( @names, @values );
    if ( reftype( $constants ) eq 'HASH' ) {
        @names  = keys $constants->%*;
        @values = values $constants->%*;
    }
    elsif ( reftype( $constants ) eq 'ARRAY' ) {
        my @copy = $constants->@*;
        while ( my ( $name, $value ) = splice( @copy, 0, 2 ) ) {
            push @names,  $name;
            push @values, $value;
        }
        $constants = { $constants->@* };
    }
    else {
        _croak(
            '$constants argument should be either a hashref or an arrayref' );
    }

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

    # caller may specify distinct tag and enumeration function names.
    my ( $tag, $fname )
      = 'ARRAY' eq ( reftype( $id ) // '' )
      ? ( $id->[0], $id->[1] )
      : ( lc( $id ), $id );


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

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












































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


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__