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; Config->import; 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_msg'} ne 'define') { 15 skip_all('-- $Config{d_msg} 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 IPC_CREAT IPC_STAT IPC_CREAT IPC_NOWAIT/; 25use Errno qw(EINVAL); 26 27my $id; 28END { msgctl $id, IPC_RMID, 0 if defined $id } 29 30{ 31 local $SIG{SYS} = sub { skip_all("SIGSYS caught") } if exists $SIG{SYS}; 32 $id = msgget IPC_PRIVATE, S_IRUSR | S_IWUSR | IPC_CREAT; 33} 34 35if (not defined $id) { 36 my $info = "msgget failed: $!"; 37 if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS || 38 $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) { 39 skip_all($info); 40 } 41 else { 42 die $info; 43 } 44} 45else { 46 pass('acquired msg queue'); 47} 48 49{ 50 # basic send/receive 51 my $type = 0x1F0; 52 my $content = "AB\xFF\xC0"; 53 54 my $msg = pack("l! a*", $type, $content); 55 if (ok(msgsnd($id, $msg, IPC_NOWAIT), "send a message")) { 56 my $rcvbuf; 57 ok(msgrcv($id, $rcvbuf, 1024, 0, IPC_NOWAIT), "receive it"); 58 is($rcvbuf, $msg, "received should match sent"); 59 } 60 61 # try upgraded send 62 utf8::upgrade(my $umsg = $msg); 63 if (ok(msgsnd($id, $umsg, IPC_NOWAIT), "send a message (upgraded)")) { 64 my $rcvbuf; 65 ok(msgrcv($id, $rcvbuf, 1024, 0, IPC_NOWAIT), "receive it"); 66 is($rcvbuf, $msg, "received should match sent"); 67 } 68 69 # try a receive buffer that starts upgraded 70 if (ok(msgsnd($id, $msg, IPC_NOWAIT), "send a message (upgraded receiver)")) { 71 my $rcvbuf = "\x{101}"; 72 ok(msgrcv($id, $rcvbuf, 1024, 0, IPC_NOWAIT), "receive it (upgraded receiver)"); 73 is($rcvbuf, $msg, "received should match sent (upgraded receiver)"); 74 } 75} 76 77{ 78 # receive to magic 79 my $x; 80 my $fetch = 0; 81 my $store = 0; 82 package MyScalar { 83 sub TIESCALAR { bless {}, shift } 84 sub FETCH { ++$fetch; $x } 85 sub STORE { ++$store; $x = $_[1]; } 86 }; 87 tie my $rcvbuf, "MyScalar"; 88 my $msg = pack("l! a*", 1, "Hello"); 89 my $warn = ""; 90 if (ok(msgsnd($id, $msg, IPC_NOWAIT), "send to magic receive")) { 91 { 92 local $SIG{__WARN__} = sub { $warn .= "@_\n" }; 93 ok(msgrcv($id, $rcvbuf, 1024, 0, IPC_NOWAIT), "receive it (magic receiver)"); 94 } 95 is($x, $msg, "magic properly triggered"); 96 is($fetch, 0, "should be no fetch"); 97 is($store, 1, "should be one store"); 98 unlike($warn, qr/uninitialized/, "shouldn't be uninitialized warning"); 99 } 100} 101 102{ 103 # this resulted in a panic 104 my $buf; 105 ok(!msgrcv($id, $buf, -10, 0, IPC_NOWAIT), "fail with negative length"); 106 is(0+$!, &Errno::EINVAL, "check proper error"); 107} 108 109done_testing(); 110