File Coverage

blib/lib/Symbol/Glob.pm

Criterion	Covered	Total	%
statement	111	111	100.0
branch	42	50	84.0
condition	1	6	16.6
subroutine	18	18	100.0
pod	7	7	100.0
total	179	192	93.2

package Symbol::Glob;

our $VERSION = '0.04';

use warnings;
use strict;
use Carp;

use Scalar::Util qw(reftype);

{
  my (%hash_of, %code_of, %array_of, %scalar_of, %io_of, %format_of, %name_of);

  my %Slot_To_Storage_Of = (
    SCALAR => \%scalar_of,
    ARRAY  => \%array_of,
    HASH   => \%hash_of,
    CODE   => \%code_of,
    IO     => \%io_of,
    FORMAT => \%format_of,
  );

  my %Slot_To_Method_Of = (
    SCALAR => 'scalar',
    ARRAY  => 'array',
    HASH   => 'hash',
    CODE   => 'sub',
    IO     => 'io',
    FORMAT => 'format',
  );

  my %Method_To_Slot_Of = reverse %Slot_To_Method_Of;

  sub new {
      my($class, $arg_ref) = @_;
      my $self = {};
      bless $self, $class;
      $self->BUILD($arg_ref);
      return $self;
  }

  sub BUILD {
    my ($self, $arg_ref) = @_;

    die "Argument to Symbol::Glob->new() must be hash reference"
        if not ref $arg_ref eq 'HASH';
    my $name = $arg_ref->{'name'};
    die "No typeglob name supplied" unless $name;

    $name_of{$self} = $name;

  CHECK_SLOTS:
    for my $slot (keys %Slot_To_Storage_Of) {
      my $slot_of = $Slot_To_Storage_Of{$slot};
      my $method  = $Slot_To_Method_Of{$slot};

      # Copy out the original glob's contents if they exist.
      my $contents;
      {
        no strict 'refs';
        $contents = *{ $name }{$slot};
      }

      if (defined $contents) {
        if ($method eq 'scalar') {
          # We should have gotten a reference to the scalar value here.
          $contents = $$contents;
          # special case: undef scalar is \undef.
          next CHECK_SLOTS if !defined $contents;
        }

        $self->$method($contents);
      }

      # Arguments supplied to new() override
      # the glob contents.
      next CHECK_SLOTS if !exists $arg_ref->{$method};

      my $override = $arg_ref->{$method};

      if (defined $override) {
        $self->$method($override);
      }
    }

    # Object and glob are now in sync.
    return $self;
  }

  sub scalar {
    my ($self, $value) = @_;

    if (defined $value) {
      $self->_reslot(\$value, \%scalar_of, 'SCALAR');
    }

    my $return_value = $scalar_of{$self};
    return   !defined $return_value ? undef
           : !ref $return_value     ? $return_value
           : $$return_value;
  }

  sub hash {
    my ($self, $value) = @_;
    if (defined $value) {
      wantarray ? %{$self->_reslot($value, \%hash_of, 'HASH')}
                : $self->_reslot($value, \%hash_of, 'HASH');
    }
    else {
      wantarray ? %{$hash_of{$self}} : $hash_of{$self};
    }
  }

  sub array {
    my ($self, $value) = @_;
    if (defined $value) {
      wantarray ? @{$self->_reslot($value, \%array_of, 'ARRAY')}
                : $self->_reslot($value, \%array_of, 'ARRAY');
    }
    else {
      wantarray ? @{$array_of{$self}} : $array_of{$self};
    }
  }

  sub sub {
    my ($self, $value) = @_;
    if (defined $value) {
      $self->_reslot($value, \%code_of, 'CODE');
    }
    else {
      $code_of{$self};
    }
  }

  sub _reslot {
    my ($self, $value, $slot_of_ref, $slot_to_be_replaced) = @_;
    if ($slot_to_be_replaced eq 'SCALAR') {
      $slot_of_ref->{$self} = $$value;
    }
    else {
      $slot_of_ref->{$self} = $value;
    }

    croak "You can't fill a $slot_to_be_replaced with a " .  reftype($value)
      unless (reftype($value) eq $slot_to_be_replaced) or
             (reftype($value) eq 'REF' and $slot_to_be_replaced eq 'SCALAR');

    # Handy way to reference the glob.
    my $dest = $name_of{$self};

    {
      no strict;
      no warnings 'redefine';
      *{$dest} = $value;
    }

    return $slot_of_ref->{$self};
  }

  sub delete {
    my ($self, $slot_to_delete) = @_;
    my $storage_ref;

    # delete the slot in the object, and
    # then copy the object back into the
    # glob again as we do duing BUILD.
    if (defined $slot_to_delete) {
      my $glob_slot = $Method_To_Slot_Of{$slot_to_delete};
      $storage_ref = $Slot_To_Storage_Of{$glob_slot};

      delete $storage_ref->{$self};
    }

    # Delete the glob so it can be reconstituted.
    my $dest = $name_of{$self};
    my ($package, $symbol) = ($dest =~ /(.*::)*(.*)/);
    $package = __PACKAGE__.'::' unless $package;
    my $globref;

    {
      no strict;
      $globref = \%{$package};
      undef *{$dest};
    }

    # If no argument, deleting everything.
    return unless defined $slot_to_delete;

    for my $method (keys %Method_To_Slot_Of) {
      next if $method eq $slot_to_delete;

      $storage_ref = $Slot_To_Storage_Of{$Method_To_Slot_Of{$method}};
      my $value = $storage_ref->{$self};
      $value = \$value if $method eq 'scalar';

      {
        no warnings 'redefine';
        no strict 'refs';

        $globref->{$symbol} = $value
          if defined $storage_ref->{$self};
      }
    }
  }
}

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