summaryrefslogtreecommitdiffstats
path: root/t/extra-pty.t
blob: 8393f4f7bfedd0412f529ba3ee10e70fa69602e4 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
#!/usr/bin/env perl
use strict;
use warnings;
use Test::More;

use File::Temp 'tempdir';
use File::Spec;
use IO::Pty::Easy;
use IO::Select;
use POSIX ();

my $dir = tempdir(CLEANUP => 1);
my $readp = File::Spec->catfile($dir, 'read');
my $writep = File::Spec->catfile($dir, 'write');
POSIX::mkfifo($readp, 0700)
    or die "mkfifo failed: $!";
POSIX::mkfifo($writep, 0700)
    or die "mkfifo failed: $!";

my $script = <<SCRIPT;
use strict;
use warnings;
use Term::Filter::Callback;
open my \$readfh, '<', '$readp'
    or die "can't open pipe (child): \$!";
open my \$writefh, '>', '$writep'
    or die "can't open pipe (child): \$!";
my \$term = Term::Filter::Callback->new(
    callbacks => {
        setup => sub {
            my (\$t) = \@_;
            \$t->add_input_handle(\$readfh);
        },
        read => sub {
            my (\$t, \$fh) = \@_;
            if (\$fh == \$readfh) {
                my \$buf;
                sysread(\$fh, \$buf, 4096);
                if (defined(\$buf) && length(\$buf)) {
                    print "read from pipe: \$buf\\n";
                }
                else {
                    print "pipe error (read)!\\n";
                    \$t->remove_input_handle(\$readfh);
                }
            }
        },
        read_error => sub {
            my (\$t, \$fh) = \@_;
            if (\$fh == \$readfh) {
                print "pipe error (exception)!\\n";
                \$t->remove_input_handle(\$readfh);
            }
        },
        munge_output => sub {
            my (\$t, \$buf) = \@_;
            syswrite(\$writefh, "read from term: \$buf");
            \$buf;
        },
    }
);
\$term->run(\$^X, '-ple', q[last if /^\$/]);
print "done\\n";
SCRIPT

my $crlf = "\x0d\x0a";

# just in case
alarm 60;

{
    my $pty = IO::Pty::Easy->new(handle_pty_size => 0);
    $pty->spawn($^X, (map {; '-I', $_ } @INC), '-e', $script);

    open my $readfh, '>', $readp
        or die "can't open pipe (parent): $!";
    open my $writefh, '<', $writep
        or die "can't open pipe (parent): $!";

    $pty->write("foo\n");

    is($pty->read(undef, 5), "foo$crlf");
    is($pty->read(undef, 5), "foo$crlf");

    {
        my $buf;
        sysread($writefh, $buf, 21);
        is($buf, "read from term: foo$crlf");
        sysread($writefh, $buf, 21);
        # note that this could either happen as a second write, or as part
        # of the first write (in which case, this read finishes reading
        # the rest of the data that was sent previously)
        like($buf, qr/^(?:read from term: )?foo\Q$crlf\E$/);
    }

    syswrite($readfh, "bar");

    is($pty->read(undef, 21), "read from pipe: bar\n");

    close($readfh);
    close($writefh);

    is($pty->read(undef, 19), "pipe error (read)!\n");
}

done_testing;