Commit | Line | Data |
11aea360 |
1 | ## chat.pl: chat with a server |
2 | ## V2.01.alpha.7 91/06/16 |
3 | ## Randal L. Schwartz |
4 | |
5 | package chat; |
6 | |
7 | $sockaddr = 'S n a4 x8'; |
8 | chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4]; |
9 | $thisproc = pack($sockaddr, 2, 0, $thisaddr); |
10 | |
11 | # *S = symbol for current I/O, gets assigned *chatsymbol.... |
12 | $next = "chatsymbol000000"; # next one |
13 | $nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++ |
14 | |
15 | |
16 | ## $handle = &chat'open_port("server.address",$port_number); |
17 | ## opens a named or numbered TCP server |
18 | |
19 | sub open_port { ## public |
20 | local($server, $port) = @_; |
21 | |
22 | local($serveraddr,$serverproc); |
23 | |
24 | *S = ++$next; |
25 | if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) { |
26 | $serveraddr = pack('C4', $1, $2, $3, $4); |
27 | } else { |
28 | local(@x) = gethostbyname($server); |
29 | return undef unless @x; |
30 | $serveraddr = $x[4]; |
31 | } |
32 | $serverproc = pack($sockaddr, 2, $port, $serveraddr); |
33 | unless (socket(S, 2, 1, 6)) { |
34 | # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp' |
35 | # but who the heck would change these anyway? (:-) |
36 | ($!) = ($!, close(S)); # close S while saving $! |
37 | return undef; |
38 | } |
39 | unless (bind(S, $thisproc)) { |
40 | ($!) = ($!, close(S)); # close S while saving $! |
41 | return undef; |
42 | } |
43 | unless (connect(S, $serverproc)) { |
44 | ($!) = ($!, close(S)); # close S while saving $! |
45 | return undef; |
46 | } |
47 | select((select(S), $| = 1)[0]); |
48 | $next; # return symbol for switcharound |
49 | } |
50 | |
51 | ## ($host, $port, $handle) = &chat'open_listen([$port_number]); |
52 | ## opens a TCP port on the current machine, ready to be listened to |
53 | ## if $port_number is absent or zero, pick a default port number |
54 | ## process must be uid 0 to listen to a low port number |
55 | |
56 | sub open_listen { ## public |
57 | |
58 | *S = ++$next; |
59 | local($thisport) = shift || 0; |
60 | local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr); |
61 | local(*NS) = "__" . time; |
62 | unless (socket(NS, 2, 1, 6)) { |
63 | # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp' |
64 | # but who the heck would change these anyway? (:-) |
65 | ($!) = ($!, close(NS)); |
66 | return undef; |
67 | } |
68 | unless (bind(NS, $thisproc_local)) { |
69 | ($!) = ($!, close(NS)); |
70 | return undef; |
71 | } |
72 | unless (listen(NS, 1)) { |
73 | ($!) = ($!, close(NS)); |
74 | return undef; |
75 | } |
76 | select((select(NS), $| = 1)[0]); |
77 | local($family, $port, @myaddr) = |
78 | unpack("S n C C C C x8", getsockname(NS)); |
79 | $S{"needs_accept"} = *NS; # so expect will open it |
80 | (@myaddr, $port, $next); # returning this |
81 | } |
82 | |
83 | ## $handle = &chat'open_proc("command","arg1","arg2",...); |
84 | ## opens a /bin/sh on a pseudo-tty |
85 | |
86 | sub open_proc { ## public |
87 | local(@cmd) = @_; |
88 | |
89 | *S = ++$next; |
90 | local(*TTY) = "__TTY" . time; |
91 | local($pty,$tty) = &_getpty(S,TTY); |
92 | die "Cannot find a new pty" unless defined $pty; |
93 | local($pid) = fork; |
94 | die "Cannot fork: $!" unless defined $pid; |
95 | unless ($pid) { |
96 | close STDIN; close STDOUT; close STDERR; |
97 | setpgrp(0,$$); |
98 | if (open(DEVTTY, "/dev/tty")) { |
99 | ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY |
100 | close DEVTTY; |
101 | } |
102 | open(STDIN,"<&TTY"); |
103 | open(STDOUT,">&TTY"); |
104 | open(STDERR,">&STDOUT"); |
105 | die "Oops" unless fileno(STDERR) == 2; # sanity |
106 | close(S); |
107 | exec @cmd; |
108 | die "Cannot exec @cmd: $!"; |
109 | } |
110 | close(TTY); |
68decaef |
111 | $PID{$next} = $pid; |
11aea360 |
112 | $next; # return symbol for switcharound |
113 | } |
114 | |
115 | # $S is the read-ahead buffer |
116 | |
117 | ## $return = &chat'expect([$handle,] $timeout_time, |
118 | ## $pat1, $body1, $pat2, $body2, ... ) |
119 | ## $handle is from previous &chat'open_*(). |
120 | ## $timeout_time is the time (either relative to the current time, or |
121 | ## absolute, ala time(2)) at which a timeout event occurs. |
122 | ## $pat1, $pat2, and so on are regexs which are matched against the input |
123 | ## stream. If a match is found, the entire matched string is consumed, |
124 | ## and the corresponding body eval string is evaled. |
125 | ## |
126 | ## Each pat is a regular-expression (probably enclosed in single-quotes |
127 | ## in the invocation). ^ and $ will work, respecting the current value of $*. |
128 | ## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded. |
129 | ## If pat is 'EOF', the body is executed if the process exits before |
130 | ## the other patterns are seen. |
131 | ## |
132 | ## Pats are scanned in the order given, so later pats can contain |
133 | ## general defaults that won't be examined unless the earlier pats |
134 | ## have failed. |
135 | ## |
136 | ## The result of eval'ing body is returned as the result of |
137 | ## the invocation. Recursive invocations are not thought |
138 | ## through, and may work only accidentally. :-) |
139 | ## |
140 | ## undef is returned if either a timeout or an eof occurs and no |
141 | ## corresponding body has been defined. |
142 | ## I/O errors of any sort are treated as eof. |
143 | |
144 | $nextsubname = "expectloop000000"; # used for subroutines |
145 | |
146 | sub expect { ## public |
147 | if ($_[0] =~ /$nextpat/) { |
148 | *S = shift; |
149 | } |
150 | local($endtime) = shift; |
151 | |
152 | local($timeout,$eof) = (1,1); |
153 | local($caller) = caller; |
154 | local($rmask, $nfound, $timeleft, $thisbuf); |
155 | local($cases, $pattern, $action, $subname); |
156 | $endtime += time if $endtime < 600_000_000; |
157 | |
158 | if (defined $S{"needs_accept"}) { # is it a listen socket? |
159 | local(*NS) = $S{"needs_accept"}; |
160 | delete $S{"needs_accept"}; |
161 | $S{"needs_close"} = *NS; |
162 | unless(accept(S,NS)) { |
163 | ($!) = ($!, close(S), close(NS)); |
164 | return undef; |
165 | } |
166 | select((select(S), $| = 1)[0]); |
167 | } |
168 | |
169 | # now see whether we need to create a new sub: |
170 | |
171 | unless ($subname = $expect_subname{$caller,@_}) { |
172 | # nope. make a new one: |
173 | $expect_subname{$caller,@_} = $subname = $nextsubname++; |
174 | |
175 | $cases .= <<"EDQ"; # header is funny to make everything elsif's |
176 | sub $subname { |
177 | LOOP: { |
178 | if (0) { ; } |
179 | EDQ |
180 | while (@_) { |
181 | ($pattern,$action) = splice(@_,0,2); |
182 | if ($pattern =~ /^eof$/i) { |
183 | $cases .= <<"EDQ"; |
184 | elsif (\$eof) { |
185 | package $caller; |
186 | $action; |
187 | } |
188 | EDQ |
189 | $eof = 0; |
190 | } elsif ($pattern =~ /^timeout$/i) { |
191 | $cases .= <<"EDQ"; |
192 | elsif (\$timeout) { |
193 | package $caller; |
194 | $action; |
195 | } |
196 | EDQ |
197 | $timeout = 0; |
198 | } else { |
199 | $pattern =~ s#/#\\/#g; |
200 | $cases .= <<"EDQ"; |
201 | elsif (\$S =~ /$pattern/) { |
202 | \$S = \$'; |
203 | package $caller; |
204 | $action; |
205 | } |
206 | EDQ |
207 | } |
208 | } |
209 | $cases .= <<"EDQ" if $eof; |
210 | elsif (\$eof) { |
211 | undef; |
212 | } |
213 | EDQ |
214 | $cases .= <<"EDQ" if $timeout; |
215 | elsif (\$timeout) { |
216 | undef; |
217 | } |
218 | EDQ |
219 | $cases .= <<'ESQ'; |
220 | else { |
221 | $rmask = ""; |
222 | vec($rmask,fileno(S),1) = 1; |
223 | ($nfound, $rmask) = |
224 | select($rmask, undef, undef, $endtime - time); |
225 | if ($nfound) { |
226 | $nread = sysread(S, $thisbuf, 1024); |
227 | if ($nread > 0) { |
228 | $S .= $thisbuf; |
229 | } else { |
230 | $eof++, redo LOOP; # any error is also eof |
231 | } |
232 | } else { |
233 | $timeout++, redo LOOP; # timeout |
234 | } |
235 | redo LOOP; |
236 | } |
237 | } |
238 | } |
239 | ESQ |
240 | eval $cases; die "$cases:\n$@" if $@; |
241 | } |
242 | $eof = $timeout = 0; |
243 | do $subname(); |
244 | } |
245 | |
246 | ## &chat'print([$handle,] @data) |
247 | ## $handle is from previous &chat'open(). |
248 | ## like print $handle @data |
249 | |
250 | sub print { ## public |
251 | if ($_[0] =~ /$nextpat/) { |
252 | *S = shift; |
253 | } |
254 | print S @_; |
255 | } |
256 | |
257 | ## &chat'close([$handle,]) |
258 | ## $handle is from previous &chat'open(). |
259 | ## like close $handle |
260 | |
261 | sub close { ## public |
68decaef |
262 | local($pid); |
11aea360 |
263 | if ($_[0] =~ /$nextpat/) { |
68decaef |
264 | $pid = $PID{$_[0]}; |
11aea360 |
265 | *S = shift; |
68decaef |
266 | } else { |
267 | $pid = $PID{$next}; |
11aea360 |
268 | } |
269 | close(S); |
68decaef |
270 | waitpid($pid,0); |
11aea360 |
271 | if (defined $S{"needs_close"}) { # is it a listen socket? |
272 | local(*NS) = $S{"needs_close"}; |
273 | delete $S{"needs_close"}; |
274 | close(NS); |
275 | } |
276 | } |
277 | |
278 | ## @ready_handles = &chat'select($timeout, @handles) |
279 | ## select()'s the handles with a timeout value of $timeout seconds. |
280 | ## Returns an array of handles that are ready for I/O. |
281 | ## Both user handles and chat handles are supported (but beware of |
282 | ## stdio's buffering for user handles). |
283 | |
284 | sub select { ## public |
285 | local($timeout) = shift; |
286 | local(@handles) = @_; |
287 | local(%handlename) = (); |
288 | local(%ready) = (); |
289 | local($caller) = caller; |
290 | local($rmask) = ""; |
291 | for (@handles) { |
292 | if (/$nextpat/o) { # one of ours... see if ready |
293 | local(*SYM) = $_; |
294 | if (length($SYM)) { |
295 | $timeout = 0; # we have a winner |
296 | $ready{$_}++; |
297 | } |
298 | $handlename{fileno($_)} = $_; |
299 | } else { |
300 | $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_; |
301 | } |
302 | } |
303 | for (sort keys %handlename) { |
304 | vec($rmask, $_, 1) = 1; |
305 | } |
306 | select($rmask, undef, undef, $timeout); |
307 | for (sort keys %handlename) { |
308 | $ready{$handlename{$_}}++ if vec($rmask,$_,1); |
309 | } |
310 | sort keys %ready; |
311 | } |
312 | |
313 | # ($pty,$tty) = $chat'_getpty(PTY,TTY): |
314 | # internal procedure to get the next available pty. |
315 | # opens pty on handle PTY, and matching tty on handle TTY. |
316 | # returns undef if can't find a pty. |
317 | |
318 | sub _getpty { ## private |
319 | local($_PTY,$_TTY) = @_; |
320 | $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; |
321 | $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; |
322 | local($pty,$tty); |
323 | for $bank (112..127) { |
324 | next unless -e sprintf("/dev/pty%c0", $bank); |
325 | for $unit (48..57) { |
326 | $pty = sprintf("/dev/pty%c%c", $bank, $unit); |
327 | open($_PTY,"+>$pty") || next; |
328 | select((select($_PTY), $| = 1)[0]); |
329 | ($tty = $pty) =~ s/pty/tty/; |
330 | open($_TTY,"+>$tty") || next; |
331 | select((select($_TTY), $| = 1)[0]); |
332 | system "stty nl>$tty"; |
333 | return ($pty,$tty); |
334 | } |
335 | } |
336 | undef; |
337 | } |
338 | |
339 | 1; |