1# chat.pl: chat with a server 2# 3# This library is no longer being maintained, and is included for backward 4# compatibility with Perl 4 programs which may require it. 5# 6# In particular, this should not be used as an example of modern Perl 7# programming techniques. 8# 9# Suggested alternative: Socket 10# 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> 15 16package chat; 17 18require 'sys/socket.ph'; 19 20if( 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; 25} 26else { 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; 32} 33 34 35$sockaddr = 'S n a4 x8'; 36chop($thishost = `hostname`); 37 38# *S = symbol for current I/O, gets assigned *chatsymbol.... 39$next = "chatsymbol000000"; # next one 40$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++ 41 42 43## $handle = &chat'open_port("server.address",$port_number); 44## opens a named or numbered TCP server 45 46sub open_port { ## public 47 local($server, $port) = @_; 48 49 local($serveraddr,$serverproc); 50 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); 54 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]; 62 } 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; 67 } 68 unless (bind(S, $thisproc)) { 69 ($!) = ($!, close(S)); # close S while saving $! 70 return undef; 71 } 72 unless (connect(S, $serverproc)) { 73 ($!) = ($!, close(S)); # close S while saving $! 74 return undef; 75 } 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 85} 86 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 91 92sub open_listen { ## public 93 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; 101 } 102 unless (bind(NS, $thisproc_local)) { 103 ($!) = ($!, close(NS)); 104 return undef; 105 } 106 unless (listen(NS, 1)) { 107 ($!) = ($!, close(NS)); 108 return undef; 109 } 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 115} 116 117## $handle = &chat'open_proc("command","arg1","arg2",...); 118## opens a /bin/sh on a pseudo-tty 119 120sub open_proc { ## public 121 local(@cmd) = @_; 122 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; 135 } 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: $!"; 143 } 144 close(TTY); 145 $next; # return symbol for switcharound 146} 147 148# $S is the read-ahead buffer 149 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. 158## 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. 164## 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. 168## 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. :-) 172## 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. 176 177$nextsubname = "expectloop000000"; # used for subroutines 178 179sub expect { ## public 180 if ($_[0] =~ /$nextpat/) { 181 *S = shift; 182 } 183 local($endtime) = shift; 184 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; 190 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; 198 } 199 select((select(S), $| = 1)[0]); 200 } 201 202 # now see whether we need to create a new sub: 203 204 unless ($subname = $expect_subname{$caller,@_}) { 205 # nope. make a new one: 206 $expect_subname{$caller,@_} = $subname = $nextsubname++; 207 208 $cases .= <<"EDQ"; # header is funny to make everything elsif's 209sub $subname { 210 LOOP: { 211 if (0) { ; } 212EDQ 213 while (@_) { 214 ($pattern,$action) = splice(@_,0,2); 215 if ($pattern =~ /^eof$/i) { 216 $cases .= <<"EDQ"; 217 elsif (\$eof) { 218 package $caller; 219 $action; 220 } 221EDQ 222 $eof = 0; 223 } elsif ($pattern =~ /^timeout$/i) { 224 $cases .= <<"EDQ"; 225 elsif (\$timeout) { 226 package $caller; 227 $action; 228 } 229EDQ 230 $timeout = 0; 231 } else { 232 $pattern =~ s#/#\\/#g; 233 $cases .= <<"EDQ"; 234 elsif (\$S =~ /$pattern/) { 235 \$S = \$'; 236 package $caller; 237 $action; 238 } 239EDQ 240 } 241 } 242 $cases .= <<"EDQ" if $eof; 243 elsif (\$eof) { 244 undef; 245 } 246EDQ 247 $cases .= <<"EDQ" if $timeout; 248 elsif (\$timeout) { 249 undef; 250 } 251EDQ 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 264 } 265 } else { 266 $timeout++, redo LOOP; # timeout 267 } 268 redo LOOP; 269 } 270 } 271} 272ESQ 273 eval $cases; die "$cases:\n$@" if $@; 274 } 275 $eof = $timeout = 0; 276 do $subname(); 277} 278 279## &chat'print([$handle,] @data) 280## $handle is from previous &chat'open(). 281## like print $handle @data 282 283sub print { ## public 284 if ($_[0] =~ /$nextpat/) { 285 *S = shift; 286 } 287 288 local $out = join $, , @_; 289 syswrite(S, $out, length $out); 290 if( $chat'debug ){ 291 print STDERR "printed:"; 292 print STDERR @_; 293 } 294} 295 296## &chat'close([$handle,]) 297## $handle is from previous &chat'open(). 298## like close $handle 299 300sub close { ## public 301 if ($_[0] =~ /$nextpat/) { 302 *S = shift; 303 } 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); 309 } 310} 311 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). 317 318sub 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{$_}++; 331 } 332 $handlename{fileno($_)} = $_; 333 } else { 334 $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_; 335 } 336 } 337 for (sort keys %handlename) { 338 vec($rmask, $_, 1) = 1; 339 } 340 select($rmask, undef, undef, $timeout); 341 for (sort keys %handlename) { 342 $ready{$handlename{$_}}++ if vec($rmask,$_,1); 343 } 344 sort keys %ready; 345} 346 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. 352 353sub _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 362 } 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); 374 } 375 } 376 undef; 377} 378 3791; 380