/usr/share/perl5/chat2.pl is in libperl4-corelibs-perl 0.004-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 | # chat.pl: chat with a server
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Socket
#
# Based on: V2.01.alpha.7 91/06/16
# Randal L. Schwartz (was <merlyn@stonehenge.com>)
# multihome additions by A.Macpherson@bnr.co.uk
# allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU>
package chat;
require 'sys/socket.ph';
if( defined( &main'PF_INET ) ){
$pf_inet = &main'PF_INET;
$sock_stream = &main'SOCK_STREAM;
local($name, $aliases, $proto) = getprotobyname( 'tcp' );
$tcp_proto = $proto;
}
else {
# XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
# but who the heck would change these anyway? (:-)
$pf_inet = 2;
$sock_stream = 1;
$tcp_proto = 6;
}
$sockaddr = 'S n a4 x8';
chop($thishost = `hostname`);
# *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);
# We may be multi-homed, start with 0, fixup once connexion is made
$thisaddr = "\0\0\0\0" ;
$thisproc = pack($sockaddr, 2, 0, $thisaddr);
*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, $pf_inet, $sock_stream, $tcp_proto)) {
($!) = ($!, 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;
}
# We opened with the local address set to ANY, at this stage we know
# which interface we are using. This is critical if our machine is
# multi-homed, with IP forwarding off, so fix-up.
local($fam,$lport);
($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S));
$thisproc = pack($sockaddr, 2, 0, $thisaddr);
# end of post-connect fixup
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, $pf_inet, $sock_stream, $tcp_proto)) {
($!) = ($!, 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;
$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;
}
local $out = join $, , @_;
syswrite(S, $out, length $out);
if( $chat'debug ){
print STDERR "printed:";
print STDERR @_;
}
}
## &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.
# Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik.
sub _getpty { ## private
local($_PTY,$_TTY) = @_;
$_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
$_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
local($pty, $tty, $kind);
if( -e "/dev/pts000" ){ ## mods by Joe Doupnik Dec 1992
$kind = "pts"; ## SVR4 Streams
} else {
$kind = "pty"; ## BSD Clist stuff
}
for $bank (112..127) {
next unless -e sprintf("/dev/$kind%c0", $bank);
for $unit (48..57) {
$pty = sprintf("/dev/$kind%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;
|