File Coverage

blib/lib/Devel/Constants.pm

Criterion	Covered	Total	%
statement	57	57	100.0
branch	21	28	75.0
condition	6	9	66.6
subroutine	12	12	100.0
pod	2	2	100.0
total	98	108	90.7

package Devel::Constants;
$Devel::Constants::VERSION = '1.04';
use 5.006;
use strict;
use warnings;
use vars qw( $VERSION %EXPORT_OK );

%EXPORT_OK =
(
	flag_to_names => \&flag_to_names,
	to_name       => \&to_name,
);

use constant;
use subs 'oldimport';

{
    no warnings;
	*oldimport        = \&constant::import;
	*constant::import = \&_newimport;
}

my %constants;

sub import
{
	my $class      = shift;

	my $pkg        = my $import = caller();
	my $flagholder = {};

	my @exports;

	while ( my $arg = shift )
	{
		if ( ref($arg) eq 'HASH' )
		{
			$flagholder = $arg;
		}
		elsif ( $arg eq 'package' )
		{
			$pkg = shift if @_;
		}
		elsif ( $arg eq 'import' )
		{
			$import = shift if @_;
		}
		elsif ( exists $EXPORT_OK{$arg} )
		{
			my $name = (@_ and ! exists $EXPORT_OK{ $_[0] }) ? shift : $arg;
			push @exports, [ $name, $EXPORT_OK{$arg} ];
		}
	}

	$constants{$pkg} = $flagholder;

	no strict 'refs';
	for my $export (@exports)
	{
		*{ $import . "::$export->[0]" } = $export->[1];
	}

}

sub _newimport
{
	my ( $class, @args ) = @_;
	my $pkg              = caller();

	if ( defined $constants{$pkg} )
	{
		while (@args)
		{
			my ( $name, $val ) = splice( @args, 0, 2 );
			last unless $val;
			$constants{$pkg}{$val} = $name;
		}
	}

	goto &oldimport;
}

sub flag_to_names
{
	my ( $val, $pkg ) = @_;
	$pkg            ||= caller();

	return unless my $constants = $constants{$pkg};

	my @flags;
	for my $flag ( keys %$constants )
	{
		push @flags, $constants->{$flag} if $val & $flag;
	}
	return wantarray() ? @flags : join( ' ', @flags );
}

sub to_name
{
	my ( $val, $pkg ) = @_;
	$pkg            ||= caller();

	return unless my $constants = $constants{$pkg};
	return $constants->{$val} if exists $constants->{$val};
}

1;

__END__