File Coverage

blib/lib/Constant/FromGlobal.pm

Criterion	Covered	Total	%
statement	57	57	100.0
branch	18	18	100.0
condition	6	6	100.0
subroutine	13	13	100.0
pod			n/a
total	94	94	100.0

package Constant::FromGlobal;
$Constant::FromGlobal::VERSION = '0.10';
# ABSTRACT: declare constant(s) with value from global or environment variable

use strict;
use warnings;
use 5.8.0;
use Carp;
use Data::OptList;
use constant ();

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

    my $opt = ref($args[0]) eq 'HASH' ? shift @args : {};

    @_ = (
		"constant",
		$class->_process_constants(
			package => scalar(caller),
			%$opt,
			constants => \@args
		)
	);

    goto &constant::import;
}

sub _process_constants {
    my ( $class, %args ) = @_;

    my $options = Data::OptList::mkopt(delete $args{constants}, "constant", 1, [qw(HASH ARRAY)]);

    my $constants = {};

    my $caller = $args{package};

    foreach my $constant ( @$options ) {
        my ( $name, $opt ) = @$constant;

        $constants->{$name} = $class->_get_value(
            %args,
            name => $name,
            %$opt,
        );
    }

    return $constants;
}

sub _get_value {
    my ( $class, %args ) = @_;

    my $value = $class->_get_var(%args);

    if ( not defined $value and $args{env} ) {
        $value = $class->_get_env_var(%args);
    }

	if ( not defined $value and defined $args{default} ) {
		$value = $args{default};
	}

    if ( $args{bool} ) {
        return not not $value;
    } elsif ( defined $value ) {
        if ( $args{num} ) {
            require Scalar::Util;
            croak "'$value' does not look like a number" unless Scalar::Util::looks_like_number($value);
            return 0+$value;
        } elsif ( $args{int} ) {
            croak "'$value' does not look like an integer" unless $value =~ /^\s* -? \d+ \s*$/x;
            return int 0+$value;
        }
	}

	return $value;
}

sub _var_name {
    my ( $class, %args ) = @_;

    join "::", @args{qw(package name)};
}

sub _get_var {
    my ( $class, %args ) = @_;

    no strict 'refs';
    return ${ $class->_var_name(%args) }
}

sub _get_env_var {
    my ( $class, %args ) = @_;

    my $name = uc $class->_var_name(%args);
    $name =~ s/^MAIN:://;
    $name =~ s/::/_/g;

    $ENV{$name};
}

# ex: set sw=4 et:

__PACKAGE__

__END__