File: test.pl

package info (click to toggle)
libio-pty-perl 1:1.08-1.1
  • links: PTS
  • area: main
  • in suites: bullseye, bullseye-proposed-updates, buster, sid, stretch
  • size: 120 kB
  • ctags: 16
  • sloc: perl: 493; makefile: 39
file content (242 lines) | stat: -rw-r--r-- 6,587 bytes parent folder | download | duplicates (3)
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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242

use strict;
$^W = 1; # enable warnings
my ($testnr, $maxnr, $oknr);

BEGIN { $testnr = 1; $maxnr = 4; print "$testnr..$maxnr\n"; }
sub ok ($) {
  if ($_[0]) {
    print "ok ", $testnr++, "\n";
    $oknr++;
  } else {
    print "not ok ", $testnr++, "\n";
    my ($package, $filename, $line) = caller;
    print "# Test failed at $filename line $line.\n";
  }
}

use blib;
use IO::Pty;
use IO::Tty qw(TIOCSCTTY TIOCNOTTY TCSETCTTY);
$IO::Tty::DEBUG = 1;
use POSIX ();

my $Perl = $^X;

print "Configuration: $IO::Tty::CONFIG\n";
print "Checking for appropriate ioctls: ";
print "TIOCNOTTY " if defined TIOCNOTTY;
print "TIOCSCTTY " if defined TIOCSCTTY;
print "TCSETCTTY " if defined TCSETCTTY;
print "\n";

print "Checking that returned fd's don't clash with stdin/out/err...\n";
{
  my $pid = fork();
  die "Cannot fork" if not defined $pid;
  unless ($pid) {
    # child closes stdin/out and reports test result via exit status
    sleep 0;
    close STDIN;
    close STDOUT;
    my $master = new IO::Pty;
    my $slave = $master->slave();
    if ($master->fileno < 3 or $slave->fileno < 3) {
      die 'ERROR: masterfd='.$master->fileno.', slavefd='.$slave->fileno."\n";
    }
    exit(0);
  }

  die "Wrong child" if wait != $pid;
  print "child exit=$?\n" if $?;
  ok($? == 0);
}


print "Checking if child gets pty as controlling terminal...\n";
{
  my $master = new IO::Pty;

  pipe(FROM_CHILD, TO_PARENT)
    or die "Cannot create pipe: $!";
  my $pid = fork();
  die "Cannot fork" if not defined $pid;
  unless ($pid) {
    # child
    sleep(1);
    $master->make_slave_controlling_terminal();
    my $slave = $master->slave();
    close $master;
    close FROM_CHILD;
    print TO_PARENT "\n";
    close TO_PARENT;
    open(TTY, "+>/dev/tty") or die "no controlling terminal";
    autoflush TTY 1;
    print TTY "gimme on /dev/tty: ";
    my $s = <TTY>;
    chomp $s;
    print $slave "back on STDOUT: \U$s\n";
    close TTY; close $slave;
    sleep(1);
    exit 0;
  }

  close TO_PARENT;
  $master->close_slave();
  my $dummy;
  my $stat = sysread(FROM_CHILD, $dummy, 1);
  die "Cannot sync with child: $!" if not $stat;
  close FROM_CHILD;

  my ($s, $chunk);
  $SIG{ALRM} = sub { ok(0); die "Timeout ($s)"; };
  alarm(10);

  sysread($master, $s, 100) or die "sysread() failed: $!";
  ok($s =~ m/gimme.*:/);

  print $master "seems OK!\n";

  # collect all responses
  my $ret;
  while ($ret = sysread($master, $chunk, 100)) {
    $s .= $chunk;
  }
  print $s;
  ok($s =~ m/back on STDOUT: SEEMS OK!/);
  warn <<"_EOT_" unless defined $ret;

WARNING: when the client closes the slave pty, the master gets an error
(undef return value and \$! eq "$!")
instead of EOF (0 return value).  Please be sure to handle this 
in your application (Expect already does).

_EOT_

  alarm(0);
  kill TERM => $pid;
}

# now for the echoback tests
print <<_EOT_;
Checking basic functionality and how your ptys handle large strings...
  This test may hang on certain systems, even though it is protected
  by alarm().  If the counter stops, try Ctrl-C, the test should continue.

_EOT_

