[asperl] fixups to make it build and pass tests under both compilers

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

diff --git a/pp_sys.c b/pp_sys.c
index e630e1f..3a6010f 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -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;
 }
@@ -485,40 +514,10 @@ PP(pp_binmode)
     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
        RETPUSHUNDEF;
 
-#ifdef DOSISH
-#ifdef atarist
-    if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
-       RETPUSHYES;
-    else
-       RETPUSHUNDEF;
-#else
-    if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
-#if defined(WIN32) && defined(__BORLANDC__)
-       /* The translation mode of the stream is maintained independent
-        * of the translation mode of the fd in the Borland RTL (heavy
-        * digging through their runtime sources reveal).  User has to
-        * set the mode explicitly for the stream (though they don't
-        * document this anywhere). GSAR 97-5-24
-        */
-       PerlIO_seek(fp,0L,0);
-       fp->flags |= _F_BIN;
-#endif
+    if (do_binmode(fp,IoTYPE(io),TRUE)) 
        RETPUSHYES;
-    }
     else
        RETPUSHUNDEF;
-#endif
-#else
-#if defined(USEMYBINMODE)
-    if (my_binmode(fp,IoTYPE(io)) != NULL)
-       RETPUSHYES;
-       else
-       RETPUSHUNDEF;
-#else
-    RETPUSHYES;
-#endif
-#endif
-
 }
 
 
@@ -599,7 +598,8 @@ PP(pp_untie)
 {
     djSP;
     SV * sv ;
-    sv = POPs;          
+
+    sv = POPs;
 
     if (dowarn) {
         MAGIC * mg ;
@@ -924,7 +924,7 @@ PP(pp_read)
     return pp_sysread(ARGS);
 }
 
-static OP *
+STATIC OP *
 doform(CV *cv, GV *gv, OP *retop)
 {
     dTHR;
@@ -1587,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
@@ -1641,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;
@@ -2603,6 +2603,13 @@ PP(pp_chdir)
        if (svp)
            tmps = SvPV(*svp, na);
     }
+#ifdef VMS
+    if (!tmps || !*tmps) {
+       svp = hv_fetch(GvHVn(envgv), "SYS$LOGIN", 9, FALSE);
+       if (svp)
+           tmps = SvPV(*svp, na);
+    }
+#endif
     TAINT_PROPER("chdir");
     PUSHi( PerlDir_chdir(tmps) >= 0 );
 #ifdef VMS
@@ -3368,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)));
@@ -3470,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);
@@ -3970,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
@@ -3988,7 +3995,7 @@ PP(pp_shostent)
 {
     djSP;
 #ifdef HAS_SETHOSTENT
-    sethostent(TOPi);
+    PerlSock_sethostent(TOPi);
     RETSETYES;
 #else
     DIE(no_sock_func, "sethostent");
@@ -3999,7 +4006,7 @@ PP(pp_snetent)
 {
     djSP;
 #ifdef HAS_SETNETENT
-    setnetent(TOPi);
+    PerlSock_setnetent(TOPi);
     RETSETYES;
 #else
     DIE(no_sock_func, "setnetent");
@@ -4010,7 +4017,7 @@ PP(pp_sprotoent)
 {
     djSP;
 #ifdef HAS_SETPROTOENT
-    setprotoent(TOPi);
+    PerlSock_setprotoent(TOPi);
     RETSETYES;
 #else
     DIE(no_sock_func, "setprotoent");
@@ -4021,7 +4028,7 @@ PP(pp_sservent)
 {
     djSP;
 #ifdef HAS_SETSERVENT
-    setservent(TOPi);
+    PerlSock_setservent(TOPi);
     RETSETYES;
 #else
     DIE(no_sock_func, "setservent");
@@ -4163,7 +4170,7 @@ PP(pp_gpwent)
        sv_setpv(sv, pwent->pw_gecos);
 #endif
 #ifndef INCOMPLETE_TAINTS
-       /* pw_gecos is tainted. */
+       /* pw_gecos is tainted because user himself can diddle with it. */
        SvTAINTED_on(sv);
 #endif
 
@@ -4301,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;
@@ -4314,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];
@@ -4528,4 +4535,3 @@ int operation;
 }
 
 #endif /* LOCKF_EMULATE_FLOCK */
-