hexfp: Use Perl_fp_class_nzero unconditionally.

[perl5.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index 658dee1..15b4d8b 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -192,6 +192,10 @@ void setservent(int);
 void endservent(void);
 #endif
 
 void endservent(void);
 #endif
 

+#ifdef __amigaos4__
+#  include "amigaos4/amigaio.h"
+#endif
+

 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
 
 /* F_OK unused: if stat() cannot find it... */
 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
 
 /* F_OK unused: if stat() cannot find it... */


@@ -529,6 +533,7 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
 {
     SV **orig_sp = sp;
     I32 ret_args;
 {
     SV **orig_sp = sp;
     I32 ret_args;

+    SSize_t extend_size;

 
     PERL_ARGS_ASSERT_TIED_METHOD;
 
 
     PERL_ARGS_ASSERT_TIED_METHOD;
 


@@ -539,7 +544,20 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
 
     PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
     PUSHSTACKi(PERLSI_MAGIC);
 
     PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
     PUSHSTACKi(PERLSI_MAGIC);

-    EXTEND(SP, argc+1); /* object + args */
+    /* extend for object + args. If argc might wrap/truncate when cast
+     * to SSize_t and incremented, set to -1, which will trigger a panic in
+     * EXTEND().
+     * The weird way this is written is because g++ is dumb enough to
+     * warn "comparison is always false" on something like:
+     *
+     * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1
+     *
+     * (where the LH condition is false)
+     */
+    extend_size =
+        (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc))
+            ? -1 : (SSize_t)argc + 1;
+    EXTEND(SP, extend_size);

     PUSHMARK(sp);
     PUSHs(SvTIED_obj(sv, mg));
     if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
     PUSHMARK(sp);
     PUSHs(SvTIED_obj(sv, mg));
     if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {


@@ -677,8 +695,6 @@ PP(pp_pipe_op)
     GV * const wgv = MUTABLE_GV(POPs);
     GV * const rgv = MUTABLE_GV(POPs);
 
     GV * const wgv = MUTABLE_GV(POPs);
     GV * const rgv = MUTABLE_GV(POPs);
 

-    assert (isGV_with_GP(rgv));
-    assert (isGV_with_GP(wgv));

     rstio = GvIOn(rgv);
     if (IoIFP(rstio))
        do_close(rgv, FALSE);
     rstio = GvIOn(rgv);
     if (IoIFP(rstio))
        do_close(rgv, FALSE);


@@ -1265,10 +1281,10 @@ PP(pp_sselect)
 
 =for apidoc setdefout
 
 
 =for apidoc setdefout
 

-Sets PL_defoutgv, the default file handle for output, to the passed in
-typeglob.  As PL_defoutgv "owns" a reference on its typeglob, the reference
+Sets C<PL_defoutgv>, the default file handle for output, to the passed in
+typeglob.  As C<PL_defoutgv> "owns" a reference on its typeglob, the reference

 count of the passed in typeglob is increased by one, and the reference count
 count of the passed in typeglob is increased by one, and the reference count

-of the typeglob that PL_defoutgv points to is decreased by one.
+of the typeglob that C<PL_defoutgv> points to is decreased by one.

 
 =cut
 */
 
 =cut
 */


@@ -3716,17 +3732,20 @@ PP(pp_rename)
 {
     dSP; dTARGET;
     int anum;
 {
     dSP; dTARGET;
     int anum;

+#ifndef HAS_RENAME
+    Stat_t statbuf;
+#endif

     const char * const tmps2 = POPpconstx;
     const char * const tmps = SvPV_nolen_const(TOPs);
     TAINT_PROPER("rename");
 #ifdef HAS_RENAME
     anum = PerlLIO_rename(tmps, tmps2);
 #else
     const char * const tmps2 = POPpconstx;
     const char * const tmps = SvPV_nolen_const(TOPs);
     TAINT_PROPER("rename");
 #ifdef HAS_RENAME
     anum = PerlLIO_rename(tmps, tmps2);
 #else

-    if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
+    if (!(anum = PerlLIO_stat(tmps, &statbuf))) {

        if (same_dirent(tmps2, tmps))   /* can always rename to same name */
            anum = 1;
        else {
        if (same_dirent(tmps2, tmps))   /* can always rename to same name */
            anum = 1;
        else {

-           if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
+           if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))

                (void)UNLINK(tmps2);
            if (!(anum = link(tmps, tmps2)))
                anum = UNLINK(tmps);
                (void)UNLINK(tmps2);
            if (!(anum = link(tmps, tmps2)))
                anum = UNLINK(tmps);


@@ -3888,7 +3907,8 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename)
            return 0;
        }
        else {  /* some mkdirs return no failure indication */
            return 0;
        }
        else {  /* some mkdirs return no failure indication */

-           anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
+           Stat_t statbuf;
+           anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);

            if (PL_op->op_type == OP_RMDIR)
                anum = !anum;
            if (anum)
            if (PL_op->op_type == OP_RMDIR)
                anum = !anum;
            if (anum)


@@ -4207,7 +4227,7 @@ PP(pp_fork)
     PUSHi(childpid);
     RETURN;
 #else
     PUSHi(childpid);
     RETURN;
 #else

-#  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
+#  if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)

     dSP; dTARGET;
     Pid_t childpid;
 
     dSP; dTARGET;
     Pid_t childpid;
 


@@ -4259,6 +4279,12 @@ PP(pp_waitpid)
     const int optype = POPi;
     const Pid_t pid = TOPi;
     Pid_t result;
     const int optype = POPi;
     const Pid_t pid = TOPi;
     Pid_t result;

+#ifdef __amigaos4__
+    int argflags = 0;
+    result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
+    STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
+    result = result == 0 ? pid : -1;
+#else

     int argflags;
 
     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
     int argflags;
 
     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)


@@ -4275,6 +4301,7 @@ PP(pp_waitpid)
 #  else
     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
 #  endif
 #  else
     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
 #  endif

+# endif /* __amigaos4__ */

     SETi(result);
     RETURN;
 #else
     SETi(result);
     RETURN;
 #else


@@ -4291,7 +4318,11 @@ PP(pp_system)
     XPUSHi(-1);
 #else
     I32 value;
     XPUSHi(-1);
 #else
     I32 value;

+# ifdef __amigaos4__
+    void * result;
+# else

     int result;
     int result;

+# endif

 
     if (TAINTING_get) {
        TAINT_ENV();
 
     if (TAINTING_get) {
        TAINT_ENV();


@@ -4304,17 +4335,33 @@ PP(pp_system)
        TAINT_PROPER("system");
     }
     PERL_FLUSHALL_FOR_CHILD;
        TAINT_PROPER("system");
     }
     PERL_FLUSHALL_FOR_CHILD;

-#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
+#if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)

     {
     {

+#ifdef __amigaos4__
+        struct UserData userdata;
+        pthread_t proc;
+#else

        Pid_t childpid;
        Pid_t childpid;

+#endif

        int pp[2];
        I32 did_pipes = 0;
        int pp[2];
        I32 did_pipes = 0;

+        bool child_success = FALSE;

 #ifdef HAS_SIGPROCMASK
        sigset_t newset, oldset;
 #endif
 
        if (PerlProc_pipe(pp) >= 0)
            did_pipes = 1;
 #ifdef HAS_SIGPROCMASK
        sigset_t newset, oldset;
 #endif
 
        if (PerlProc_pipe(pp) >= 0)
            did_pipes = 1;

+#ifdef __amigaos4__
+        amigaos_fork_set_userdata(aTHX_
+                                  &userdata,
+                                  did_pipes,
+                                  pp[1],
+                                  SP,
+                                  mark);
+        pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
+        child_success = proc > 0;
+#else

 #ifdef HAS_SIGPROCMASK
        sigemptyset(&newset);
        sigaddset(&newset, SIGCHLD);
 #ifdef HAS_SIGPROCMASK
        sigemptyset(&newset);
        sigaddset(&newset, SIGCHLD);


@@ -4336,19 +4383,27 @@ PP(pp_system)
            }
            sleep(5);
        }
            }
            sleep(5);
        }

-       if (childpid > 0) {
+        child_success = childpid > 0;
+#endif
+       if (child_success) {

            Sigsave_t ihand,qhand; /* place to save signals during system() */
            int status;
 
            Sigsave_t ihand,qhand; /* place to save signals during system() */
            int status;
 

+#ifndef __amigaos4__

            if (did_pipes)
                PerlLIO_close(pp[1]);
            if (did_pipes)
                PerlLIO_close(pp[1]);

+#endif

 #ifndef PERL_MICRO
            rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
            rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
 #endif
 #ifndef PERL_MICRO
            rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
            rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
 #endif

+#ifdef __amigaos4__
+            result = pthread_join(proc, (void **)&status);
+#else

            do {
                result = wait4pid(childpid, &status, 0);
            } while (result == -1 && errno == EINTR);
            do {
                result = wait4pid(childpid, &status, 0);
            } while (result == -1 && errno == EINTR);

+#endif

 #ifndef PERL_MICRO
 #ifdef HAS_SIGPROCMASK
            sigprocmask(SIG_SETMASK, &oldset, NULL);
 #ifndef PERL_MICRO
 #ifdef HAS_SIGPROCMASK
            sigprocmask(SIG_SETMASK, &oldset, NULL);


@@ -4377,12 +4432,20 @@ PP(pp_system)
                    if (n != sizeof(int))
                        DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
                    errno = errkid;             /* Propagate errno from kid */
                    if (n != sizeof(int))
                        DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
                    errno = errkid;             /* Propagate errno from kid */

-                   STATUS_NATIVE_CHILD_SET(-1);
+#ifdef __amigaos4__
+                    /* The pipe always has something in it
+                     * so n alone is not enough. */
+                    if (errno > 0)
+#endif
+                    {
+                        STATUS_NATIVE_CHILD_SET(-1);
+                    }

                }
            }
            XPUSHi(STATUS_CURRENT);
            RETURN;
        }
                }
            }
            XPUSHi(STATUS_CURRENT);
            RETURN;
        }

