;;; -*- Mode: Common-Lisp; Package: DOMAIN-NAME-SYSTEM; Base: 10.; Patch-File: T -*-
;;; Patch file for DOMAINS version 2.2
;;; Reason: (1) Fixed get-domain-name-hairy to handle compression correctly.
;;; (2) Fixed decode-data-for-describe to handle "all" types.
;;; Written 31-Jul-88 00:56:12 by Victor,
;;; while running on George Ballantine from band LOD2
;;; With IO 3.47, PATHNAME 3.17, FILE 3.16, SYSTEM 3.114, METER 3.7, SERIAL 3.2, CHAOSNET 3.25,
;;;  ETHERNET 3.4, GC 3.25, IMAGEN 3.0, MAIL-DAEMON 3.8, NETWORK-SUPPORT 3.21, PROFILE 3.7,
;;;  SUGGESTIONS 3.7, UCL 3.4, ZWEI 3.45, STREAMER-TAPE 3.20, DEBUG-TOOLS 3.7, FONT-EDITOR 3.2,
;;;  GLOSSARY 3.1, INPUT-EDITOR 3.0, MAIL-READER 3.23, NAMESPACE-EDITOR 3.7, NVRAM 3.6,
;;;  TELNET 3.8, TV 3.34, NAMESPACE 3.15, COMPILER 3.35, PRINTER 3.10, SYSLOG 3.1,
;;;  VT100 3.15, VISIDOC 1.0, IP 2.77, RPC 3.2, NFS 3.2, Experimental NFS-PATCHES 2.0,
;;;  Experimental SYSTEM-PATCHES 2.80, GRAPHICS-WINDOW 3.5, GED 3.5, TREE 3.0, VISIDOC-SERVER 1.0,
;;;  Experimental ICU-DOCS 10.0, Experimental TCP-IMAGEN 9.1, Experimental NAME-DRAGON 2.1,
;;;  Experimental ICU-LIBRARY 9.1, Experimental TEXINFO 4.1, Experimental SYSTEM-ENHANCEMENTS 14.4,
;;;  Experimental DOMAINS 2.1,  microcode 469, Band Name: 3.114 w Visidoc, 880503/Victor

#!C
; From file ACCESSORS.LISP#> VICTOR.NETWORK.DNS; JJ:
#10R DOMAIN-NAME-SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "DOMAIN-NAME-SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "John: VICTOR.NETWORK.DNS; ACCESSORS.#"



(defun get-domain-name-hairy (pkt start-index)
  (do* ((i start-index)
	(slen (aref pkt i) (aref pkt i))
	(domain nil))
       ((zerop slen)
	(nreverse domain))
    (cond ((< slen 64)
	   (push (coerce (subseq pkt (+ i 1) (+ i 1 slen)) 'string) domain)
	   (incf i (1+ slen)))
	  ((= (ldb (byte 2 6) slen) #b11)	;Pointer
	   (let ((offset (dpb 0 (byte 2 14) (16b-ref pkt i))))
	     (let ((domain-name (get-domain-name-hairy pkt offset)))
	       (return (append (nreverse domain) domain-name))
	       )))
	  (t (error "Undefined length field in label: ~b" slen)))))

))

#!C
; From file ACCESSORS.LISP#> VICTOR.NETWORK.DNS; JJ:
#10R DOMAIN-NAME-SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "DOMAIN-NAME-SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "John: VICTOR.NETWORK.DNS; ACCESSORS.#"



(defun decode-data-for-describe (pkt start len type class)
  (cond ((= type *type-canonical-name*)
	 (get-domain-name pkt start))
	((= type *type-host-info*)
	 (cons (get-character-string pkt start)
	       (get-character-string pkt (+ start (8b-ref pkt start) 1))))
	((= type *type-mailbox*)
	 (get-domain-name pkt start))
	((= type *type-mail-destination*)
	 (get-domain-name pkt start))
	((= type *type-mail-forwarder*)
	 (get-domain-name pkt start))
	((= type *type-mail-group*)
	 (get-domain-name pkt start))
	((= type *type-mail-info*)
	 (let ((resp-dom-len (domain-name-field-length pkt start)))
	   (cons (get-domain-name pkt start)
		 (get-domain-name pkt (+ start resp-dom-len)))))
	((= type *type-mail-rename*)
	 (get-domain-name pkt start))
	((= type *type-mail-exchange*)
	 (cons (16b-ref pkt start)
	       (get-domain-name pkt (+ start 2))))
	((= type *type-null*)
	 (subseq pkt start (+ start len)))
	((= type *type-name-server*)
	 (get-domain-name pkt start))
	((= type *type-pointer*)
	 (get-domain-name pkt start))
	((= type *type-start-of-authority*)
	 (let* ((mname-len (domain-name-field-length pkt start))
		(rname-len (domain-name-field-length pkt (+ start mname-len))))
	   (list (get-domain-name pkt start)	;MNAME
		 (get-domain-name pkt (+ start mname-len))	;RNAME
		 (32b-ref pkt (+ start mname-len rname-len))	;SERIAL
		 (32b-ref pkt (+ start mname-len rname-len 4))	;REFRESH
		 (32b-ref pkt (+ start mname-len rname-len 4 4))	;RETRY
		 (32b-ref pkt (+ start mname-len rname-len 4 4 4))	;EXPIRE
		 (32b-ref pkt (+ start mname-len rname-len 4 4 4 4))	;MINIMUM
		 )))
	((= type *type-text*)
	 (do ((data nil)
	      (s start (+ s 1 (8b-ref pkt s)))
	      (e (+ start len)))
	     ((>= s e) (nreverse data))
	   (push (get-character-string pkt s) data)))
	((and (= type *type-address*)
	      (= class *class-internet*))
	 (format nil "~d.~d.~d.~d"
		 (8b-ref pkt start) (8b-ref pkt (+ start 1)) (8b-ref pkt (+ start 2)) (8b-ref pkt (+ start 3))))
	((and (= type *type-well-known-service*)
	      (= class *class-internet*))
	 (list (format nil "~d.~d.~d.~d"
		       (8b-ref pkt start) (8b-ref pkt (+ start 1)) (8b-ref pkt (+ start 2)) (8b-ref pkt (+ start 3)))
	       (8b-ref pkt (+ start 4))
	       (let ((bytes nil))
		 (dotimes (i (- len 4) (nreverse bytes))
		   (push (8b-ref pkt (+ start 4 i 1)) bytes)))))
	(t (warn "~&>>Warning:  Unknown type/class combination in ~s: ~d/~d" 'decode-data-for-describe type class)
	   (subseq pkt start (+ start len)))))
))