;;; -*- Mode:Common-Lisp; Package:NSE; Base:10; Fonts:(COURIER TR12I TR12BI TR12 MEDFNTB); Patch-file:T -*-

;1 File name: NETWORK-MODE-EXPERT-EDITORS.LISP*
;1 Patches the Auto-update feature on the Services list to include my new services.*
;1 Started 8-4-1989 by Eric Karlson, UC-Berkeley under Robert Wilensky*
;1 Phone: (415) 642-9076, E-mail Address: karlson@ucbarpa.berkeley.edu*

(defun 4side-effect-for-addresses* ()
"2Modify the Services for this host if the user so desires.*"
  (declare (function side-effect-for-addresses () FIXNUM))
  ;1 Only do this for adding an address.*
  (when (eq *OPERATION* :delete-attribute)
    (return-from side-effect-for-addresses))

  (let* ((services-list (get-attribute-value *OBJECT* :services))
	 (addresses (copy-alist *VALUE*))
	 (old-addresses (copy-alist *VALUE*))
	 (start-bp (copy-bp (buffer-point *BUFFER*))))
    (declare (LIST services-list addresses old-addresses)
	     (T start-bp))

    ;1 These service lists can NOT be constants like '(:status :tcp :ip-status)*
    ;1 since our Explorer -> Symbolics NS transformation code changes these values.*

    ;1 ADD IP SERVICES*
    (when (and (second (assoc :ip addresses))
	       (not (member '(:file :tcp :ftp) services-list :test #'equal)))
      (dolist (new-group-member (list (list :exec :tcp-stream :unix-exec)
				      (list :file :tcp :ftp)
				      (list :login :tcp-stream :telnet)
				      (list :mail-to-user :tcp-stream :smtp)
				      (list :lispm-finger :udp :lispm-finger)
				      (list :lpd :tcp-stream :unix-lpd)
				      (list :shell :tcp-stream :unix-shell)
				      (list :show-users :tcp-stream :ascii-name)
				      (list :status :tcp :ip-status)
				      (list :time :udp :time-simple-msb)))
	(declare (LIST new-group-member))
	(nse:add-group-member :class (second *OBJECT*)
			      :object (object-name *OBJECT*)
			      :attribute :services
			      :new-group-member new-group-member
			      :buffer *BUFFER*)))
    ;1 ADD CHAOS SERVICES*
    (when (and (second (assoc :chaos addresses))
	       (not (member '(:file :chaos :qfile) services-list :test #'equal)))
      (dolist (new-group-member (list (list :exec :chaos-stream :chaos-exec)
				      (list :file :chaos :qfile)
				      (list :lispm-finger :chaos-simple :lispm-finger)
				      (list :login :chaos-stream :telnet)
				      (list :lpd :chaos-stream :chaos-lpd)
				      (list :mail-to-user :chaos-stream :mail)
				      (list :show-users :chaos-stream :name)
				      (list :status :chaos :chaos-status)
				      (list :time :chaos-simple :time-simple)
				      (list :uptime :chaos-simple :uptime-simple)))
	(declare (LIST new-group-member))
	(nse:add-group-member :class (second *OBJECT*)
			      :object (object-name *OBJECT*)
			      :attribute :services
			      :new-group-member new-group-member
			      :buffer *BUFFER*)))
    ;1 ADD DNA SERVICES*
    (when (and (second (assoc :dna addresses))
	       (not (member '(:status :dna :decnet-status) services-list :test #'equal)))
      (dolist (new-group-member (list (list :file :dna :dap)
				      (list :status :dna :decnet-status)))
	(declare (LIST new-group-member))
	(nse:add-group-member :class (second *OBJECT*)
			      :object (object-name *OBJECT*)
			      :attribute :services
			      :new-group-member new-group-member
			      :buffer *BUFFER*)))

    ;1 FORCE ADDRESS-LIST TO ONLY HAVE ONE ADDRESS PER ADDRESS-SPEC*
    ;1 EXAMPLE:  ((:CHAOS XX) (:CHAOS YY))  INSTEAD OF ((:CHAOS XX YY))*
    (dolist (address addresses)
      (declare (LIST address))
      (unless (eql (length address) 2)
	(when (> (length address) 2)
	  (setf addresses (delete address addresses :test #'equal))
	  (dolist (addr (rest address))
	    (declare (T addr))
	    (setf addresses (push-end (list (first address) addr) addresses))))))

    (unless (equal addresses old-addresses)
      (edit-attribute-or-group-attribute addresses :class (second *OBJECT*)
					 :object (object-name *OBJECT*)
					 :attribute :addresses
					 :buffer *BUFFER*))

    ;1 Add the (:gateway <protocol> :<protocol>-gateway) service if multiple addresses on <protocol>*
    (do ((addr (first addresses) (first addr-tail))
	 (addr-tail (rest addresses) (rest addr-tail))
	 new-group-member)
	((null addr-tail))
      (declare (T addr)
	       (LIST addr-tail new-group-member))
      (when (member addr addr-tail :test #'(lambda (a b) (eq (first a) (first b))))
	(setf new-group-member (list :gateway (first addr)
				     (intern (string-append (string (first addr)) "3-GATEWAY*") 'keyword)))
	(unless (member new-group-member services-list :test #'equal)
	  (nse:add-group-member :class (second *OBJECT*)
				:object (object-name *OBJECT*)
				:attribute :services
				:new-group-member new-group-member
				:buffer *BUFFER*))))
    
    (move-bp (buffer-point *buffer*) (beg-line start-bp))))