Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?

Un "tie"ing a "tie"

by herby1620 (Monk)
on Apr 17, 2006 at 19:00 UTC ( #543891=perlquestion: print w/replies, xml ) Need Help??

herby1620 has asked for the wisdom of the Perl Monks concerning the following question:

It all seemed so simple, but alas... What I wanted to do is make up a simple module that would prefix all output (like print statements) with a prefix. I attempted to use the "tie" function to tie standard output. This is OK, but how does one write to standard output INSIDE the tie routines. Won't they go back and re-invoke themselves recursively until memory runs dry or some such. So the delimea, once something is tie'd, how does one use the previous old un "tie"'d function. While I suspect that this isn't too relevant to other tie'd objects (hash, array, scalar) it is important to handles. I'm after a "pay no attention to the man behind the curtain" solution.


Replies are listed 'Best First'.
Re: Un "tie"ing a "tie"
by ikegami (Patriarch) on Apr 17, 2006 at 19:32 UTC
    Make a copy of STDOUT and save it in the tied object.
    use Tie::Handle (); package Tie::Handle::TimeStamp; our @ISA = 'Tie::StdHandle'; sub wrap { my ($class, $globref) = @_; tie *$globref, $class, ">&=".fileno($globref); } sub WRITE { my $fh = $_[0]; local ($,, $\); print $fh "[" . localtime() . "] " . substr($_[1], 0, $_[2]); } 1;
    use Tie::Handle::TimeStamp(); tie *STDOUT, 'Tie::Handle::TimeStamp', ">&STDOUT"; print("test\n"); # -or- Tie::Handle::TimeStamp->wrap(\*STDOUT); print("test\n");

    Update: Changed $/ to $\.

      Better yet, here's a version that looks for prefixes lines as opposed to calls to print.

      use strict; use warnings; use Tie::Handle (); package Tie::Handle::TimeStamp; our @ISA = 'Tie::Handle'; sub wrap { my ($class, $globref) = @_; tie *$globref, $class, ">&=".fileno($globref); } sub TIEHANDLE { my $class = shift; my $fh = \do { local *HANDLE }; my $self = bless({ fh => $fh, nl => 1, }, $class); $self->OPEN(@_) if (@_); return $self; } sub EOF { return eof($_[0]{fh}) } sub TELL { return tell($_[0]{fh}) } sub FILENO { return fileno($_[0]{fh}) } sub SEEK { return seek($_[0]{fh}, $_[1], $_[2]) } # hum... sub CLOSE { return close($_[0]{fh}) } sub BINMODE { return binmode($_[0]{fh}) } sub OPEN { my $self = $_[0]; $self->CLOSE if defined($self->FILENO); return (@_ == 2 ? open($self->{fh}, $_[1]) : open($self->{fh}, $_[1], $_[2]) ); } sub WRITE { my $self = $_[0]; my $len = $_[2]; my $text = substr($_[1], 0, $len); return 1 unless $len; my $fh = $self->{fh}; my $nl = $self->{nl}; my $lt; local ($,, $\); my $qsep = quotemeta($/); while ($text =~ /((?:(?!$qsep).)*(?:($qsep)|(?!$qsep).))/gs) { if ($nl) { $lt ||= "[" . localtime() . "] "; print $fh ($lt) or return 0; } print $fh $1 or return 0; $nl = !!$2; } $self->{nl} = $nl; return 1; } 1;

      Note: Prints the time at which the caller started printing the line, not the time at which the caller finished printing the line.

      Bug: Doesn't support zero length or undefined $/.

      Bug: Doesn't properly detect the line ending if it's split over multiple prints.

      Bug: Uses more memory than in should.

      local $/ = '||' print('a|'); print('|b||'); # [timestamp] a||b|| print('a||b||'); # [timestamp] a||[timestamp] b||

      Update: Added paren that was accidently deleted after testing.

      Update: Simplified through the use of regexp. Tested to be safe.

      Update: Changed $/ to $\.

      Update: Added error checking, but I'm not sure that I'm returning the right value on error.

      Update: Re-added support for $len which was accidently removed when I switched to regexps. Unfortunately, a copy is now made of the text to print.

      Update: Switched from "\n" to $\ for splitting.

        I couldn't help thinking a PerlIO layer would be more appropriate, so I wrote a layer:
        use v5.8.0; use strict; use warnings; package PerlIO::via::TimeStamp; sub PUSHED { my ($class, $mode, $fh) = @_; # We can't be the bottom layer. if (@_ < 3) { # XXX Set "$!"? return -1; } # We only support writting. if ($mode ne 'w' && $mode ne 'a') { # XXX Set "$!"? return -1; } return bless({ nl => 1 }, $class); } sub WRITE { my $self = $_[0]; our $ibuf; local *ibuf = \$_[1]; my $fh = $_[2]; return 0 if not length $ibuf; local ($,, $\); our $nl; local *nl = \($self->{nl}); my $lt; my $qsep = quotemeta($/); while ($_[1] =~ /((?:(?!$qsep).)*(?:($qsep)|(?!$qsep).))/gs) { my $obuf = ''; if ($nl) { $lt ||= "[" . localtime() . "] "; $obuf .= $lt; } $obuf .= $1; print $fh $obuf or return 0; $nl = !!$2; } return length($ibuf); } 1;
        binmode(STDOUT, '>:via(TimeStamp)'); print("test\n");


        Instead of just doing timestamps, perhaps a generic "send output lines to this sub" routine is more useful:
        =head1 NAME FileHandle::Sub - an output filehandle that sends each line of output +to a user-specified CODE block =head1 SYNOPSIS use FileHandle::Sub; # grep my $fh = FileHandle::Sub::open { /token/ and print }; # prefix my $fh = FileHandle::Sub::open { s/^/scalar localtime/e; print }; =head1 DESCRIPTION Each line of output sent to this file handle will be passed to the COD +E block supplied to C<open>. =cut package FileHandle::Sub; { require 5.8.0; use strict; use warnings; sub open (&) { local *FH; tie *FH, __PACKAGE__, @_ or return; return *FH; } sub TIEHANDLE { my($class, $code) = @_; bless [$code, ""], $class; } sub _emit { my ($self, $txt) = @_; my ($code, $prev) = @$self; if ($txt =~ /\n$/) { local $_ = $prev . $txt; $code->($_); $prev = ""; } else { $prev .= $txt; } $self->[1] = $prev; } sub PRINT { my ($self, @txt) = @_; local $_; for my $txt (@txt) { _emit($self, $_) for $txt =~ /[^\n]*\n?/g; } } sub PRINTF { my ($self, $fmt, @args) = @_; PRINT $self, sprintf $fmt, @args; } sub CLOSE { my ($self) = @_; local $_ = $self->[1]; if (length) { $self->[0]->($_); } $self->[1] = ""; } sub DESTROY { &CLOSE } } 1;
        Opinions my own; statements of fact may be in error.
Re: Un "tie"ing a "tie"
by dragonchild (Archbishop) on Apr 17, 2006 at 19:07 UTC
    CORE and CORE::GLOBAL. However, what you really want is to save off a handle to the original STDOUT when your STDOUT-like handle is created.

    My criteria for good software:
    1. Does it work?
    2. Can someone else come in, make a change, and be reasonably certain no bugs were introduced?
      This sounds pretty much what I want to do. I'd like to have a copy of the original "STDOUT" file handle to refer to, while I do a 'tie' on the original. I've got the tie part working, and I attempted to do a copy with
      open (TagPrint::THELOG, ">&STDOUT") or die "dup: $!";
      And this works quite well, BUT (repeat after me Windoze is evil!) the new file handle isn't STDOUT, and redirecting STDOUT doesn't work. How does one save "*STDOUT", which is a symbol table reference, in another variable. I can't say
      then refer to 'THELOG' as if it were the original STDOUT at the point where I did the assignment. This would be "logical", but I can see it being difficult, as STDOUT is a "special" thing. It all seemed so easy. Just add a few lines to a program and it would take care of the magic. Alas, it is a bit more.
        % perldoc -f open ... Here is a script that saves, redirects, and restores "STDOUT" and "STDERR" using various methods: #!/usr/bin/perl open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!"; open OLDERR, ">&", \*STDERR or die "Can't dup STDERR: $!"; open STDOUT, '>', "foo.out" or die "Can't redirect STDOUT: $!"; open STDERR, ">&STDOUT" or die "Can't dup STDOUT: $!"; select STDERR; $| = 1; # make unbuffered select STDOUT; $| = 1; # make unbuffered print STDOUT "stdout 1\n"; # this works for print STDERR "stderr 1\n"; # subprocesses too open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!"; open STDERR, ">&OLDERR" or die "Can't dup OLDERR: $!"; print STDOUT "stdout 2\n"; print STDERR "stderr 2\n";
        Opinions my own; statements of fact may be in error.
        While "perldoc -f open" is very handy, looking at prior art would also be educational. Me, I'd look at querying CPAN for 'stdout' - the first result is probably a good one to read the source code of. In fact, you may find that using that module solves your problems. It certainly has solved a few of mine.

        My criteria for good software:
        1. Does it work?
        2. Can someone else come in, make a change, and be reasonably certain no bugs were introduced?

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://543891]
Approved by blokhead
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others about the Monastery: (5)
As of 2023-12-10 00:25 GMT
Find Nodes?
    Voting Booth?
    What's your preferred 'use VERSION' for new CPAN modules in 2023?

    Results (38 votes). Check out past polls.