1#!perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 6 require "./test.pl"; 7 set_up_inc( '../lib' ) if -d '../lib' && -d '../ext'; 8 require Config; import Config; 9 10 if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) { 11 skip_all('-- IPC::SysV was not built'); 12 } 13 skip_all_if_miniperl(); 14 if ($Config{'d_sem'} ne 'define') { 15 skip_all('-- $Config{d_sem} undefined'); 16 } 17} 18 19use strict; 20use warnings; 21our $TODO; 22 23use sigtrap qw/die normal-signals error-signals/; 24use IPC::SysV qw/ IPC_PRIVATE S_IRUSR S_IWUSR IPC_RMID SETVAL GETVAL SETALL GETALL IPC_CREAT IPC_STAT /; 25 26my $id; 27my $nsem = 10; 28my $ignored = 0; 29END { semctl $id, 0, IPC_RMID, 0 if defined $id } 30 31{ 32 local $SIG{SYS} = sub { skip_all("SIGSYS caught") } if exists $SIG{SYS}; 33 $id = semget IPC_PRIVATE, $nsem, S_IRUSR | S_IWUSR | IPC_CREAT; 34} 35 36if (not defined $id) { 37 my $info = "semget failed: $!"; 38 if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS || 39 $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) { 40 skip_all($info); 41 } 42 else { 43 die $info; 44 } 45} 46else { 47 plan(tests => 22); 48 pass('acquired semaphore'); 49} 50 51my @warnings; 52$SIG{__WARN__} = sub { push @warnings, "@_"; print STDERR @_; }; 53{ # [perl #120635] 64 bit big-endian semctl SETVAL bug 54 ok(semctl($id, $ignored, SETALL, pack("s!*",(0)x$nsem)), 55 "Initialize all $nsem semaphores to zero"); 56 57 my $sem2set = 3; 58 my $semval = 192; 59 ok(semctl($id, $sem2set, SETVAL, $semval), 60 "Set semaphore $sem2set to $semval"); 61 62 my $semvals; 63 ok(semctl($id, $ignored, GETALL, $semvals), 64 'Get current semaphore values'); 65 66 my @semvals = unpack("s!*", $semvals); 67 is(scalar(@semvals), $nsem, 68 "Make sure we get back statuses for all $nsem semaphores"); 69 70 is($semvals[$sem2set], $semval, 71 "Checking value of semaphore $sem2set"); 72 73 is(semctl($id, $sem2set, GETVAL, $ignored), $semval, 74 "Check value via GETVAL"); 75 76 # check utf-8 flag handling 77 # first that we reset it on a fetch 78 utf8::upgrade($semvals); 79 ok(semctl($id, $ignored, GETALL, $semvals), 80 "fetch into an already UTF-8 buffer"); 81 @semvals = unpack("s!*", $semvals); 82 is($semvals[$sem2set], $semval, 83 "Checking value of semaphore $sem2set after fetch into originally UTF-8 buffer"); 84 85 # second that we treat it as bytes on input 86 @semvals = ( 0 ) x $nsem; 87 $semvals[$sem2set] = $semval + 1; 88 $semvals = pack "s!*", @semvals; 89 utf8::upgrade($semvals); 90 # eval{} since it would crash due to the UTF-8 form being longer 91 ok(eval { semctl($id, $ignored, SETALL, $semvals) }, 92 "set all semaphores from an upgraded string"); 93 # undef here to test it doesn't warn 94 is(semctl($id, $sem2set, GETVAL, undef), $semval+1, 95 "test value set from UTF-8"); 96 97 # third, that we throw on a code point above 0xFF 98 substr($semvals, 0, 1) = chr(0x101); 99 ok(!eval { semctl($id, $ignored, SETALL, $semvals); 1 }, 100 "throws on code points above 0xff"); 101 like($@, qr/Wide character/, "with the expected error"); 102 103 { 104 # semop tests 105 ok(semctl($id, $sem2set, SETVAL, 0), 106 "reset our working entry"); 107 # sanity check without UTF-8 108 my $op = pack "s!*", $sem2set, $semval, 0; 109 ok(semop($id, $op), "add to entry $sem2set"); 110 is(semctl($id, $sem2set, GETVAL, 0), $semval, 111 "check it added to the entry"); 112 utf8::upgrade($op); 113 # unlike semctl this doesn't throw on a bad size, so we don't need an 114 # eval with the buggy code 115 ok(semop($id, $op), "add more to entry $sem2set (UTF-8)"); 116 is(semctl($id, $sem2set, GETVAL, 0), $semval*2, 117 "check it added to the entry"); 118 119 substr($op, 0, 1) = chr(0x101); 120 ok(!eval { semop($id, $op); 1 }, 121 "test semop throws if the op string isn't 'bytes'"); 122 like($@, qr/Wide character/, "with the expected error"); 123 } 124} 125 126{ 127 my $stat; 128 # shouldn't warn 129 semctl($id, $ignored, IPC_STAT, $stat); 130 ok(defined $stat, "it statted"); 131} 132 133is(scalar @warnings, 0, "no warnings"); 134