Re: truncate using a globref

Message-Id: <200301231448.h0NEmqnu022591@vran.herceg.de>

p4raw-id: //depot/perl@18581

2 files changed, 59 insertions, 23 deletions

diff --git a/pp_sys.c b/pp_sys.c
index 46d06f5ede..b14dd7719e 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2031,22 +2031,31 @@ PP(pp_truncate)
         STRLEN n_a;
 	int result = 1;
 	GV *tmpgv;
-	
+	IO *io;
+
 	if (PL_op->op_flags & OPf_SPECIAL) {
 	    tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
 
-	do_ftruncate:
-	    TAINT_PROPER("truncate");
-	    if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
-	        result = 0;
+	do_ftruncate_gv:
+	    if (!GvIO(tmpgv))
+		result = 0;
 	    else {
-	        PerlIO_flush(IoIFP(GvIOp(tmpgv)));
+		PerlIO *fp;
+		io = GvIOp(tmpgv);
+	    do_ftruncate_io:
+		TAINT_PROPER("truncate");
+		if (!(fp = IoIFP(io))) {
+		    result = 0;
+		}
+		else {
+		    PerlIO_flush(fp);
 #ifdef HAS_TRUNCATE
-		if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+		    if (ftruncate(PerlIO_fileno(fp), len) < 0)
 #else
-		if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+		    if (my_chsize(PerlIO_fileno(fp), len) < 0)
 #endif
-		    result = 0;
+			result = 0;
+		}
 	    }
 	}
 	else {
@@ -2055,11 +2064,15 @@ PP(pp_truncate)
 	
 	    if (SvTYPE(sv) == SVt_PVGV) {
 	        tmpgv = (GV*)sv;		/* *main::FRED for example */
-		goto do_ftruncate;
+		goto do_ftruncate_gv;
 	    }
 	    else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
 	        tmpgv = (GV*) SvRV(sv);	/* \*main::FRED for example */
-		goto do_ftruncate;
+		goto do_ftruncate_gv;
+	    }
+	    else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
+		io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
+		goto do_ftruncate_io;
 	    }
 
 	    name = SvPV(sv, n_a);
diff --git a/t/io/fs.t b/t/io/fs.t
index 7535e4ebfd..eb305a93e8 100755
--- a/t/io/fs.t
+++ b/t/io/fs.t
@@ -47,7 +47,7 @@ $needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95());
 my $skip_mode_checks =
     $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/;
 
-plan tests => 32;
+plan tests => 34;
 
 
 if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
@@ -271,7 +271,7 @@ SKIP: {
 # Check truncating a closed file.
     eval { truncate "Iofs.tmp", 5; };
 
-    skip("no truncate - $@", 6) if $@;
+    skip("no truncate - $@", 8) if $@;
 
     is(-s "Iofs.tmp", 5, "truncation to five bytes");
 
@@ -303,21 +303,44 @@ SKIP: {
 	close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
     }
 
-    if ($^O eq 'vos') {
-        skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 3);
-    }
+    SKIP: {
+        if ($^O eq 'vos') {
+	    skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5);
+	}
 
-    is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)");
+	is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)");
 
-    ok(truncate(FH, 0), "fh resize to zero");
+	ok(truncate(FH, 0), "fh resize to zero");
 
-    if ($needs_fh_reopen) {
-	close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
-    }
+	if ($needs_fh_reopen) {
+	    close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
+	}
 
-    ok(-z "Iofs.tmp", "fh resize to zero working (filename check)");
+	ok(-z "Iofs.tmp", "fh resize to zero working (filename check)");
 
-    close FH;
+	close FH;
+
+	open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending";
+
+	binmode FH;
+	select FH;
+	$| = 1;
+	select STDOUT;
+
+	{
+	    use strict;
+	    print FH "x\n" x 200;
+	    ok(truncate(*FH{IO}, 100), "fh resize by IO slot");
+	}
+
+	if ($needs_fh_reopen) {
+	    close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
+	}
+
+	is(-s "Iofs.tmp", 100, "fh resize by IO slot working");
+
+	close FH;
+    }
 }
 
 # check if rename() can be used to just change case of filename