[comp.lang.perl] A Domain Client in Perl

yukngo@obelix.gaul.csd.uwo.ca (Cheung Yukngo) (05/27/90)

I wrote this program a few weeks ago. I was sort of tired of rshing to
one of the machines where nslookup, nstest and nsquery work correctly.
I did not want to learn how to use libresolv.a and this program was
the result. I don't exactly use most of the options; they are included
just for completeness' sake.  Details about the protocol is in
rfc1123, I think.

I learned perl only two months ago so my style is not exactly good.
Tell me what you think. Bug reports, diffs, etc. are all welcome.

BTW, this is the first time I post any article at all. Sorry if I did
something wrong.

Khun Yee Fung
(My first name is `Khun Yee', two words. Not Khun or Khun-Yee.)
clipper@csd.uwo.ca

----
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	pns
#	pns.doc
#
if test -f 'pns'
then
	echo shar: will not over-write existing file "'pns'"
else
	echo x - 'pns'
	sed 's/^X//' >'pns' << 'SHAR_EOF'
X#!/u3/thesis/clipper/pl/perl
X# Copyright 1990 by Khun Yee Fung <clipper@csd.uwo.ca>
X# See pns.doc for warranty information
X# $Source: /u3/thesis/clipper/pl/RCS/pns,v $
X# $Id: pns,v 1.3 90/05/12 16:29:58 clipper Exp $
Xdo 'sys/socket.h' || die "can\'t do sys/socket.h: $@";
Xdo 'getopts.pl' || die "Can't do getopts.pl: $@";
Xdo Getopts('A:andfcsbgr0wphmxte');
X$sockaddr = 'S n a4 x8';
X$hostname = $ARGV[0];
Xif (defined($opt_A)) {
X  $server = $opt_A;
X}
Xelse {
X  $server = 'ria.ccs.uwo.ca';
X}
X$port = 53;
X
X@bits = (0x8000, 0x4000, 0x2000, 0x1000, 0x0800, 0x0400, 0x0200, 0x0100,
X  0x0080, 0x0040, 0x0020, 0x0010, 0x0008, 0x0004, 0x0002, 0x0001);
X$PORTS[5] = "RJE"; $PORTS[7] = "ECHO"; $PORTS[9] = "DISCARD";
X$PORTS[11] = "USERS"; $PORTS[13] = "DAYTIME"; $PORTS[17] = "QUOTE";
X$PORTS[19] = "CHARGEN"; $PORTS[20] = "FTP-DATA"; $PORTS[21] = "FTP";
X$PORTS[23] = "TELNET"; $PORTS[25] = "SMTP"; $PORTS[27] = "NSW-FE";
X$PORTS[29] = "MSG-ICP"; $PORTS[31] = "MSG-AUTH"; $PORTS[33] = "DSP";
X$PORTS[37] = "TIME"; $PORTS[39] = "RLP"; $PORTS[41] = "GRAPHICS";
X$PORTS[42] = "NAMESERVER"; $PORTS[43] = "NICNAME"; $PORTS[44] = "MPM-FLAGS";
X$PORTS[45] = "MPM"; $PORTS[46] = "MPM-SND"; $PORTS[47] = "NI-FTP";
X$PORTS[49] = "LOGIN"; $PORTS[51] = "LA-MAINT"; $PORTS[53] = "DOMAIN";
X$PORTS[55] = "ISI-GL"; $PORTS[61] = "NI-MAIL"; $PORTS[63] = "VIA-FTP";
X$PORTS[65] = "TACACS-DS"; $PORTS[67] = "BOOTPS"; $PORTS[68] = "BOOTPC";
X$PORTS[69] = "TFTP"; $PORTS[71] = "NETRJS-1"; $PORTS[72] = "NETRJS-2";
X$PORTS[73] = "NETRJS-3"; $PORTS[64] = "NETRJS-4"; $PORTS[79] = "FINGER";
X$PORTS[81] = "HOSTS-NS"; $PORTS[83] = "MIT-ML-DEV"; $PORTS[85] = "MIT-ML-DEV";
X$PORTS[89] = "SU-MIT-TG"; $PORTS[91] = "MIT-DOV"; $PORTS[93] = "DCP";
X$PORTS[95] = "SUPDUP"; $PORTS[97] = "SWIFT-RVF"; $PORTS[98] = "TACNEWS";
X$PORTS[99] = "METAGRAM"; $PORTS[101] = "HOSTNAME"; $PORTS[102] = "ISO-TSAP";
X$PORTS[103] = "X400"; $PORTS[104] = "X400-SND"; $PORTS[105] = "CSNET-NS";
X$PORTS[107] = "RTELNET"; $PORTS[109] = "POP2"; $PORTS[111] = "SUNRPC";
X$PORTS[113] = "AUTH"; $PORTS[115] = "SFTP"; $PORTS[117] = "UUCP-PATH";
X$PORTS[119] = "NNTP"; $PORTS[121] = "ERPC"; $PORTS[123] = "NTP";
X$PORTS[125] = "LOCUS-MAP"; $PORTS[127] = "LOCUS-CON"; $PORTS[129] = "PWDGEN";
X$PORTS[130] = "CISCO-FNA"; $PORTS[131] = "CISCO-TNA"; 
X$PORTS[132] = "CISCO-SYS"; $PORTS[133] = "STATSRV"; $PORTS[134] = "INGRES-NET";
X$PORTS[135] = "LOC-SRV"; $PORTS[136] = "PROFILE"; $PORTS[137] = "NETBIOS-NS";
X$PORTS[138] = "NETBIOS-DGM"; $PORTS[139] = "NETBIOS-SSN"; 
X$PORTS[140] = "EMFIS-DATA"; $PORTS[141] = "EMFIS-CNTL"; $PORTS[142] = "BL-IDM";
X@QR = ("query", "response");
X@OPCODE = ("QUERY", "IQUERY", "STATUS");
X@AA = ("Non-Authoritive", "Authoritive");
X@TC = ("Not Truncated", "Truncated");
X@RD = ("Don't recurse", "Do Recurse");
X@RA = ("No recursion", "Has recursion");
X@RCODE = ("No error", "Format error", "Server Failure", "Name error",
X    "Not implemented", "Refused");
X@QTYPE = ("", "A", "NS", "MD", "MF", "CNAME", "SOA", "MB", "MG", "MR",
X "NULL", "WKS", "PTR", "HINFO", "MINFO", "MX", "TXT");
X$QTYPE[252] = "AXFR";
X$QTYPE[253] = "MAILB";
X$QTYPE[254] = "MAILA";
X$QTYPE[255] = "ANY";
X@QCLASS = ("", "Internet", "CSNET", "CHAOS", "HESIOD");
X$QCLASS[255] = "ANY";
X@PROTOCOL = ("", "ICMP", "IGMP", "GGP", "", "ST", "TCP", "UCL", "EGP",
X  "IGP", "BBN-RCC-MON", "NVP-II", "PUP", "ARGUS", "EMCON", "XNET", "CHAOS",
X  "UDP", "MUX", "DCN-MEAS", "HMP", "PRM", "XNS-IDP", "TRUNK1", "TRUNK2",
X  "LEAF1", "LEAF2", "RDP", "IRTP", "ISO-TP4", "NETBLT", "MFE-NSP", "MERIT-INP",
X  "SEP");
X$PROTOCOL[62] = "CFTP";
X$PROTOCOL[64] = "SAT-EXPAK";
X$PROTOCOL[65] = "MIT-SUBNET";
X$PROTOCOL[66] = "RVD";
X$PROTOCOL[67] = "IPPC";
X$PROTOCOL[69] = "SAT-MON";
X$PROTOCOL[71] = "IPCV";
X$PROTOCOL[76] = "BR-SAT-MON";
X$PROTOCOL[78] = "WB-MON";
X$PROTOCOL[79] = "WB-EXPAK";
X$question = 1;
X$question = 1 if (defined($opt_a));
X$question = 2 if (defined($opt_n));
X$question = 3 if (defined($opt_d));
X$question = 4 if (defined($opt_f));
X$question = 5 if (defined($opt_c));
X$question = 6 if (defined($opt_s));
X$question = 7 if (defined($opt_b));
X$question = 8 if (defined($opt_g));
X$question = 9 if (defined($opt_r));
X$question = 10 if (defined($opt_0));
X$question = 11 if (defined($opt_w));
X$question = 12 if (defined($opt_p));
X$question = 13 if (defined($opt_h));
X$question = 14 if (defined($opt_m));
X$question = 15 if (defined($opt_x));
X$question = 16 if (defined($opt_t));
X$question = 255 if (defined($opt_e));
X
Xif ($server =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/) {
X  $saddr = pack("CCCC", $1, $2, $3, $4);
X}
Xelsif (!(($name, $aliases, $type, $len, $saddr) = gethostbyname($server))) {
X  $saddr = &resolver($server) || ((print "No such host\n"), return);
X}
X
X$sin = pack($sockaddr, 2, $port, $saddr);
X$head = pack('S6', 319, 256, 1, 0, 0, 0);
X
Xsocket(SERVER, 2, 1, 0) || die "socket: $!";
Xconnect(SERVER, $sin) || die "connect: $!";
X
Xselect(SERVER); $| = 1; select(STDOUT); $| = 1;
X
X$len = 12;
X@names = split('\.', $hostname);
Xforeach $arg (@names) {
X  $len += 1 + length($arg);
X}
X$len += 5;
Xprint SERVER pack('S', $len);
Xprint SERVER $head;
Xforeach $arg (@names) {
X  print SERVER pack('C', length($arg));
X  print SERVER $arg;
X}
Xprint SERVER pack('C', 0);
Xprint SERVER pack('S2', $question, 1);
X
Xread(SERVER, $len, 2);
Xread(SERVER, $response, unpack('S', $len));
Xclose SERVER;
X
Xprint "Record length: ", unpack('S', $len), "\n";
X@shead = unpack('S6', $response);
Xprint "
XID: $shead[0]	QR: $QR[($shead[1] & 0x8000) >> 15]
XOpcode: $OPCODE[($shead[1] & 0x7800) >> 11]
XAA: $AA[($shead[1] & 0x0400) >> 10]	TC: $TC[($shead[1] & 0x0200) >> 9]
XRD: $RD[($shead[1] & 0x0100) >> 8]	RA: $RA[($shead[1] & 0x0080) >> 7]
XRCODE: $RCODE[$shead[1] & 0x000F]
XQcount: $shead[2]   Acount: $shead[3] Ncount: $shead[4] Mcount: $shead[5]
X";
X
X$in = 12;
X$ans = $shead[2];
Xwhile ($ans > 0) {
X  print "\nQUESTION:\nhostname:";
X  &label();
X  $qtype = substr($response, $in, 2); $in += 2;
X  print "qtype: $QTYPE[unpack('S', $qtype)]   ";
X  $qclass = substr($response, $in, 2); $in += 2;
X  print "qclass: $QCLASS[unpack('S', $qclass)]\n";
X}
Xcontinue {
X  $ans--;
X}
X
X$ans = $shead[3];
Xwhile ($ans > 0) {
X  print "\nANSWER Name:";
X  &label();
X  $type = substr($response, $in, 2); $in += 2;
X  print "type: $QTYPE[unpack('S', $type)]   ";
X  $class = substr($response, $in, 2); $in += 2;
X  print "class: $QCLASS[unpack('S', $class)]   ";
X  $ttl = substr($response, $in, 4); $in += 4;
X  print "ttl: ", unpack('I', $ttl), "  ";
X  $rdlength = substr($response, $in, 2); $in += 2;
X  $rdata = substr($response, $in, unpack('n', $rdlength));
X  &process();
X}
Xcontinue {
X  $ans--;
X}
X
X$ans = $shead[4];
Xwhile ($ans > 0) {
X  print "\nAuthority Name:";
X  &label();
X  $type = substr($response, $in, 2); $in += 2;
X  print "type: $QTYPE[unpack('S', $type)]   ";
X  $class = substr($response, $in, 2); $in += 2;
X  print "class: $QCLASS[unpack('S', $class)]   ";
X  $ttl = substr($response, $in, 4); $in += 4;
X  print "ttl: ", unpack('I', $ttl), "  ";
X  $rdlength = substr($response, $in, 2); $in += 2;
X  $rdata = substr($response, $in, unpack('n', $rdlength));
X  &process();
X}
Xcontinue {
X  $ans--;
X}
X
X$ans = $shead[5];
Xwhile ($ans > 0) {
X  print "\nAdditional Name:";
X  &label();
X  $type = substr($response, $in, 2); $in += 2;
X  print "type: $QTYPE[unpack('S', $type)]   ";
X  $class = substr($response, $in, 2); $in += 2;
X  print "class: $QCLASS[unpack('S', $class)]   ";
X  $ttl = substr($response, $in, 4); $in += 4;
X  print "ttl: ", unpack('I', $ttl), "  ";
X  $rdlength = substr($response, $in, 2); $in += 2;
X  $rdata = substr($response, $in, unpack('n', $rdlength));
X  &process();
X}
Xcontinue {
X  $ans--;
X}
X
X
Xsub label {
X  $qname = "";
X  $c = substr($response, $in, 1); $in++;
X  $offset = $in;
X  $forward = 1;
X  loop: while ($c ne "\000") {
X    $cc = ord($c);
X    if (($cc & 0xc0) == 0xc0) {
X      if ($forward) {
X        $forward = 0;
X        $in = $offset + 1;
X      }
X      $offset = ($cc - 192) * 256 + ord(substr($response, $offset, 1));
X    }
X    else {
X      $qname = $qname . substr($response, $offset, $cc) . "."; $offset += $cc;
X    }
X    $c = substr($response, $offset, 1); $offset++;
X  }
X  if ($forward) {
X    $in = $offset;
X  }
X  chop($qname);
X  print "$qname\n";
X}
X
Xsub process {
X  $RR = unpack('S', $type);
X  if ($RR == 1) {
X    print "\nhost address: ";
X    @host = unpack('C4', $rdata);
X    print "$host[0].$host[1].$host[2].$host[3]\n";
X    $in += 4;
X  }
X  elsif ($RR == 5) {
X    print "\ncanonical name: ";
X    &label();
X  }
X  elsif ($RR == 7) {
X    print "\nMail box: ";
X    &label();
X  }
X  elsif ($RR ==13) {
X    print "\nHinfo: ";
X    $len = substr($response, $in, 1); $in++;
X    $CPU = substr($response, $in, ord($len)); $in += ord($len);
X    $len = substr($response, $in, 1); $in++;
X    $OS = substr($response, $in, ord($len)); $in += ord($len);
X    print "CPU: $CPU   OS: $OS\n";
X  }
X  elsif ($RR == 8) {
X    print "\nMail group: ";
X    &label();
X  }
X  elsif ($RR == 14) {
X    print "\nMinfo: mailing list box: ";
X    &label();
X    print "mailing list error box: ";
X    &label();
X  }
X  elsif ($RR == 9) {
X    print "\nrename mail box:";
X    &label();
X  }
X  elsif ($RR == 4) {
X    print "\nmail forwarder: ";
X    &label();
X  }
X  elsif ($RR == 3) {
X    print "\nmail destination: ";
X    &label();
X  }
X  elsif ($RR == 15) {
X    print "\nMail box exchange: ";
X    $prefer = unpack("n", substr($response, $in, 2)); $in += 2;
X    print "preference: $prefer\n";
X    print "exchange: ";
X    &label();
X  }
X  elsif ($RR == 10) {
X    print "\nNull \n ";
X    $in += unpack('n', $rdlength);
X  }
X  elsif ($RR == 2) {
X    print "\nName server:";
X    &label();
X  }
X  elsif ($RR == 12) {
X    print "\nPointer:";
X    &label();
X  }
X  elsif ($RR == 6) {
X    print "\nSOA:\n";
X    print "Name server:";
X    &label();
X    print "Admin.: ";
X    &label();
X    $serial = substr($response, $in, 4); $in += 4;
X    $refresh = substr($response, $in, 4); $in += 4;
X    $retry = substr($response, $in, 4); $in += 4;
X    $expire = substr($response, $in, 4); $in += 4;
X    $minimum = substr($response, $in, 4); $in += 4;
X    print "serial: ", unpack('N', $serial), " ";
X    print "refresh: ", unpack('N', $refresh), " ";
X    print "retry: ", unpack('N', $retry), " ";
X    print "expire: ", unpack('N', $expire), " ";
X    print "mininum: ", unpack('N', $minimum), "\n";
X  }
X  elsif ($RR == 16) {
X    $limit = $in + unpack('n', $rdlength);
X    print "\nText:\n";
X    while ($in < $limit) {
X      $len = substr($response, $in, 1); $in++;
X      $string = substr($response, $in, ord($len)); $in += ord($len);
X      print "    $string\n";
X    }
X  }
X  elsif ($RR == 11) {
X    $limit = $in + unpack('n', $rdlength);
X    $ip = substr($response, $in, 4); $in += 4;
X    $protocol = substr($response, $in, 1); $in++;
X    $bitmap = substr($response, $in, $limit - $in);
X    $in = $limit;
X    print "\nSupported service:\n";
X    print "protocol: $PROTOCOL[ord($protocol)]   IP address:";
X    &ipaddr($ip);
X    print "Protocols:\n";
X    &protocols();
X  }
X}
X
Xsub ipaddr {
X  local(@host) = unpack('C4', $_[0]);
X  print "$host[0].$host[1].$host[2].$host[3]\n";
X}
X
Xsub protocols {
X  local($i, $j, $k);
X  $k = length($bitmap);
X  @portsnum = unpack('n10', $bitmap);
X  for ($i = 0; $i <= $k; $i++) {
X    for ($j = 0; $j < 16; $j++) {
X      if (($portsnum[$i] & $bits[$j]) != 0) {
X        print "$PORTS[$i * 16 + $j] ";
X      }
X    }
X  }
X  print "\n";
X}
SHAR_EOF
if test 11243 -ne "`wc -c < 'pns'`"
then
	echo shar: error transmitting "'pns'" '(should have been 11243 characters)'
fi
fi
if test -f 'pns.doc'
then
	echo shar: will not over-write existing file "'pns.doc'"
else
	echo x - 'pns.doc'
	sed 's/^X//' >'pns.doc' << 'SHAR_EOF'
X# Copyright 1990 Khun Yee Fung <clipper@csd.uwo.ca>
X#
X# Permission to use, copy, modify, and distribute, this software and its
X# documentation for any purpose is hereby granted without fee, provided that
X# the above copyright notice appear in all copies and that both that
X# copyright notice and this permission notice appear in supporting
X# documentation, and that the name of the copyright holders be used in
X# advertising or publicity pertaining to distribution of the software with
X# specific, written prior permission, and that no fee is charged for further
X# distribution of this software, or any modifications thereof.  The copyright
X# holder make no representations about the suitability of this software for
X# any purpose.  It is provided "as is" without express or implied warranty.
X#
X# THE COPYRIGHT HOLDER DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
X# INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO
X# EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR
X# CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE,
X# DATA, PROFITS, QPA OR GPA, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE 
X# OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X# PERFORMANCE OF THIS SOFTWARE.
X
Xpns [-A servername] [option] hostname
X
Xpns, a domain name server query program, has the following options:
X
X
X-A [servername]
X	use servername as the name server, the default is ria.ccs.uwo.ca
X-a
X	ask for the IP address of hostname
X-n
X	ask for authoritative name server for hostname
X-d
X	obselete
X-f
X	obselete
X-c
X	ask for the canonical name of hostname
X-s
X	ask for SOA for the hostname
X-b
X	experimental
X-g
X	experimental
X-r
X	experimental
X-0
X	experimental
X-w
X	well known services query
X-p
X	domain name pointer
X-h
X	ask for host information
X-m
X	mailing list information
X-x
X	mail exchange information
X-t
X	text string
X-e
X	ask for everything
X
XWish list:
X	- multiple questions in the same query.
SHAR_EOF
if test 1967 -ne "`wc -c < 'pns.doc'`"
then
	echo shar: error transmitting "'pns.doc'" '(should have been 1967 characters)'
fi
fi
echo Done
exit 0
----
In Real life: Khun Yee Fung    clipper@csd.uwo.ca (Internet) 
Alternative: 4054_3267@UWOVAX.BITNET
UUCP: ...!{ihnp4|decvax|seismo}!{watmath|utzoo}!julian!csd!clipper
Department of Computer Science
Middlesex College
The University of Western Ontario
London, Ontario, N6A 5B7  CANADA