diff options
author | Charles Bailey <bailey.charles@gmail.com> | 2011-02-13 13:16:56 -0500 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2011-02-14 10:00:46 -0800 |
commit | 692dce0887a12795213f4ff0fc00b3b25d90a32e (patch) | |
tree | 3fef3fce1a50713eedad5be23c6e15d96bf13ec3 /ext/VMS-DCLsym | |
parent | e36465968f3fc8c1cc7b2e0e5bd51e296be018aa (diff) | |
download | perl-692dce0887a12795213f4ff0fc00b3b25d90a32e.tar.gz |
Fix symbol table associations in VMS::DCLsym
Diffstat (limited to 'ext/VMS-DCLsym')
-rw-r--r-- | ext/VMS-DCLsym/DCLsym.pm | 8 | ||||
-rw-r--r-- | ext/VMS-DCLsym/t/vms_dclsym.t | 46 |
2 files changed, 45 insertions, 9 deletions
diff --git a/ext/VMS-DCLsym/DCLsym.pm b/ext/VMS-DCLsym/DCLsym.pm index 8eedf7facd..9bbfd918c8 100644 --- 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 57f2afbd20..9124bacfda 100644 --- 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"; |