Re: truncate using a globref

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

p4raw-id: //depot/perl@18581

diff --git a/pp_sys.c b/pp_sys.c
index 46d06f5..b14dd77 100644 (file)
--- 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 7535e4e..eb305a9 100755 (executable)
--- 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