io/sem.t: eliminate warnings

This eliminates some warnings that semctl() (or other *ctl()) calls
might generate, and some warnings specific to io/sem.t:

- for IPC_STAT and GETALL, the current value of ARG is overwritten
  so making an undefined value warning for it nonsensical, so don't
  use SvPV_force().

- for other calls, ARG is either ignored, or in a behaviour
  introduced in perl 3 (along with the ops), treats the supplied
  value as an integer which is then converted to a pointer.  Rather
  than warning on an undef value which is most likely to be ignored
  we treat the undef as zero without the usual warning.

- always pass a number for SEMNUM in the test code

I didn't try to eliminate warning for non-numeric/undefined SEMNUM,
since while we know it isn't used by SETALL, GETALL, IPC_STAT and
IPC_SET, it may or may not be used by system defined *ctl() operators
such as SEM_INFO and SHM_LOCK on Linux.

fixes #17926

2 files changed, 40 insertions, 12 deletions

diff --git a/doio.c b/doio.c
index 29a431d8eb..bc59c178df 100644
--- a/doio.c
+++ b/doio.c
@@ -2999,7 +2999,11 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
     {
 	if (getinfo)
 	{
-            SvPV_force_nolen(astr);
+            /* we're not using the value here, so don't SvPVanything */
+            SvUPGRADE(astr, SVt_PV);
+            SvGETMAGIC(astr);
+            if (SvTHINKFIRST(astr))
+                sv_force_normal_flags(astr, 0);
 	    a = SvGROW(astr, infosize+1);
 	}
 	else
@@ -3015,8 +3019,18 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
     }
     else
     {
-	const IV i = SvIV(astr);
-	a = INT2PTR(char *,i);		/* ouch */
+        /* We historically treat this as a pointer if we don't otherwise recognize
+           the op, but for many ops the value is simply ignored anyway, so
+           don't warn on undef.
+        */
+        SvGETMAGIC(astr);
+        if (SvOK(astr)) {
+            const IV i = SvIV_nomg(astr);
+            a = INT2PTR(char *,i);		/* ouch */
+        }
+        else {
+            a = NULL;
+        }
     }
     SETERRNO(0,0);
     switch (optype)
@@ -3058,7 +3072,7 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
     if (getinfo && ret >= 0) {
 	SvCUR_set(astr, infosize);
 	*SvEND(astr) = '\0';
-        SvUTF8_off(astr);
+        SvPOK_only(astr);
 	SvSETMAGIC(astr);
     }
     return ret;
diff --git a/t/io/sem.t b/t/io/sem.t
index 07e3fab1e3..7be1c181f1 100644
--- a/t/io/sem.t
+++ b/t/io/sem.t
@@ -17,13 +17,15 @@ BEGIN {
 }
 
 use strict;
+use warnings;
 our $TODO;
 
 use sigtrap qw/die normal-signals error-signals/;
-use IPC::SysV qw/ IPC_PRIVATE S_IRUSR S_IWUSR IPC_RMID SETVAL GETVAL SETALL GETALL IPC_CREAT /;
+use IPC::SysV qw/ IPC_PRIVATE S_IRUSR S_IWUSR IPC_RMID SETVAL GETVAL SETALL GETALL IPC_CREAT IPC_STAT /;
 
 my $id;
 my $nsem = 10;
+my $ignored = 0;
 END { semctl $id, 0, IPC_RMID, 0 if defined $id }
 
 {
@@ -42,12 +44,14 @@ if (not defined $id) {
     }
 }
 else {
-    plan(tests => 9);
+    plan(tests => 15);
     pass('acquired semaphore');
 }
 
+my @warnings;
+$SIG{__WARN__} = sub { push @warnings, "@_"; print STDERR @_; };
 { # [perl #120635] 64 bit big-endian semctl SETVAL bug
-    ok(semctl($id, "ignore", SETALL, pack("s!*",(0)x$nsem)),
+    ok(semctl($id, $ignored, SETALL, pack("s!*",(0)x$nsem)),
        "Initialize all $nsem semaphores to zero");
 
     my $sem2set = 3;
@@ -56,7 +60,7 @@ else {
        "Set semaphore $sem2set to $semval");
 
     my $semvals;
-    ok(semctl($id, "ignore", GETALL, $semvals),
+    ok(semctl($id, $ignored, GETALL, $semvals),
        'Get current semaphore values');
 
     my @semvals = unpack("s!*", $semvals);
@@ -66,10 +70,11 @@ else {
     is($semvals[$sem2set], $semval, 
        "Checking value of semaphore $sem2set");
 
-    is(semctl($id, $sem2set, GETVAL, "ignored"), $semval,
+    is(semctl($id, $sem2set, GETVAL, $ignored), $semval,
        "Check value via GETVAL");
 
     # check utf-8 flag handling
+    # first that we reset it on a fetch
     utf8::upgrade($semvals);
     ok(semctl($id, $ignored, GETALL, $semvals),
        "fetch into an already UTF-8 buffer");
@@ -83,15 +88,24 @@ else {
     $semvals = pack "s!*", @semvals;
     utf8::upgrade($semvals);
     # eval{} since it would crash due to the UTF-8 form being longer
-    ok(eval { semctl($id, "ignored", SETALL, $semvals) },
+    ok(eval { semctl($id, $ignored, SETALL, $semvals) },
        "set all semaphores from an upgraded string");
-    is(semctl($id, $sem2set, GETVAL, $ignored), $semval+1,
+    # undef here to test it doesn't warn
+    is(semctl($id, $sem2set, GETVAL, undef), $semval+1,
        "test value set from UTF-8");
 
     # third, that we throw on a code point above 0xFF
     substr($semvals, 0, 1) = chr(0x101);
-    ok(!eval { semctl($id, "ignored", SETALL, $semvals); 1 },
+    ok(!eval { semctl($id, $ignored, SETALL, $semvals); 1 },
        "throws on code points above 0xff");
     like($@, qr/Wide character/, "with the expected error");
 }
 
+{
+    my $stat;
+    # shouldn't warn
+    semctl($id, $ignored, IPC_STAT, $stat);
+    ok(defined $stat, "it statted");
+}
+
+is(scalar @warnings, 0, "no warnings");