error when trying to init a stash slot with a value of the wrong type

[gitmo/Package-Stash.git] / lib / Stash / Manip.pm

diff --git a/lib/Stash/Manip.pm b/lib/Stash/Manip.pm
index be37e87..40e9567 100644 (file)
--- a/lib/Stash/Manip.pm
+++ b/lib/Stash/Manip.pm
@@ -24,6 +24,9 @@ Manipulating stashes (Perl's symbol tables) is occasionally necessary, but
 incredibly messy, and easy to get wrong. This module hides all of that behind a
 simple API.
 
+NOTE: Most methods in this class require a variable specification that includes
+a sigil. If this sigil is absent, it is assumed to represent the IO slot.
+
 =head1 METHODS
 
 =cut
@@ -75,23 +78,23 @@ sub namespace {
         '@' => 'ARRAY',
         '%' => 'HASH',
         '&' => 'CODE',
+        ''  => 'IO',
     );
 
     sub _deconstruct_variable_name {
         my ($self, $variable) = @_;
 
-        (defined $variable)
+        (defined $variable && length $variable)
             || confess "You must pass a variable name";
 
         my $sigil = substr($variable, 0, 1, '');
 
-        (defined $sigil)
-            || confess "The variable name must include a sigil";
-
-        (exists $SIGIL_MAP{$sigil})
-            || confess "I do not recognize that sigil '$sigil'";
-
-        return ($variable, $sigil, $SIGIL_MAP{$sigil});
+        if (exists $SIGIL_MAP{$sigil}) {
+            return ($variable, $sigil, $SIGIL_MAP{$sigil});
+        }
+        else {
+            return ("${sigil}${variable}", '', $SIGIL_MAP{''});
+        }
     }
 }
 
@@ -107,6 +110,19 @@ will create C<%Foo::foo>.
 
 =cut
 
+sub _valid_for_type {
+    my $self = shift;
+    my ($value, $type) = @_;
+    if ($type eq 'HASH' || $type eq 'ARRAY'
+     || $type eq 'IO'   || $type eq 'CODE') {
+        return reftype($value) eq $type;
+    }
+    else {
+        my $ref = reftype($value);
+        return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE';
+    }
+}
+
 sub add_package_symbol {
     my ($self, $variable, $initial_value) = @_;
 
@@ -114,6 +130,11 @@ sub add_package_symbol {
         ? @{$variable}{qw[name sigil type]}
         : $self->_deconstruct_variable_name($variable);
 
+    if (@_ > 2) {
+        $self->_valid_for_type($initial_value, $type)
+            || confess "$initial_value is not of type $type";
+    }
+
     my $pkg = $self->name;
 
     no strict 'refs';
@@ -184,8 +205,12 @@ sub get_package_symbol {
     my $namespace = $self->namespace;
 
     # FIXME
-    $self->add_package_symbol($variable)
-        unless exists $namespace->{$name};
+    if (!exists $namespace->{$name}) {
+        my $initial = $type eq 'ARRAY' ? []
+                    : $type eq 'HASH'  ? {}
+                    : \undef;
+        $self->add_package_symbol($variable, $initial)
+    }
 
     my $entry_ref = \$namespace->{$name};
 
@@ -222,33 +247,44 @@ sub remove_package_symbol {
     # no doubt this is grossly inefficient and 
     # could be done much easier and faster in XS
 
-    my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
+    my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
         { sigil => '$', type => 'SCALAR', name => $name },
         { sigil => '@', type => 'ARRAY',  name => $name },
         { sigil => '%', type => 'HASH',   name => $name },
         { sigil => '&', type => 'CODE',   name => $name },
+        { sigil => '',  type => 'IO',     name => $name },
     );
 
-    my ($scalar, $array, $hash, $code);
+    my ($scalar, $array, $hash, $code, $io);
     if ($type eq 'SCALAR') {
         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
+        $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
     }
     elsif ($type eq 'ARRAY') {
         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
+        $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
     }
     elsif ($type eq 'HASH') {
         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
+        $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
     }
     elsif ($type eq 'CODE') {
         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
+        $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
+    }
+    elsif ($type eq 'IO') {
+        $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
+        $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
+        $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
+        $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
     }
     else {
         confess "This should never ever ever happen";
@@ -260,6 +296,7 @@ sub remove_package_symbol {
     $self->add_package_symbol($array_desc  => $array)  if defined $array;
     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
     $self->add_package_symbol($code_desc   => $code)   if defined $code;
+    $self->add_package_symbol($io_desc     => $io)     if defined $io;
 }
 
 =head2 list_all_package_symbols $type_filter