#!/usr/bin/perl -w
#
# $Id: //pentools/main/pcascan/pcascan.p#1 $
#
# written by :	Stephen J. Friedl
#		Software Consultant
#		steve@unixwiz.net
#
#	This program scans a network for pcAnywhere hosts that might
#	be listening and reports as much of the details as it can. This
#	reporting is done with the pcAnywhere status port (UDP 5632),
#	and we query the remote name and status.
#
#	We provide a list of IP addresses in our "standard" form, which
#	includes a naked IP address or a domain name, plus an optional
#	/## netbits. Doing:
#
#		$ pcascan 192.168.1.0/24
#
#	scans the whole class C network. We report the name that the other
#	end tells us, the capabilities, plus the availability status.
#
#	Eventually we'll rewrite this in C, but this has been a good
#	proof-of-concept code.
#
# THE PROTOCOL
# ------------
#
#	Everything we know about the pcAnywhere protocol we figured out
#	by sniffing the wire, so it's possible that there is stuff here
#	we have not discovered yet.
#
#	We send our messages to the remote device via UDP port 5632,
#	and all messages appear to be two bytes long. The responses
#	depend on the message sent.
#
#	NAME QUERY
#
#	The name query asks the remote to identify itself by name and
#	(probably) capabilities. We send off a packet with:
#
#	    +---+---+
#	--> | N | Q |
#	    +---+---+
#
#	And we expect a response of the form:
#	
#	    +---+---+---~~----+---+---+---+---+---+---+---+---+---+---+
#	<-- | N | R | name... | _ | _ | A | H | M | _ | _ | _ | _ | _ |
#	    +---+---+---~~----+---+---+---+---+---+---+---+---+---+---+
#
#	The workstation name is padded with _ chars up to 24 bytes long,
#	though it's possible that something else can appear in this
#	position. The last eight bytes seem to be "capabilities", though
#	we're not sure what all of them mean or what might appear in the
#	last five _ positions.
#
#	So far we have seen "AHM" and "AGMM" in the capabilities position,
#	and the latter was for a gateway machine. We're still not real
#	sure about what all of them mean.
#
#	STATUS REPORT
#
#	Once we know the name of a machine, we can query its status, and
#	this is done by the two-byte query:
#
#	    +---+---+
#	--> | S | T |
#	    +---+---+
#
#	The reply is five bytes:
#
#	    +---+---+---+---+---+
#	<-- | S | T | a | b | c |
#	    +---+---+---+---+---+
#
#	We're very fuzzy on just what the last three bytes are, but
#	we have observed that "a" is always zero, "b" always contains
#	one, and the last byte is either \x43 for "Available" and \x0B
#	for "In use".
#
#	We'll fill more in when we discover it.
#
# COMMAND-LINE PARAMS
# -------------------
#
#	--verbose       show a bit more about what the program is doing
#	                internally.
#
#	--port=###      use UDP port ### instead of the default (5632)
#	                Not sure why anybody would want this.
#
#	--timeout=##    once all status queries have been sent, we will
#	                wait only this number of seconds before we decide
#	                to just give up and go home.
#
#	--wtime=##.#    after each write, pause for this much time (in
#	                seconds, but floating point) to avoid running
#	                out of bandwidth over a potentially limited
#	                channel.
#
#	--query=XX      query characters are XX instead of NR. This for
#	                testing only.
#
# TODO
# ----
#
#	This is still very much a proof of concept and needs work. We
#	will ultimately rewrite this in portable C to make it easier to
#	install and use remotely, but perl was great for prototyping.
#
#	- use the much better select package than we're using now.
#
#	- look into the alternate UDP port 22 and scan it also.

use strict;
#--------------------------
# use Target;
#======================================================================
#
# Target.pm -- (module included inline so we don't need two files)
#
#	This module takes a "target" in our standard form and creates
#	a list of IP addresses for the caller. We always permit the
#	trailing /## for the number of bits, and eventually we'll allow
#	the other range notation (a-b or a,b,c).
#
#	If the user requests /## notation, this normally excludes the
#	broadcast addresses, but doubling the slash means we include
#	ALL addresses of interest.
#

