File Coverage

blib/lib/Exporter/Almighty.pm

Criterion	Covered	Total	%
statement	236	237	99.5
branch	35	40	87.5
condition	22	32	68.7
subroutine	39	39	100.0
pod	0	14	0.0
total	332	362	91.7

use 5.012;
use strict;
use warnings;

package Exporter::Almighty;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.001004';

use parent qw( Exporter::Tiny );

my @builtins;
BEGIN { @builtins = qw( is_bool created_as_string created_as_number ) };
use if $] lt '5.036000', 'builtins::compat' => @builtins;
use if $] ge '5.036000', 'builtin' => @builtins;
no if $] ge '5.036000', 'warnings' => qw( experimental::builtin );

use B                 qw( perlstring );
use Carp              qw( croak );
use Eval::TypeTiny    qw( eval_closure set_subname );
use Exporter::Tiny    qw( mkopt );
use Import::Into;
use Module::Runtime   qw( require_module module_notional_filename );
use Type::Registry    qw();
use Types::Common     qw(
	-sigs
	-types
	assert_Ref       is_Ref
	assert_ArrayRef  is_ArrayRef
	assert_HashRef   is_HashRef
	is_NonEmptySimpleStr
);

sub _exporter_validate_opts {
	my ( $me, $options ) = @_;
	my $into  = $options->{into};
	my $setup = $options->{setup};
	strict->import::into( $into );
	warnings->import::into( $into );
	$me->setup_for( $into, $setup );
}

# Subclasses may wish to provide a subclass of Exporter::Tiny here.
sub base_exporter {
	return 'Exporter::Tiny';
}

sub standard_package_variables {
	my ( $me, $into ) = @_;
	no strict 'refs';
	return (
		\@{"$into\::ISA"},
		\@{"$into\::EXPORT"},
		\@{"$into\::EXPORT_OK"},
		\%{"$into\::EXPORT_TAGS"},
	);
}

signature_for setup_for => (
	method  => 1,
	head    => [ NonEmptySimpleStr ],
	named   => [
		tag    => Optional[HashRef],
		also   => Optional[ArrayRef],
		enum   => Optional[HashRef[ArrayRef]],
		class  => Optional[ArrayRef],
		role   => Optional[ArrayRef],
		duck   => Optional[HashRef[ArrayRef]],
		type   => Optional[ArrayRef],
		const  => Optional[HashRef],
	],
);

sub setup_for {
	my ( $me, $into, $setup ) = @_;
	$INC{ module_notional_filename($into) } //= __FILE__;
	my @steps = $me->steps( $into, $setup );
	for my $step ( @steps ) {
		$me->$step( $into, $setup );
	}
	return;
}

# Subclasses can wrap this to easily add and remove steps.
sub steps {
	my ( $me, $into, $setup ) = @_;
	my @steps;
	push @steps, 'setup_exporter_for';
	push @steps, 'setup_reexports_for'            if $setup->{also};
	push @steps, 'setup_enums_for'                if $setup->{enum};
	push @steps, 'setup_classes_for'              if $setup->{class};
	push @steps, 'setup_roles_for'                if $setup->{role};
	push @steps, 'setup_ducks_for'                if $setup->{duck};
	push @steps, 'setup_types_for'                if $setup->{type};
	push @steps, 'setup_constants_for'            if $setup->{const};
	push @steps, 'setup_readonly_vars_for';
	push @steps, 'finalize_export_variables_for';
	return @steps;
}

