File Coverage

blib/lib/Capture/Attribute.pm

Criterion	Covered	Total	%
statement	76	113	67.2
branch	13	40	32.5
condition	2	5	40.0
subroutine	21	21	100.0
pod	1	1	100.0
total	113	180	62.7

package Capture::Attribute;

use 5.010;
use strict;

BEGIN {
	$Capture::Attribute::AUTHORITY = 'cpan:TOBYINK';
	$Capture::Attribute::VERSION   = '0.001';
}

use Attribute::Handlers;
use Capture::Attribute::Return;
use Capture::Tiny qw//;
use Carp qw//;
use Sub::Name qw//;

my @importers;
sub import
{
	my ($class, %args) = @_;
	my $caller =
		   $args{-into}
		|| $args{-package}
		|| caller;

	no strict 'refs';
	push @{"$caller\::ISA"}, __PACKAGE__;
	push @importers, $caller unless $args{-keep};
}

my ($make_replacement_coderef, $save_coderef, $saved);
BEGIN
{
	$make_replacement_coderef = sub
	{
		my ($orig, $data) = @_;

		if ($data eq 'STDOUT')
		{
			return sub
			{
				my (@args) = @_;
				my $wa = wantarray;
				my $stdout = Capture::Tiny::capture {
					$wa ? $save_coderef->(1, my @r = $orig->(@args)) :
					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
					do { $orig->(@args); $save_coderef->() } ;
				};
				return $stdout;
			}
		}
		elsif ($data eq 'STDERR')
		{
			return sub
			{
				my (@args) = @_;
				my $wa = wantarray;
				my (undef, $stderr) = Capture::Tiny::capture {
					$wa ? $save_coderef->(1, my @r = $orig->(@args)) :
					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
					do { $orig->(@args); $save_coderef->() } ;
				};
				return $stderr;
			}
		}
		elsif ($data eq 'MERGED')
		{
			return sub
			{
				my (@args) = @_;
				my $wa = wantarray;
				my $merged = Capture::Tiny::capture_merged {
					$wa ? $save_coderef->(1, my @r = $orig->(@args)) :
					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
					do { $orig->(@args); $save_coderef->() } ;
				};
				return $merged;
			}
		}
		elsif ($data eq 'STDERR,STDOUT')
		{
			return sub
			{
				my (@args) = @_;
				my $wa = wantarray;
				my @r = Capture::Tiny::capture {
					$wa ? $save_coderef->(1, my @r = $orig->(@args)) :
					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
					do { $orig->(@args); $save_coderef->() } ;
				};
				return wantarray ? reverse(@r[0..1]) : $r[0];
			}
		}
		elsif ($data eq 'STDOUT,STDERR')
		{
			return sub
			{
				my (@args) = @_;
				my $wa = wantarray;
				return Capture::Tiny::capture {
					$wa ? $save_coderef->(1, my @r = $orig->(@args)) :
					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
					do { $orig->(@args); $save_coderef->() } ;
				};
			}
		}

		return;
	};

	$save_coderef = sub
	{
		if (not scalar @_)
		{
			$saved = Capture::Attribute::Return->new(wasarray => undef);
			return;
		}

		my $context = shift;
		$saved = Capture::Attribute::Return->new(
			wasarray => $context,
			value    => ($context ? \@_ : $_[0]),
			);
	}
}

INIT # runs AFTER attributes have been handled.
{
	no strict 'refs';
	foreach my $caller (@importers)
	{
		@{"$caller\::ISA"} = grep { $_ ne __PACKAGE__ } @{"$caller\::ISA"};
	}
	no warnings 'once';
	*return = sub { $saved };
}

sub Capture :ATTR(CODE,RAWDATA)
{
	my (
		$package,
		$symbol,
		$referent,
		$attr,
		$data,
		$phase,
		$filename,
		$linenum,
		) = @_;

	$data = uc($data) || (my $default_data = 'STDOUT');

	my $orig = *{$symbol}{CODE};
	my $replacement = $make_replacement_coderef->($orig, $data)
		or Carp::croak "Unrecognised option string: $data";

	{
		no strict 'refs';
		no warnings 'redefine';
		my $subname = sprintf '%s::%s', *{$symbol}{PACKAGE}, *{$symbol}{NAME};
		*{$subname} = Sub::Name::subname($subname, $replacement);
	}
}

__PACKAGE__
__END__