merlyn@iwarp.intel.com (Randal L. Schwartz) (04/12/91)
Argh. Had some problems with filehandles not being closed. Hmm.
Larry, is it a bug that a failed connect() leaves a filehandle open,
and I have to close the handle (even though the close generates an
error)? Or is that just the way the underlying system works? (To
test this, I'd have to *gasp* code in C! :-)
Anyway, here's the stuff I've got so far that I've been playing with.
No new comments, but if you look through this, you might come up with
some interesting stuff. (WARNING: use this stuff at your own risk.)
(I particularly like the "anon FTP" finder. You have to have "dig" to
use it, though.)
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: anonftp.pl chat2.pl dbx.pl expand-postmaster.pl
# findnntp.pl smtp-intel.pl x2.pl
# Wrapped by merlyn@iwarpse on Thu Apr 11 15:21:35 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'anonftp.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'anonftp.pl'\"
else
echo shar: Extracting \"'anonftp.pl'\" \(1408 characters\)
sed "s/^X//" >'anonftp.pl' <<'END_OF_FILE'
X$|++;
X
Xpush(@INC,'/local/merlyn/lib/perl');
Xrequire 'chat2.pl';
X
X$rshr = 'rsh r ' unless `hostname` =~ "iwarpr\n";
X
Xfor $domain (@ARGV) {
X print "working on $domain...\n";
X $domain .= '.' unless $domain =~ /\.$/;
X %nameservers = ();
X for $line (`$rshr dig $domain ns`) {
X next if $line =~ /^\s*(;.*)?$/;
X next unless $line =~ /\s+NS\s+(\S+)$/;
X print "nameserver = $1\n"; ## trace
X $nameservers{$1}++;
X }
X @nameservers = sort keys nameservers;
X (warn "no nameservers for $domain?"), next unless @nameservers;
X %names = ();
X for $nameserver (@nameservers) {
X print "using nameserver $nameserver...\n";
X for $line (`$rshr dig \@$nameserver $domain axfr`) {
X next if $line =~ /^\s*(;.*)?$/;
X next unless $line =~ /^(\S+)\s+(\d+\s+)?A/;
X print "name = $1\n"; ## trace
X $names{$1}++;
X }
X @names = sort keys names;
X last if @names; # stop when we've seen some!
X }
X (warn "no names for $domain?"), next unless @names;
X for $name (@names) {
X print "connecting to $name...\n";
X unless (&chat'open_port($name,21)) {
X warn "no response from $name: $!";
X next;
X }
X unless (&chat'expect(10,'^220.*\n',1)) {
X warn "did not get 220";
X &chat'close();
X next;
X }
X &chat'print("USER anonymous\n");
X unless(&chat'expect(10,'^331.*\n',1)) {
X warn "did not get 331";
X &chat'close();
X next;
X }
X print "$name supports anon FTP.\n";
X &chat'close(); # don't care about further response
X }
X}
END_OF_FILE
if test 1408 -ne `wc -c <'anonftp.pl'`; then
echo shar: \"'anonftp.pl'\" unpacked with wrong size!
fi
# end of 'anonftp.pl'
fi
if test -f 'chat2.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'chat2.pl'\"
else
echo shar: Extracting \"'chat2.pl'\" \(6216 characters\)
sed "s/^X//" >'chat2.pl' <<'END_OF_FILE'
X## chat.pl: chat with a server
X## V2.01.alpha.2 91/04/10
X## Randal L. Schwartz
X
Xpackage chat;
X
X$sockaddr = 'S n a4 x8';
Xchop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
X$thisproc = pack($sockaddr, 2, 0, $thisaddr);
X
X# *S = symbol for current I/O, gets assigned *chatsymbol....
X$next = "chatsymbol000000"; # next one
X$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
X
X
X## $handle = &chat'open_port("server.address",$port_number);
X## opens a named or numbered TCP server
X
Xsub open_port { ## public
X local($server, $port) = @_;
X
X local($serveraddr,$serverproc);
X
X *S = ++$next;
X if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
X $serveraddr = pack('C4', $1, $2, $3, $4);
X } else {
X local(@x) = gethostbyname($server);
X return undef unless @x;
X $serveraddr = $x[4];
X }
X $serverproc = pack($sockaddr, 2, $port, $serveraddr);
X unless (socket(S, 2, 1, 6)) {
X # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
X # but who the heck would change these anyway? (:-)
X ($!) = ($!, close(S)); # close S while saving $!
X return undef;
X }
X unless (bind(S, $thisproc)) {
X ($!) = ($!, close(S)); # close S while saving $!
X return undef;
X }
X unless (connect(S, $serverproc)) {
X ($!) = ($!, close(S)); # close S while saving $!
X return undef;
X }
X select((select(S), $| = 1)[0]);
X $next; # return symbol for switcharound
X}
X
X## $handle = &chat'open_proc("command","arg1","arg2",...);
X## opens a /bin/sh on a pseudo-tty
X
Xsub open_proc { ## public
X local(@cmd) = @_;
X
X *S = ++$next;
X local(*TTY) = "__TTY" . time;
X local($pty,$tty) = &_getpty(S,TTY);
X die "Cannot find a new pty" unless defined $pty;
X local($pid) = fork;
X die "Cannot fork: $!" unless defined $pid;
X unless ($pid) {
X close STDIN; close STDOUT; close STDERR;
X setpgrp(0,$$);
X if (open(DEVTTY, "/dev/tty")) {
X ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
X close DEVTTY;
X }
X open(STDIN,"<&TTY");
X open(STDOUT,">&TTY");
X open(STDERR,">&STDOUT");
X die "Oops" unless fileno(STDERR) == 2; # sanity
X close(S);
X exec @cmd;
X die "Cannot exec @cmd: $!";
X }
X close(TTY);
X $next; # return symbol for switcharound
X}
X
X# $S is the read-ahead buffer
X
X## $return = &chat'expect([$handle,] $timeout_time,
X## $pat1, $body1, $pat2, $body2, ... )
X## $handle is from previous &chat'open_*().
X## $timeout_time is the time (either relative to the current time, or
X## absolute, ala time(2)) at which a timeout event occurs.
X## $pat1, $pat2, and so on are regexs which are matched against the input
X## stream. If a match is found, the entire matched string is consumed,
X## and the corresponding body eval string is evaled.
X##
X## Each pat is a regular-expression (probably enclosed in single-quotes
X## in the invocation). ^ and $ will work, respecting the current value of $*.
X## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
X## If pat is 'EOF', the body is executed if the process exits before
X## the other patterns are seen.
X##
X## Pats are scanned in the order given, so later pats can contain
X## general defaults that won't be examined unless the earlier pats
X## have failed.
X##
X## The result of eval'ing body is returned as the result of
X## the invocation. Recursive invocations are not thought
X## through, and may work only accidentally. :-)
X##
X## undef is returned if either a timeout or an eof occurs and no
X## corresponding body has been defined.
X## I/O errors of any sort are treated as eof.
X
Xsub expect { ## public
X if ($_[0] =~ /$nextpat/) {
X *S = shift;
X }
X local($endtime) = shift;
X
X $endtime += time if $endtime < 600_000_000;
X local($rmask, $nfound, $timeleft, $thisbuf);
X local($timeout,$eof) = (1,1);
X local($cases,$pattern,$action);
X local($caller) = caller;
X local($return,@return);
X local($returnvar) = wantarray ? '@return' : '$return';
X
X ## strategy: create a giant block inside $cases
X $cases .= <<'ESQ';
X LOOP: {
XESQ
X while (@_) {
X ($pattern,$action) = splice(@_,0,2);
X if ($pattern =~ /^eof$/i) {
X $cases .= <<"EDQ";
X if (\$eof) {
X $returnvar = do { package $caller; $action; };
X last LOOP;
X }
XEDQ
X $eof = 0;
X } elsif ($pattern =~ /^timeout$/i) {
X $cases .= <<"EDQ";
X if (\$timeout) {
X $returnvar = do { package $caller; $action; };
X last LOOP;
X }
XEDQ
X $timeout = 0;
X } else {
X $pattern =~ s#/#\\/#g;
X $cases .= <<"EDQ";
X if (\$S =~ /$pattern/) {
X \$S = \$';
X $returnvar = do { package $caller; $action; };
X last LOOP;
X }
XEDQ
X }
X }
X $cases .= <<"EDQ" if $eof;
X if (\$eof) {
X $returnvar = undef;
X last LOOP;
X }
XEDQ
X $cases .= <<"EDQ" if $timeout;
X if (\$timeout) {
X $returnvar = undef;
X last LOOP;
X }
XEDQ
X $eof = $timeout = 0;
X $cases .= <<'ESQ';
X $rmask = "";
X vec($rmask,fileno(S),1) = 1;
X ($nfound, $rmask) =
X select($rmask, undef, undef, $endtime - time);
X if ($nfound) {
X "<nfound = $nfound>";
X $nread = sysread(S, $thisbuf, 1024);
X if ($nread > 0) {
X $S .= $thisbuf;
X } else {
X $eof++, redo LOOP; # any error is also eof
X }
X } else {
X $timeout++, redo LOOP; # timeout
X }
X redo LOOP;
X }
XESQ
X eval $cases; die $@ if $@;
X if (wantarray) {
X return @return;
X } else {
X return $return;
X }
X}
X
X## &chat'print([$handle,] @data)
X## $handle is from previous &chat'open().
X## like print $handle @data
X
Xsub print { ## public
X if ($_[0] =~ /$nextpat/) {
X *S = shift;
X }
X print S @_;
X}
X
X## &chat'close([$handle,])
X## $handle is from previous &chat'open().
X## like close $handle
X
Xsub close { ## public
X if ($_[0] =~ /$nextpat/) {
X *S = shift;
X }
X close(S);
X}
X
X# ($pty,$tty) = $chat'_getpty(PTY,TTY):
X# internal procedure to get the next available pty.
X# opens pty on handle PTY, and matching tty on handle TTY.
X# returns undef if can't find a pty.
X
Xsub _getpty { ## private
X local($_PTY,$_TTY) = @_;
X $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
X $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
X local($pty,$tty);
X for $bank (112..127) {
X next unless -e sprintf("/dev/pty%c0", $bank);
X for $unit (48..57) {
X $pty = sprintf("/dev/pty%c%c", $bank, $unit);
X open($_PTY,"+>$pty") || next;
X select((select($_PTY), $| = 1)[0]);
X ($tty = $pty) =~ s/pty/tty/;
X open($_TTY,"+>$tty") || next;
X select((select($_TTY), $| = 1)[0]);
X system "stty nl>$tty";
X return ($pty,$tty);
X }
X }
X undef;
X}
X
X1;
END_OF_FILE
if test 6216 -ne `wc -c <'chat2.pl'`; then
echo shar: \"'chat2.pl'\" unpacked with wrong size!
fi
# end of 'chat2.pl'
fi
if test -f 'dbx.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'dbx.pl'\"
else
echo shar: Extracting \"'dbx.pl'\" \(265 characters\)
sed "s/^X//" >'dbx.pl' <<'END_OF_FILE'
X
Xrequire './chat2.pl';
X
Xchdir "/r2/sbradley/dbx.test" || die "chdir: $!";
X
Xfor (1..20) {
X system "./a.out";
X &chat'open_proc("trace dbx ./a.out core");
X &chat'print("where\nquit\n");
X 1 while &chat'expect(10,TIMEOUT,0,EOF,0,'(.|\n)+','print $&');
X &chat'close();
X}
END_OF_FILE
if test 265 -ne `wc -c <'dbx.pl'`; then
echo shar: \"'dbx.pl'\" unpacked with wrong size!
fi
# end of 'dbx.pl'
fi
if test -f 'expand-postmaster.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'expand-postmaster.pl'\"
else
echo shar: Extracting \"'expand-postmaster.pl'\" \(333 characters\)
sed "s/^X//" >'expand-postmaster.pl' <<'END_OF_FILE'
X$| = 1;
Xrequire './chat2.pl';
X
X&chat'open_port("localhost",25);
X
X&chat'expect(10,'^220.*\n',1) || die "No header";
X&chat'print("expn Postmaster\n");
X1 while &chat'expect(10,
X '^250-(.*[^\r])\r?\n','print "$1\n "; 1',
X '^250 (.*[^\r])\r?\n','print "$1\n"; 0',
X '^550.*\n','print "no such user\n"; 0',
X TIMEOUT,'0'
X);
X
X&chat'close();
X
END_OF_FILE
if test 333 -ne `wc -c <'expand-postmaster.pl'`; then
echo shar: \"'expand-postmaster.pl'\" unpacked with wrong size!
fi
# end of 'expand-postmaster.pl'
fi
if test -f 'findnntp.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'findnntp.pl'\"
else
echo shar: Extracting \"'findnntp.pl'\" \(545 characters\)
sed "s/^X//" >'findnntp.pl' <<'END_OF_FILE'
X$|++;
X
Xpush(@INC,'/local/merlyn/lib/perl');
Xrequire 'chat2.pl';
X
Xchdir "/nfs/backups/usr.spool.news/comp.mail.maps" || die "cd: $!";
X
X@ARGV=(<u.usa.*>);
Xwhile (<>) {
X next unless (/^(\S+)\s*=\s*(\S+)/);
X $name = $2; $name =~ s/,.*//;
X print "connecting to $name...\n";
X unless (&chat'open_port($name,119)) {
X warn "no response from $name: $!";
X next;
X }
X unless (&chat'expect(10,'^20[01].*\n',1)) {
X warn "did not get 20[01]";
X &chat'close();
X next;
X }
X print "$name supports NNTP.\n";
X &chat'close(); # don't care about further response
X}
END_OF_FILE
if test 545 -ne `wc -c <'findnntp.pl'`; then
echo shar: \"'findnntp.pl'\" unpacked with wrong size!
fi
# end of 'findnntp.pl'
fi
if test -f 'smtp-intel.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'smtp-intel.pl'\"
else
echo shar: Extracting \"'smtp-intel.pl'\" \(472 characters\)
sed "s/^X//" >'smtp-intel.pl' <<'END_OF_FILE'
X$|++;
X
Xpush(@INC,'/local/merlyn/lib/perl');
X
Xrequire 'chat2.pl';
X
Xopen(YC,"ypcat hosts|") || die "cannot open ypcat hosts: $!";
Xwhile (<YC>) {
X chop;
X ($addr,@names) = split;
X $name = shift(@names); # canon name is first
X next unless $name =~ /iwarp/i;
X print "$name $addr\n";
X unless (&chat'open_port($addr,25)) {
X warn "cannot connect to SMTP at $name: $!";
X next;
X }
X &chat'expect(15, '(.*[^\r])\r?\n','print "$1\n"; 1') ||
X warn "timeout or eof";
X &chat'close();
X}
END_OF_FILE
if test 472 -ne `wc -c <'smtp-intel.pl'`; then
echo shar: \"'smtp-intel.pl'\" unpacked with wrong size!
fi
# end of 'smtp-intel.pl'
fi
if test -f 'x2.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'x2.pl'\"
else
echo shar: Extracting \"'x2.pl'\" \(469 characters\)
sed "s/^X//" >'x2.pl' <<'END_OF_FILE'
X$| = 1;
Xrequire './chat2.pl';
X
Xfor (1..20) {
X push(@a, &chat'open_proc("/bin/sh") || die "Cannot open sh");
X}
Xfor (@a) {
X &chat'expect($_, 5, '\$ $', 1) || die "no prompt";
X}
Xfor (@a) {
X &chat'print($_, "date\n");
X}
Xfor (@a) {
X &chat'expect($_, 10, '\$ $', 'print $`') || die "no prompt";
X}
Xfor (@a) {
X &chat'print($_, "tty; stty\n");
X}
Xfor (@a) {
X &chat'expect($_, 10, '\$ $', 'print $`') || die "no prompt";
X}
X
Xfor (@a) {
X &chat'close($_) || die "cannot close $_";
X}
END_OF_FILE
if test 469 -ne `wc -c <'x2.pl'`; then
echo shar: \"'x2.pl'\" unpacked with wrong size!
fi
# end of 'x2.pl'
fi
echo shar: End of shell archive.
exit 0
--
/=Randal L. Schwartz, Stonehenge Consulting Services (503)777-0095 ==========\
| on contract to Intel's iWarp project, Beaverton, Oregon, USA, Sol III |
| merlyn@iwarp.intel.com ...!any-MX-mailer-like-uunet!iwarp.intel.com!merlyn |
\=Cute Quote: "Intel: putting the 'backward' in 'backward compatible'..."====/lwall@jpl-devvax.jpl.nasa.gov (Larry Wall) (04/12/91)
In article <1991Apr11.222343.28800@iwarp.intel.com> merlyn@iwarp.intel.com (Randal L. Schwartz) writes:
: Argh. Had some problems with filehandles not being closed. Hmm.
: Larry, is it a bug that a failed connect() leaves a filehandle open,
: and I have to close the handle (even though the close generates an
: error)? Or is that just the way the underlying system works? (To
: test this, I'd have to *gasp* code in C! :-)
If the OS doesn't close a socket on connect failure, neither should Perl.
(It doesn't.) You're probably getting the failure on close because there
are two stdio streams bound to a single socket (stdio gets confused on
some machines otherwise). Only the first fclose() can actually close the
fd, so the second one gets an error. That should probably be suppressed.
In fact, looking at the code, it seems to me that close shouldn't be returning
an error on that, even though $! gets set. You aren't relying on $! without
checking the return value, are you? The do_close() routine returns the
value from the first fclose(), not the second. Or are you perhaps using
an older version that returned the value of the second fclose()?
Larry