t/getline.tt - metacpan.org

#!/usr/bin/perl -I.

use strict;

my $slowest = 5;

my $debug = 0;
my $c = 1;
$| = 1;
my $testcount = 100;

use Carp qw(verbose);
use Sys::Hostname;

my $startingport = 1025;

my $tnum;

package T;

use IO::Event;
use IO::Socket::INET;
use Carp;
use strict;
use warnings;

our $last_send = 0;
our $last_receive = 0;

BEGIN {
	eval { require Time::HiRes };
	if ($@) {
		print "1..0 # Skipped: $@";
		exit;
	}
}

#
# basic idea...   the receiver reads something.  Once it
# has read it, it performs actions that cause more stuff
# to be sent.  The recevier stuff is called within ie_input
#

our (@tests) = (
	{
		# the first one is thrown away
	},
	{ #2
		send => "woa baby\n",
		acquire =>	sub {
			print "about to get() a line\n" if $debug;
			puller()->get()
		},
		compare => "woa baby",
		repeat => 1,
		desc => 'copy one line: print method & get method',
	},
	{ #3
		send => "woa frog\n",
		acquire =>	sub {
			print "about to getline() a line\n" if $debug;
			puller()->getline()
		},
		compare => "woa frog\n",
		desc => 'copy one line: print method & getline method',
		repeat => 1,
	},
	{ #4
		send =>		sub {
			my $p = pusher();
			print $p "foo\nbar\n";
		},
		acquire =>	sub {
			my $p = puller();
			return <$p>;
		},
		compare => [ "foo\n", "bar\n" ],
		repeat => 1,
		array => 1,
		desc => 'copy two lines: print filehandle & <filehandle>',
	},
	{ #5
		send =>		sub {
			my $p = pusher();
			printf $p "%s\n%s\n", 'foo', 'baz';
		},
		acquire =>	sub {
			my $p = puller();
			return <$p>;
		},
		compare => [ "foo\n", "baz\n" ],
		repeat => 1,
		array => 1,
		desc => 'copy two lines: printf filehandle & <filehandle>',
	},
	{ #6
		send =>		sub {
			pusher()->print("abc123");
		},
		acquire =>	sub {
			my ($s, $ibr, $t) = @_;
			return '' unless length($$ibr) >= 6;
			my $p = puller();
			my $x;
			read($p, $x, 3);
			die unless length($x) == 3;
			read($p, $x, 3, 3);
			return $x;
		},
		compare => "abc123",
		repeat => 1,
		desc => 'copy 2x3 chars: print method & read filehandle',
	},
	{ #7
		send =>		sub {
			pusher()->print("a\nb\n\nc\n\n\nd\n\n\n\ne\n");
			$/ = '';
		},
		acquire =>	sub {
			my $p = puller();
			return <$p>;
		},
		compare => [ "a\nb\n\n", "c\n\n", "d\n\n", "e\n" ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 sets many lines: print method & array context <filehandle>',
	},
	{ #8
		send =>		sub {
			$/ = '';
			pusher()->print("a\nb\n\nc\n\n\nd\n\n\n\ne\n");
		},
		acquire =>	sub {
			my $p = puller();
			my @l;
			while (<$p>) {
				push(@l, $_);
			}
			return @l;
		},
		compare => [ "a\nb\n\n", "c\n\n", "d\n\n", "e\n" ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 sets many lines: print method & scalar context <filehandle>',
	},
	{ #9
		send =>		sub {
			pusher()->print("\n\n\na\nb\n\nc\n\n\nd\n\n\n\ne\n");
		},
		connect => 	sub {
			$/ = "xyz";
			puller()->input_record_separator('');
		},
		acquire =>	sub {
			my $p = puller();
			return <$p>;
		},
		compare => [ "a\nb\n\n", "c\n\n", "d\n\n", "e\n" ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 sets many lines: print method & <filehandle> with $/ funny',
	},
	{ #10
		send =>		sub {
			pusher()->print("\n\na\nb\n\nc\n\n\nd\n\n\n\ne\n");
		},
		connect =>	sub {
			$/ = "xyz";
			puller()->input_record_separator('');
		},
		acquire =>	sub {
			my $p = puller();
			my @l;
			while (<$p>) {
				push(@l, $_);
			}
			return @l;
		},
		compare => [ "a\nb\n\n", "c\n\n", "d\n\n", "e\n" ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 sets many lines: print method & scalar <filehandle> with $/ funny',
	},
	{ #11
		send =>		sub {
			pusher()->print("xyz124abc567");
		},
		connect =>	sub {
			$/ = "\n";
			puller()->input_record_separator(3);
		},
		acquire =>	sub {
			my $p = puller();
			my @l;
			while (<$p>) {
				push(@l, $_);
			}
			return @l;
		},
		compare => [ "xyz", "124", "abc", "567" ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 sets many lines: print method & scalar <filehandle> with $/ == 3',
	},
	{ #12
		send =>		sub {
			pusher()->print("xyz124abc567");
		},
		connect =>	sub {
			$/ = "\n";
			puller()->input_record_separator(3);
		},
		acquire =>	sub {
			my $p = puller();
			return <$p>;
		},
		compare => [ "xyz", "124", "abc", "567" ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 sets many lines: print method & <filehandle> with $/ == 3',
	},
	{ #13
		send =>		sub {
			pusher()->print("xyzYYY124YYYabcYYY567");
		},
		connect =>	sub {
			$/ = "\n";
			puller()->input_record_separator("YYY");
		},
		acquire =>	sub {
			my $p = puller();
			return <$p>;
		},
		compare => [ "xyzYYY", "124YYY", "abcYYY", "567" ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 sets many lines: print method & <filehandle> with $/ == YYY',
	},
	{ #14
		send =>		sub {
			pusher()->print("xyzYYY124YYYYabcYYY567");
		},
		connect =>	sub {
			$/ = "\n";
			puller()->input_record_separator("YYY");
		},
		acquire =>	sub {
			my $p = puller();
			return <$p>;
		},
		compare => [ "xyzYYY", "124YYY", "YabcYYY", "567" ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 sets many lines: print method & <filehandle> with $/ == YYY & extra Y',
	},
	{ #15
		send =>		sub {
			pusher()->print("xyzYYY124YYYYabcYYY567");
		},
		connect =>	sub {
			puller()->input_record_separator("YYY");
		},
		acquire =>	sub {
			my $p = puller();
			my @l;
			while (<$p>) {
				push(@l, $_);
			}
			return @l;
		},
		compare => [ "xyzYYY", "124YYY", "YabcYYY", "567" ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 sets many lines: print method & scalar <filehandle> with $/ == YYY & extra Y',
	},
	{ #15
		send =>		sub {
			pusher()->print("my\ndog\nate\nmy...");
		},
		acquire =>	sub {
			my $p = puller();
			my @l;
			my $x;
			while (defined ($x = $p->get())) {
				push(@l, $x);
			}
			return @l;
		},
		compare => [ "my", "dog", "ate", "my..." ],
		repeat => 1,
		array => 1,
		desc => 'copy 4 lines: print method & get method',
	},
	{ #16
		send =>		sub {
			pusher()->print("aaabbbcccddde");
		},
		acquire =>	sub {
			my $p = puller();
			my @l;
			my $x;
			my $r = "12";
			while ($x = $p->sysread($r, 3)) {
				die unless length($r) == $x;
				push(@l, $r);
			}
			return @l;
		},
		compare => [ "aaa", "bbb", "ccc", "ddd", "e" ],
		repeat => 1,
		array => 1,
		desc => 'copy 5x3 chars: print method & sysread method',
	},
	{ #17
		send =>		sub {
			pusher()->print("aaabbbcccddde");
		},
		acquire =>	sub {
			my $p = puller();
			my @l;
			my $x;
			my $r = "12";
			while ($x = $p->sysread($r, 3, 1)) {
				die unless length($r) == $x+1;
				push(@l, $r);
			}
			return @l;
		},
		compare => [ "1aaa", "1bbb", "1ccc", "1ddd", "1e" ],
		repeat => 1,
		array => 1,
		desc => 'copy 5x3 chars: print method & sysread method with offset',
	},
	{ #18
		send =>		sub {
			pusher()->print("aaabbbcccddde");
		},
		acquire =>	sub {
			my $p = puller();
			my @l;
			my $x;
			my $r = "12";
			while ($x = sysread($p, $r, 3)) {
				die unless length($r) == $x;
				push(@l, $r);
			}
			return @l;
		},
		compare => [ "aaa", "bbb", "ccc", "ddd", "e" ],
		repeat => 1,
		array => 1,
		desc => 'copy 5x3 chars: print method & sysread filehandle',
	},
	{ #19
		send =>		sub {
			pusher()->print("aaabbbcccddde");
		},
		acquire =>	sub {
			my $p = puller();
			my @l;
			my $x;
			my $r = "12";
			while ($x = sysread($p, $r, 3, 1)) {
				die unless length($r) == $x+1;
				push(@l, $r);
			}
			return @l;
		},
		compare => [ "1aaa", "1bbb", "1ccc", "1ddd", "1e" ],
		repeat => 1,
		array => 1,
		desc => 'copy 5x3 chars: print method & sysread filehandle with offset',
	},
	{ #20
		send =>		sub {
			pusher()->print("aaabbbcccddde");
		},
		acquire =>	sub {
			my $p = puller();
			my $b;
			my $c;
			my @l;
			while ($c = $p->getc()) {
				if ($b && substr($b, 0, 1) eq $c) {
					$b .= $c;
				} elsif (! $b) {
					$b = $c;
				} else {
					$p->xungetc($c);
					push(@l, $b);
					undef $b;
				}
			}
			push(@l, $b) if defined $b;
			return @l;
		},
		compare => [ "aaa", "bbb", "ccc", "ddd", "e" ],
		repeat => 1,
		array => 1,
		desc => 'getc & xungetc',
	},
);

printf "1..%d\n", scalar(@tests);

# let's listen on a socket.  We'll expect to receive
# test numbers.  We'll print ok.

my $rp = T::pickport();
my $results = IO::Event::Socket::INET->new(
	Listen => 10,
	Proto => 'tcp',
	LocalPort => $rp,
	LocalAddr => '127.0.0.1',
	Handler => 'Pull',
	Description => "Listener, will receive on 127.0.0.1:$rp",
);

die unless $results;
die unless $results->filehandle;

my $fh = $results->filehandle;
my $fn = $fh->fileno;

print STDERR "fh=$fh\n" if $debug;
print STDERR "fn=$fn\n" if $debug;

my $idle;
my $time = time;
my $waitingfor = $c;
my $ptime;

my $push_socket;
my $pull_socket;

IO::Event->idle (
	cb => \&startup,
	reentrant => 0,
	repeat => 0,
);

okay($results, "now listening on results socket 127.0.0.1:$rp");

alarm($slowest);

print STDERR "about to loop\n" if $debug;

my $r = IO::Event::loop();
okay($r == 7, "loop finshed ($r)");

exit(0);

sub pusher
{
	my ($np) = @_;
	$push_socket = $np if $np;
	return $push_socket;
}

sub puller
{
	my ($np) = @_;
	$pull_socket = $np if $np;
	return $pull_socket;
}


# support routine
sub pickport
{
	for (my $i = 0; $i < 1000; $i++) {
		my $s = new IO::Socket::INET (
			Listen => 1,
			LocalPort => $startingport,
		);
		if ($s) {
			$s->close();
			return $startingport++;
		}
		$startingport++;
	}
	die "could not find an open port";
}

# support routine
sub okay
{
        my ($cond, $message) = @_;
        if ($cond) {
                print "ok $c # $message\n";
        } else {
		my($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller(0);
		print "not ok $c # $filename:$line $message\n";
        }
        $c++;
	if ($c > $testcount) {
		print STDERR "too many test results\n";
		exit(0);
	}
}

# default to oops
sub ie_input
{
	confess "we shoudn't be here";
}

sub startup
{
	print "Creating new sending socket, connecting to 127.0.0.1:$rp\n" if $debug;
	IO::Event::Socket::INET->new (
		Proto => 'tcp',
		PeerPort => $rp,
		PeerAddr => '127.0.0.1',
		Handler => 'Push',
		Description => "Sending socket",
	) or T::okay(0, "create pusher to $rp: $@");
}

sub sender
{
	print "sender() invoked\n" if $debug;
	die "send/receive out of sync $last_send/$last_receive" if $last_send != $last_receive;
	shift(@tests);
	if (! @tests) {
		okay(1, "all done");
		exit(0);
	}
	my $t = $tests[0];
	print "##############################################################################\n" if $debug;
	print "# starting $t->{desc}\n";
	$a = $t->{send};
	$last_send++;
	# okay(1, "keys = ".join(' ',keys %$t));
	if (ref $a) {
		eval { &$a() };
		if ($@) {
			T::okay(0, "send error $@");
			exit(0);
		}
	} else {
		pusher || confess "no pusher";
		print "# printing '$a' for new test\n" if $debug;
		pusher->print($a);
	}
	pusher->close();
	alarm($slowest);
}

package Push;

sub ie_connected
{
	my ($self, $s) = @_;
	T::pusher($s);
	T::sender($s);
}

sub ie_input
{
	my ($self, $s, $br) = @_;
	print $s->getlines();
}

package Pull;

use strict;
use warnings;

sub ie_connection
{
	my ($self, $s) = @_;
	print STDERR "Got puller connection  $T::last_receive\n" if $debug;
	T::puller($s->accept);
	my $t = $T::tests[0];
	my $c = $t->{connect};
	&$c if $c;
}

sub ie_input
{
	print STDERR "INPUT  $T::last_receive\n" if $debug;
#use Carp;
#print Carp::longmess("DEBUG... ie_input called\n");
	my ($self, $iput, $ibuf) = @_;
	my $t = $T::tests[0];
	my $acquire = $t->{acquire};
	my ($r, @r);
	if ($t->{array}) {
		@r = eval { &$acquire($iput, $ibuf, $t) };
	} else { 
		$r = eval { &$acquire($iput, $ibuf, $t) };
	}
	if ($@) {
		T::okay(0, "acquire error: $@ errno:$!");
		exit(0);
	}
	if ($t->{repeat}) {
		if ($t->{array}) {
			unshift(@r, @{$t->{prev}})
				if $t->{prev};
			$t->{prev} = [ @r ];
		} else {
			$r = $t->{prev}.$r
				if $t->{prev};
			$t->{prev} = $r;
		}
	}
	my $compare = $t->{compare};
	my $cr;
	if (ref $compare eq 'CODE') {
		if ($t->{array}) {
			$cr = eval { &$compare(@r) };
		} else {
			$cr = eval { &$compare($r) };
		}
		if ($@) {
			T::okay(0, "copmare error $@");
			exit(0);
		}
	} elsif ($t->{array}) {
		$r = join('><', @r);
		$compare = join('><', @$compare);
		$cr = length($r) < length($compare) 
			? -1
			: ($r eq $compare
				? 0
				: 1);
	} else {
		$cr = length($r) < length($compare) 
			? -1
			: ($r eq $compare
				? 0
				: 1);
		print "COMPARE '$r' vs '$compare' = $cr\n" if $debug;
	}
	my $dr = $r;
	$dr =~ s/\n/\\n/g;
	my $dcompare = $compare;
	$dcompare =~ s/\n/\\n/g;
	if ($t->{repeat} && $cr == -1 && ! $iput->eof) {
		print STDERR "waiting for more input:\n\t<$dr>\n\t<$dcompare>\n"
			if $debug;
		# we'll wait for more input
		print "# wait for more input\n";
		return;
	}
	my $desc = $t->{desc};
	if ($cr == 0) {
		T::okay(1, $desc);
	} else {
		T::okay(0, "test $desc failed: $cr: <$dr> <$dcompare>");
	}
	print "# done\n";
	print "##############################################################################\n" if $debug;
	$T::last_receive++;
	if (@tests > 1) {
		T::startup;
	} else {
		exit 0;
	}
	alarm($slowest);
}

sub ie_eof
{
	print "# eof\n";
}

1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)