develooper Front page | perl.perl5.porters | Postings from May 2004

[PATCH bleadperl] add truncate for tied handles

Thread Next
From:
Dan Boorstein
Date:
May 8, 2004 13:16
Subject:
[PATCH bleadperl] add truncate for tied handles
Message ID:
20040508103121.519a8d9f.dan_boo@bellsouth.net
First a few caveats. I haven't sent a patch in about 5 years, and I
rarely muck around in the core.

Anyway, after having written a few tied handle classes, I've found
myself wishing truncating was a bit easier. So, here's a patch that
adds that support to bleadperl.

It touches the core, a module, and related docs and tests.

Let me know if I should produce this diff in a different manner.

-- 

Dan Boorstein

diff -rup perl-latest.orig/lib/Tie/Handle/stdhandle.t perl-latest.diff/lib/Tie/Handle/stdhandle.t
--- perl-latest.orig/lib/Tie/Handle/stdhandle.t	2001-06-18 01:21:16.000000000 -0400
+++ perl-latest.diff/lib/Tie/Handle/stdhandle.t	2004-05-08 10:19:13.000000000 -0400
@@ -10,7 +10,7 @@ tie *tst,Tie::StdHandle;
 
 $f = 'tst';
 
-print "1..13\n";
+print "1..15\n";
 
 # my $file tests
 
@@ -39,9 +39,12 @@ print "'$b' not " unless $b eq 'Some';
 print "ok 10\n";
 print "not " unless getc($f) eq ' ';
 print "ok 11\n";
-$b = <$f>;
-print "not " unless eof($f);
+print "not " if truncate($f, 0);       # no tie magic for strings and truncate
 print "ok 12\n";
-print "not " unless close($f);
+print "not " unless truncate(tst, 0);
 print "ok 13\n";
+print "not " unless eof($f);
+print "ok 14\n";
+print "not " unless close($f);
+print "ok 15\n";
 unlink("afile");
diff -rup perl-latest.orig/lib/Tie/Handle.pm perl-latest.diff/lib/Tie/Handle.pm
--- perl-latest.orig/lib/Tie/Handle.pm	2002-06-28 09:13:56.000000000 -0400
+++ perl-latest.diff/lib/Tie/Handle.pm	2004-05-08 10:19:13.000000000 -0400
@@ -92,6 +92,10 @@ Position the file.
 
 Test for end of file.
 
+=item TRUNCATE this, length
+
+Truncate the file.
+
 =item DESTROY this
 
 Free the storage associated with the tied handle referenced by I<this>.
@@ -207,12 +211,13 @@ sub TIEHANDLE 
  return $fh;
 }
 
