File Coverage

blib/lib/Output/Buffer.pm

Criterion	Covered	Total	%
statement	24	43	55.8
branch	0	4	0.0
condition	0	3	0.0
subroutine	8	13	61.5
pod	0	4	0.0
total	32	67	47.7

#!/usr/local/bin/perl

=head1 NAME

Output::Buffer - module that assists in the capturing of output

=head1 DESCRIPTION

This module assists in the capture and buffer of data outputted from a program.
For more information please see http://www.theperlreview.com Volume 0 Issue 5
"Filehandle Ties".

=head1 TODO

=over 4

=item *

test.pl

=back

=head1 BUGS

This is a new module and has not been thoroughly tested.

=cut

package Output::Buffer;

# BEHAVIORAL CONSTANTS
use constant WARN => 2;
use constant FLUSH => 1;
use constant CLEAN => 0;

# EXPORT
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS $VERSION);
@ISA = qw(Exporter);
@EXPORT_OK = qw(WARN FLUSH CLEAN);
%EXPORT_TAGS = ( constants => [@EXPORT_OK] );

# VERSION
$VERSION = 0.1;

# DEPENDENCIES
use Tie::FileHandle::Buffer;
use Symbol;
use Carp;
use strict;

# Create a new output buffer
# Usage: my $buffer = Output::Buffer->new( behavior )
# where behavior is either FLUSH, CLEAN, or WARN
#    FLUSH - when the object loses scope, print its buffer
#    CLEAN - when the object loses scope, discard its buffer
#    WARN - when the object loses scope, discard its buffer
#           but issue a warning
sub new {
	my $fh = gensym; # create an anonymous filehandle
	tie *{$fh}, 'Tie::FileHandle::Buffer';

	# store our behavior, our handle, and the handle we replaced
	bless [ $_[1], $fh, select $fh ], $_[0];
}

# clean the output buffer, discarding its contents
sub clean {
	(tied *{$_[0]->[1]})->clear;
}

# get our contents
sub get_contents {
	(tied *{$_[0]->[1]})->get_contents;
}

# flush the output buffer, printing its contents
sub flush {
	my $self = shift;
	my $handle = $self->[2];

	# print our contents to our parent
	print $handle $self->get_contents;

	# then discard them
	$self->clean;
}

# Our scope has ended - deal with it by acting out our behavior
sub DESTROY {
	my $self = shift;
	if ( $self->[0] == FLUSH ) {
		# FLUSH means flush!
		$self->flush;
	} else {
		# only WARN carps - and only if there was buffered output
		carp "Discarded output buffer contents"
		   if ( ($self->[0] == WARN) && (length($self->get_contents) != 0));
		# both CLEAN and WARN imply cleaning
		$self->clean;
	}

	# return the old filehandle to domination
	my $handle = $self->[2];
	select $handle;
}

1;

=head1 AUTHORS AND COPYRIGHT

Written by Robby Walker ( [e-mail] ) for Point Writer ( http://www.pointwriter.com/ ).

You may redistribute/modify/etc. this module under the same terms as Perl itself.