File Coverage

blib/lib/custom/failures/x/alias.pm

Criterion	Covered	Total	%
statement	64	70	91.4
branch	11	18	61.1
condition	9	27	33.3
subroutine	8	9	88.8
pod			n/a
total	92	124	74.1

package custom::failures::x::alias;

# ABSTRACT: export aliases for custom::failures

use v5.10.0;

use strict;
use warnings;

our $VERSION = '0.01';

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

sub _alias {
    my ( $failure, $opt ) = @_;
    $failure =~ s/::/_/g;
    return ($opt->{-prefix} // '')  . $failure . ($opt->{-suffix} // '') ;
}

sub import {
    my ( $class, @failures ) = @_;
    my $caller;

    # mimic what failures::import does to allow specifying the caller
    if ( 'ARRAY' eq ref $failures[1] ) {
        $caller   = shift @failures;
        @failures = @{ $failures[0] };
    }
    else {
        $caller = caller;
    }

    my $export   = 'EXPORT_OK';
    my $exporter = 'Exporter';
    my $alias    = \&_alias;
    my %opt;

    while ( @failures && substr( $failures[0], 0, 1 ) eq '-' ) {
        my $opt = shift @failures;

        if ( $opt eq '-prefix' ) {
            $opt{prefix} = shift( @failures )
              // _croak( "missing value for -prefix" );
        }

        elsif ( $opt eq '-suffix' ) {
            $opt{suffix} = shift( @failures )
              // _croak( "missing value for -suffix" );
        }

        elsif ( $opt eq '-alias' ) {
            $alias = shift( @failures ) // _croak( "missing value for -alias" );
            'CODE' eq ref $alias
              or _croak( "-alias must be a coderef" );
        }

        elsif ( $opt eq '-export' ) {
            $export = 'EXPORT';
        }

        elsif ( $opt eq '-exporter' ) {
            $exporter = shift( @failures )
              // _croak( "missing value for -exporter" );
            eval "use $exporter ; 1 "  ## no critic (ProhibitStringyEval)
              || _croak(
                "requested exporter '$exporter' cannot be loaded: $@" );
        }

    }


    require custom::failures;
    custom::failures->import( $caller => \@failures );

    {
        no strict 'refs';    ## no critic (ProhibitNoStrict)

        my @export;
        for my $failure ( @failures ) {
            my $alias = $alias->( $failure, \%opt );
            push @export, $alias;
            my $fqn = "${caller}::${alias}";
            *$fqn = sub () { "${caller}::${failure}" }
        }

        if ( $exporter eq 'Exporter' ) {
            require Exporter;
            my $fqn  = "${caller}::import";
            *$fqn = \&Exporter::import;
        }
        else {
            my $fqn = "${caller}::ISA";
            my $ISA = *{$fqn}{ARRAY} // ( *$fqn = [] );
            push @$ISA, $exporter;
        }

        {
            my $fqn  = "${caller}::${export}";
            my $export = *{$fqn}{ARRAY} // ( *$fqn = [] );
            push @$export, @export;
        }

        {
            my $fqn = "${caller}::EXPORT_TAGS";
            my $tags = *{$fqn}{HASH} // ( *$fqn = {} );
            push @{ $tags->{all} //= [] },  @export;
        }
    }

    return;
}

1;

#
# This file is part of custom-failures-x-alias
#
# This software is Copyright (c) 2021 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__