-sub EOF     { eof($_[0]) }
-sub TELL    { tell($_[0]) }
-sub FILENO  { fileno($_[0]) }
-sub SEEK    { seek($_[0],$_[1],$_[2]) }
-sub CLOSE   { close($_[0]) }
-sub BINMODE { binmode($_[0]) }
+sub EOF      { eof($_[0]) }
+sub TELL     { tell($_[0]) }
+sub FILENO   { fileno($_[0]) }
+sub SEEK     { seek($_[0],$_[1],$_[2]) }
+sub TRUNCATE { truncate($_[0],$_[1]) }
+sub CLOSE    { close($_[0]) }
+sub BINMODE  { binmode($_[0]) }
 
 sub OPEN
 {
diff -rup perl-latest.orig/pod/perlfunc.pod perl-latest.diff/pod/perlfunc.pod
--- perl-latest.orig/pod/perlfunc.pod	2004-05-07 14:42:55.000000000 -0400
+++ perl-latest.diff/pod/perlfunc.pod	2004-05-08 10:19:13.000000000 -0400
@@ -6013,6 +6013,7 @@ A class implementing a file handle shoul
     EOF this
     FILENO this
     SEEK this, position, whence
+    TRUNCATE this, length
     TELL this
     OPEN this, mode, LIST
     CLOSE this
diff -rup perl-latest.orig/pod/perltie.pod perl-latest.diff/pod/perltie.pod
--- perl-latest.orig/pod/perltie.pod	2003-12-07 17:46:11.000000000 -0500
+++ perl-latest.diff/pod/perltie.pod	2004-05-08 10:19:13.000000000 -0400
@@ -818,7 +818,7 @@ This is partially implemented now.
 A class implementing a tied filehandle should define the following
 methods: TIEHANDLE, at least one of PRINT, PRINTF, WRITE, READLINE, GETC,
 READ, and possibly CLOSE, UNTIE and DESTROY.  The class can also provide: BINMODE,
-OPEN, EOF, FILENO, SEEK, TELL - if the corresponding perl operators are
+OPEN, EOF, FILENO, SEEK, TELL, TRUNCATE - if the corresponding perl operators are
 used on the handle.
 
 When STDERR is tied, its PRINT method will be called to issue warnings
@@ -906,6 +906,14 @@ This method will be called when the C<ge
 
     sub GETC { print "Don't GETC, Get Perl"; return "a"; }
 
+=item SEEK this, position, whence
+
+This method will be called when the C<seek> function is called.
+
+=item TRUNCATE this, length
+
+This method will be called when the C<truncate> function is called.
+
 =item CLOSE this
 
 This method will be called when the handle is closed via the C<close>
@@ -1122,8 +1130,8 @@ module that does attempt to address this
 module.  Check your nearest CPAN site as described in L<perlmodlib> for
 source code to MLDBM.
 
-Tied filehandles are still incomplete.  sysopen(), truncate(),
-flock(), fcntl(), stat() and -X can't currently be trapped.
+Tied filehandles are still incomplete.  sysopen(), flock(), fcntl(), stat() and
+-X can't currently be trapped.
 
 =head1 AUTHOR
 
diff -rup perl-latest.orig/pp_sys.c perl-latest.diff/pp_sys.c
--- perl-latest.orig/pp_sys.c	2004-03-16 13:42:23.000000000 -0500
+++ perl-latest.diff/pp_sys.c	2004-05-08 10:19:13.000000000 -0400
@@ -2069,12 +2069,12 @@ PP(pp_truncate)
      * might not be signed: if it is not, clever compilers will moan. */
     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
     SETERRNO(0,0);
-#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
     {
         STRLEN n_a;
 	int result = 1;
 	GV *tmpgv;
 	IO *io;
+   MAGIC *mg;
 
 	if (PL_op->op_flags & OPf_SPECIAL) {
 	    tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
@@ -2086,6 +2086,27 @@ PP(pp_truncate)
 		PerlIO *fp;
 		io = GvIOp(tmpgv);
 	    do_ftruncate_io:
+
+   /* Call the TRUNCATE() method for tied handles. Note that truncate()
+    * treats strings as file names, so we can't perform tied magic on them. */
+	if ((mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+    {
+	PUSHMARK(SP);
+	XPUSHs(SvTIED_obj((SV*)io, mg));
+#if Off_t_size > IVSIZE
+	XPUSHs(sv_2mortal(newSVnv(len)));
+#else
+	XPUSHs(sv_2mortal(newSViv(len)));
+#endif
+	PUTBACK;
+	ENTER;
+	call_method("TRUNCATE", G_SCALAR);
+	LEAVE;
+	SPAGAIN;
+	RETURN;
+    }
+
+#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
 		TAINT_PROPER("truncate");
 		if (!(fp = IoIFP(io))) {
 		    result = 0;
@@ -2099,6 +2120,10 @@ PP(pp_truncate)
 #endif
 			result = 0;
 		}
+#else
+    DIE(aTHX_ "truncate not implemented");
+#endif
+
 	    }
 	}
 	else {
@@ -2118,6 +2143,7 @@ PP(pp_truncate)
 		goto do_ftruncate_io;
 	    }
 
+#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
 	    name = SvPV(sv, n_a);
 	    TAINT_PROPER("truncate");
 #ifdef HAS_TRUNCATE
@@ -2136,6 +2162,10 @@ PP(pp_truncate)
 		}
 	    }
 #endif
+#else
+    DIE(aTHX_ "truncate not implemented");
+#endif
+
 	}
 
 	if (result)
@@ -2144,9 +2174,6 @@ PP(pp_truncate)
 	    SETERRNO(EBADF,RMS_IFI);
 	RETPUSHUNDEF;
     }
-#else
-    DIE(aTHX_ "truncate not implemented");
-#endif
 }
 
 PP(pp_fcntl)
diff -rup perl-latest.orig/t/op/tiehandle.t perl-latest.diff/t/op/tiehandle.t
--- perl-latest.orig/t/op/tiehandle.t	2003-07-27 17:00:38.000000000 -0400
+++ perl-latest.diff/t/op/tiehandle.t	2004-05-08 10:19:13.000000000 -0400
@@ -10,7 +10,7 @@ my $data = "";
 my @data = ();
 
 require './test.pl';
-plan(tests => 41);
+plan(tests => 43);
 
 sub compare {
     return unless @expect;
@@ -65,6 +65,12 @@ sub WRITE {
     length($data);
 }
 
+sub TRUNCATE {
+    ::compare(TRUNCATE => @_);
+    substr($data, $_[1]) = '';
+    length($data);
+}
+
 sub CLOSE {
     ::compare(CLOSE => @_);
     
@@ -106,6 +112,11 @@ $data = "abc";
 $ch = getc $fh;
 is($ch, "a");
 
+@expect = (TRUNCATE => $ob, 2);
+$data = "abc";
+$r = truncate $fh, 2;
+is($r, "2");
+
 $buf = "xyz";
 @expect = (READ => $ob, $buf, 3);
 $data = "abc";

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About