# ------------------------------------------------------------------------
# These masks are for converting the /## netbits notation into proper
# IP address ranges.
#
my @NETMASKS = (
	0x00000000,                                             # 0
        0x80000000, 0xC0000000, 0xE0000000, 0xF0000000,         #  1 -  4
        0xF8000000, 0xFC000000, 0xFE000000, 0xFF000000,         #  5 -  8
        0xFF800000, 0xFFC00000, 0xFFE00000, 0xFFF00000,         #  9 - 12
        0xFFF80000, 0xFFFC0000, 0xFFFE0000, 0xFFFF0000,         # 13 - 16
        0xFFFF8000, 0xFFFFC000, 0xFFFFE000, 0xFFFFF000,         # 17 - 20
        0xFFFFF800, 0xFFFFFC00, 0xFFFFFE00, 0xFFFFFF00,         # 21 - 24
        0xFFFFFF80, 0xFFFFFFC0, 0xFFFFFFE0, 0xFFFFFFF0,         # 25 - 28
        0xFFFFFFF8, 0xFFFFFFFC, 0xFFFFFFFE, 0xFFFFFFFF          # 29 - 32
);


sub parse_targets($)
{
	my $target = shift;

	my @IPLIST = ();
	my $ipbase;

	# ----------------------------------------------------------------
	# EASY SYNTAX CHECKS
	#
	# Some things we never permit, so catch them early. Our main goals
	# are "good error reporting" and "avoid hostname lookups", and by
	# catching it here we make the following code easier.
	#
	# -> Slash notation cannot be used with [-,] ranges
	# -> Slash can't be at the start or the end

#	if ( $target =~ m|/|   &&  $target =~ m|[-,]| )
#	{
#		return ( 0, "/ and -, notations are mutually exclusive" );
#	}

	if ( $target =~ m|^/|  ||  $target =~ m|/$| )
	{
		return ( 0, "Invalid / notation [$target]" );
	}

	if ( $target =~ m|/[^/]+/| )
	{
		return ( 0, "Too many sets of slashes in target [$target]" );
	}


	# ----------------------------------------------------------------
	# PROCESS /## NOTATION
	#
	# The /## and //## notations are allowed at the end of the target
	# spec, This ## is a number of bits found in the network part of
	# the target (as opposed to the node), and this nbits can only be
	# in the range 1..32.
	#
	# The / separating the nbits normally tells us to NOT include the
	# broadcast addresses (.0 and .255), but doubling this slash means
	# that we include every single address in the range.
	#

	if ( $target =~ m|^ ([^/]+)		# "base" target name
	                    (/+)		# one or more slashes
	                    (.+) $ |x )		# "netbits" digits after
	{
		my $base         = $1;
		my $enable_bcast = length($2) > 1;	# slashes?
		my $netbits      = $3;

		return ( 0, "Slash notation requires digits after" )
			if length $netbits == 0
			       || $netbits !~ m/^\d+$/;

		return ( 0, "net bits [$netbits] must be 1..32" )
			unless $netbits >= 1  &&  $netbits <= 32;

		# --------------------------------------------------------
		# Look up the hostname (or simply decode the dotted quad)
		# and bail if we're not able to find the name.
		#
		my $iaddr = undef;

		if ( ! defined( $iaddr = &lookup_hostname($base) ) )
		{
			return ( 0, "[$base] is not a valid target" );
		}

		$iaddr = &ipaddr_to_long( inet_aton($iaddr) );

		# --------------------------------------------------------
		# The given IP address might be in the middle of our range,
		# mask off the "node" bits and figure out how many hosts
		# we'll be generating.
		#
		# But if we're not including broadcast addresses, we have
		# to actively skip them.
		#

		$iaddr &= $NETMASKS[ $netbits ];	# drop node part

		my $nhosts;

		if ( $netbits == 32 )
		{
			$nhosts = 1;
		}
		else
		{
			$nhosts = 1 + ~$NETMASKS[ $netbits ];
		}

		if ( ! $enable_bcast &&  $netbits < 32 )
		{
			$nhosts -= 2;		# drop .0 and .255 addrs
			$iaddr++;		# start at dot-one
                }

		while ( $nhosts-- > 0 )
		{
			push @IPLIST, inet_ntoa( &long_to_ipaddr($iaddr++) );
		}

		return ( 1, @IPLIST );
	}
	elsif ( my $ipa = &lookup_hostname($target) )
	{
		return ( 1, $ipa );
	}
	else
	{
		return ( 0, "Invalid format for target [target]" );
	}
}

#
# looks_like_dotquad
#
#	Given a string, return TRUE if it looks like a regular IP
#	address in dotted-quad format, or FALSE if not.
#

sub looks_like_dotquad($)
{
	my $ipa = shift;

	my @PARTS = split(/\./, $ipa);

	return 0	if @PARTS != 4;		# "Quad" means "four"

	foreach my $octet ( @PARTS )
	{
		return 0	unless $octet =~ m/^\d+$/;

		return 0	if  $octet > 255;
	}

	return 1;
}

#
# lookup_hostname
#
#	Given a target address, resolve this to an IP address. If the
#	format of the string is already that way, then return it 
#	directly. Otherwise we try to look up the name in the DNS.
#

