File Coverage

blib/lib/vars/global.pm

Criterion	Covered	Total	%
statement	64	67	95.5
branch	20	22	90.9
condition			n/a
subroutine	12	12	100.0
pod	2	2	100.0
total	98	103	95.1

package vars::global;
{
   use version; $VERSION = qv('0.0.4');

   use warnings;
   use strict;
   use Carp;

   # Module implementation here
   # Where we keep existing globals
   my %ref_for;

   sub import {
      my $package = shift;
      my $caller  = caller;
      my @import;
      GRAB_IMPORTS:
      while (@_) {
         my $param = shift;
         last GRAB_IMPORTS if lc($param) eq 'create';

         if (lc($param) eq ':all') {
            @import = keys %ref_for;
            while (@_) {
                last GRAB_IMPORTS if shift eq 'create';
            }
            last GRAB_IMPORTS;
         }

         push @import, $param;
      }
      $package->_create($caller, @_);
      $package->_import($caller, @import, @_);
      return;
   } ## end sub import

   sub create {
      my $package = shift;
      my $caller  = caller;
      $package->_create($caller, @_);
      $package->_import($caller, @_);
      return;
   } ## end sub create

   sub has {
      my $package = shift;
      my ($symbol) = @_;
      return unless exists $ref_for{$symbol};
      return $ref_for{$symbol};
   } ## end sub has

   sub _create {
      my $package = shift;
      my $caller  = shift;
      my @symbols = @_;
      no strict 'refs';
      no warnings 'once';
      foreach my $symbol (@symbols) {

         # Some checks
         croak "undefined symbol" unless defined $symbol;
         croak "empty symbol"     unless length $symbol;
         my $identifier = substr $symbol, 1;
         croak "invalid identifier '$identifier'"
           unless $identifier =~ /\A \w+ \z/mxs;

         my $fqn = $package . '::' . $identifier;
         my $sigil = substr $symbol, 0, 1;
         $ref_for{$symbol} =
             $sigil eq '$' ? \${$fqn}
           : $sigil eq '@' ? \@{$fqn}
           : $sigil eq '%' ? \%{$fqn}
           : croak "invalid sigil: '$sigil'";
      } ## end foreach my $symbol (@symbols)
      return;
   } ## end sub _create

   sub _import {
      my $package = shift;
      my $caller  = shift;
      no strict 'refs';
      foreach my $symbol (@_) {
        my $ref = $package->has($symbol)
           or croak "non existent global: '$symbol'";
         *{$caller . '::' . substr $symbol, 1} = $ref;
      }
      return;
   } ## end sub _import
}

1;    # Magic true value required at end of module
__END__