ext/VMS-DCLsym/t/vms_dclsym.t

   1 print "1..15\n";
   2
   3 require VMS::DCLsym or die "failed 1\n";
   4 print "ok 1\n";
   5
   6 tie %syms, VMS::DCLsym or die "failed 2\n";
   7 print "ok 2\n";
   8
   9 $name = 'FOO_'.time();
  10 $syms{$name} = 'Perl_test';
  11 print +($! ? "(\$! = $!) not " : ''),"ok 3\n";
  12
  13 print +($syms{$name} eq 'Perl_test' ? '' : 'not '),"ok 4\n";
  14
  15 ($val) = `Show Symbol $name` =~ /(\w+)"$/;
  16 print +($val eq 'Perl_test' ? '' : 'not '),"ok 5\n";
  17
  18 while (($sym,$val) = each %syms) {
  19   last if $sym eq $name && $val eq 'Perl_test';
  20 }
  21 print +($sym ? '' : 'not '),"ok 6\n";
  22
  23 delete $syms{$name};
  24 print +($! ? "(\$! = $!) not " : ''),"ok 7\n";
  25
  26 print +(defined($syms{$name}) ? 'not ' : ''),"ok 8\n";
  27 undef %syms;
  28
  29 $obj = new VMS::DCLsym 'GLOBAL';
  30 print +($obj ? '' : 'not '),"ok 9\n";
  31
  32 print +($obj->clearcache(0) ? '' : 'not '),"ok 10\n";
  33 print +($obj->clearcache(1) ? 'not ' : ''),"ok 11\n";
  34
  35 print +($obj->setsym($name,'Another_test') ? '' : 'not '),"ok 12\n";
  36
  37 ($val,$tab) = $obj->getsym($name);
  38 print +($val eq 'Another_test' && $tab eq 'GLOBAL' ? '' : 'not '),"ok 13\n";
  39
  40 print +($obj->delsym($name,'LOCAL') ? 'not ' : ''),"ok 14\n";
  41 print +($obj->delsym($name,'GLOBAL') ? '' : 'not '),"ok 15\n";