;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-
;;; Written 08/12/88 16:38:14 by Victor,
;;; Reason: Fixed PARSE-DOMAIN which was broken in the process of Common Lisp-purifying the stuff.
;;; while running on George Ballantine from band LOD1
;;; With SYSTEM 4.61, VIRTUAL-MEMORY 4.4, EH 4.5, MAKE-SYSTEM 4.5, MICRONET 4.5, LOCAL-FILE 4.1,
;;;  BASIC-PATHNAME 4.12, NETWORK-SUPPORT-COLD 4.1, NAMESPACE 4.22, NETWORK-NAMESPACE 4.2,
;;;  DISK-IO 4.13, DISK-LABEL 4.0, BASIC-FILE 4.7, MAC-PATHNAME 4.5, NETWORK-PATHNAME 4.1,
;;;  COMPILER 4.13, TV 4.85, DATALINK 4.14, CHAOSNET 4.18, GC 4.3, MEMORY-AUX 4.0,
;;;  NVRAM 4.6, SYSLOG 4.0, STREAMER-TAPE 4.4, UCL 4.1, INPUT-EDITOR 4.0, METER 4.3,
;;;  ZWEI 4.18, DEBUG-TOOLS 4.2, NETWORK-SUPPORT 4.5, NETWORK-SERVICE 4.0, DATALINK-DISPLAYS 4.0,
;;;  FONT-EDITOR 4.0, SERIAL 4.0, PRINTER 4.8, PRINTER-TYPES 4.2, IMAGEN 4.0, SUGGESTIONS 4.0,
;;;  MAIL-DAEMON 4.7, MAIL-READER 4.6, TELNET 4.1, VT100 4.6, NAMESPACE-EDITOR 4.5,
;;;  PROFILE 4.4, VISIDOC 4.5, IP 3.19, Experimental DOMAIN 3.0,  microcode 534, Band Name: Release 4.1 - 6/2

#!C
; From file ACCESSORS.LISP#> VICTOR.NETWORK.DNS; John-Jameson:
#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 parse-domain (string)
  (declare (values vector length))
  (let ((domain (make-array 64 :element-type '(unsigned-byte 8) :fill-pointer 0)))
    (do* ((s 0 (1+ e))
	  ;; Handle escaped dots.  This must be possible in a simpler way.
	  (e (let ((i 0))
	       (do ((dot (position #\. string :test #'char= :start i)))
		   ((if (and dot (plusp dot))
			(not (char= #\\ (char string (1- dot))))
			t)
		    dot)
		 (setq i (1+ dot))))
	     (let ((i s))
	       (do ((dot (position #\. string :test #'char= :start i)))
		   ((if (and dot (plusp dot))
			(not (char= #\\ (char string (1- dot))))
			t)
		    dot)
		 (setq i (1+ dot))))))
	((null e)
	 (let* ((end-domain (subseq string s e))
		(l (length end-domain))
		(f (fill-pointer domain)))
	   (unless (zerop l)
	     (warn "~&>>Warning: Domain name doesn't end with a \".\""))
	   (when (>= l 64)
	     (error "Label length exceeds 63: ~s" end-domain))
	   (vector-push-extend l domain)
	   (dotimes (i l)
	     (vector-push-extend (char string (+ i f)) domain))
	   (values domain (fill-pointer domain))))
      (let* ((subdomain (subseq string s e))
	     (l (length subdomain))
	     (f (fill-pointer domain)))
	(when (>= l 64)
	  (error "Label length exceeds 63: ~s" subdomain))
	(unless (zerop l)
	  (vector-push-extend l domain))
	(dotimes (i l)
	  (vector-push-extend (char string (+ i f)) domain))
	))))

))