File Coverage

blib/lib/ex/constant/vars.pm

Criterion	Covered	Total	%
statement	99	99	100.0
branch	14	16	87.5
condition	2	3	66.6
subroutine	29	29	100.0
pod	1	3	33.3
total	145	150	96.6

package ex::constant::vars;

use 5.006;
use strict;
use warnings;
use Carp;

require Exporter;

our $VERSION    = '0.05';

our @ISA        = qw(
                      Exporter
                      ex::constant::vars::scalar
                      ex::constant::vars::array
                      ex::constant::vars::hash
                    );
our @EXPORT_OK  = qw( const SCALAR ARRAY HASH );

sub const {
  my $type   = shift;
  my @values = splice @_, 1;
  if ( $type eq 'scalar' ) {
    return tie ${$_[0]}, __PACKAGE__ . '::' . $type, @values;
  } elsif ( $type eq 'array' ) {
    return tie @{$_[0]}, __PACKAGE__ . '::' . $type, @values;
  } else {
    return tie %{$_[0]}, __PACKAGE__ . '::' . $type, @values;
  }
}

sub SCALAR (\$$) { 'scalar', @_ }
sub ARRAY  (\@@) { 'array',  @_ }
sub HASH   (\%%) { 'hash',   @_ }

sub import {
  my $self = shift;
  return unless @_;
  if ( @_ == 1 && $_[0] eq 'const' ) {
    $self->export_to_level( 1, $self, @EXPORT_OK );
  } else {
    my %variables = @_;
    my $caller    = caller( 0 );
    while ( my( $var, $val ) = each %variables ) {
      my( $prefix, $name ) = split //, $var, 2;
      croak "'$var' not a valid variable name" unless $prefix =~ /^[\$\@\%]$/;
      if ( $prefix eq '$' ) {
        no strict 'refs';
        *{__PACKAGE__ . "::variables::$name"} = \$val;
        *{"${caller}::$name"} = \${__PACKAGE__ . "::variables::$name"};
        const SCALAR ${"${caller}::$name"}, $val;
      } elsif ( $prefix eq '@' ) {
        no strict 'refs';
        *{__PACKAGE__ . "::variables::$name"} = \@{$val};
        *{"${caller}::$name"} = \@{__PACKAGE__ . "::variables::$name"};
        const ARRAY @{"${caller}::$name"}, @{$val};
      } elsif ( $prefix eq '%' ) {
        no strict 'refs';
        *{__PACKAGE__ . "::variables::$name"} = \%{$val};
        *{"${caller}::$name"} = \%{__PACKAGE__ . "::variables::$name"};
        const HASH %{"${caller}::$name"}, %{$val};
      }
    }
  }
}


package ex::constant::vars::scalar;
use Carp;
$Carp::CarpLevel = 1;
sub TIESCALAR { shift; bless \(my $scalar = shift), __PACKAGE__ }
sub FETCH     { ${$_[0]} }
sub STORE     { croak "Modification of a read-only value attempted" }


package ex::constant::vars::array;
use Carp;
$Carp::CarpLevel = 1;
sub TIEARRAY  { shift; bless $_=\@_, __PACKAGE__ }
sub FETCH     { $_[0]->[$_[1]] }
sub FETCHSIZE { @{$_[0]} }
sub EXISTS    { exists $_[0]->[$_[1]] }
sub STORE     { croak "Modification of a read-only value attempted" }
*CLEAR   = *EXTEND = *POP       = *PUSH   = *SHIFT =
*UNSHIFT = *SPLICE = *STORESIZE = *DELETE = \*STORE;


package ex::constant::vars::hash;
use Carp;
$Carp::CarpLevel = 1;
sub TIEHASH  { bless {@_[1...$#_]}, __PACKAGE__ }
sub FETCH    { $_[0]->{$_[1]} }
sub FIRSTKEY { keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY  { each %{$_[0]} }
sub EXISTS   { exists $_[0]->{$_[1]} }
sub STORE    { croak "Modification of a read-only value attempted" }
*CLEAR = *DELETE = \*STORE;

1;

__END__