Make Power MachTen use vfork and perl's malloc

[p5sagit/p5-mst-13.2.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index d841d04..6fb7cb5 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -207,7 +207,7 @@ PP(pp_backtick)
            SV *sv;
 
            for (;;) {
-               sv = NEWSV(56, 80);
+               sv = NEWSV(56, 79);
                if (sv_gets(sv, fp, 0) == Nullch) {
                    SvREFCNT_dec(sv);
                    break;
@@ -290,10 +290,11 @@ PP(pp_warn)
        tmps = SvPV(TOPs, na);
     }
     if (!tmps || !*tmps) {
-       (void)SvUPGRADE(ERRSV, SVt_PV);
-       if (SvPOK(ERRSV) && SvCUR(ERRSV))
-           sv_catpv(ERRSV, "\t...caught");
-       tmps = SvPV(ERRSV, na);
+       SV *error = ERRSV;
+       (void)SvUPGRADE(error, SVt_PV);
+       if (SvPOK(error) && SvCUR(error))
+           sv_catpv(error, "\t...caught");
+       tmps = SvPV(error, na);
     }
     if (!tmps || !*tmps)
        tmps = "Warning: something's wrong";
@@ -305,6 +306,8 @@ PP(pp_die)
 {
     djSP; dMARK;
     char *tmps;
+    SV *tmpsv = Nullsv;
+    char *pat = "%s";
     if (SP - MARK != 1) {
        dTARGET;
        do_join(TARG, &sv_no, MARK, SP);
@@ -312,17 +315,43 @@ PP(pp_die)
        SP = MARK + 1;
     }
     else {
-       tmps = SvPV(TOPs, na);
+       tmpsv = TOPs;
+       tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, na);
     }
     if (!tmps || !*tmps) {
-       (void)SvUPGRADE(ERRSV, SVt_PV);
-       if (SvPOK(ERRSV) && SvCUR(ERRSV))
-           sv_catpv(ERRSV, "\t...propagated");
-       tmps = SvPV(ERRSV, na);
+       SV *error = ERRSV;
+       (void)SvUPGRADE(error, SVt_PV);
+       if(tmpsv ? SvROK(tmpsv) : SvROK(error)) {
+           if(tmpsv)
+               SvSetSV(error,tmpsv);
+           else if(sv_isobject(error)) {
+               HV *stash = SvSTASH(SvRV(error));
+               GV *gv = gv_fetchmethod(stash, "PROPAGATE");
+               if (gv) {
+                   SV *file = sv_2mortal(newSVsv(GvSV(curcop->cop_filegv)));
+                   SV *line = sv_2mortal(newSViv(curcop->cop_line));
+                   EXTEND(SP, 3);
+                   PUSHMARK(SP);
+                   PUSHs(error);
+                   PUSHs(file);
+                   PUSHs(line);
+                   PUTBACK;
+                   perl_call_sv((SV*)GvCV(gv),
+                                G_SCALAR|G_EVAL|G_KEEPERR);
+                   sv_setsv(error,*stack_sp--);
+               }
+           }
+           pat = Nullch;
+       }
+       else {
+           if (SvPOK(error) && SvCUR(error))
+               sv_catpv(error, "\t...propagated");
+           tmps = SvPV(error, na);
+       }
     }
     if (!tmps || !*tmps)
        tmps = "Died";
-    DIE("%s", tmps);
+    DIE(pat, tmps);
 }
 
 /* I/O. */
@@ -464,7 +493,7 @@ PP(pp_umask)
     TAINT_PROPER("umask");
     XPUSHi(anum);
 #else
-    DIE(no_func, "Unsupported function umask");
+    XPUSHs(&sv_undef);
 #endif
     RETURN;
 }
@@ -525,7 +554,7 @@ PP(pp_tie)
     items = SP - MARK++;
     if (sv_isobject(*MARK)) {
        ENTER;
-       PUSHSTACK(SI_MAGIC);
+       PUSHSTACKi(SI_MAGIC);
        PUSHMARK(SP);
        EXTEND(SP,items);
        while (items--)
@@ -543,7 +572,7 @@ PP(pp_tie)
                 methname, SvPV(*MARK,na));                   
        }
        ENTER;
-       PUSHSTACK(SI_MAGIC);
+       PUSHSTACKi(SI_MAGIC);
        PUSHMARK(SP);
        EXTEND(SP,items);
        while (items--)
@@ -554,7 +583,7 @@ PP(pp_tie)
     SPAGAIN;
 
     sv = TOPs;