+#ifndef __amigaos4__

 #ifdef HAS_SIGPROCMASK
        sigprocmask(SIG_SETMASK, &oldset, NULL);
 #endif
 #ifdef HAS_SIGPROCMASK
        sigprocmask(SIG_SETMASK, &oldset, NULL);
 #endif


@@ -4402,6 +4465,7 @@ PP(pp_system)
        else {
            value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
        }
        else {
            value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
        }

+#endif /* __amigaos4__ */

        PerlProc__exit(-1);
     }
 #else /* ! FORK or VMS or OS/2 */
        PerlProc__exit(-1);
     }
 #else /* ! FORK or VMS or OS/2 */


@@ -4451,6 +4515,7 @@ PP(pp_exec)
        MARK = ORIGMARK;
        TAINT_PROPER("exec");
     }
        MARK = ORIGMARK;
        TAINT_PROPER("exec");
     }

+

     PERL_FLUSHALL_FOR_CHILD;
     if (PL_op->op_flags & OPf_STACKED) {
        SV * const really = *++MARK;
     PERL_FLUSHALL_FOR_CHILD;
     if (PL_op->op_flags & OPf_STACKED) {
        SV * const really = *++MARK;


@@ -4469,7 +4534,6 @@ PP(pp_exec)
        value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
 #endif
     }
        value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
 #endif
     }

-

     SP = ORIGMARK;
     XPUSHi(value);
     RETURN;
     SP = ORIGMARK;
     XPUSHi(value);
     RETURN;