home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / ipc_sysv.t < prev    next >
Text File  |  2000-03-18  |  5KB  |  217 lines

  1. #!./perl
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.  
  6.     unshift @INC, '../lib';
  7.  
  8.     require Config; import Config;
  9.  
  10.     my $reason;
  11.  
  12.     if ($Config{'d_sem'} ne 'define') {
  13.       $reason = '$Config{d_sem} undefined';
  14.     } elsif ($Config{'d_msg'} ne 'define') {
  15.       $reason = '$Config{d_msg} undefined';
  16.     }
  17.     if ($reason) {
  18.     print "1..0 # Skip: $reason\n";
  19.     exit 0;
  20.     }
  21. }
  22.  
  23. # These constants are common to all tests.
  24. # Later the sem* tests will import more for themselves.
  25.  
  26. use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU);
  27. use strict;
  28.  
  29. print "1..16\n";
  30.  
  31. my $msg;
  32. my $sem;
  33.  
  34. $SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
  35.  
  36. # FreeBSD is known to throw this if there's no SysV IPC in the kernel.
  37. $SIG{SYS} = sub {
  38.     print STDERR <<EOM;
  39. SIGSYS caught.
  40. It may be that your kernel does not have SysV IPC configured.
  41.  
  42. EOM
  43.     if ($^O eq 'freebsd') {
  44.     print STDERR <<EOM;
  45. You must have following options in your kernel:
  46.  
  47. options         SYSVSHM
  48. options         SYSVSEM
  49. options         SYSVMSG
  50.  
  51. See config(8).
  52. EOM
  53.     }
  54.     exit(1);
  55. };
  56.  
  57. my $perm = S_IRWXU;
  58.  
  59. if ($Config{'d_msgget'} eq 'define' &&
  60.     $Config{'d_msgctl'} eq 'define' &&
  61.     $Config{'d_msgsnd'} eq 'define' &&
  62.     $Config{'d_msgrcv'} eq 'define') {
  63.  
  64.     $msg = msgget(IPC_PRIVATE, $perm);
  65.     # Very first time called after machine is booted value may be 0 
  66.     die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
  67.  
  68.     print "ok 1\n";
  69.  
  70.     #Putting a message on the queue
  71.     my $msgtype = 1;
  72.     my $msgtext = "hello";
  73.  
  74.     my $test2bad;
  75.     my $test5bad;
  76.     my $test6bad;
  77.  
  78.     unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) {
  79.     print "not ";
  80.     $test2bad = 1;
  81.     }
  82.     print "ok 2\n";
  83.     if ($test2bad) {
  84.     print <<EOM;
  85. #
  86. # The failure of the subtest #2 may indicate that the message queue
  87. # resource limits either of the system or of the testing account
  88. # have been reached.  Error message "Operating would block" is
  89. # usually indicative of this situation.  The error message was now:
  90. # "$!"
  91. #
  92. # You can check the message queues with the 'ipcs' command and
  93. # you can remove unneeded queues with the 'ipcrm -q id' command.
  94. # You may also consider configuring your system or account
  95. # to have more message queue resources.
  96. #
  97. # Because of the subtest #2 failing also the substests #5 and #6 will
  98. # very probably also fail.
  99. #
  100. EOM
  101.     }
  102.  
  103.     my $data;
  104.     msgctl($msg,IPC_STAT,$data) or print "not ";
  105.     print "ok 3\n";
  106.  
  107.     print "not " unless length($data);
  108.     print "ok 4\n";
  109.  
  110.     my $msgbuf;
  111.     unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) {
  112.     print "not ";
  113.     $test5bad = 1;
  114.     }
  115.     print "ok 5\n";
  116.     if ($test5bad && $test2bad) {
  117.     print <<EOM;
  118. #
  119. # This failure was to be expected because the subtest #2 failed.
  120. #
  121. EOM
  122.     }
  123.  
  124.     my($rmsgtype,$rmsgtext);
  125.     ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf);
  126.     unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
  127.     print "not ";
  128.     $test6bad = 1;
  129.     }
  130.     print "ok 6\n";
  131.     if ($test6bad && $test2bad) {
  132.     print <<EOM;
  133. #
  134. # This failure was to be expected because the subtest #2 failed.
  135. #
  136. EOM
  137.      }
  138. } else {
  139.     for (1..6) {
  140.     print "ok $_\n"; # fake it
  141.     }
  142. }
  143.  
  144. if($Config{'d_semget'} eq 'define' &&
  145.    $Config{'d_semctl'} eq 'define') {
  146.  
  147.     if ($Config{'d_semctl_semid_ds'} eq 'define' ||
  148.     $Config{'d_semctl_semun'}    eq 'define') {
  149.  
  150.     use IPC::SysV qw(IPC_CREAT GETALL SETALL);
  151.  
  152.     $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
  153.     # Very first time called after machine is booted value may be 0 
  154.     die "semget: $!\n" unless defined($sem) && $sem >= 0;
  155.  
  156.     print "ok 7\n";
  157.  
  158.     my $data;
  159.     semctl($sem,0,IPC_STAT,$data) or print "not ";
  160.     print "ok 8\n";
  161.     
  162.     print "not " unless length($data);
  163.     print "ok 9\n";
  164.  
  165.     my $nsem = 10;
  166.  
  167.     semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not ";
  168.     print "ok 10\n";
  169.  
  170.     $data = "";
  171.     semctl($sem,0,GETALL,$data) or print "not ";
  172.     print "ok 11\n";
  173.  
  174.     print "not " unless length($data) == length(pack("s!*",(0) x $nsem));
  175.     print "ok 12\n";
  176.  
  177.     my @data = unpack("s!*",$data);
  178.  
  179.     my $adata = "0" x $nsem;
  180.  
  181.     print "not " unless @data == $nsem and join("",@data) eq $adata;
  182.     print "ok 13\n";
  183.  
  184.     my $poke = 2;
  185.  
  186.     $data[$poke] = 1;
  187.     semctl($sem,0,SETALL,pack("s!*",@data)) or print "not ";
  188.     print "ok 14\n";
  189.     
  190.     $data = "";
  191.     semctl($sem,0,GETALL,$data) or print "not ";
  192.     print "ok 15\n";
  193.  
  194.     @data = unpack("s!*",$data);
  195.  
  196.     my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
  197.  
  198.     print "not " unless join("",@data) eq $bdata;
  199.     print "ok 16\n";
  200.     } else {
  201.     for (7..16) {
  202.         print "ok $_ # skipped, no semctl possible\n";
  203.     }
  204.     }
  205. } else {
  206.     for (7..16) {
  207.     print "ok $_\n"; # fake it
  208.     }
  209. }
  210.  
  211. sub cleanup {
  212.     msgctl($msg,IPC_RMID,0)       if defined $msg;
  213.     semctl($sem,0,IPC_RMID,undef) if defined $sem;
  214. }
  215.  
  216. cleanup;
  217.