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;
[download]

use Tie::Handle::TimeStamp();

tie *STDOUT, 'Tie::Handle::TimeStamp', ">&STDOUT";
print("test\n");

# -or-

Tie::Handle::TimeStamp->wrap(\*STDOUT);
print("test\n");
[download]

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;
[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.

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.

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.

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: $!";
[download]

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;
[download]

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";
[download]

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