File Coverage

blib/lib/Devel/Ditto.pm

Criterion	Covered	Total	%
statement	21	49	42.8
branch	0	8	0.0
condition			n/a
subroutine	7	17	41.1
pod			n/a
total	28	74	37.8

package Devel::Ditto;

use 5.008;

=head1 NAME

Devel::Ditto - Identify where print output comes from

=head1 VERSION

This document describes Devel::Ditto version 0.06

=cut

our $VERSION = '0.06';

=head1 SYNOPSIS

  $ perl -MDevel::Ditto myprog.pl
  [main, t/myprog.pl, 9] This is regular text
  [main, t/myprog.pl, 10] This is a warning
  [MyPrinter, t/lib/MyPrinter.pm, 7] Hello, World
  [MyPrinter, t/lib/MyPrinter.pm, 8] Whappen?

=head1 DESCRIPTION

Sometimes it's hard to work out where some printed output is coming
from. This module ties STDOUT and STDERR such that each call to C
or C will have its output prefixed with the package, file and line
of the C or C statement.

Load it in your program:

  use Devel::Ditto;

or from the command line:

  perl -MDevel::Ditto myprog.pl

=cut

no warnings;

open( REALSTDOUT, ">&STDOUT" );
open( REALSTDERR, ">&STDERR" );

use warnings;
use strict;

use File::Spec;

sub import {
  my $class  = shift;
  my %params = @_;

  tie *STDOUT, $class, %params,
   is_err  => 0,
   realout => sub {
    open( local *STDOUT, ">&REALSTDOUT" );
    $_[0]->( @_[ 1 .. $#_ ] );
   };

  tie *STDERR, $class, %params,
   is_err  => 1,
   realout => sub {
    open( local *STDOUT, ">&REALSTDERR" );
    $_[0]->( @_[ 1 .. $#_ ] );
   };
}

sub TIEHANDLE {
  my ( $class, %params ) = @_;
  bless \%params, $class;
}

sub _caller {
  my $self  = shift;
  my $depth = 0;
  while () {
    my ( $pkg, $file, $line ) = caller $depth;
    return unless defined $pkg;
    return ( $pkg, $file, $line )
     unless $pkg->isa( __PACKAGE__ );
    $depth++;
  }
}

sub _logbit {
  my $self = shift;
  my ( $pkg, $file, $line ) = $self->_caller();
  $file = File::Spec->canonpath($file);
  return "[$pkg, $file, $line] ";
}

sub PRINT {
  my $self = shift;
  $self->{realout}->( sub { print $self->_logbit, @_ }, @_ );
}

sub PRINTF {
  my $self = shift;
  $self->PRINT( sprintf $_[0], @_[ 1 .. $#_ ] );
}

sub WRITE {
  my $self = shift;
  $self->{realout}->(
    sub {
      my ( $buf, $len, $offset ) = @_;
      syswrite STDOUT, $buf, $len, defined $offset ? $offset : 0;
    },
    @_
  );
}

sub CLOSE {
  my $self = shift;
  if ( $self->{is_err} ) {
    close REALSTDERR;
  }
  else {
    close REALSTDOUT;
  }
}

1;
__END__