{
  my $randstring = "fakjdf ijj845jtirg\r8e 4jy8 gfuoyhj\agt8h\0x00 gues98\0xFF 45th guoa\beh gt98hae 45t8u ha8rhg ue4ht 8eh tgo8he4 t8 gfj aoingf9a8hgf uain dgkjadshft+uehgf =us�and9�87vgh afugh 8*h 98H 978H 7HG zG 86G (&g (O/g &(GF(/EG F78G F87SG F(/G F(/a sldjkf ha\@j<\rksdhf jk>~|ahsd fjkh asdHJKGDSG TRJKSGO  JGDSFJDFHJGSDK1%&FJGSDGFSH\0xADJ�DGFljkhf lakjs(dh fkjahs djfk hasjkdh fjklahs dfkjhdjkf ha�jksdh fkjah sdjf)\$/�&k has���jkdh fkjhuerhtuwe htui eruth ZI AHD BIZA Di7GH )/g98 9 97 86tr(& TA&(t 6t &T 75r 5\$R%/4r76 5&/% R79 5 )/&";
  my $master = new IO::Pty;
  print "isatty(\$master): ", POSIX::isatty($master)? "YES\n": "NO\n";
  if (POSIX::isatty($master)) {
    $master->set_raw() or
      warn "warning: \$master->set_raw(): $!";
  }

  pipe(FROM_CHILD, TO_PARENT)
    or die "Cannot create pipe: $!";
  my $pid = fork();
  die "Cannot fork" if not defined $pid;
  unless ($pid) {
    # child sends back everything inverted
    my $c;
    my $slave = $master->slave();
    close $master;
    print "isatty(\$slave): ", POSIX::isatty($slave)? "YES\n": "NO\n";
    $slave->set_raw() or
      warn "warning: \$slave->set_raw(): $!";
    close FROM_CHILD;
    print TO_PARENT "\n";
    close TO_PARENT;
    my $cnt = 0;
    my $linecnt = 0;
    while(1) { 
      my $ret = sysread($slave, $c, 1);
      warn "sysread(): $!" unless defined $ret;
      die "Slave got EOF at line $linecnt, byte $cnt.\n" unless $ret;
      $cnt++;
      if ($c eq "\n") {
	$linecnt++;
	$cnt = 0;
      } else {
	$c = ~$c;
      }
      $ret = syswrite($slave, $c, 1);
      warn "syswrite(): $!" unless defined $ret;
    }
  }
  close TO_PARENT;
  $master->close_slave();
  my $dummy;
  my $stat = sysread(FROM_CHILD, $dummy, 1);
  die "Cannot sync with child: $!" if not $stat;
  close FROM_CHILD;

  print "Child PID = $pid\n";

  # parent sends down some strings and expects to get them back inverted
  my $maxlen = 0;
  foreach my $len (1 .. length($randstring)) {
    print STDERR "$len\r";
    my $s = substr($randstring, 0, $len);
    my $buf;
    my $ret = "";
    my $inv = ~$s."\n";
    $s .= "\n";
    my $sendbuf = $s;
    $SIG{ALRM} = $SIG{TERM} = $SIG{INT} = sub {die "TIMEOUT(SIG".shift().")";};
    eval {
      alarm(15);
      while ($sendbuf or length($ret) < length($s)) {
	if ($sendbuf) {
	  my $sent = syswrite($master, $sendbuf, length($sendbuf));
	  die "syswrite() failed: $!" unless defined $sent;
	  $sendbuf = substr($sendbuf, $sent);
	}
	$buf = "";
	my $read = sysread($master, $buf, length($s));
	die "Couldn't read from child: $!" if not $read;
	$ret .= $buf;
      }
      alarm(0);
    };
    if ($@) {
      warn $@;
      last;
    }

    if ($ret eq $inv) {
      $maxlen = $len;
    } else {
      if (length($s) == length($ret)) {
	warn "Got back a wrong string with the right length ".length($ret)."\n";
      } else {
	warn "Got back a wrong string with the wrong length ".length($ret).
	  " (instead of ".length($s).")\n";
      }
      ok(0);
      last;
    }
  }
  $SIG{ALRM} = $SIG{TERM} = $SIG{INT} = 'DEFAULT';
  if ($maxlen < length($randstring)) {
    warn <<"_EOT_";

WARNING: your raw ptys block when sending more than $maxlen bytes!
This may cause problems under special scenarios, but you probably
will never encounter that problem.

_EOT_
  } else {
    warn "Good, your raw ptys can handle at least $maxlen bytes at once.\n";
  }
  ok($maxlen >= 200);
  close($master);
  sleep(1);
  kill TERM => $pid;
}

print "Passed $oknr of $maxnr tests.\n";