sub lookup_hostname($)
{
	my $name = shift;

	return undef	unless $name =~ m/^[-_a-z0-9\.]+$/;

	if ( &looks_like_dotquad($name) )
	{
		return $name;
	}

	if ( my $ipa = gethostbyname($name) )
	{
		return inet_ntoa($ipa);
	}

	return undef;
}

#
# ipaddr_to_long
# long_to_ipaddr
#
#	The internal representation of an IP address is an array of
#	bytes, but for doing math we really need a long int. These
#	convert back and forth between the two.
#
#	NOTE: we're not completely sure of host/net ordering issues!
#

sub ipaddr_to_long($)
{
        my($a, $b, $c, $d) = unpack('C4', shift);

        return ($a<<24) | ($b << 16) | ($c << 8) | $d;
}

sub long_to_ipaddr($)
{
        my $ipa = shift;

        my @X = ();

        push @X, $ipa % 256;            $ipa /= 256;
        push @X, $ipa % 256;            $ipa /= 256;
        push @X, $ipa % 256;            $ipa /= 256;
        push @X, $ipa % 256;

        return pack('C4', reverse @X);
}

1;
#--------------------------
#--------------------------
# use Usleep;
#
# usleep
#
#	This little subroutine sleeps for subsecond intervals, and it's
#	implemented with the old "select" trick. The parameter is the
#	number of seconds in *float*, and this is a no-op if the time
#	to sleep happens to be zero.
#
sub usleep($)
{
	my $time = shift;

	select undef, undef, undef, $time	if $time > 0;
}

1;
#--------------------------
use IO::Socket;
use IO::Select;

# ------------------------------------------------------------------------
# These are the two outgoing messages we know about that can be sent from
# the scanner to the remote pcAnywhere tool. These messages are very short.
# We suspect that there are other commands available, but we don't know
# what they are.
#
my $NAME_QUERY   = "NQ";		# NETWORK QUERY
my $STATUS_QUERY = "ST";		# STATUS QUERY

# ------------------------------------------------------------------------
# Command-line parameters and tunables
#
my $verbose = 0;	# 
my $port    = 5632;	# pca-status
my $timeout = 2;	# seconds
my $wtime   = 0.010;	# post-write pause time
my $query   = $NAME_QUERY;
my $help;

my @WORKLIST = ();

foreach ( @ARGV )
{
	if ( m/^--help/ )
	{
		print STDERR <<EOF;

usage: $0 [options] target [targets...]

  --help        show this help listing

  --verbose     show a bit more debugging about what's going on inside

  --port=##     use UDP port ### instead of the default $port. It's not
                clear why anybody would actually want to use this.

  --timeout=##  wait at most this many seconds after all queries have been
                sent for replies from remotes.  Default = $timeout seconds.

  --wtime=##.#  after each write, pause for this much time (in seconds, but
                in floating point) to avoid running out of bandwidth over a
                limited channel. Default = $wtime seconds.

EOF
		exit 1;
	}
	elsif ( m/^--verbose/ )			# --verbose
	{
		$verbose = 1;
	}
	elsif ( m/^--port=(\d+)/ )		# --port=##
	{
		$port = $1;
	}
	elsif ( m/^--timeout=(\d+)/ )		# --timeout=##
	{
		$timeout = $1;
	}
	elsif ( m/^--wtime=(.+)/ )		# --wtime=##
	{
		$wtime = $1;
	}
	elsif ( m/^--query=(.+)/ )		# --query=XXXX
	{
		$query = $1;
	}
	elsif ( m/^-/ )
	{
		die "ERROR: {$_} is an invalid cmdline parameter\n";
	}
	else
	{
		my @T = parse_targets( $_ );

		if ( shift @T == 0 )
		{
			die join(" ", "ERROR:", @T), "\n";
		}

		foreach my $ip ( @T )
		{
			push @WORKLIST, { IP	=> $ip,
					  Port	=> $port,
					  Msg	=> $query };
		}
	}
}

die "ERROR: missing targets\n"	unless @WORKLIST;

my $socket = IO::Socket::INET->new(Proto     => 'udp',
				   Type      => SOCK_DGRAM);
my $select = IO::Select->new($socket);

my %Waiting;
my %Responses;

