File Coverage

blib/lib/Tie/STDERR.pm

Criterion	Covered	Total	%
statement	27	55	49.0
branch	10	26	38.4
condition	2	3	66.6
subroutine	6	10	60.0
pod	0	3	0.0
total	45	97	46.3

package Tie::STDERR;

use strict;

my $stderr = '';		### here we store the STDERR output

my $need_apache_cleanup = 0;
if (defined $ENV{'MOD_PERL'})
	{ $need_apache_cleanup = 1; }

sub TIEHANDLE
	{
	my $class = shift;
	bless {}, $class;
	}
sub PRINT
	{
	my $self = shift;
	$stderr .= join	'', @_;
	}

my $default_user = 'root';			### change this to 'root'
my $default_subject = 'STDERR output detected';	### change this to your Subject
my $default_mail = '| /usr/lib/sendmail -t';	### default command
my $run_function = undef;
my $append_scalar = undef;

my ($user, $subject, $command);

sub error_id {
	my @localtime = localtime;
	sprintf "%04d%02d%02d-%02d%02d%02d-%05d", $localtime[5] + 1900,
		$localtime[4] + 1, @localtime[3, 2, 1, 0], $$;
	}

sub process_result {
	### local *STDERR; untie *STDERR;
	local $ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin';
	if ($stderr ne '')
		{
		if (defined $run_function)
			{ &$run_function($stderr); }
		elsif (defined $append_scalar)
			{ $$append_scalar .= $stderr; }
		elsif (defined $command)
			{
			open OUT, $command;
			print OUT $stderr;
			}
		else
			{
			open OUT, $default_mail;
			### print STDERR "Sending bug by email\n";
			my $now = error_id;
			print OUT "To: $user\nSubject: $subject\n\nOutput to STDERR detected in $0:\n", $stderr, "\n\nTime: $now\n\n";
			print OUT "\%ENV:\n";
			for (sort keys %ENV) { print OUT "$_ = $ENV{$_}\n"; }
			}
		close OUT;
		$stderr = '';
		}
	}

END {
	process_result();
	}
sub register_apache_cleanup {
	eval 'use Apache; my $r = Apache->request; $r->register_cleanup(\&process_result); ';
	}
sub import {
	### print STDERR "Tie::STDERR::import(@_) called\n";
	my $class = shift;

	if (@_ and not defined $_[0])	### explicit undef
		{
		$^W = 0;
		untie *STDERR if ref tied *STDERR eq 'Tie::STDERR';
		$run_function = undef; $append_scalar = undef;
		return;
		}

	### return if -t STDERR or -t STDOUT;

	unless (ref tied *STDERR eq 'Tie::STDERR')
		{
		tie *STDERR, __PACKAGE__;

		$SIG{__WARN__} = sub { print STDERR @_; };

		$SIG{__DIE__} = sub { print STDERR @_; };
		}

	($user, $subject, $command) = ($default_user, $default_subject, undef);

	return unless @_;

	if (ref $_[0] eq 'CODE')
		{ $run_function = $_[0]; }
	elsif (ref $_[0] eq 'SCALAR')
		{ $append_scalar = $_[0]; }
	else {
		my $arg = shift;
		if ($arg =~ /^\s*([|>].*)/s)
			{ $command = $1; }
		else
			{
			$arg =~ s/\n$//;
			$user = $arg;
			$arg = shift;
			if (defined $arg)
				{ $arg =~ s/\n$//; $subject = $arg; }
			}
		}
	if ($need_apache_cleanup) {
		register_apache_cleanup();
		}
	}

$Tie::STDERR::VERSION = '0.26';

1;

__END__