os2/OS2/REXX/t/rx_tievar.t

   1 BEGIN {
   2     chdir 't' if -d 't/lib';
   3     @INC = '../lib' if -d 'lib';
   4     require Config; import Config;
   5     if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
   6         print "1..0\n";
   7         exit 0;
   8     }
   9 }
  10
  11 use OS2::REXX;
  12
  13 #
  14 # DLL
  15 #
  16 load OS2::REXX "ydbautil"
  17   or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
  18
  19 print "1..19\n";
  20
  21 REXX_call {
  22   print "ok 1\n";
  23
  24   #
  25   # scalar
  26   #
  27   tie $s, OS2::REXX, "TEST";
  28   print "ok 2\n";
  29   $s = 1;
  30   print "ok 3\n" if $s eq 1;
  31   print "not ok 3\n# `$s'\n" unless $s eq 1;
  32   untie $s;
  33
  34   #
  35   # hash
  36   #
  37
  38   tie %all, OS2::REXX, "";      # all REXX vars
  39   print "ok 4\n";
  40
  41   sub show {
  42         # show all REXX vars
  43         print "--@_--\n";
  44         foreach (keys %all) {
  45                 $v = $all{$_};
  46                 print "$_ => $v\n";
  47         }
  48   }
  49
  50   sub check {
  51         # check all REXX vars
  52         my ($test, @arr) = @_;
  53         my @rx;
  54         foreach $key (sort keys %all) { push @rx, $key, $all{$key} }
  55         if ("@rx" eq "@arr") {print "ok $test\n"}
  56         else { print "not ok $test\n# expect `@arr', got `@rx'\n" }
  57   }
  58
  59
  60   tie %h, OS2::REXX, "TEST.";
  61   print "ok 5\n";
  62   check(6);
  63
  64   $h{"one"} = 1;
  65   check(7, "TEST.one", 1);
  66
  67   $h{"two"} = 2;
  68   check(8, "TEST.one", 1, "TEST.two", 2);
  69
  70   $h{"one"} = "";
  71   check(9, "TEST.one", "", "TEST.two", 2);
  72   print "ok 10\n" if exists $h{"one"};
  73   print "ok 11\n" if exists $h{"two"};
  74
  75   delete $h{"one"};
  76   check(12, "TEST.two", 2);
  77   print "ok 13\n" if not exists $h{"one"};
  78   print "ok 14\n" if exists $h{"two"};
  79
  80   OS2::REXX::dropall("TEST.");
  81   print "ok 15\n";
  82   check(16);
  83   print "ok 17\n" if not exists $h{"one"};
  84   print "ok 18\n" if not exists $h{"two"};
  85
  86   untie %h;
  87   print "ok 19";
  88
  89 };