Fix symbol table associations in VMS::DCLsym

diff --git a/ext/VMS-DCLsym/DCLsym.pm b/ext/VMS-DCLsym/DCLsym.pm
index 8eedf7f..9bbfd91 100644 (file)
--- a/ext/VMS-DCLsym/DCLsym.pm
+++ b/ext/VMS-DCLsym/DCLsym.pm
@@ -7,7 +7,7 @@ use strict;
 
 # Package globals
 @ISA = ( 'DynaLoader' );
-$VERSION = '1.04';
+$VERSION = '1.05';
 my(%Locsyms) = ( ':ID' => 'LOCAL' );
 my(%Gblsyms) = ( ':ID' => 'GLOBAL');
 my $DoCache = 1;
@@ -18,6 +18,8 @@ my $Cache_set = 0;
 
 sub new {
   my($pkg,$type) = @_;
+  $type ||= 'LOCAL';
+  $type = 'LOCAL' unless $type eq 'GLOBAL';
   bless { TYPE => $type }, $pkg;
 }
 
@@ -73,7 +75,7 @@ sub clearcache {
 #====> TIEHASH methods
 
 sub TIEHASH {
-  $_[0]->new(@_);
+  shift->new(@_);
 }
 
 sub FETCH {
@@ -262,7 +264,7 @@ Charles Bailey  bailey@newman.upenn.edu
 
 =head1 VERSION
 
-1.01  08-Dec-1996
+1.05  12-Feb-2011
 
 =head1 BUGS
 

diff --git a/ext/VMS-DCLsym/t/vms_dclsym.t b/ext/VMS-DCLsym/t/vms_dclsym.t
index 57f2afb..9124bac 100644 (file)
--- a/ext/VMS-DCLsym/t/vms_dclsym.t
+++ b/ext/VMS-DCLsym/t/vms_dclsym.t
@@ -1,14 +1,14 @@
-print "1..15\n";
+print "1..30\n";
 
-require VMS::DCLsym or die "failed 1\n";
+require VMS::DCLsym or die "not ok 1\n";
 print "ok 1\n";
 
-tie %syms, VMS::DCLsym or die "failed 2\n";
+tie %syms, VMS::DCLsym or die "not ok 2\n";
 print "ok 2\n";
 
 $name = 'FOO_'.time();
 $syms{$name} = 'Perl_test';
-print +($! ? "(\$! = $!) not " : ''),"ok 3\n";
+print +($! ? "#(\$! = $!)\nnot " : ''),"ok 3\n";
 
 print +($syms{$name} eq 'Perl_test' ? '' : 'not '),"ok 4\n";
 
@@ -21,10 +21,9 @@ while (($sym,$val) = each %syms) {
 print +($sym ? '' : 'not '),"ok 6\n";
 
 delete $syms{$name};
-print +($! ? "(\$! = $!) not " : ''),"ok 7\n";
+print +($! ? "#(\$! = $!)\nnot " : ''),"ok 7\n";
 
 print +(defined($syms{$name}) ? 'not ' : ''),"ok 8\n";
-undef %syms;
 
 $obj = new VMS::DCLsym 'GLOBAL';
 print +($obj ? '' : 'not '),"ok 9\n";
@@ -39,3 +38,38 @@ print +($val eq 'Another_test' && $tab eq 'GLOBAL' ? '' : 'not '),"ok 13\n";
 
 print +($obj->delsym($name,'LOCAL') ? 'not ' : ''),"ok 14\n";
 print +($obj->delsym($name,'GLOBAL') ? '' : 'not '),"ok 15\n";
+
+($val,$tab) = $obj->getsym($name);
+print +(defined($val) || defined($tab) ? 'not ' : ''),"ok 16\n";
+
+($val) = `Show Symbol/Global $name` =~ /==\s+"(\w+)"$/;
+print +(defined($val) ? 'not ' : ''),"ok 17\n";
+
+tie %gsyms, VMS::DCLsym, 'GLOBAL' or die "not ok 18\n";
+print "ok 18\n";
+
+print +(tied(%gsyms) =~ /^VMS::DCLsym/ ? '' : 'not '),"ok 19\n";
+print +(exists $gsyms{$name} ? 'not ' : ''),"ok 20\n";
+
+$gsyms{$name} = 'Perl_test';
+print +($! ? "#(\$! = $!)\nnot " : ''),"ok 21\n";
+
+print +($gsyms{$name} eq 'Perl_test' ? '' : 'not '),"ok 22\n";
+
+($val) = `Show Symbol/Global $name` =~ /==\s+"(\w+)"$/;
+print +($val eq 'Perl_test' ? '' : 'not '),"ok 23\n";
+
+delete $gsyms{$name};
+print +($! ? "#(\$! = $!)\nnot " : ''),"ok 24\n";
+
+($val,$tab) = $obj->getsym($name);
+print +(defined($val) || defined($tab) ? 'not ' : ''),"ok 25\n";
+
+($val) = `Show Symbol/Global $name` =~ /==\s+"(\w+)"$/;
+print +($val eq 'Perl_test' ? 'not ' : ''),"ok 26\n";
+
+print +($syms{':LOCAL'} ?  '' : 'not '),"ok 27\n";
+print +($syms{':GLOBAL'} ? 'not ' : ''),"ok 28\n";
+
+print +($gsyms{':LOCAL'} ?  'not ' : ''),"ok 29\n";
+print +($gsyms{':GLOBAL'} ? '' : 'not '),"ok 30\n";