[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]
[PATCH] stat() and -X for tied handles
Hi porters,
Here's a patch that makes stat() and the -X file test ops work on tied
handles. It was made against blead but applies cleanly to maint-5.10.
It adds three methods to the tied object interface:
* STAT, called by stat() and most of the file test ops
* ISATTY, called by -t
* ISBINARY, called by -B and -T
This is my first time poking at Perl's innards and I'm still unfamiliar
with most of it so I'm not sure what mistakes I might have made,
particularly with the stack macros. I think the idea is right though.
The end of S_do_stat_maybe_tiehandle() where it pulls the values
returned by STAT off the stack is probably wrong. Its based on the
opposite code at the end of pp_stat(), but I don't have the ability to
test the various possibilities.
One bit I don't like is that pp_stat() calls S_do_stat_maybe_tiehandle()
which then repeats most of the tests to determine if its working on a
tied handle. Its seems to fix this properly I'd want to have a single
function that does the all the "stat a handle" work, and then have
pp_stat() just wrap that. If I did that though I'm not sure where
Perl_my_stat() in doio.c fits, and I don't think we want tiehandle stuff
in that function, so I opted to leave it for now.
The additional three methods seemed to be the simplest interface I could
come up with, but I don't know if it looks right - I'm bad at
interfaces.
This functionality is something that I really need, so I'm keen to get
it right. All feedback very welcome.
Cheers,
Rob.
diff --git a/lib/Tie/Handle.pm b/lib/Tie/Handle.pm
index 1751650..5568105 100644
--- a/lib/Tie/Handle.pm
+++ b/lib/Tie/Handle.pm
@@ -96,6 +96,18 @@ Position the file.
Test for end of file.
+=item STAT this
+
+Get info about the file.
+
+=item ISATTY
+
+See if the file is connected to a terminal.
+
+=item ISBINARY
+
+See if the file content is binary or text.
+
=item DESTROY this
Free the storage associated with the tied handle referenced by I<this>.
@@ -193,6 +205,21 @@ sub WRITE {
croak "$pkg doesn't define a WRITE method";
}
+sub STAT {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a STAT method";
+}
+
+sub ISATTY {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a ISATTY method";
+}
+
+sub ISBINARY {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a ISBINARY method";
+}
+
sub CLOSE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a CLOSE method";
diff --git a/pod/perltie.pod b/pod/perltie.pod
index 162272b..e4471c4 100644
--- a/pod/perltie.pod
+++ b/pod/perltie.pod
@@ -952,6 +952,29 @@ This method will be called when the C<getc> function is called.
sub GETC { print "Don't GETC, Get Perl"; return "a"; }
+=item STAT this
+X<STAT>
+
+This method will be called when the C<stat> function or any of the
+C<-X> file test operators (except C<-t>, C<-B> and C<-T>) are called.
+
+ sub STAT { return (0, 0, 0644, 0, $<, $>, 0, 42, 0, 0, 0, 0, 0); }
+
+=item ISATTY this
+X<ISATTY>
+
+This method will be called when the C<-t> file test operator is called.
+
+ sub ISATTY { return 0; }
+
+=item ISBINARY this
+X<ISBINARY>
+
+This method will be called when the C<-B> or C<-T> file test operators
+are called.
+
+ sub ISBINARY { return 1; }
+
=item CLOSE this
X<CLOSE>
@@ -1176,7 +1199,7 @@ at solving the problem is MLDBM, which is also available on the CPAN, but
which has some fairly serious limitations.
Tied filehandles are still incomplete. sysopen(), truncate(),
-flock(), fcntl(), stat() and -X can't currently be trapped.
+flock(), and fcntl() can't currently be trapped.
=head1 AUTHOR
@@ -1189,3 +1212,5 @@ UNTIE by Nick Ing-Simmons <F<nick@ing-simmons.net>>
SCALAR by Tassilo von Parseval <F<tassilo.von.parseval@rwth-aachen.de>>
Tying Arrays by Casey West <F<casey@geeknest.com>>
+
+STAT, ISATTY and ISBINARY by Robert Norris <F<rob@cataclysm.cx>>
diff --git a/pp_sys.c b/pp_sys.c
index 833e565..12d900a 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2790,6 +2790,100 @@ nuts2:
}
/* Stat calls. */
+STATIC I32
+S_do_stat_maybe_tiehandle(pTHX)
+{
+ dSP;
+ GV *gv = NULL;
+ IO *io = NULL;
+ MAGIC *mg = NULL;
+ int count;
+
+ if (PL_op->op_flags & OPf_REF) {
+ gv = cGVOP_gv;
+ if (gv)
+ io = GvIO(gv);
+ } else {
+ SV * const sv = POPs;
+ if (SvTYPE(sv) == SVt_PVGV)
+ io = GvIO((GV*) sv);
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ gv = (GV*) SvRV(sv);
+ if (gv)
+ io = GvIO(gv);
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO)
+ io = (IO*) SvRV(sv);
+ }
+
+ if (io)
+ mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+
+ if (!mg)
+ return my_stat();
+
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ count = call_method("STAT", G_ARRAY);
+ LEAVE;
+ SPAGAIN;
+
+ if (count != 13)
+ Perl_croak(aTHX_ "STAT method for tied handle did not return correct number of items");
+
+#ifdef USE_STAT_BLOCKS
+ PL_statcache.st_blocks = (UV) POPi;
+ PL_statcache.st_blksize = (UV) POPi;
+#else
+ (void) POPi;
+ (void) POPi;
+#endif
+#ifdef BIG_TIME
+ PL_statcache.st_ctime = POPn;
+ PL_statcache.st_mtime = POPn;
+ PL_statcache.st_atime = POPn;
+#else
+ PL_statcache.st_ctime = POPi;
+ PL_statcache.st_mtime = POPi;
+ PL_statcache.st_atime = POPi;
+#endif
+#if Off_t_size > IVSIZE
+ PL_statcache.st_size = POPn;
+#else
+ PL_statcache.st_size = POPi;
+#endif
+#ifdef USE_STAT_RDEV
+ PL_statcache.st_rdev = POPi;
+#else
+ (void) POPi;
+#endif
+#if Gid_t_size > IVSIZE
+ PL_statcache.st_gid = POPn;
+#else
+# if Gid_t_sign <= 0
+ PL_statcache.st_gid = POPi;
+# else
+ PL_statcache.st_gid = (UV) POPi;
+# endif
+#endif
+#if Uid_t_size > IVSIZE
+ PL_statchace.st_uid = POPn;
+#else
+# if Uid_t_sign <= 0
+ PL_statcache.st_uid = POPi;
+# else
+ PL_statcache.st_uid = (UV) POPi;
+# endif
+#endif
+ PL_statcache.st_nlink = (UV) POPi;
+ PL_statcache.st_mode = (UV) POPi;
+ PL_statcache.st_ino = POPi;
+ PL_statcache.st_dev = POPi;
+
+ return 0;
+}
PP(pp_stat)
{
@@ -2821,7 +2915,13 @@ PP(pp_stat)
io = GvIO(gv);
do_fstat_have_io:
if (io) {
- if (IoIFP(io)) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ PL_laststatval =
+ /* XXX this sucks since it does most of the tests
+ * that have already been done */
+ S_do_stat_maybe_tiehandle(aTHX);
+ } else if (IoIFP(io)) {
PL_laststatval =
PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
} else if (IoDIRP(io)) {
@@ -3042,8 +3142,7 @@ PP(pp_ftrread)
RETPUSHNO;
#endif
}
-
- result = my_stat();
+ result = S_do_stat_maybe_tiehandle(aTHX);
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
@@ -3059,7 +3158,7 @@ PP(pp_ftis)
const int op_type = PL_op->op_type;
dSP;
STACKED_FTEST_CHECK;
- result = my_stat();
+ result = S_do_stat_maybe_tiehandle(aTHX);
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
@@ -3113,7 +3212,7 @@ PP(pp_ftrowned)
#endif
STACKED_FTEST_CHECK;
- result = my_stat();
+ result = S_do_stat_maybe_tiehandle(aTHX);
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
@@ -3195,6 +3294,7 @@ PP(pp_fttty)
int fd;
GV *gv;
SV *tmpsv = NULL;
+ IO *io = NULL;
STACKED_FTEST_CHECK;
@@ -3207,6 +3307,27 @@ PP(pp_fttty)
else
gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
+ io = GvIO(gv);
+ if (!io && tmpsv && SvROK(tmpsv))
+ io = (IO*) SvRV(tmpsv);
+ if (io) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ SV *sv;
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("ISATTY", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ sv = POPs;
+ if (SvTRUE(sv)) RETPUSHYES;
+ RETPUSHNO;
+ }
+ }
+
+
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
else if (tmpsv && SvOK(tmpsv)) {
@@ -3298,6 +3419,26 @@ PP(pp_fttext)
len = 512;
}
else {
+ if (io) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ SV *sv;
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("ISBINARY", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ sv = POPs;
+ if (PL_op->op_type == OP_FTTEXT) {
+ if (SvTRUE(sv)) RETPUSHNO;
+ RETPUSHYES;
+ }
+ if (SvTRUE(sv)) RETPUSHYES;
+ RETPUSHNO;
+ }
+ }
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
gv = cGVOP_gv;
report_evil_fh(gv, GvIO(gv), PL_op->op_type);
diff --git a/t/lib/TieIn.pm b/t/lib/TieIn.pm
index a240867..58916c8 100644
--- a/t/lib/TieIn.pm
+++ b/t/lib/TieIn.pm
@@ -20,4 +20,6 @@ sub EOF {
return !length $$self;
}
+sub ISATTY {}
+
1;
diff --git a/t/lib/TieOut.pm b/t/lib/TieOut.pm
index 0a0f5f9..359c2e9 100644
--- a/t/lib/TieOut.pm
+++ b/t/lib/TieOut.pm
@@ -18,6 +18,9 @@ sub PRINTF {
sub FILENO {}
+sub STAT { (0,0,0,0,0,0,0,0,0,0,0,0,0); }
+sub ISATTY {}
+
sub read {
my $self = shift;
my $data = $$self;
diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t
index 735a25c..642baed 100755
--- a/t/op/tiehandle.t
+++ b/t/op/tiehandle.t
@@ -10,7 +10,7 @@ my $data = "";
my @data = ();
require './test.pl';
-plan(tests => 50);
+plan(tests => 161);
sub compare {
local $Level = $Level + 1;
@@ -73,6 +73,21 @@ sub CLOSE {
5;
}
+sub STAT {
+ ::compare(STAT => @_);
+ return @$data;
+}
+
+sub ISATTY {
+ ::compare(ISATTY => @_);
+ return $data;
+}
+
+sub ISBINARY {
+ ::compare(ISBINARY => @_);
+ return $data;
+}
+
package main;
use Symbol;
@@ -144,6 +159,92 @@ $r = syswrite $fh,$buf;
is($r, 6);
is($data, "qwerty");
+@expect = (STAT => $ob);
+$data = [1,2,3,4,5,6,7,8,9,10,11,12,13];
+@r = stat $fh;
+is($#r, 12);
+is($r[$_], $_+1) for (0..12);
+
+@filetests = (
+ # test, stat elem, value, expect
+ [ "r", 2, 0444, 1 ], # ftrread, OP_FTRREAD
+ [ "r", 2, 0000, 0 ],
+ [ "w", 2, 0222, 1 ], # ftrread, OP_FTRWRITE
+ [ "w", 2, 0000, 0 ],
+ [ "x", 2, 0111, 1 ], # ftrread, OP_FTREXEC
+ [ "x", 2, 0000, 0 ],
+ [ "R", 2, 0444, 1 ], # ftrread, OP_FTEREAD
+ [ "R", 2, 0000, 0 ],
+ [ "W", 2, 0222, 1 ], # ftrread, OP_FTEWRITE
+ [ "W", 2, 0000, 0 ],
+ [ "X", 2, 0111, 1 ], # ftrread, OP_FTEEXEC
+ [ "X", 2, 0000, 0 ],
+ [ "e", 0, 0, 1 ], # ftis, OP_FTIS
+ [ "s", 7, 0, 0 ], # ftis, OP_FTSIZE
+ [ "s", 7, 12345, 12345 ],
+ [ "M", 9, $^T+12345, $^T+12345 ], # ftis, OP_FTMTIME
+ [ "A", 8, $^T+12345, $^T+12345 ], # ftis, OP_FTATIME
+ [ "C", 10, $^T+12345, $^T+12345 ], # ftis, OP_FTCTIME
+ [ "o", 4, $<, 1 ], # ftrowned, OP_FTEOWNED
+ [ "o", 4, $<+1, 0 ],
+ [ "O", 4, $>, 1 ], # ftrowned, OP_FTROWNED
+ [ "O", 4, $>+1, 0 ],
+ [ "z", 7, 0, 1 ], # ftrowned, OP_FTZERO
+ [ "z", 7, 12345, 0 ],
+ [ "S", 2, 0140000, 1 ], # ftrowned, OP_FTSOCK
+ [ "S", 2, 0000000, 0 ],
+ [ "c", 2, 0020000, 1 ], # ftrowned, OP_FTCHR
+ [ "c", 2, 0000000, 0 ],
+ [ "b", 2, 0060000, 1 ], # ftrowned, OP_FTBLK
+ [ "b", 2, 0000000, 0 ],
+ [ "f", 2, 0100000, 1 ], # ftrowned, OP_FTFILE
+ [ "f", 2, 0000000, 0 ],
+ [ "d", 2, 0040000, 1 ], # ftrowned, OP_FTDIR
+ [ "d", 2, 0000000, 0 ],
+ [ "p", 2, 0010000, 1 ], # ftrowned, OP_FTPIPE
+ [ "p", 2, 0000000, 0 ],
+ [ "u", 2, 0004000, 1 ], # ftrowned, OP_FTSUID
+ [ "u", 2, 0000000, 0 ],
+ [ "g", 2, 0002000, 1 ], # ftrowned, OP_FTSGID
+ [ "g", 2, 0000000, 0 ],
+ [ "k", 2, 0001000, 1 ], # ftrowned, OP_FTSVTX
+ [ "k", 2, 0000000, 0 ],
+);
+
+@expect = (STAT => $ob);
+$data = [0,0,0,0,0,0,0,0,0,0,0,0,0];
+for $ft (@filetests) {
+ $data->[$ft->[1]] = $ft->[2];
+ $r = eval "-$ft->[0] \$fh";
+ ok(!($r xor $ft->[3]) || $r == $ft->[3]);
+}
+
+@expect = (ISATTY => $ob);
+$data = 0;
+$r = -t $fh;
+ok(!$r);
+
+$data = 1;
+$r = -t $fh;
+ok($r);
+
+@expect = (ISBINARY => $ob);
+$data = 0;
+$r = -B $fh;
+ok(!$r);
+
+$data = 1;
+$r = -B $fh;
+ok($r);
+
+$data = 0;
+$r = -T $fh;
+ok($r);
+
+$data = 1;
+$r = -T $fh;
+ok(!$r);
+
@expect = (CLOSE => $ob);
$r = close $fh;
is($r, 5);
- Follow-Ups from:
-
"Rafael Garcia-Suarez" <rgarciasuarez@gmail.com>
[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]