[comp.lang.perl] getduatweather

merlyn@iwarp.intel.com (Randal L. Schwartz) (05/04/91)

In article <1991May3.105129.4453@vax5.cit.cornell.edu>, c52y@vax5 writes:
| 
|     I seem to recall that there exists an Internet access to the
|     Contel DUAT system, but I don't remember the address. Can anyone
|     tell me what it is? Thanks.

Not only is there an address for Contel on the net, but whadda you get
when you intersect a Perl hacker and a pilot?

answer: A Perl script that connects to DUAT and gives you the weather
in plain (not plane! :-) near-English (thanks Contel!).

(This is a lot like geoff's script, but because it interacts with the
output, it moves along much faster.  It also does the telnet directly,
rather than invoking "telnet" to do it.)

I call this "getduatweather", and this is how I use it:

getduatweather pdx sa,ft
	gives me sa and ft for pdx
getduatweather pdx
	gives me wt,ft for pdx (the default weather products)
getduatweather
	gives me wt,ft for hio (the location default)
getduatweather pdx,sjc sa,ft x
	gives me sa,ft UNDECODED for pdx and sjc
getduatweather -d pdx,sjc sa,ft x
	the same thing, but watch it happen (for debugging)

You'll have to adjust the push(@INC) line to reflect where you've
stuck the chat2.pl package.  You'll also need a file called
'contel-id' in the current directory that contains two lines: your
Contel user number, and your password.

################################################## cut here for chat2.pl
## chat.pl: chat with a server
## V2.01.alpha.4 91/05/02
## Randal L. Schwartz

package chat;

$sockaddr = 'S n a4 x8';
chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
$thisproc = pack($sockaddr, 2, 0, $thisaddr);

# *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);

	*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, 2, 1, 6)) {
		# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
		# but who the heck would change these anyway? (:-)
		($!) = ($!, 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;
	}
	select((select(S), $| = 1)[0]);
	$next; # return symbol for switcharound
}

## ($host, $port, $handle) = &chat'open_listen();
## opens a TCP port on the current machine, ready to be listened to

sub open_listen { ## public

	*S = ++$next;
	local(*NS) = "__" . time;
	unless (socket(NS, 2, 1, 6)) {
		# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
		# but who the heck would change these anyway? (:-)
		($!) = ($!, close(NS));
		return undef;
	}
	unless (bind(NS, $thisproc)) {
		($!) = ($!, 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;
	local($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.

sub expect { ## public
	if ($_[0] =~ /$nextpat/) {
		*S = shift;
	}
	local($endtime) = shift;

	$endtime += time if $endtime < 600_000_000;
	local($rmask, $nfound, $timeleft, $thisbuf);
	local($timeout,$eof) = (1,1);
	local($cases,$pattern,$action);
	local($caller) = caller;
	local($return,@return);
	local($returnvar) = wantarray ? '@return' : '$return';

	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]);
	}

	## strategy: create a giant block inside $cases
	$cases .= <<'ESQ';
	LOOP: {
ESQ
	while (@_) {
		($pattern,$action) = splice(@_,0,2);
		if ($pattern =~ /^eof$/i) {
			$cases .= <<"EDQ";
		if (\$eof) {
			$returnvar = do { package $caller; $action; };
			last LOOP;
		}
EDQ
			$eof = 0;
		} elsif ($pattern =~ /^timeout$/i) {
			$cases .= <<"EDQ";
		if (\$timeout) {
			$returnvar = do { package $caller; $action; };
			last LOOP;
		}
EDQ
			$timeout = 0;
		} else {
			$pattern =~ s#/#\\/#g;
			$cases .= <<"EDQ";
		if (\$S =~ /$pattern/) {
			\$S = \$';
			$returnvar = do { package $caller; $action; };
			last LOOP;
		}
EDQ
		}
	}
	$cases .= <<"EDQ" if $eof;
		if (\$eof) {
			$returnvar = undef;
			last LOOP;
		}
EDQ
	$cases .= <<"EDQ" if $timeout;
		if (\$timeout) {
			$returnvar = undef;
			last LOOP;
		}
EDQ
	$eof = $timeout = 0;
	$cases .= <<'ESQ';
		$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 $@;
	if (wantarray) {
		return @return;
	} else {
		return $return;
	}
}

## &chat'print([$handle,] @data)
## $handle is from previous &chat'open().
## like print $handle @data

sub print { ## public
	if ($_[0] =~ /$nextpat/) {
		*S = shift;
	}
	print S @_;
}

## &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);
	}
}

# ($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.

