;;; -*- Mode: Common-Lisp; Package: DOMAIN-NAME-SYSTEM; Base: 10.; Patch-File: T -*-
;;; Written 31-Jul-88 03:12:43 by Victor,
;;; Reason: Made PARSE-DOMAIN handle the root correctly.
;;; 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, Experimental DOMAIN 2.2,  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 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 (loop with i = 0
		   for dot = (position #\. string :test #'char= :start i)
		   until (if (and dot (plusp dot))
			     (not (char= #\\ (char string (1- dot))))
			     t)
		   doing (setq i (1+ dot))
		   finally (return dot))
	     (loop with i = s
		   for dot = (position #\. string :test #'char= :start i)
		   until (if (and dot (plusp dot))
			     (not (char= #\\ (char string (1- dot))))
			     t)
		   doing (setq i (1+ dot))
		   finally (return 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))
	))))

))