Un "tie"ing a "tie"

[herby1620]

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.

Thanks

[ikegami]

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 $\.

[ikegami]

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.

[ikegami]

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");

Untested.

[dpuu]

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;

[dragonchild]

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.

[herby1620]

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

THELOG = STDOUT;

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.

[dpuu]

% 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";

[dragonchild]

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.