home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-osu / bind.pl < prev    next >
Encoding:
Internet Message Format  |  1991-01-28  |  7.2 KB
  1. Path: tut.cis.ohio-state.edu!magnus.ircc.ohio-state.edu!zaphod.mps.ohio-state.edu!sdd.hp.com!decwrl!mcnc!uvaarpa!mmdf
  2. From: marc@athena.mit.edu (Marc Horowitz)
  3. Newsgroups: comp.lang.perl
  4. Subject: Re: DNS routines for perl
  5. Message-ID: <1991Jan28.182042.5440@uvaarpa.Virginia.EDU>
  6. Date: 28 Jan 91 18:20:42 GMT
  7. Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System)
  8. Reply-To: marc@mit.edu
  9. Organization: The Internet
  10. Lines: 276
  11.  
  12. I have an implementation of DNS in perl.  It's major drawback is that
  13. I never got around to implementing routines to print the answers in
  14. useful ways.  I also have some gross kludges 'cause perl doesn't have
  15. real multi dimensional arrays (you can't do nested foreach's
  16. meaningfully on $foo{$a,$b}).  And it should be a package.  In
  17. general, it's something I just hacked up, and never really finished.
  18. Cleaning it up shouldn't be too hard, I don't think.  It should be
  19. better than starting from scratch.  Well, here it is, whatever it's
  20. worth.  One request: If you hack on it, send me back the changes so I
  21. can use them, too.
  22.  
  23.         Marc
  24.  
  25. P.S.  The test queries at the end are Hesiod queries.  If you don't
  26. know what Hesiod is, don't worry.  This should work fine for normal IN
  27. queries.
  28.  
  29. --snip--
  30. #!/mit/watchmaker/@sys/perl
  31.  
  32. # $Id: bind.pl,v 1.3 90/06/07 02:50:06 marc Exp Locker: marc $
  33.  
  34. # hack! hack!  This is to confuse the byte order stuff in arpa/nameser.h
  35. # nothing here depends on it anyway.
  36.  
  37. sub vax {1;}
  38.  
  39. #  This all probably belongs in a package.  Tomorrow.
  40.  
  41. do 'sys/socket.h' || die "can\'t do sys/socket.h: $@";
  42. do 'arpa/nameser.h' || die "can\'t do arpa/nameser.h: $@";
  43.  
  44. # who? me? kludge?
  45.  
  46. undef &vax;
  47.  
  48. # This is gross, but at least it's portable.
  49. @qtype[&T_A] = "A";
  50. @qtype[&T_NS] = "NS";
  51. @qtype[&T_MD] = "MD";
  52. @qtype[&T_MF] = "MF";
  53. @qtype[&T_CNAME] = "CNAME";
  54. @qtype[&T_SOA] = "SOA";
  55. @qtype[&T_MB] = "MB";
  56. @qtype[&T_MG] = "MG";
  57. @qtype[&T_MR] = "MR";
  58. @qtype[&T_NULL] = "NULL";
  59. @qtype[&T_WKS] = "WKS";
  60. @qtype[&T_PTR] = "PTR";
  61. @qtype[&T_HINFO] = "HINFO";
  62. @qtype[&T_MINFO] = "MINFO";
  63. @qtype[&T_MX] = "MX";
  64. @qtype[&T_TXT] = "TXT";
  65. @qtype[&T_UINFO] = "UINFO";
  66. @qtype[&T_UID] = "UID";
  67. @qtype[&T_GID] = "GID";
  68. @qtype[&T_UNSPEC] = "UNSPEC";
  69. @qtype[&T_UNSPECA] = "UNSPECA";
  70. @qtype[&T_AXFR] = "AXFR";
  71. @qtype[&T_MAILB] = "MAILB";
  72. @qtype[&T_MAILA] = "MAILA";
  73. @qtype[&T_ANY] = "ANY";
  74.  
  75. @qclass[&C_IN] = "IN";
  76. @qclass[&C_CHAOS] = "CHAOS";
  77. @qclass[&C_HS] = "HS";
  78. @qclass[&C_ANY] = "ANY";
  79.  
  80. sub qtype_strtonum {
  81.     local($num) = eval("&T_$_[0];");
  82.  
  83.     if ($@ == "") {
  84.         return($num);
  85.     } else {
  86.         return(-1);
  87.     }
  88. }
  89.  
  90. sub qclass_strtonum {
  91.     local($num) = eval("&C_$_[0];");
  92.  
  93.     if ($@ == "") {
  94.         return($num);
  95.     } else {
  96.         return(-1);
  97.     }
  98. }
  99.  
  100. sub qtype_numtostr {
  101.     local($str) = @qtype[$_[0]];
  102.  
  103.     if (defined($str)) {
  104.         return($str);
  105.     } else {
  106.         return("$_[0]");
  107.     }
  108. }
  109.  
  110. sub qclass_numtostr {
  111.     local($str) = @qclass[$_[0]];
  112.  
  113.     if (defined($str)) {
  114.         return($str);
  115.     } else {
  116.         return("$_[0]");
  117.     }
  118. }
  119.  
  120. sub res_init { # @_ = ($nameserver)
  121.     local($saddr,$port,$sin,$sock,$fd);
  122.  
  123.     if ($_[0] =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/) {
  124.         $saddr = pack("CCCC", $1, $2, $3, $4);
  125.     } else {
  126. #        $saddr = ((gethostbyname($_[0]))[4] || return(undefined));
  127.         $saddr = (gethostbyname($_[0]))[4];
  128.     }
  129.  
  130.     # lossage in /etc/services.  hardcode for now.
  131.     #$port = (getservbyname("nameserver","tcp"))[2];
  132.     $port = 53;
  133.  
  134.     $sin = pack("S n a4 x8",&AF_INET,$port,$saddr);
  135.     socket(NS, &AF_INET, &SOCK_STREAM, &PF_UNSPEC) || die "socket: $!";
  136.     connect(NS, $sin) || die "connect: $!";
  137.  
  138.     $fd = select(NS); $| = 1;   # set nonbufferred
  139.     select($fd);
  140. }
  141.  
  142. sub res_mkquery { # @_ = ($name,$type,$class,$id)
  143.     local($question);
  144.  
  145.     $question = pack("n6",$_[3],0x0100,1,0,0,0);    # header
  146.     $question .= &unparse_name($_[0]);
  147.     $question .= pack("n n",&qtype_strtonum($_[1]),    # query
  148.               &qclass_strtonum($_[2]));
  149. }
  150.     
  151. sub unparse_name {
  152.     local($label,$labellen,$str);
  153.     $str = "";
  154.     foreach $label (split(/\./,$_[0])) {
  155.         $labellen = length($label);
  156.         $str .= pack("Ca$labellen",$labellen,$label);
  157.     }
  158.     $str .= pack("C",0);        # root octet
  159. }
  160.  
  161. sub res_send { # @_ = ($socket,$query)
  162.     local($fd,$packet) = ($_[0],pack("n",length($_[1])).$_[1]);
  163.     print $fd $packet;
  164.     &get_response($_[0]);
  165. }
  166.  
  167. # response format:
  168. # [0] = id
  169. # [1] = authoritative
  170. # [2] = recursion available
  171. # [3] = query name
  172. # [4] = query class
  173. # [5] = query type
  174. # [6] = start of answers
  175. # [7] = end of answers
  176. # [8] = start of authority records
  177. # [9] = end of authority records
  178. # [10] = start of add'l records
  179. # [11] = end of add'l records
  180. # [12] ...   resource records (in multiples of 5)
  181.  
  182. sub get_response { # @_ = ($socket)
  183.     local($len,$response,@resp);
  184.     read($_[0],$len,2);
  185.     read($_[0],$response,unpack("n",$len));
  186.     @ptr = ($response,0);
  187.  
  188.     $header = &next_chars(12,@ptr);
  189.     ($id,$bits,$qdcount,$ancount,$nscount,$adcount) = unpack("n6",$header);
  190.     $auth = ($bits >> 10) & 0x01;
  191.     $recurse = ($bits >> 8) & 0x01;
  192.     $rrs = $ancount+$nscount+$adcount;
  193.     @resp = ($id,$auth,$recurse);        #         [0..2]
  194.  
  195.     push(@resp,&parse_name(@ptr));                # QNAME    [3]
  196.     push(@resp,&qtype_numtostr(&next_netshort(@ptr)));    # QTYPE    [4]
  197.     push(@resp,&qclass_numtostr(&next_netshort(@ptr)));    # QCLASS[5]
  198.  
  199.     push(@resp,12);                #         [6]
  200.     push(@resp,@resp[$#resp]+5*$ancount-1);    #        [7]
  201.  
  202.     push(@resp,@resp[$#resp]+1);        #        [8]
  203.     push(@resp,@resp[$#resp]+5*$nscount-1);    #        [9]
  204.  
  205.     push(@resp,@resp[$#resp]+1);        #        [10]
  206.     push(@resp,@resp[$#resp]+5*$adcount-1);    #        [11]
  207.  
  208.     for ($i = 0 ; $i < $rrs ; $i++) {
  209.         @resp = (@resp,&parse_rrbits(@ptr));
  210.     }
  211.     return(@resp);
  212. }
  213.  
  214. sub parse_name {
  215.     local($name,$ch,$ptr,@temp) = ("",substr($_[0],$_[1],1));
  216.     while (ord($ch = substr($_[0],$_[1],1)) != 0) {
  217.         # Message compression (RFC1035 4.1.4)
  218.         if (ord($ch) >= 0xc0) {
  219.             $ptr = &next_netshort(@_) & 0x3fff;
  220.             @temp=($_[0],$ptr);
  221.             $name .= "".&parse_name(@temp);
  222.             return($name);
  223.         }
  224.         $name .= &next_str(@_).".";
  225.     }
  226.     &next_chars(1,@_);    # move past \0
  227.     if ($name eq "") { $name = ".."; }
  228.     chop($name);  # remove trailing "."
  229.     return($name);
  230. }
  231.  
  232. sub parse_rrbits {
  233.     local(@rrec,$name,$rdlen);
  234.     @rrec = ();
  235.  
  236.     $name = &parse_name(@_);
  237.     # if NAME is an odd number of bytes, eat an extra byte
  238.     if (($name == "") || (length($name)%1 == 1)) {&next_chars(1,$_[0]);}
  239.     @rrec = ($name);            # NAME
  240.     push(@rrec,&qtype_numtostr(&next_netshort(@_)));    # TYPE
  241.     push(@rrec,&qclass_numtostr(&next_netshort(@_)));    # CLASS
  242.     push(@rrec,&next_netlong(@_));        # TTL (integer)
  243.  
  244.     $rdlen = &next_netshort(@_);
  245.     push(@rrec,&next_chars($rdlen,@_));    # RDATA
  246.     @rrec;
  247. }
  248.  
  249. sub next_netshort {unpack("n",&next_chars(2,@_));}
  250. sub next_netlong  {unpack("N",&next_chars(4,@_));}
  251.  
  252. # strips the first character-string from the argument, and returns it as a
  253. # perl string
  254. sub next_str {
  255.     local($cslen);
  256.     $cslen = unpack("C",&next_chars(1,@_));
  257.     &next_chars($cslen,@_);
  258. }
  259.  
  260. # takes returns the first $_[0] chars at position $_[2] in string $_[1]
  261. # and increments $_[2]
  262. sub next_chars {
  263.     local($len,$str) = (length($_[1]),$_[1]);
  264.     $_[2] += $_[0];
  265.     substr($_[1],$_[2]-$_[0],$_[0]);
  266. }
  267.  
  268. # ah!  something coherent.
  269.  
  270. #$ns = "16.129.224.205";
  271. $ns = "127.0.0.1";
  272. $nsport = &res_init($ns);
  273.  
  274. @qs = ("marc.passwd","marc.filsys","marc.grplist","beeblebrox.cluster",
  275.     "zephyr.sloc");
  276. #@qs = ("marc.filsys");
  277.  
  278. foreach $q (@qs) {
  279.     $query = &res_mkquery($q.".ns.athena.mit.edu.","ANY","ANY",0);
  280.  
  281.     @response = &res_send($nsport,$query);
  282.     @answers = @response[$response[6]..$response[7]];
  283.  
  284.     foreach $ans (@answers) { print "$ans\n"; }
  285. }
  286.  
  287. --snip--
  288.  
  289.