summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJesse Luehrs <doy@tozt.net>2010-05-11 22:11:15 -0500
committerJesse Luehrs <doy@tozt.net>2010-05-11 22:28:21 -0500
commit3634ce60eff13a438a24efd8b61192aadff7d0de (patch)
tree69834701b2dc9938cd92483e8f1790289630b8c5
parent56a29840c0b7b0c4a09243ea05400c3df8ad0823 (diff)
downloadpackage-stash-3634ce60eff13a438a24efd8b61192aadff7d0de.tar.gz
package-stash-3634ce60eff13a438a24efd8b61192aadff7d0de.zip
error when trying to init a stash slot with a value of the wrong type
-rw-r--r--lib/Stash/Manip.pm18
-rw-r--r--t/001-basic.t23
2 files changed, 41 insertions, 0 deletions
diff --git a/lib/Stash/Manip.pm b/lib/Stash/Manip.pm
index 944eab3..40e9567 100644
--- a/lib/Stash/Manip.pm
+++ b/lib/Stash/Manip.pm
@@ -110,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) = @_;
@@ -117,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';
diff --git a/t/001-basic.t b/t/001-basic.t
index 52ddfaa..ef95bf1 100644
--- a/t/001-basic.t
+++ b/t/001-basic.t
@@ -225,4 +225,27 @@ is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for
ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
}
+# check some errors
+
+dies_ok {
+ $foo_stash->add_package_symbol('@bar', {})
+} "can't initialize a slot with the wrong type of value";
+
+dies_ok {
+ $foo_stash->add_package_symbol('bar', [])
+} "can't initialize a slot with the wrong type of value";
+
+dies_ok {
+ $foo_stash->add_package_symbol('$bar', sub { })
+} "can't initialize a slot with the wrong type of value";
+
+{
+ package Bar;
+ open *foo, '<', $0;
+}
+
+dies_ok {
+ $foo_stash->add_package_symbol('$bar', *Bar::foo{IO})
+} "can't initialize a slot with the wrong type of value";
+
done_testing;