perl 5.003_01: t/lib/filehand.t

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

diff --git a/pp_sys.c b/pp_sys.c
index 4608a2a..ee51347 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -89,6 +89,11 @@ extern int h_errno;
 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
 static int dooneliner _((char *cmd, char *filename));
 #endif
+
+#ifdef HAS_CHSIZE
+# define my_chsize chsize
+#endif
+
 /* Pushy I/O. */
 
 PP(pp_backtick)
@@ -365,7 +370,7 @@ PP(pp_binmode)
 
 #ifdef DOSISH
 #ifdef atarist
-    if (!fflush(fp) && (fp->_flag |= _IOBIN))
+    if (!Fflush(fp) && (fp->_flag |= _IOBIN))
        RETPUSHYES;
     else
        RETPUSHUNDEF;
@@ -376,8 +381,16 @@ PP(pp_binmode)
        RETPUSHUNDEF;
 #endif
 #else
+#if defined(USEMYBINMODE)
+    if (my_binmode(fp,IoTYPE(io)) != NULL)
+       RETPUSHYES;
+       else
+       RETPUSHUNDEF;
+#else
     RETPUSHYES;
 #endif
+#endif
+
 }
 
 PP(pp_tie)
@@ -415,12 +428,14 @@ PP(pp_tie)
     ENTER;
     SAVESPTR(op);
     op = (OP *) &myop;
+    if (perldb && curstash != debstash)
+       op->op_private |= OPpENTERSUB_DB;
 
-    XPUSHs(gv);
+    XPUSHs((SV*)gv);
     PUTBACK;
 
     if (op = pp_entersub())
-        run();
+        runops();
     SPAGAIN;
 
     sv = TOPs;
@@ -443,16 +458,34 @@ PP(pp_tie)
 PP(pp_untie)
 {
     dSP;
-    if (SvTYPE(TOPs) == SVt_PVHV || SvTYPE(TOPs) == SVt_PVAV)
-       sv_unmagic(TOPs, 'P');
+    SV * sv ;
+
+    sv = POPs;
+    if (hints & HINT_STRICT_UNTIE)
+    {
+        MAGIC * mg ;
+        if (SvMAGICAL(sv)) {
+            if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
+                mg = mg_find(sv, 'P') ;
+            else
+                mg = mg_find(sv, 'q') ;
+    
+            if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)  
+               croak("Can't untie: %d inner references still exist", 
+                       SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+        }
+    }
+ 
+    if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
+       sv_unmagic(sv, 'P');
     else
-       sv_unmagic(TOPs, 'q');
+       sv_unmagic(sv, 'q');
     RETSETYES;
 }
 
 PP(pp_tied)
 {
-    dSP; dTARGET ;
+    dSP;
     SV * sv ;
     MAGIC * mg ;
 
@@ -503,6 +536,8 @@ PP(pp_dbmopen)
     ENTER;
     SAVESPTR(op);
     op = (OP *) &myop;
+    if (perldb && curstash != debstash)
+       op->op_private |= OPpENTERSUB_DB;
     PUTBACK;
     pp_pushmark();
 
@@ -514,11 +549,11 @@ PP(pp_dbmopen)
     else
        PUSHs(sv_2mortal(newSViv(O_RDWR)));
     PUSHs(right);
-    PUSHs(gv);
+    PUSHs((SV*)gv);
     PUTBACK;
 
     if (op = pp_entersub())
-        run();
+        runops();
     SPAGAIN;
 
     if (!sv_isobject(TOPs)) {
@@ -531,11 +566,11 @@ PP(pp_dbmopen)
        PUSHs(left);
        PUSHs(sv_2mortal(newSViv(O_RDONLY)));
        PUSHs(right);
-       PUSHs(gv);
+       PUSHs((SV*)gv);
        PUTBACK;
 
        if (op = pp_entersub())
-           run();
+           runops();
        SPAGAIN;
     }
 
@@ -710,11 +745,11 @@ PP(pp_select)
     if (! hv)
        XPUSHs(&sv_undef);
     else {
-       GV **gvp = hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
+       GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
        if (gvp && *gvp == egv)
            gv_efullname(TARG, defoutgv);
        else
-           sv_setsv(TARG, sv_2mortal(newRV(egv)));
+           sv_setsv(TARG, sv_2mortal(newRV((SV*)egv)));
        XPUSHTARG;
     }
 
@@ -827,7 +862,7 @@ PP(pp_leavewrite)
     I32 gimme;
     register CONTEXT *cx;
 
-    DEBUG_f(fprintf(stderr,"left=%ld, todo=%ld\n",
+    DEBUG_f(fprintf(Perl_debug_log,"left=%ld, todo=%ld\n",
          (long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
     if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
        formtarget != toptarget)
@@ -919,7 +954,7 @@ PP(pp_leavewrite)
            SvCUR_set(formtarget, 0);
            *SvEND(formtarget) = '\0';
            if (IoFLAGS(io) & IOf_FLUSH)
-               (void)fflush(fp);
+               (void)Fflush(fp);
            PUSHs(&sv_yes);
        }
     }
@@ -965,7 +1000,7 @@ PP(pp_prtf)
            goto just_say_no;
 
        if (IoFLAGS(io) & IOf_FLUSH)
-           if (fflush(fp) == EOF)
+           if (Fflush(fp) == EOF)
                goto just_say_no;
     }
     SvREFCNT_dec(sv);
@@ -982,9 +1017,8 @@ PP(pp_prtf)
 
 PP(pp_sysopen)
 {
-    dSP; dTARGET;
+    dSP;
     GV *gv;
-    IO *io;
     SV *sv;
     char *tmps;
     STRLEN len;
@@ -1212,34 +1246,44 @@ PP(pp_truncate)
 
     SETERRNO(0,0);
 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
-#ifdef HAS_TRUNCATE
     if (op->op_flags & OPf_SPECIAL) {
        tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
+    do_ftruncate:
        if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
+#ifdef HAS_TRUNCATE
          ftruncate(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
-           result = 0;
-    }
-    else if (truncate(POPp, len) < 0)
-       result = 0;
-#else
-    if (op->op_flags & OPf_SPECIAL) {
-       tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
-       if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
-         chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+#else 
+         my_chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+#endif
            result = 0;
     }
     else {
-       int tmpfd;
-
-       if ((tmpfd = open(POPp, 0)) < 0)
+       SV *sv = POPs;
+       if (SvTYPE(sv) == SVt_PVGV) {
+           tmpgv = (GV*)sv;            /* *main::FRED for example */
+           goto do_ftruncate;
+       }
+       else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+           tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
+           goto do_ftruncate;
+       }
+#ifdef HAS_TRUNCATE
+       if (truncate (SvPV (sv, na), len) < 0)
            result = 0;
-       else {
-           if (chsize(tmpfd, len) < 0)
-               result = 0;
-           close(tmpfd);
+#else
+       {
+           int tmpfd;
+
+           if ((tmpfd = open(SvPV (sv, na), 0)) < 0)
+               result = 0;
+           else {
+               if (my_chsize(tmpfd, len) < 0)
+                   result = 0;
+               close(tmpfd);
+           }
        }
-    }
 #endif
+    }
 
     if (result)
        RETPUSHYES;
@@ -1832,11 +1876,21 @@ PP(pp_stat)
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
+#ifdef USE_STAT_RDEV
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
+#else
+       PUSHs(sv_2mortal(newSVpv("", 0)));
+#endif
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
+#ifdef BIG_TIME
+       PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
+       PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
+       PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
+#else
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
+#endif
 #ifdef USE_STAT_BLOCKS
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
        PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
@@ -1966,7 +2020,7 @@ PP(pp_ftmtime)
     dSP; dTARGET;
     if (result < 0)
        RETPUSHUNDEF;
-    PUSHn( (basetime - statcache.st_mtime) / 86400.0 );
+    PUSHn( ((I32)basetime - (I32)statcache.st_mtime) / 86400.0 );
     RETURN;
 }
 
@@ -1976,7 +2030,7 @@ PP(pp_ftatime)
     dSP; dTARGET;
     if (result < 0)
        RETPUSHUNDEF;
-    PUSHn( (basetime - statcache.st_atime) / 86400.0 );
+    PUSHn( ((I32)basetime - (I32)statcache.st_atime) / 86400.0 );
     RETURN;
 }
 
@@ -1986,7 +2040,7 @@ PP(pp_ftctime)
     dSP; dTARGET;
     if (result < 0)
        RETPUSHUNDEF;
-    PUSHn( (basetime - statcache.st_ctime) / 86400.0 );
+    PUSHn( ((I32)basetime - (I32)statcache.st_ctime) / 86400.0 );
     RETURN;
 }
 
