File Coverage

blib/lib/define.pm

Criterion	Covered	Total	%
statement	57	60	95.0
branch	16	18	88.8
condition	2	6	33.3
subroutine	12	13	92.3
pod	0	3	0.0
total	87	100	87.0

package define;
$define::VERSION = '1.04';
use 5.006;
use strict;
use warnings;
use Carp qw/ carp croak /;

my %AllPkgs;
my %DefPkgs;
my %Vals;

my %Forbidden = map { $_ => 1 } qw{
  BEGIN INIT CHECK END DESTROY AUTOLOAD
  STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG
};

sub import {
  my $class = shift;
  my $pkg = (caller)[0];
  if( @_ ) {
    if( ref $_[0] eq 'HASH' ) {
      while( my( $name, $val ) = each %{$_[0]} ) {
        do_import( $pkg, $name, $val );
      }
    }
    else {
      do_import( $pkg, @_ );
    }
  }
  else {
    croak "Must call 'use define' with parameters";
  }
}

sub unimport {
  my $class = shift;
  my $pkg = (caller)[0];
  if( @_ ) {
    check_name( my $name = shift );
    $DefPkgs{$name}{$pkg} = 1;
    if( $Vals{$name} ) {
      makedef( $pkg, $name, @{$Vals{$name}} );
    }
    else {
      makedef( $pkg, $name );
    }
  }
  else {
    # export all Declared to pkg
    $AllPkgs{$pkg} = 1;
    while( my( $name, $val ) = each %Vals ) {
      # warn "Defining ALL $pkg:$name:$val";
      makedef( $pkg, $name, @$val );
    }
  }
}

sub check_name {
  my $name = shift;
  if( $name =~ /^__/
      or $name !~ /^_?[^\W_0-9]\w*\z/
      or $Forbidden{$name} ) {
    croak "Define name '$name' is invalid";
  }
}

sub do_import {
  my( $pkg, $name, @vals ) = @_;
  check_name( $name );
  $DefPkgs{$name}{$pkg} = 1;
  $Vals{$name} = [ @vals ];
  my %pkgs = ( $pkg => 1, %AllPkgs, %{$DefPkgs{$name}} );
  for (keys %pkgs) {
    makedef( $_, $name, @vals );
  }
}

sub makedef {
  my ($pkg, $name, @Vals) = @_;
  my $subname = "${pkg}::$name";

  no strict 'refs';

  if (defined *{$subname}{CODE}) {
    carp "Global constant $subname redefined";
  }

  if (@Vals > 1) {
    *$subname = sub () { @Vals };
  }
  elsif (@Vals == 1) {
    my $val = $Vals[0];

    if ($val =~ /^[0-9]+$/) {
        *$subname = eval "sub () { $val }";
    }
    else {
        *$subname = sub () { $val };
    }
  }
  else {
    *$subname = sub () { };
  }
}

1;

__END__