-    POPSTACK();
+    POPSTACK;
     if (sv_isobject(sv)) {
        sv_unmagic(varsv, how);            
        sv_magic(varsv, sv, how, Nullch, 0);
@@ -569,7 +598,8 @@ PP(pp_untie)
 {
     djSP;
     SV * sv ;
-    sv = POPs;          
+
+    sv = POPs;
 
     if (dowarn) {
         MAGIC * mg ;
@@ -894,7 +924,7 @@ PP(pp_read)
     return pp_sysread(ARGS);
 }
 
-static OP *
+STATIC OP *
 doform(CV *cv, GV *gv, OP *retop)
 {
     dTHR;
@@ -1557,7 +1587,7 @@ PP(pp_ioctl)
 
     if (optype == OP_IOCTL)
 #ifdef HAS_IOCTL
-       retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s);
+       retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
 #else
        DIE("ioctl is not implemented");
 #endif
@@ -1611,7 +1641,7 @@ PP(pp_flock)
        fp = Nullfp;
     if (fp) {
        (void)PerlIO_flush(fp);
-       value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
+       value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
     }
     else
        value = 0;
@@ -1938,7 +1968,7 @@ PP(pp_ssockopt)
                buf = SvPV(sv, na);
                len = na;
            }
-           else if (SvOK(sv)) {
+           else {
                aint = (int)SvIV(sv);
                buf = (char*)&aint;
                len = sizeof(int);
@@ -3345,11 +3375,11 @@ PP(pp_tms)
     EXTEND(SP, 4);
 
 #ifndef VMS
-    (void)times(&timesbuf);
+    (void)PerlProc_times(&timesbuf);
 #else
-    (void)times((tbuffer_t *)&timesbuf);  /* time.h uses different name for */
-                                          /* struct tms, though same data   */
-                                          /* is returned.                   */
+    (void)PerlProc_times((tbuffer_t *)&timesbuf);  /* time.h uses different name for */
+                                                   /* struct tms, though same data   */
+                                                   /* is returned.                   */
 #endif
 
     PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
@@ -3447,10 +3477,10 @@ PP(pp_sleep)
 
     (void)time(&lasttime);
     if (MAXARG < 1)
-       Pause();
+       PerlProc_pause();
     else {
        duration = POPi;
-       sleep((unsigned int)duration);
+       PerlProc_sleep((unsigned int)duration);
     }
     (void)time(&when);
     XPUSHi(when - lasttime);
@@ -3947,7 +3977,7 @@ PP(pp_gservent)
        }
        PUSHs(sv = sv_mortalcopy(&sv_no));
 #ifdef HAS_NTOHS
-       sv_setiv(sv, (IV)ntohs(sent->s_port));
+       sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
 #else
        sv_setiv(sv, (IV)(sent->s_port));
 #endif
@@ -3965,7 +3995,7 @@ PP(pp_shostent)
 {
     djSP;
 #ifdef HAS_SETHOSTENT
-    sethostent(TOPi);
+    PerlSock_sethostent(TOPi);
     RETSETYES;
 #else
     DIE(no_sock_func, "sethostent");
@@ -3976,7 +4006,7 @@ PP(pp_snetent)
 {
     djSP;
 #ifdef HAS_SETNETENT
-    setnetent(TOPi);
+    PerlSock_setnetent(TOPi);
     RETSETYES;
 #else
     DIE(no_sock_func, "setnetent");
@@ -3987,7 +4017,7 @@ PP(pp_sprotoent)
 {
     djSP;
 #ifdef HAS_SETPROTOENT
-    setprotoent(TOPi);
+    PerlSock_setprotoent(TOPi);
     RETSETYES;
 #else
     DIE(no_sock_func, "setprotoent");
@@ -3998,7 +4028,7 @@ PP(pp_sservent)
 {
     djSP;
 #ifdef HAS_SETSERVENT
-    setservent(TOPi);
+    PerlSock_setservent(TOPi);
     RETSETYES;
 #else
     DIE(no_sock_func, "setservent");
@@ -4101,41 +4131,55 @@ PP(pp_gpwent)
     if (pwent) {
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setpv(sv, pwent->pw_name);
+
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setpv(sv, pwent->pw_passwd);
+
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setiv(sv, (IV)pwent->pw_uid);
+
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setiv(sv, (IV)pwent->pw_gid);
+
+       /* pw_change, pw_quota, and pw_age are mutually exclusive. */
        PUSHs(sv = sv_mortalcopy(&sv_no));
 #ifdef PWCHANGE
        sv_setiv(sv, (IV)pwent->pw_change);
 #else
-#ifdef PWQUOTA
+#   ifdef PWQUOTA
        sv_setiv(sv, (IV)pwent->pw_quota);
-#else
-#ifdef PWAGE
+#   else
+#       ifdef PWAGE
        sv_setpv(sv, pwent->pw_age);
+#       endif
+#   endif
 #endif
-#endif
-#endif
+
+       /* pw_class and pw_comment are mutually exclusive. */
        PUSHs(sv = sv_mortalcopy(&sv_no));
 #ifdef PWCLASS
        sv_setpv(sv, pwent->pw_class);
 #else
-#ifdef PWCOMMENT
+#   ifdef PWCOMMENT
        sv_setpv(sv, pwent->pw_comment);
+#   endif
 #endif
-#endif
+
        PUSHs(sv = sv_mortalcopy(&sv_no));
+#ifdef PWGECOS
        sv_setpv(sv, pwent->pw_gecos);
+#endif
 #ifndef INCOMPLETE_TAINTS
+       /* pw_gecos is tainted because user himself can diddle with it. */
        SvTAINTED_on(sv);
 #endif
+
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setpv(sv, pwent->pw_dir);
+
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setpv(sv, pwent->pw_shell);
+
 #ifdef PWEXPIRE
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setiv(sv, (IV)pwent->pw_expire);
@@ -4264,7 +4308,7 @@ PP(pp_getlogin)
 #ifdef HAS_GETLOGIN
     char *tmps;
     EXTEND(SP, 1);
-    if (!(tmps = getlogin()))
+    if (!(tmps = PerlProc_getlogin()))
        RETPUSHUNDEF;
     PUSHp(tmps, strlen(tmps));
     RETURN;
@@ -4277,7 +4321,7 @@ PP(pp_getlogin)
 
 PP(pp_syscall)
 {
-#ifdef HAS_SYSCALL   
+#ifdef HAS_SYSCALL
     djSP; dMARK; dORIGMARK; dTARGET;
     register I32 items = SP - MARK;
     unsigned long a[20];
@@ -4491,4 +4535,3 @@ int operation;
 }
 
 #endif /* LOCKF_EMULATE_FLOCK */
-