@@ -2771,7 +2825,7 @@ PP(pp_system)
     Signal_t (*ihand)();     /* place to save signal during system() */
     Signal_t (*qhand)();     /* place to save signal during system() */
 
-#if defined(HAS_FORK) && !defined(VMS)
+#if defined(HAS_FORK) && !defined(VMS) && !defined(OS2)
     if (SP - MARK == 1) {
        if (tainting) {
            char *junk = SvPV(TOPs, na);
@@ -2817,7 +2871,7 @@ PP(pp_system)
        value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
     }
     _exit(-1);
-#else /* ! FORK or VMS */
+#else /* ! FORK or VMS or OS/2 */
     if (op->op_flags & OPf_STACKED) {
        SV *really = *++MARK;
        value = (I32)do_aspawn(really, MARK, SP);
@@ -2903,8 +2957,8 @@ PP(pp_getpgrp)
        pid = 0;
     else
        pid = SvIVx(POPs);
-#ifdef USE_BSDPGRP
-    value = (I32)getpgrp(pid);
+#ifdef BSD_GETPGRP
+    value = (I32)BSD_GETPGRP(pid);
 #else
     if (pid != 0)
        DIE("POSIX getpgrp can't take an argument");
@@ -2933,8 +2987,8 @@ PP(pp_setpgrp)
     }
 
     TAINT_PROPER("setpgrp");
-#ifdef USE_BSDPGRP
-    SETi( setpgrp(pid, pgrp) >= 0 );
+#ifdef BSD_SETPGRP
+    SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
 #else
     if ((pgrp != 0) || (pid != 0)) {
        DIE("POSIX setpgrp can't take an argument");
@@ -2985,7 +3039,11 @@ PP(pp_setpriority)
 PP(pp_time)
 {
     dSP; dTARGET;
+#ifdef BIG_TIME
+    XPUSHn( time(Null(Time_t*)) );
+#else
     XPUSHi( time(Null(Time_t*)) );
+#endif
     RETURN;
 }
 
@@ -3039,7 +3097,11 @@ PP(pp_gmtime)
     if (MAXARG < 1)
        (void)time(&when);
     else
+#ifdef BIG_TIME
+       when = (Time_t)SvNVx(POPs);
+#else
        when = (Time_t)SvIVx(POPs);
+#endif
 
     if (op->op_type == OP_LOCALTIME)
        tmbuf = localtime(&when);