sub _getpty { ## private
	local($_PTY,$_TTY) = @_;
	$_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
	$_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
	local($pty,$tty);
	for $bank (112..127) {
		next unless -e sprintf("/dev/pty%c0", $bank);
		for $unit (48..57) {
			$pty = sprintf("/dev/pty%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;
################################################## cut here for getduatweather
#!/usr/bin/perl

push(@INC, '/local/merlyn/lib/perl');

require 'chat2.pl';

shift, $| = $trace = 1 if $ARGV[0] =~ /^-d/; # debug mode

$where = shift || "hio";
$what = shift || "wt,ft";
$decoded = 1 unless @ARGV;

open(C,"contel-id") || die "Cannot open contel-id: $!";
($accesscode,$pass) = <C>; chop($accesscode,$pass);
close(C);

&chat'open_port('duat.contel.com', 23) || die "open: $!";
die "wanted open, got $_"
	unless ($_ = &listenr(5, 'last name:')) =~ /DUAT access code/i;
&talk("$accesscode\r");
die "wanted password, got $_"
	unless ($_ = &listenr(5, 'password:')) =~ /password/i;
&talk("$pass\r");
die "wanted RETURN to continue, got $_"
	unless ($_ = &listenr(5, 'RETURN to continue')) =~ /RETURN to con/i;
&talk("\r");
die "wanted main menu, got $_"
	unless ($_ = &listenr(5, '\):')) =~ /weather briefing\s+(\d)/i;
&talk("$1\r");
if ($decoded) {
	die "wanted wb menu, got $_"
		unless ($_ = &listenr(5, '\):'))
			=~ /plain language weather\s+(\d)/i;
	&talk("$1\r");
	die "wanted pacific time, got $_"
		unless ($_ = &listenr(5, '\):')) =~ /pacific\s+(\d)/i;
	&talk("$1\r");
}
die "wanted wb menu, got $_"
	unless ($_ = &listenr(5, '\):')) =~ /selected location weather\s+(\d)/i;
&talk("$1\r");
die "wanted aircraft tail, got $_"
	unless ($_ = &listenr(5, 'aircraft tail.*\]')) =~ /aircraft tail/i;
&talk("\r");
die "wanted locations, got $_"
	unless ($_ = &listenr(5, 'ions:')) =~ /locations/i;
&talk("$where\r");
die "wanted types, got $_"
	unless ($_ = &listenr(5, 'ypes:')) =~ /types/i;
&talk("$what\r");
die "wanted current time, got $_"
	unless ($_ = &listenr(5, 'hhmm\)')) =~ /current time.*(\d\d):\d\d/i;
&talk("${1}59\r"); # feed back what you see, but at 59 minutes past hour
# hmm... the next response can either be "end of info" or "hazards prompt"
$_ = &listenr(5, $decoded ? 'quit:' : 'quit\):');
if (/Adverse Conditions unless you specifically/i) {
	# hmm... looks like we got it
	&talk("\r");
	$_ .= &listenr(5, $decoded ? 'quit:' : 'quit\):');
}
if ($decoded) {
	die "wanted RETURN to continue, got $_"
		unless /RETURN to continue/i;
	&talk("\r");
	$_ = &listenr(5, 'to quit\):');
}
die "wanted q to quit, got $_"
	unless /'q' to quit/i;
s/\r//g;
s/.*\n//; # chop the first line
s/\s+(Plain Language)? Weather Briefing(.|\n)+//;
$weather = $_; # should process this
if ($decoded) { # one additional quit if inside decoded menu
	&talk("q\r");
	die "wanted q for quit, got $_"
		unless ($_ = &listenr(5, '\):')) =~ /'q' to quit/i;
}
&talk("q\r");
die "wanted q for quit, got $_"
	unless ($_ = &listenr(5, '\):')) =~ /'q' to quit/i;
&talk("q\r");
die "wanted confirm exit, got $_"
	unless ($_ = &listenr(5, 'sion:')) =~ /confirm exit/i;
&talk("y\r");
&listen(10); # for trace

&chat'close();
print $weather, "\n";
exit(0);


sub talk {
	local($text) = @_;
	print "{$text}" if $trace;
	&chat'print($text);
}

sub listen {
	local($secs) = @_;
	local($return,$tmp) = "";
	while (length($tmp = &telnet_read($secs))) {
		print $tmp if $trace;
		$return .= $tmp;
	}
	$return;
}

sub listenr {
	local($secs,$regex) = @_;
	local($return,$tmp) = "";
	while (length($tmp = &telnet_read($secs))) {
		print $tmp if $trace;
		$return .= $tmp;
		last if $return =~ /$regex/i;
	}
	$return;
}

sub telnet_read {
	local($secs) = @_;
	&chat'expect($secs,
		'^\377[\375\376](.|\n)',
		q#&chat'print ("\377\374".$1); redo LOOP#,
			# WON'T do these do/don't requests
		'^\377[\373\374](.|\n)', 'redo LOOP',
			# ignore these will/won't changes
		'^\377\377', '"\377"',
			# escaping the IAC
		'^\377(.|\n)', 'redo LOOP',
			# ignoring these
		'^[^\377]+', '$&'
			# return these
		);
}
################################################## cut here

Just another Perl hacker and aviator,
-- 
/=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'..."====/