perl 5.003_01: pp_sys.c

Use home-grown name for chsize() to avoid possible collision with
  function which exists in system libraries but isn't used
Support home-grown analogue to binmode()
Give debugger access to function call executing "tie" and "dbmopen"
Implement strict untie
Add casts to reflect new GV type
Allow redirection of debug messages
Fix handling of file truncation
Handle missing rdev field in struct stat
Handle 64-bit time values

1 files changed, 90 insertions, 27 deletions

diff --git a/pp_sys.c b/pp_sys.c
index ba1f105a06..ee51347cdc 100644
--- 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)
@@ -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,8 +428,10 @@ 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())
@@ -443,10 +458,28 @@ 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;
 }
 
@@ -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,7 +549,7 @@ PP(pp_dbmopen)
     else
 	PUSHs(sv_2mortal(newSViv(O_RDWR)));
     PUSHs(right);
-    PUSHs(gv);
+    PUSHs((SV*)gv);
     PUTBACK;
 
     if (op = pp_entersub())
@@ -531,7 +566,7 @@ PP(pp_dbmopen)
 	PUSHs(left);
 	PUSHs(sv_2mortal(newSViv(O_RDONLY)));
 	PUSHs(right);
-	PUSHs(gv);
+	PUSHs((SV*)gv);
 	PUTBACK;
 
 	if (op = pp_entersub())
@@ -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)
@@ -1211,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;
@@ -1831,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)));
@@ -2984,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;
 }
 
@@ -3038,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);