-
Notifications
You must be signed in to change notification settings - Fork 557
/
chat2.pl
333 lines (301 loc) · 8.38 KB
/
chat2.pl
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
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
## chat.pl: chat with a server
## V2.01.alpha.7 91/06/16
## Randal L. Schwartz
package chat;
$sockaddr = 'S n a4 x8';
chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
$thisproc = pack($sockaddr, 2, 0, $thisaddr);
# *S = symbol for current I/O, gets assigned *chatsymbol....
$next = "chatsymbol000000"; # next one
$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
## $handle = &chat'open_port("server.address",$port_number);
## opens a named or numbered TCP server
sub open_port { ## public
local($server, $port) = @_;
local($serveraddr,$serverproc);
*S = ++$next;
if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
$serveraddr = pack('C4', $1, $2, $3, $4);
} else {
local(@x) = gethostbyname($server);
return undef unless @x;
$serveraddr = $x[4];
}
$serverproc = pack($sockaddr, 2, $port, $serveraddr);
unless (socket(S, 2, 1, 6)) {
# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
# but who the heck would change these anyway? (:-)
($!) = ($!, close(S)); # close S while saving $!
return undef;
}
unless (bind(S, $thisproc)) {
($!) = ($!, close(S)); # close S while saving $!
return undef;
}
unless (connect(S, $serverproc)) {
($!) = ($!, close(S)); # close S while saving $!
return undef;
}
select((select(S), $| = 1)[0]);
$next; # return symbol for switcharound
}
## ($host, $port, $handle) = &chat'open_listen([$port_number]);
## opens a TCP port on the current machine, ready to be listened to
## if $port_number is absent or zero, pick a default port number
## process must be uid 0 to listen to a low port number
sub open_listen { ## public
*S = ++$next;
local($thisport) = shift || 0;
local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
local(*NS) = "__" . time;
unless (socket(NS, 2, 1, 6)) {
# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
# but who the heck would change these anyway? (:-)
($!) = ($!, close(NS));
return undef;
}
unless (bind(NS, $thisproc_local)) {
($!) = ($!, close(NS));
return undef;
}
unless (listen(NS, 1)) {
($!) = ($!, close(NS));
return undef;
}
select((select(NS), $| = 1)[0]);
local($family, $port, @myaddr) =
unpack("S n C C C C x8", getsockname(NS));
$S{"needs_accept"} = *NS; # so expect will open it
(@myaddr, $port, $next); # returning this
}
## $handle = &chat'open_proc("command","arg1","arg2",...);
## opens a /bin/sh on a pseudo-tty
sub open_proc { ## public
local(@cmd) = @_;
*S = ++$next;
local(*TTY) = "__TTY" . time;
local($pty,$tty) = &_getpty(S,TTY);
die "Cannot find a new pty" unless defined $pty;
local($pid) = fork;
die "Cannot fork: $!" unless defined $pid;
unless ($pid) {
close STDIN; close STDOUT; close STDERR;
setpgrp(0,$$);
if (open(DEVTTY, "/dev/tty")) {
ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
close DEVTTY;
}
open(STDIN,"<&TTY");
open(STDOUT,">&TTY");
open(STDERR,">&STDOUT");
die "Oops" unless fileno(STDERR) == 2; # sanity
close(S);
exec @cmd;
die "Cannot exec @cmd: $!";
}
close(TTY);
$next; # return symbol for switcharound
}
# $S is the read-ahead buffer
## $return = &chat'expect([$handle,] $timeout_time,
## $pat1, $body1, $pat2, $body2, ... )
## $handle is from previous &chat'open_*().
## $timeout_time is the time (either relative to the current time, or
## absolute, ala time(2)) at which a timeout event occurs.
## $pat1, $pat2, and so on are regexs which are matched against the input
## stream. If a match is found, the entire matched string is consumed,
## and the corresponding body eval string is evaled.
##
## Each pat is a regular-expression (probably enclosed in single-quotes
## in the invocation). ^ and $ will work, respecting the current value of $*.
## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
## If pat is 'EOF', the body is executed if the process exits before
## the other patterns are seen.
##
## Pats are scanned in the order given, so later pats can contain
## general defaults that won't be examined unless the earlier pats
## have failed.
##
## The result of eval'ing body is returned as the result of
## the invocation. Recursive invocations are not thought
## through, and may work only accidentally. :-)
##
## undef is returned if either a timeout or an eof occurs and no
## corresponding body has been defined.
## I/O errors of any sort are treated as eof.
$nextsubname = "expectloop000000"; # used for subroutines
sub expect { ## public
if ($_[0] =~ /$nextpat/) {
*S = shift;
}
local($endtime) = shift;
local($timeout,$eof) = (1,1);
local($caller) = caller;
local($rmask, $nfound, $timeleft, $thisbuf);
local($cases, $pattern, $action, $subname);
$endtime += time if $endtime < 600_000_000;
if (defined $S{"needs_accept"}) { # is it a listen socket?
local(*NS) = $S{"needs_accept"};
delete $S{"needs_accept"};
$S{"needs_close"} = *NS;
unless(accept(S,NS)) {
($!) = ($!, close(S), close(NS));
return undef;
}
select((select(S), $| = 1)[0]);
}
# now see whether we need to create a new sub:
unless ($subname = $expect_subname{$caller,@_}) {
# nope. make a new one:
$expect_subname{$caller,@_} = $subname = $nextsubname++;
$cases .= <<"EDQ"; # header is funny to make everything elsif's
sub $subname {
LOOP: {
if (0) { ; }
EDQ
while (@_) {
($pattern,$action) = splice(@_,0,2);
if ($pattern =~ /^eof$/i) {
$cases .= <<"EDQ";
elsif (\$eof) {
package $caller;
$action;
}
EDQ
$eof = 0;
} elsif ($pattern =~ /^timeout$/i) {
$cases .= <<"EDQ";
elsif (\$timeout) {
package $caller;
$action;
}
EDQ
$timeout = 0;
} else {
$pattern =~ s#/#\\/#g;
$cases .= <<"EDQ";
elsif (\$S =~ /$pattern/) {
\$S = \$';
package $caller;
$action;
}
EDQ
}
}
$cases .= <<"EDQ" if $eof;
elsif (\$eof) {
undef;
}
EDQ
$cases .= <<"EDQ" if $timeout;
elsif (\$timeout) {
undef;
}
EDQ
$cases .= <<'ESQ';
else {
$rmask = "";
vec($rmask,fileno(S),1) = 1;
($nfound, $rmask) =
select($rmask, undef, undef, $endtime - time);
if ($nfound) {
$nread = sysread(S, $thisbuf, 1024);
if ($nread > 0) {
$S .= $thisbuf;
} else {
$eof++, redo LOOP; # any error is also eof
}
} else {
$timeout++, redo LOOP; # timeout
}
redo LOOP;
}
}
}
ESQ
eval $cases; die "$cases:\n$@" if $@;
}
$eof = $timeout = 0;
do $subname();
}
## &chat'print([$handle,] @data)
## $handle is from previous &chat'open().
## like print $handle @data
sub print { ## public
if ($_[0] =~ /$nextpat/) {
*S = shift;
}
print S @_;
}
## &chat'close([$handle,])
## $handle is from previous &chat'open().
## like close $handle
sub close { ## public
if ($_[0] =~ /$nextpat/) {
*S = shift;
}
close(S);
if (defined $S{"needs_close"}) { # is it a listen socket?
local(*NS) = $S{"needs_close"};
delete $S{"needs_close"};
close(NS);
}
}
## @ready_handles = &chat'select($timeout, @handles)
## select()'s the handles with a timeout value of $timeout seconds.
## Returns an array of handles that are ready for I/O.
## Both user handles and chat handles are supported (but beware of
## stdio's buffering for user handles).
sub select { ## public
local($timeout) = shift;
local(@handles) = @_;
local(%handlename) = ();
local(%ready) = ();
local($caller) = caller;
local($rmask) = "";
for (@handles) {
if (/$nextpat/o) { # one of ours... see if ready
local(*SYM) = $_;
if (length($SYM)) {
$timeout = 0; # we have a winner
$ready{$_}++;
}
$handlename{fileno($_)} = $_;
} else {
$handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
}
}
for (sort keys %handlename) {
vec($rmask, $_, 1) = 1;
}
select($rmask, undef, undef, $timeout);
for (sort keys %handlename) {
$ready{$handlename{$_}}++ if vec($rmask,$_,1);
}
sort keys %ready;
}
# ($pty,$tty) = $chat'_getpty(PTY,TTY):
# internal procedure to get the next available pty.
# opens pty on handle PTY, and matching tty on handle TTY.
# returns undef if can't find a pty.
sub _getpty { ## private
local($_PTY,$_TTY) = @_;
$_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
$_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
local($pty,$tty);
for $bank (112..127) {
next unless -e sprintf("/dev/pty%c0", $bank);
for $unit (48..57) {
$pty = sprintf("/dev/pty%c%c", $bank, $unit);
open($_PTY,"+>$pty") || next;
select((select($_PTY), $| = 1)[0]);
($tty = $pty) =~ s/pty/tty/;
open($_TTY,"+>$tty") || next;
select((select($_TTY), $| = 1)[0]);
system "stty nl>$tty";
return ($pty,$tty);
}
}
undef;
}
1;