in reply to Re: Un "tie"ing a "tie"
in thread Un "tie"ing a "tie"

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;

[download]

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||

[download]

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.

Replies are listed 'Best First'.
Re^3: Un "tie"ing a "tie"
by ikegami (Patriarch) on Apr 17, 2006 at 22:08 UTC
    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;

    [download]
    binmode(STDOUT, '>:via(TimeStamp)');
print("test\n");

    [download]

    Untested.

[reply]
[d/l]
[select]
Re^3: Un "tie"ing a "tie"
by dpuu (Chaplain) on Apr 17, 2006 at 22:39 UTC
    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;

    [download]
    --Dave
    Opinions my own; statements of fact may be in error.
[reply]
[d/l]

      Good idea. My code was just an example. There are problems with the implementation, though.

      • For starters, you cannot easily replace an existing file handle, so you failed to address the original question.

      • No support for $,.

      • No support for $\.

      • No error code is returned. People won't be able to use this module when error checking is being done.

      • No support for write, binmode, etc. People won't be able to use this module when these are called with the filehandle.

      • Only your open function requires 5.8.0, and it could easily be rewritten to avoid that requirement.

      • Using $/ as the line terminator would be better than \n because it would give more flexibility to the caller at no cost.

      • _emit for //g would be more efficient as _emit while //g.

[reply]
[d/l]
[select]
        Obviously I agree that the implementation is incomplete; and yes, it is orthogonal to the OP's question. A user of a module like this would be responsible for managing their own filehandles -- as earlier answers said: store a dup of STDOUT.

        Support for all the special variables needs a little thought, because they are dynamically scoped. I'd probably want to capture their values in the "open" function and store those values in the object. But, OTOH, maybe someone changing the values dynamically knows what they're doing.

        I'm not sure that binmode is required for this filehandle. All it does is call a user-defined perl function for each line (implicitly text). If that code prints to a "real" filehandle, then it is that filehandle that needs to support binmode.

        I'd be interested to know how to rewrite the "open" function to avoid needing 5.8.x -- the requirement exists because of bugs in 5.6.x, so the simplest (and safest) thing it to require a version of perl that works reliably with tied filehandles.

        The conclusion I'd draw from this is that filehandles aren't as simple as we'd like -- because there's more underlying complexity than initially apparent.

        --Dave
        Opinions my own; statements of fact may be in error.
[reply]

In Section Seekers of Perl Wisdom