This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
op.h: Restrict to core certain internal symbols
[perl5.git] / doio.c
diff --git a/doio.c b/doio.c
index 9fe222e..439f2d0 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -112,11 +112,10 @@ Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd)
        } while(0)
 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) && \
                        defined(F_GETFD)
-enum { CLOEXEC_EXPERIMENT, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN };
-#  define DO_GENOPEN_EXPERIMENTING_CLOEXEC(TESTFD, GENOPEN_CLOEXEC, \
+enum { CLOEXEC_EXPERIMENT = 0, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN };
+#  define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \
                        GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
        do { \
-           static int strategy = CLOEXEC_EXPERIMENT; \
            switch (strategy) { \
                case CLOEXEC_EXPERIMENT: default: { \
                    int res = (GENOPEN_CLOEXEC), eno; \
@@ -149,7 +148,7 @@ enum { CLOEXEC_EXPERIMENT, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN };
            } \
        } while(0)
 #else
-#  define DO_GENOPEN_EXPERIMENTING_CLOEXEC(TESTFD, GENOPEN_CLOEXEC, \
+#  define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \
                        GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
        DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC)
 #endif
@@ -160,10 +159,13 @@ enum { CLOEXEC_EXPERIMENT, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN };
            DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \
                setfd_cloexec(fd)); \
        } while(0)
-#define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \
+#define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(strategy, \
+                ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \
        do { \
            int fd; \
-           DO_GENOPEN_EXPERIMENTING_CLOEXEC(fd, fd = (ONEOPEN_CLOEXEC), \
+           DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
+                fd, \
+                fd = (ONEOPEN_CLOEXEC), \
                fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \
        } while(0)
 
@@ -174,9 +176,10 @@ enum { CLOEXEC_EXPERIMENT, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN };
        } while(0)
 #define DO_PIPEOPEN_THEN_CLOEXEC(PIPEFD, PIPEOPEN_NORMAL) \
        DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD))
-#define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PIPEFD, PIPEOPEN_CLOEXEC, \
+#define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(strategy, PIPEFD, PIPEOPEN_CLOEXEC, \
                        PIPEOPEN_NORMAL) \
-       DO_GENOPEN_EXPERIMENTING_CLOEXEC((PIPEFD)[0], PIPEOPEN_CLOEXEC, \
+       DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
+                (PIPEFD)[0], PIPEOPEN_CLOEXEC, \
            PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD))
 
 int
@@ -189,6 +192,7 @@ Perl_PerlLIO_dup_cloexec(pTHX_ int oldfd)
      * PERL_IMPLICIT_SYS builds.
      */
     DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+        PL_strategy_dup,
        fcntl(oldfd, F_DUPFD_CLOEXEC, 0),
        PerlLIO_dup(oldfd));
 #else
@@ -206,6 +210,7 @@ Perl_PerlLIO_dup2_cloexec(pTHX_ int oldfd, int newfd)
      * PERL_IMPLICIT_SYS builds.
      */
     DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+        PL_strategy_dup2,
        dup3(oldfd, newfd, O_CLOEXEC),
        PerlLIO_dup2(oldfd, newfd));
 #else
@@ -219,6 +224,7 @@ Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag)
     PERL_ARGS_ASSERT_PERLLIO_OPEN_CLOEXEC;
 #if defined(O_CLOEXEC)
     DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+        PL_strategy_open,
        PerlLIO_open(file, flag | O_CLOEXEC),
        PerlLIO_open(file, flag));
 #else
@@ -232,6 +238,7 @@ Perl_PerlLIO_open3_cloexec(pTHX_ const char *file, int flag, int perm)
     PERL_ARGS_ASSERT_PERLLIO_OPEN3_CLOEXEC;
 #if defined(O_CLOEXEC)
     DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+        PL_strategy_open3,
        PerlLIO_open3(file, flag | O_CLOEXEC, perm),
        PerlLIO_open3(file, flag, perm));
 #else
@@ -245,6 +252,7 @@ Perl_my_mkstemp_cloexec(char *templte)
     PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC;
 #if defined(O_CLOEXEC)
     DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+        PL_strategy_mkstemp,
        Perl_my_mkostemp(templte, O_CLOEXEC),
        Perl_my_mkstemp(templte));
 #else
@@ -252,6 +260,20 @@ Perl_my_mkstemp_cloexec(char *templte)
 #endif
 }
 
+int
+Perl_my_mkostemp_cloexec(char *templte, int flags)
+{
+    PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC;
+#if defined(O_CLOEXEC)
+    DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+        PL_strategy_mkstemp,
+       Perl_my_mkostemp(templte, flags | O_CLOEXEC),
+       Perl_my_mkostemp(templte, flags));
+#else
+    DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags));
+#endif
+}
+
 #ifdef HAS_PIPE
 int
 Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd)
@@ -263,7 +285,7 @@ Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd)
      * PERL_IMPLICIT_SYS builds.
      */
 #  if !defined(PERL_IMPLICIT_SYS) && defined(HAS_PIPE2) && defined(O_CLOEXEC)
-    DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(pipefd,
+    DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_pipe, pipefd,
        pipe2(pipefd, O_CLOEXEC),
        PerlProc_pipe(pipefd));
 #  else
@@ -279,6 +301,7 @@ Perl_PerlSock_socket_cloexec(pTHX_ int domain, int type, int protocol)
 {
 #  if defined(SOCK_CLOEXEC)
     DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+        PL_strategy_socket,
        PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol),
        PerlSock_socket(domain, type, protocol));
 #  else
@@ -298,6 +321,7 @@ Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr,
      * on PERL_IMPLICIT_SYS builds.
      */
     DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
