File Coverage

blib/lib/Text/ASCIIPipe.pm

Criterion	Covered	Total	%
statement	3	95	3.1
branch	0	66	0.0
condition	0	3	0.0
subroutine	1	16	6.2
pod	9	9	100.0
total	13	189	6.8

package Text::ASCIIPipe;
# See POD below.

# TODO: sanitize line end from handlers!

use strict;
# major.minor.bugfix, the latter two with 3 digits each
# or major.minor_alpha
our $VERSION = '1.001000';
$VERSION = eval $VERSION;


# State codes. The numerocal values are important for the code in this module (used as array indices).
our $funky  = 0;
our $line   = 1;
our $begin  = 2; # From here identical to ASCII code
our $end    = 3;
our $allend = 4;

# The actualy control characters.
my %control = (stx=>"\002", eot=>"\003", etx=>"\004");

# Map plain character codes to state codes.
# I do not really care about codes 0 and 1.
my @codemap = ($funky, $funky, $begin, $end, $allend);

sub fetch
{
	my $fh = shift;
	$fh = \*STDIN unless defined $fh;

	# Note to self: MAC style line endings will only work here for an old-style MAC Perl. All others see one big line with CRs in it.
	$_[0] = <$fh>;
	return undef unless defined $_[0];
	my $code = ord($_[0]);
	return $line if $code > 4;
	return $codemap[$code];
}

# plain text means: first byte does not qualify as control code
sub plaintext
{
	my $code = ord($_[0]);
	return ($code > 4);
}

sub process
{
	my %arg = @_;

	my $fline;
	my $lend = undef;
	my $in  = $arg{in};
	my $out = $arg{out};
	$out = \*STDOUT unless defined $out;
	$arg{flush} = 1 unless defined $arg{flush};

	# The begin function is special because we ensure that the output gets flushed to prevent stalling of the pipe readers.
	# Function table according to numerical value of state codes.
	# A handler gets the current line as first in/output argument and the detected line end as second.
	my $prefilter = defined $arg{pre} ? $arg{pre} : sub {};
	my @handlers =
	(
		 sub {} # 0 is some unknown crap. Ignore.
		,defined $arg{line}  ? $arg{line}  : sub {}
		,sub
		{
			# That flush may be better placed after $arg{end} ...
			if($arg{flush})
			{
				my $old = select($out);
				$|=1;
				select($old);
			}
			&{$arg{begin}}(@_) if defined $arg{begin};
		}
		,defined $arg{end}    ? $arg{end}      : sub {}
		,defined $arg{allend} ? $arg{allend}   : sub {}
	);

	my @gotcode; # Need to check if control codes were actually present.
	my @prearg;
	push(@prearg, $arg{handle}) if defined $arg{handle};
	while(defined (my $state = fetch($in, $fline)))
	{
		# Store first encountered line end to be used for constructed lines.
		unless(defined $lend)
		{
			$fline =~ m/([\012\015]*)$/;
			$lend = $1;
		}
		$gotcode[$state] = 1;
		if(not $gotcode[$begin])
		{
			my $extraline = '';
			# Trigger begin hook implicitly when just encountering data.
			&{$handlers[$begin]}(@prearg, $extraline, $lend);
			print $out $extraline;
			$gotcode[$begin] = 1;
		}
		if($state == $line)
		{
			next if &{$prefilter}(@prearg, $fline, $lend);
			# A line handler shall modify the line.
			&{$handlers[$state]}(@prearg, $fline, $lend);
			print $out $fline if $fline ne '';
		}
		else
		{
			# Other handlers could generate something.
			my $extraline = '';
			&{$handlers[$state]}(@prearg, $extraline, $lend);
			print $out ($state == $begin ? $fline.$extraline : $extraline.$fline);
		}

		return if($state == $allend);
		# If we got proper end code, clear records for next file.
		@gotcode = () if($state == $end);
	}

	# Make sure that handlers get called even for empty file, or partial transfer with missing end markers.
	# I wonder if $lend should be simply guessed to "\n".
	for my $c ($begin,$end,$allend)
	{
		next if $gotcode[$c];
		# The handlers are allowed to generate some output.
		my $extraline = '';
		&{$handlers[$c]}(@prearg, $extraline, $lend);
		print $out $extraline;
	}
}

# Simple shortcut to pull a full file from pipe handle into an output file.
# Returns indication if this was not the last file (so you can loop until it returns a non-true value).
# return value:
# <0: Pull was invalid, no data for file (not even an empty one).
#  0: Pull successful, but this was it, no more files to expect.
# >0: Pull successful and no indication that there is not more to come.

sub pull_file
{
	my ($from, $to) = @_;
	$from = \*STDIN  unless defined $from;
	$to   = \*STDOUT unless defined $to;
	my $payload;
	my $state;
	while(defined ($state = fetch($from, $payload)))
	{
		next if $state == $begin;
		last if $state != $line;
		print $to $payload;
	}

	# All fine: Loop ended with orderly file end marker.
	return  1 if(defined $state and $state != $allend);
	# Ended on EOF (or some esoteric error we still treat as such),
	# as there was no allend or error before that, just assume normal end of things.
	return  0 if(not defined $state);
	# If we hit allend, we did not stop with an orderly file end,
	# so must assume we got nothing at all.
	return -1; # if($state == allend) is already implied
}

# The senders.

sub push_file
{
	my ($from, $to) = @_;
	$from = \*STDIN  unless defined $from;
	$to   = \*STDOUT unless defined $to;

	file_begin($to);
	while(<$from>)
	{
		print $to $_;
	}
	file_end($to);
	return 1; # Should it return something special?
}

sub file_begin
{
	my $to = shift;
	$to = \*STDOUT unless defined $to;

	print $to $control{stx}."\n";
}

sub file_lines
{
	my $to = shift;
	$to = \*STDOUT unless defined $to;

	for(@_){ print $to $_; }
}

sub file_end
{
	my $to = shift;
	$to = \*STDOUT unless defined $to;

	print $to $control{eot}."\n";
}

sub done
{
	my $to = shift;
	$to = \*STDOUT unless defined $to;

	print $to $control{etx}."\n";
}

1;

__END__