Initial bulk commit for "Git on MSys"
[msysgit/historical-msysgit.git] / lib / perl5 / 5.6.1 / chat2.pl
blob504fa7efd7a48d5458f4ca487d3dea3ad761385e
1 # chat.pl: chat with a server
3 # This library is no longer being maintained, and is included for backward
4 # compatibility with Perl 4 programs which may require it.
6 # In particular, this should not be used as an example of modern Perl
7 # programming techniques.
9 # Suggested alternative: Socket
11 # Based on: V2.01.alpha.7 91/06/16
12 # Randal L. Schwartz (was <merlyn@stonehenge.com>)
13 # multihome additions by A.Macpherson@bnr.co.uk
14 # allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU>
16 package chat;
18 require 'sys/socket.ph';
20 if( defined( &main'PF_INET ) ){
21 $pf_inet = &main'PF_INET;
22 $sock_stream = &main'SOCK_STREAM;
23 local($name, $aliases, $proto) = getprotobyname( 'tcp' );
24 $tcp_proto = $proto;
26 else {
27 # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
28 # but who the heck would change these anyway? (:-)
29 $pf_inet = 2;
30 $sock_stream = 1;
31 $tcp_proto = 6;
35 $sockaddr = 'S n a4 x8';
36 chop($thishost = `hostname`);
38 # *S = symbol for current I/O, gets assigned *chatsymbol....
39 $next = "chatsymbol000000"; # next one
40 $nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
43 ## $handle = &chat'open_port("server.address",$port_number);
44 ## opens a named or numbered TCP server
46 sub open_port { ## public
47 local($server, $port) = @_;
49 local($serveraddr,$serverproc);
51 # We may be multi-homed, start with 0, fixup once connexion is made
52 $thisaddr = "\0\0\0\0" ;
53 $thisproc = pack($sockaddr, 2, 0, $thisaddr);
55 *S = ++$next;
56 if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
57 $serveraddr = pack('C4', $1, $2, $3, $4);
58 } else {
59 local(@x) = gethostbyname($server);
60 return undef unless @x;
61 $serveraddr = $x[4];
63 $serverproc = pack($sockaddr, 2, $port, $serveraddr);
64 unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) {
65 ($!) = ($!, close(S)); # close S while saving $!
66 return undef;
68 unless (bind(S, $thisproc)) {
69 ($!) = ($!, close(S)); # close S while saving $!
70 return undef;
72 unless (connect(S, $serverproc)) {
73 ($!) = ($!, close(S)); # close S while saving $!
74 return undef;
76 # We opened with the local address set to ANY, at this stage we know
77 # which interface we are using. This is critical if our machine is
78 # multi-homed, with IP forwarding off, so fix-up.
79 local($fam,$lport);
80 ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S));
81 $thisproc = pack($sockaddr, 2, 0, $thisaddr);
82 # end of post-connect fixup
83 select((select(S), $| = 1)[0]);
84 $next; # return symbol for switcharound
87 ## ($host, $port, $handle) = &chat'open_listen([$port_number]);
88 ## opens a TCP port on the current machine, ready to be listened to
89 ## if $port_number is absent or zero, pick a default port number
90 ## process must be uid 0 to listen to a low port number
92 sub open_listen { ## public
94 *S = ++$next;
95 local($thisport) = shift || 0;
96 local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
97 local(*NS) = "__" . time;
98 unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) {
99 ($!) = ($!, close(NS));
100 return undef;
102 unless (bind(NS, $thisproc_local)) {
103 ($!) = ($!, close(NS));
104 return undef;
106 unless (listen(NS, 1)) {
107 ($!) = ($!, close(NS));
108 return undef;
110 select((select(NS), $| = 1)[0]);
111 local($family, $port, @myaddr) =
112 unpack("S n C C C C x8", getsockname(NS));
113 $S{"needs_accept"} = *NS; # so expect will open it
114 (@myaddr, $port, $next); # returning this
117 ## $handle = &chat'open_proc("command","arg1","arg2",...);
118 ## opens a /bin/sh on a pseudo-tty
120 sub open_proc { ## public
121 local(@cmd) = @_;
123 *S = ++$next;
124 local(*TTY) = "__TTY" . time;
125 local($pty,$tty) = &_getpty(S,TTY);
126 die "Cannot find a new pty" unless defined $pty;
127 $pid = fork;
128 die "Cannot fork: $!" unless defined $pid;
129 unless ($pid) {
130 close STDIN; close STDOUT; close STDERR;
131 setpgrp(0,$$);
132 if (open(DEVTTY, "/dev/tty")) {
133 ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
134 close DEVTTY;
136 open(STDIN,"<&TTY");
137 open(STDOUT,">&TTY");
138 open(STDERR,">&STDOUT");
139 die "Oops" unless fileno(STDERR) == 2; # sanity
140 close(S);
141 exec @cmd;
142 die "Cannot exec @cmd: $!";
144 close(TTY);
145 $next; # return symbol for switcharound
148 # $S is the read-ahead buffer
150 ## $return = &chat'expect([$handle,] $timeout_time,
151 ## $pat1, $body1, $pat2, $body2, ... )
152 ## $handle is from previous &chat'open_*().
153 ## $timeout_time is the time (either relative to the current time, or
154 ## absolute, ala time(2)) at which a timeout event occurs.
155 ## $pat1, $pat2, and so on are regexs which are matched against the input
156 ## stream. If a match is found, the entire matched string is consumed,
157 ## and the corresponding body eval string is evaled.
159 ## Each pat is a regular-expression (probably enclosed in single-quotes
160 ## in the invocation). ^ and $ will work, respecting the current value of $*.
161 ## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
162 ## If pat is 'EOF', the body is executed if the process exits before
163 ## the other patterns are seen.
165 ## Pats are scanned in the order given, so later pats can contain
166 ## general defaults that won't be examined unless the earlier pats
167 ## have failed.
169 ## The result of eval'ing body is returned as the result of
170 ## the invocation. Recursive invocations are not thought
171 ## through, and may work only accidentally. :-)
173 ## undef is returned if either a timeout or an eof occurs and no
174 ## corresponding body has been defined.
175 ## I/O errors of any sort are treated as eof.
177 $nextsubname = "expectloop000000"; # used for subroutines
179 sub expect { ## public
180 if ($_[0] =~ /$nextpat/) {
181 *S = shift;
183 local($endtime) = shift;
185 local($timeout,$eof) = (1,1);
186 local($caller) = caller;
187 local($rmask, $nfound, $timeleft, $thisbuf);
188 local($cases, $pattern, $action, $subname);
189 $endtime += time if $endtime < 600_000_000;
191 if (defined $S{"needs_accept"}) { # is it a listen socket?
192 local(*NS) = $S{"needs_accept"};
193 delete $S{"needs_accept"};
194 $S{"needs_close"} = *NS;
195 unless(accept(S,NS)) {
196 ($!) = ($!, close(S), close(NS));
197 return undef;
199 select((select(S), $| = 1)[0]);
202 # now see whether we need to create a new sub:
204 unless ($subname = $expect_subname{$caller,@_}) {
205 # nope. make a new one:
206 $expect_subname{$caller,@_} = $subname = $nextsubname++;
208 $cases .= <<"EDQ"; # header is funny to make everything elsif's
209 sub $subname {
210 LOOP: {
211 if (0) { ; }
213 while (@_) {
214 ($pattern,$action) = splice(@_,0,2);
215 if ($pattern =~ /^eof$/i) {
216 $cases .= <<"EDQ";
217 elsif (\$eof) {
218 package $caller;
219 $action;
222 $eof = 0;
223 } elsif ($pattern =~ /^timeout$/i) {
224 $cases .= <<"EDQ";
225 elsif (\$timeout) {
226 package $caller;
227 $action;
230 $timeout = 0;
231 } else {
232 $pattern =~ s#/#\\/#g;
233 $cases .= <<"EDQ";
234 elsif (\$S =~ /$pattern/) {
235 \$S = \$';
236 package $caller;
237 $action;
242 $cases .= <<"EDQ" if $eof;
243 elsif (\$eof) {
244 undef;
247 $cases .= <<"EDQ" if $timeout;
248 elsif (\$timeout) {
249 undef;
252 $cases .= <<'ESQ';
253 else {
254 $rmask = "";
255 vec($rmask,fileno(S),1) = 1;
256 ($nfound, $rmask) =
257 select($rmask, undef, undef, $endtime - time);
258 if ($nfound) {
259 $nread = sysread(S, $thisbuf, 1024);
260 if ($nread > 0) {
261 $S .= $thisbuf;
262 } else {
263 $eof++, redo LOOP; # any error is also eof
265 } else {
266 $timeout++, redo LOOP; # timeout
268 redo LOOP;
273 eval $cases; die "$cases:\n$@" if $@;
275 $eof = $timeout = 0;
276 do $subname();
279 ## &chat'print([$handle,] @data)
280 ## $handle is from previous &chat'open().
281 ## like print $handle @data
283 sub print { ## public
284 if ($_[0] =~ /$nextpat/) {
285 *S = shift;
288 local $out = join $, , @_;
289 syswrite(S, $out, length $out);
290 if( $chat'debug ){
291 print STDERR "printed:";
292 print STDERR @_;
296 ## &chat'close([$handle,])
297 ## $handle is from previous &chat'open().
298 ## like close $handle
300 sub close { ## public
301 if ($_[0] =~ /$nextpat/) {
302 *S = shift;
304 close(S);
305 if (defined $S{"needs_close"}) { # is it a listen socket?
306 local(*NS) = $S{"needs_close"};
307 delete $S{"needs_close"};
308 close(NS);
312 ## @ready_handles = &chat'select($timeout, @handles)
313 ## select()'s the handles with a timeout value of $timeout seconds.
314 ## Returns an array of handles that are ready for I/O.
315 ## Both user handles and chat handles are supported (but beware of
316 ## stdio's buffering for user handles).
318 sub select { ## public
319 local($timeout) = shift;
320 local(@handles) = @_;
321 local(%handlename) = ();
322 local(%ready) = ();
323 local($caller) = caller;
324 local($rmask) = "";
325 for (@handles) {
326 if (/$nextpat/o) { # one of ours... see if ready
327 local(*SYM) = $_;
328 if (length($SYM)) {
329 $timeout = 0; # we have a winner
330 $ready{$_}++;
332 $handlename{fileno($_)} = $_;
333 } else {
334 $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
337 for (sort keys %handlename) {
338 vec($rmask, $_, 1) = 1;
340 select($rmask, undef, undef, $timeout);
341 for (sort keys %handlename) {
342 $ready{$handlename{$_}}++ if vec($rmask,$_,1);
344 sort keys %ready;
347 # ($pty,$tty) = $chat'_getpty(PTY,TTY):
348 # internal procedure to get the next available pty.
349 # opens pty on handle PTY, and matching tty on handle TTY.
350 # returns undef if can't find a pty.
351 # Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik.
353 sub _getpty { ## private
354 local($_PTY,$_TTY) = @_;
355 $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
356 $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
357 local($pty, $tty, $kind);
358 if( -e "/dev/pts000" ){ ## mods by Joe Doupnik Dec 1992
359 $kind = "pts"; ## SVR4 Streams
360 } else {
361 $kind = "pty"; ## BSD Clist stuff
363 for $bank (112..127) {
364 next unless -e sprintf("/dev/$kind%c0", $bank);
365 for $unit (48..57) {
366 $pty = sprintf("/dev/$kind%c%c", $bank, $unit);
367 open($_PTY,"+>$pty") || next;
368 select((select($_PTY), $| = 1)[0]);
369 ($tty = $pty) =~ s/pty/tty/;
370 open($_TTY,"+>$tty") || next;
371 select((select($_TTY), $| = 1)[0]);
372 system "stty nl>$tty";
373 return ($pty,$tty);
376 undef;