sub setup_exporter_for {
	my ( $me, $into, $setup ) = @_;

	my ( $into_ISA, undef, undef, $into_EXPORT_TAGS ) =
		$me->standard_package_variables( $into );

	# Set up @ISA in caller package.
	my $base = $me->base_exporter( $into, $setup );
	push @$into_ISA, $base unless $into->isa( $base );

	# Set up %EXPORT_TAGS in caller package.
	my %tags = %{ $setup->{tag} // {} };
	for my $tag_name ( keys %tags ) {
		my @exports = @{ assert_ArrayRef $tags{$tag_name} };
		$tag_name =~ s/^[-:]//;
		push @{ $into_EXPORT_TAGS->{$tag_name} //= [] }, @exports;
	}

	return;
}

sub setup_reexports_for {
	my ( $me, $into, $setup ) = @_;

	my $next = $into->can( '_exporter_validate_opts' );

	my $optlist = mkopt( $setup->{also} );
	require_module( $_->[0] ) for @$optlist;

	my $method_name = "$into\::_exporter_validate_opts";
	my $method_code = sub {
		my ( $class, $opts ) = @_;
		is_NonEmptySimpleStr( my $caller = $opts->{into} ) or return;
		for my $also ( @$optlist ) {
			my ( $module, $args ) = @$also;
			$module->import::into( $caller, @{ $args // [] } );
		}
		goto $next if $next;
	};
	no strict 'refs';
	*$method_name = set_subname $method_name => $method_code;
}

sub setup_enums_for {
	my ( $me, $into, $setup ) = @_;

	require Type::Tiny::Enum;
	my $reg = Type::Registry->for_class( $into );
	$me->_ensure_isa_type_library( $into );

	my %tags = %{ assert_HashRef $setup->{enum} // {} };
	for my $tag_name ( keys %tags ) {
		my $values = $tags{$tag_name};
		$tag_name =~ s/^[-:]//;
		my $type_name = $tag_name;
		$tag_name = lc $tag_name;

		Type::Tiny::Enum->import( { into => $into }, $type_name, $values );
		$into->add_type( $reg->lookup( $type_name ) );
	}

	return;
}

sub setup_classes_for {
	my ( $me, $into, $setup ) = @_;
	require Type::Tiny::Class;
	$me->_setup_classes_or_roles_for( $into, $setup, 'class', 'Type::Tiny::Class' );
}

sub setup_roles_for {
	my ( $me, $into, $setup ) = @_;
	require Type::Tiny::Role;
	$me->_setup_classes_or_roles_for( $into, $setup, 'role', 'Type::Tiny::Role' );
}

sub _setup_classes_or_roles_for {
	my ( $me, $into, $setup, $kind, $tt_class ) = @_;

	my $reg = Type::Registry->for_class( $into );
	$me->_ensure_isa_type_library( $into );

	my $optlist = mkopt( $setup->{$kind} );
	for my $dfn ( @$optlist ) {
		( my $pkg_name  = ( $dfn->[1] //= {} )->{$kind} // $dfn->[0] );
		( my $type_name = ( $dfn->[1] //= {} )->{name}  // $dfn->[0] ) =~ s/:://g;
		$tt_class->import( { into => $into }, @$dfn );
		$into->add_type( $reg->lookup( $type_name ) );
		eval { require_module( $pkg_name ) };
	}

	return;
}

sub setup_ducks_for {
	my ( $me, $into, $setup ) = @_;

	require Type::Tiny::Duck;
	my $reg = Type::Registry->for_class( $into );
	$me->_ensure_isa_type_library( $into );

	my %types = %{ assert_HashRef $setup->{duck} // {} };
	for my $type_name ( keys %types ) {
		my $values = $types{$type_name};
		Type::Tiny::Duck->import( { into => $into }, $type_name, $values );
		$into->add_type( $reg->lookup( $type_name ) );
	}

	return;
}

sub setup_types_for {
	my ( $me, $into, $setup ) = @_;

	my $reg = Type::Registry->for_class( $into );
	$me->_ensure_isa_type_library( $into );

	my $optlist = mkopt( $setup->{type} );
	my @extends = ();
	for my $dfn ( @$optlist ) {
		my ( $lib, $list ) = @$dfn;
		eval { require_module( $lib ) };
		if ( is_ArrayRef $list ) {
			for my $type_name ( @$list ) {
				$into->add_type( $lib->get_type( $type_name ) );
			}
		}
		else {
			push @extends, $lib;
		}
	}

	if ( @extends ) {
		require Type::Utils;
		my $wrapper = eval "sub { package $into; &Type::Utils::extends; }";
		$wrapper->( @extends );
	}

	return;
}

sub _ensure_isa_type_library {
	my ( $me, $into ) = @_;
	return if $into->isa( 'Type::Library' );
	my ( $old_isa ) = $me->standard_package_variables( $into );
	my $new_isa = [];
	my $saw_exporter_tiny = 0;
	for my $pkg ( @$old_isa ) {
		if ( $pkg eq 'Exporter::Tiny' ) {
			push @$new_isa, 'Type::Library';
			$saw_exporter_tiny++;
		}
		else {
			push @$new_isa, $pkg;
		}
	}
	push @$new_isa, 'Type::Library' unless $saw_exporter_tiny;
	@$old_isa = @$new_isa;
}

sub setup_constants_for {
	my ( $me, $into, $setup ) = @_;

	my ( $into_ISA, undef, undef, $into_EXPORT_TAGS ) =
		$me->standard_package_variables( $into );

	my %tags = %{ assert_HashRef $setup->{const} // {} };
	for my $tag_name ( keys %tags ) {
		my %exports = %{ assert_HashRef $tags{$tag_name} };
		$tag_name =~ s/^[-:]//;
		my @constant_names = sort keys %exports;
		push @{ $into_EXPORT_TAGS->{$tag_name}   //= [] }, @constant_names;
		push @{ $into_EXPORT_TAGS->{'constants'} //= [] }, @constant_names;
		$me->make_constant_subs( $into, \%exports );
	}

	return;
}

sub make_constant_subs {
	my ( $me, $into, $constants ) = @_;

	for my $key ( keys %$constants ) {
		my $value = $constants->{$key};
		my $full_name = "$into\::$key";

		my $coderef;
		if ( is_Ref $value ) {
			$coderef = eval_closure(
				source      => 'sub () { $value }',
				environment => { '$value' => \$value },
			);
		}
		else {
			$coderef = eval sprintf(
				'sub () { %s %s }',
				is_bool( $value ) ? '!!' : ( created_as_number( $value ) ? '0+' : '' ),
				perlstring( $value ),
			);
		}

		no strict 'refs';
		*$full_name = set_subname $full_name => $coderef;
	}
}

sub setup_readonly_vars_for {
	my ( $me, $into, $setup ) = @_;

	my ( $into_ISA, $into_EXPORT, $into_EXPORT_OK, $into_EXPORT_TAGS ) =
		$me->standard_package_variables( $into );

	my @constants = @{ $into_EXPORT_TAGS->{'constants'} // [] };
	for my $name ( @constants ) {
		no strict 'refs';
		my $full_name = "$into\::$name";
		${ $full_name } = &{ $full_name }();
		Internals::SvREADONLY( ${ $full_name }, 1 );
		push @{ $into_EXPORT_TAGS->{'ro_vars'} //= [] }, '$' . $name;
	}

	return;
}

sub finalize_export_variables_for {
	my ( $me, $into, $setup ) = @_;

	my ( $into_ISA, $into_EXPORT, $into_EXPORT_OK, $into_EXPORT_TAGS ) =
		$me->standard_package_variables( $into );

	my %all_exports;
	for my $list ( $into_EXPORT, $into_EXPORT_OK, values %{ $into_EXPORT_TAGS // {} } ) {
		is_ArrayRef $list or next;
		$all_exports{$_}++ for @$list;
	}
	@{ $into_EXPORT_OK } = sort keys %all_exports;

	my %default_exports;
	for my $list ( $into_EXPORT, $into_EXPORT_TAGS->{default} ) {
		is_ArrayRef $list or next;
		$default_exports{$_}++ for @$list;
	}
	@{ $into_EXPORT } = sort keys %default_exports;

	return;
}

1;

__END__