+        PL_strategy_accept,
        accept4(listenfd, addr, addrlen, SOCK_CLOEXEC),
        PerlSock_accept(listenfd, addr, addrlen));
 #  else
@@ -316,7 +340,7 @@ Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol,
 {
     PERL_ARGS_ASSERT_PERLSOCK_SOCKETPAIR_CLOEXEC;
 #  ifdef SOCK_CLOEXEC
-    DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(pairfd,
+    DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_socketpair, pairfd,
        PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd),
        PerlSock_socketpair(domain, type, protocol, pairfd));
 #  else
@@ -350,7 +374,7 @@ S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp,
        else {
             const int old_fd = PerlIO_fileno(IoIFP(io));
 
-            if (old_fd >= 0 && old_fd <= PL_maxsysfd) {
+            if (inRANGE(old_fd, 0, PL_maxsysfd)) {
                 /* This is one of the original STD* handles */
                 *saveifp  = IoIFP(io);
                 *saveofp  = IoOFP(io);
@@ -740,7 +764,7 @@ Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len,
                        Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
                    }
                }
-               else  {
+               else {
                    if (num_svs) {
                         fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
                     }
@@ -1288,7 +1312,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
     PL_filemode = 0;
     if (!GvAV(gv))
        return NULL;
-    while (av_tindex(GvAV(gv)) >= 0) {
+    while (av_count(GvAV(gv)) > 0) {
        STRLEN oldlen;
         SV *const sv = av_shift(GvAV(gv));
        SAVEFREESV(sv);
@@ -1760,7 +1784,17 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
 
     if (IoIFP(io)) {
        if (IoTYPE(io) == IoTYPE_PIPE) {
-           const int status = PerlProc_pclose(IoIFP(io));
+            PerlIO *fh = IoIFP(io);
+            int status;
+
+            /* my_pclose() can propagate signals which might bypass any code
+               after the call here if the signal handler throws an exception.
+               This would leave the handle in the IO object and try to close it again
+               when the SV is destroyed on unwind or global destruction.
+               So NULL it early.
+            */
+            IoOFP(io) = IoIFP(io) = NULL;
+           status = PerlProc_pclose(fh);
            if (not_implicit) {
                STATUS_NATIVE_CHILD_SET(status);
                retval = (STATUS_UNIX == 0);
@@ -2253,9 +2287,8 @@ bool
 Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
               int fd, int do_report)
 {
-    dVAR;
     PERL_ARGS_ASSERT_DO_AEXEC5;
-#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
+#if defined(__LIBCATAMOUNT__)
     Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
 #else
     assert(sp >= mark);
@@ -2304,7 +2337,6 @@ Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
 bool
 Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
 {
-    dVAR;
     const char **argv, **a;
     char *s;
     char *buf;
@@ -2375,7 +2407,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
 
     for (s = cmd; *s; s++) {
        if (*s != ' ' && !isALPHA(*s) &&
-           strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
+           memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) {
            if (*s == '\n' && !s[1]) {
                *s = '\0';
                break;
@@ -2450,7 +2482,7 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
     PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
 
     /* Doing this ahead of the switch statement preserves the old behaviour,
-       where attempting to use kill as a taint test test would fail on
+       where attempting to use kill as a taint test would fail on
        platforms where kill was not defined.  */
 #ifndef HAS_KILL
     if (type == OP_KILL)
@@ -2967,13 +2999,17 @@ 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
        {
            STRLEN len;
-           a = SvPV(astr, len);
+           a = SvPVbyte(astr, len);
            if (len != infosize)
                Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
                      PL_op_desc[optype],
@@ -2983,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)
@@ -3026,6 +3072,7 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
     if (getinfo && ret >= 0) {
        SvCUR_set(astr, infosize);
        *SvEND(astr) = '\0';
+        SvPOK_only(astr);
        SvSETMAGIC(astr);
     }
     return ret;
@@ -3039,7 +3086,7 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
     const I32 id = SvIVx(*++mark);
     SV * const mstr = *++mark;
     const I32 flags = SvIVx(*++mark);
-    const char * const mbuf = SvPV_const(mstr, len);
+    const char * const mbuf = SvPVbyte(mstr, len);
     const I32 msize = len - sizeof(long);
 
     PERL_ARGS_ASSERT_DO_MSGSND;
@@ -3094,6 +3141,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
     }
     if (ret >= 0) {
        SvCUR_set(mstr, sizeof(long)+ret);
+        SvPOK_only(mstr);
        *SvEND(mstr) = '\0';
        /* who knows who has been playing with this message? */
        SvTAINTED_on(mstr);
@@ -3115,7 +3163,7 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp)
     STRLEN opsize;
     const I32 id = SvIVx(*++mark);
     SV * const opstr = *++mark;
-    const char * const opbuf = SvPV_const(opstr, opsize);
+    const char * const opbuf = SvPVbyte(opstr, opsize);
 
     PERL_ARGS_ASSERT_DO_SEMOP;
     PERL_UNUSED_ARG(sp);
@@ -3203,7 +3251,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
     else {
        STRLEN len;
 
-       const char *mbuf = SvPV_const(mstr, len);
+       const char *mbuf = SvPVbyte(mstr, len);
        const I32 n = ((I32)len > msize) ? msize : (I32)len;
        Copy(mbuf, shm + mpos, n, char);
        if (n < msize)
@@ -3220,8 +3268,6 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
 #endif /* SYSV IPC */
 
 /*
-=head1 IO Functions
-
 =for apidoc start_glob
 
 Function called by C<do_readline> to spawn a glob (or do the glob inside
Unnamed repository; edit this file 'description' to name the repository.