#!/usr/athena/bin/perl
use warnings;
use strict;
use Socket;

my $VERBOSE;
@ARGV and $ARGV[0] eq '-v' and $VERBOSE = 1, shift @ARGV;

local($|) = 1;

my $port = (getservbyname("telnet","tcp"))[2];
my $proto = (getprotobyname("tcp"))[2];

my $host = shift(@ARGV) || "localhost";
my $hostaddr = ((gethostbyname($host))[4])[0];
if (! $hostaddr) {
    print STDERR "No such host '$host'.\n";
    exit 2;
}
socket(my $S, AF_INET, SOCK_STREAM, $proto) || die "$!";
bind($S, sockaddr_in(0, undef)) || die "$!";

FORK: {
    my ($pid, $diepid);
    if ($pid = fork) {
	$diepid = wait;
	if ($diepid == -1) {
	    print STDERR "No child\n";
	    exit 2;
	}
	if ($? == 14) {
	    print STDERR "Timed out connecting to '$host'\n";
	    exit 2;
	}
	if ($? == 0) {
	    print "*** ACCESS IS ON FOR '$host'\n" if $VERBOSE;
	    exit 1;
	}
	print "access is off for '$host'\n" if $VERBOSE;
    } elsif (defined $pid) {
	alarm 5;
	if (connect($S, sockaddr_in($port, $hostaddr))) {
	    shutdown($S, 2);
	    exit 0;
	}
	shutdown($S, 2);
	exit 1;
    } elsif ($! =~ /No more process/) {
	# EAGAIN
	sleep 5;
	redo FORK;
    } else {
	# weird fork error
	if ($! < 2) {$! = 2;}
	die "Can't fork: $!\n";
    }
}