MAINLOOP:
while ( @WORKLIST  or  %Waiting )
{
	# ----------------------------------------------------------------
	# See if there is anything we can do here. If we have any remote
	# targets left, we look for the ability to write to it the the
	# query message we have in mind. In every case we want to see if
	# we have any data available to read on this channel.
	#
	# When "select" returns, it gives us a reference to a list of
	# read and write channels, and we run through both lists to take
	# the actions mentioned.
	#
	# If we have NO channels to do anything with, it means we have
	# well and truly timed out and can bail on the whole thing.
	#
	my $toread = $select;
	my $towrite = @WORKLIST ? $select : undef;

	my ($readref, $writeref) = IO::Select->select( $toread,
	                                               $towrite,
	                                               undef,
	                                               $timeout );
	if ( not $readref and not $writeref )
	{
		print "timeout......\n";
		last;
	}

	# ----------------------------------------------------------------
	# For every writable channel (there should be only one), send
	# the packet to the other end. If we manage to write the packet
	# successfully, we note that we're waiting for a response to this
	# one and move on.
	#
	foreach my $sock ( @{ $writeref } )
	{
		my $workref = shift @WORKLIST;

		my $ip   = $workref->{IP};
		my $port = $workref->{Port};
		my $msg  = $workref->{Msg};

		print "sending to $ip:$port\n"		if $verbose;

		my $sin = sockaddr_in($port, inet_aton($ip));

		my $ret = $sock->send($msg, 0, $sin);
		if ( $ret )
		{
			$Waiting{$ip} = 1;

			&usleep($wtime);
		}
		elsif ( $verbose )
		{
			print "error sending to $ip:$port: $!\n";
		}

		next MAINLOOP;
	}

	# ----------------------------------------------------------------
	# For every channel where reading is a possibility (again, should
	# be only one), read the datagram. Since this is UDP it will always
	# return a single packet in a single message, and we decode this
	# message and store it in our table of responses.
	#
	# We expect two kinds of responses. First is the remote name
	# answer "NR" (response to 
	#
	foreach my $sock ( @{ $readref } )
	{
		# --------------------------------------------------------
		# since this socket is readable, fetch the next datagram
		# from it. If we can't get anything, skip it.
		#
		my $reply; 
		my $rc = $sock->recv($reply, 10_000);
		next unless $rc;

		# --------------------------------------------------------
		# top-level decode of what we received. We need to find
		# out who gave us this response, and if we weren't waiting
		# for it then we ignore it. Otherwise we WERE expecting it
		# so we remove it from the waiting list.
		#
		my ($port, $addr) = sockaddr_in($rc);

		my $ip = inet_ntoa($addr);

		if ( $reply )
		{
			my $prtreply = $reply;

			$prtreply =~ s/([^ -~])/sprintf "\\%03o", ord($1)/ge;

			print "received from $ip [$prtreply]\n" if $verbose;
		}

		if ( ! $Waiting{$ip} )
		{
			print "... unexpected reply [$reply] from $ip\n";
			next;
		}

		delete $Waiting{$ip};

		# --------------------------------------------------------
		# OK, this is an expected and valid reply. Decode it and
		# (possibly) generate then next query.
		#

		if ( $reply =~ m/^NR(........................)(........)/ )
		{
			my $name = $1;
			my $caps = $2;

			$name =~ s/_+$//;
			$caps =~ s/_+$//;

			printf " --> Name Response: $ip = %-24s [$caps]\n",
			    $name;

			unshift @WORKLIST, { IP   => $ip,
			                     Port => $port,
			                     Msg  => $STATUS_QUERY };

			$Responses{$ip}->{Name}   = $name;
			$Responses{$ip}->{Caps}   = $caps;
			$Responses{$ip}->{Status} = 'Unknown';
			                    
			                    
		}
		elsif ( $reply =~ m/^ST(.+)/ )
		{
			my @STAT = map ord, split(//, $1);

			if ( $STAT[2] == 67 )
			{
				$STAT[2] = 'Available';
			}
			elsif ( $STAT[2] == 11 )
			{
				$STAT[2] = 'Busy';
			}

			print " --> Status: $ip ", join(" ", @STAT), "\n";

#			$Responses{$ip}->[2] = $STAT[2];

			$Responses{$ip}->{Status} = $STAT[2];
		}
		else
		{
			print "unknown response: [$reply]\n";
		}
	}
}

#
# ipcompare
#
#	Compare IP addresses numerically. This is used to sort a list
#	of IP addresses for display, and we can't use the lexicographic
#	sort because 110 sorts before 90. Ugh.
#
sub ipcompare
{
	my @A = split(/\./, $a);
	my @B = split(/\./, $b);

		$A[0] <=> $B[0]
	or	$A[1] <=> $B[1]
	or	$A[2] <=> $B[2]
	or	$A[3] <=> $B[3];
}

# ------------------------------------------------------------------------
# Now dump the results from the whole scan.
#

foreach my $ip ( sort ipcompare keys %Responses )
{
	my $ref = $Responses{$ip};

	printf("%-15s: %-24s  [%s]  %s\n",
		$ip,
		$ref->{Name},
		$ref->{Caps},
		$ref->{Status});
}