;;; -*- Mode:Common-Lisp; Package:Yes-Way; Base:10 -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; This code was written by James Rice.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.

;;; The development of this software was assisted by the following grants:
;;; Biomedical Research Technology Program of the National Institutes
;;; of Health under grant RR-00785
;;; Information Systems Technologies office of the Defense Advanced
;;; Research Projects Agency under contract N00039-86-C0033.

;;; **********************************************************************

;-------------------------------------------------------------------------------

(defun parse-yw-init-file ()
"Finds a mailer window and makes sure that the yw init file has been parsed."
  (send (Get-Mail-Control-Window) :Ensure-Yw-Init-File-Parsed)
)

;-------------------------------------------------------------------------------
;;; YW init file parsing code.

(defun separator-position (separators line start)
"Returns the position of the next separator character in the line, starting at
start."
  (if separators
      (or (position (first separators) line :Start start :Test #'char-equal)
	  (separator-position (rest separators) line start)
      )
      nil
  )
)

(defun read-separated-list (separators line start)
"Reads a list of things from line that are separated by some type of separators,
maybe commas.  Start is the start index in the line for the read.
"
  (loop for (thing index)
	=  (let ((sep (separator-position separators line start)))
	        (let ((results (multiple-value-list
				 (yw-read-from-string line nil :Eof :Start start
						      :End sep
				 )
			       )
		      )
		     )
		     (if sep
			 (setq start (+ 1 sep))
			 (setq start (second results))
		     )
		     results
		)
	  )
	until (equal thing :Eof)
	collect thing
  )
)

(defmethod (Mail-Control-Window :read-comma-separated-list) (line start)
"Reads a list of things from line that are sepparated by commas."
  (read-separated-list '(#\,) line start)
)

(defmethod (Mail-Control-Window :parse-mminit-set) (line start)
"Is invoked when a SET command is parsed from the init file.  Line is the SET
command line and Start is the start index for our read, given that we have
already detected the SET command.
"
  (let ((*package* (find-package 'YW-Variables)))
       (multiple-value-bind (name index)
	   (yw-read-from-string line nil :Eof :Start start)
	 (if (or (not (symbolp name)) (equal name :Eof))
	     (Barf "Error parsing mminit line ~S" line)
	     (let ((list (send self :read-comma-separated-list line index)))
	          (setf (symbol-value name) list)
		  (values name list)
	     )
	 )
       )
  )
)

(defmethod (Mail-Control-Window :parse-mminit-define) (line start)
"Parses a DEFINE line from an MM init file.  Line is the line in question and
Start is the starting index after the DEFINE command for our parsing.  It parses
the definition and creates an entry in the alias list to mimic the definition.
"
  (let ((*package* (find-package 'YW-Variables)))
       (multiple-value-bind (name index)
	   (yw-read-from-string line nil :Eof :Start start)
	 (if (or (not (symbolp name)) (equal name :Eof))
	     (Barf "Error parsing mminit line ~S" line)
	     (progn (setf (symbol-value name)
			  (string-trim '(#\space) (subseq line index))
		    )
		    (let ((value (string-trim '(#\space)
					      (subseq line index)
				 )
			  )
			  (name-string
			         (string-trim '(#\space)
					      (subseq line start index)
				 )
			  )
			 )
		         (let ((addresses (mail:parse-all-addresses
					    value 0 nil nil :Address
					  )
			       )
			      )
			      (if addresses
				  (setq *address-alias-alist*
					(cons (list name-string
						    (if (rest addresses)
							addresses
							(first addresses)
						    )
					      )
					      (remove (assoc
							name
							*address-alias-alist*
							:Test #'string-equal
						      )
						      *address-alias-alist*
					      )
					)
				  )
				  nil
			      )
			 )
			 (first *address-alias-alist*)
		    )
	     )
	 )
       )
  )
)

(defmethod (Mail-Control-Window :Parse-Yw-Init-Line) (line)
"Parses a line called Line from an MM init file."
  (let ((*package* (find-package :Keyword)))
       (multiple-value-bind (operator index) (yw-read-from-string line nil :Eof)
	 (if (or (not (keywordp operator)) (equal operator :Eof))
	     (Barf "Error parsing mminit line ~S" line)
	     (case operator
	       (:Set (send self :parse-mminit-set line index))
	       (:Define (send self :parse-mminit-define line index))
	       (otherwise nil)
	     )
	 )
       )
  )
)

(defmethod (Mail-Control-Window :Get-Yw-Init-File-Name) ()
"The pathname for the user's mm init file."
  (make-pathname :Directory (Default-Mail-Server-User-Directory)
		 :Host *User-Host*
		 :Name ".MMINIT"
		 :Type :Unspecific
  )
)

(defmethod (Mail-Control-Window :Parse-Yw-Init-File) ()
"Forces the parsing of the user's MM init file on his prefered mail host."
  (with-open-file (stream (send self :get-yw-init-file-name) :Direction :Input)
    (let ((*readtable* *init-file-parsing-readtable*))
	 (loop for line = (read-line stream nil :Eof)
	       until (equal :Eof line)
	       do (let ((good-line (string-trim *whitespace-chars* line)))
		       (if (equal "" good-line)
			   nil
			   (pushnew (send self :parse-yw-init-line line)
				    *mm-init-info*
				    :Test #'equalp
			   )
		       )
		  )
	 )
    )
  )
)

(defmethod (Mail-Control-Window :Ensure-Yw-Init-File-Parsed) ()
"Makes sure that the user's mm init file has been parsed."
  (if *mm-init-info*
      t
      (progn (send self :parse-yw-init-file)
	     (if (not *mm-init-info*)
		 (setq *mm-init-info* t)
		 nil
	     )
      )
  )
)

;-------------------------------------------------------------------------------

;;; Address fasl dump stuff.

(defun Maybe-Save-Address-Database (&optional (force-p nil))
"Saves the address database if it is necessary.  Force-p forces the save."
  (with-address-database-locked (nil)
    (if (or force-p
	    (and *address-database-changed*
		 yw-zwei:*address-database-path*
		 (case *address-database-save-action*
		   (nil nil)
		   (:Query (y-or-n-p "~%Save address database?"))
		   (otherwise
		    (or (not (fboundp 'address-database-save-predicate))
			(funcall 'address-database-save-predicate)
		    )
		   )
		 )
	    )
	)
	(let ((*temp* *address-database*))
	     (declare (special *temp*))
	     (if (not *address-database-loaded*)
		 (Maybe-Load-Address-Database)
		 nil
	     )
	     (if (and *address-database-creation-date*
		      (not (equal *address-database-creation-date*
				  (get (second (fs:directory-list
						 yw-zwei:*address-database-path*
					       )
				       )
				       :Creation-Date
				  )
			   )
		      )
		 )
		 (progn (tv:notify tv:selected-window
			 "~&The address database has been modified ~
			    since ~&you read it.  The new version will be read ~
			    in before~&saving the address database to make the ~
			    new version~&consistent."
			)
			(Maybe-Load-Address-Database t)
		 )
		 nil
	     )
	     (if (and *address-database-creation-date*
		      (< (hash-table-count *address-database*) 20)
		      (> (file-length yw-zwei:*address-database-path*) 200)
		 )
		 ;;; This fix put in for Gruber.  The problem is that he would
		 ;;; use yw on a random machine, add addresses to the d/b
		 ;;; somehow and then this would get saved out over the real
		 ;;; one, trashing it.
		 (progn
		   (beep 'tv:notify)
		   (and (y-or-n-p
			 "~&The address database has been modified, ~%but I ~
                          suspect that your normal database has not been ~
                          loaded.~%Should I go ahead and load your address ~
                          database before saving?"
			 )
			 (Maybe-Load-Address-Database t)
		   )
		 )
		 nil
	     )
	     (progn
	       (tv:my-fasd-symbol-value yw-zwei:*address-database-path* '*temp*)
	     )
	     (setq *address-database-creation-date*
		   (get (second
			  (fs:directory-list yw-zwei:*address-database-path*)
			)
			:Creation-Date
		   )
	     )
	     (setq *address-database-changed* nil)
	)
	nil
    )
  )
)

(defun Maybe-Load-Address-Database (&optional (force-p nil) (lock-p t))
"Loads the address database if it has not been loaded yet."
  (with-address-database-locked (lock-p)
    (if (or force-p
	    (and (not *address-database-loaded*)
		 yw-zwei:*address-database-path*
		 (boundp 'yw-zwei:*address-database-path*)
		 (probe-file yw-zwei:*address-database-path*)
	    )
	)
	(let ((*temp* nil)
	      (was-updated *address-database-changed*)
	     )
	     (declare (special *temp*))
	     ;;;The act of fasloading the hash table will cause the addresses to
	     ;;;be put into the real address hash table.
	     (let ((*save-addresses-in-database-p* t))
	          ;;; We bind *save-addresses-in-database-p* so that they are
	          ;;; also entered into our hash table.
	          (load yw-zwei:*address-database-path* nil nil nil t)
	     )
	     (setq *address-database-loaded* t)
	     (setq *address-database-creation-date*
	       (get (second (fs:directory-list yw-zwei:*address-database-path*))
		    :Creation-Date
	       )
	     )
	     (setq *address-database-changed* was-updated)
	     (format-scroll-window nil
	       "~&Address database loaded.  ~D addresses found."
	       (hash-table-count *address-database*)
	     )
	)
	nil
    )
  )
)

(defmethod (mail:basic-address :Fasd-Form) ()
"Dumps a basic address to a file so that it can be reconstituted on read."
  Mail:
 `(let ((address
	  (mail:get-address-object 'basic-address
				   :local-part ',local-part
				   :domain ',domain
				   :comments ',comments
          )
	)
       )
       (send address :Set-Property-List ',sys:property-list)
       address
  )
)

(defmethod (mail:route-address :Fasd-Form) ()
"Dumps a route address to a file so that it can be reconstituted on read."
  mail:
 `(let ((address
	  (get-address-object 'route-address
			      :route ',route
			      :local-part ',local-part
			      :domain ',domain
			      :comments ',comments
          )
	)
       )
       (send address :Set-Property-List ',sys:property-list)
       address
  )
)

(defmethod (mail:named-address :Fasd-Form) ()
"Dumps a named address to a file so that it can be reconstituted on read."
  mail:
 `(let ((address
	  (get-address-object 'named-address
			      :name ',name
			      :route ',route
			      :local-part ',local-part
			      :domain ',domain
			      :comments ',comments
	  )
	)
       )
       (send address :Set-Property-List ',sys:property-list)
       address
  )
)

(defmethod (mail:group-address :Fasd-Form) ()
"Dumps a group address to a file so that it can be reconstituted on read."
  mail:
 `(let ((address
	  (get-address-object 'group-address
			      :name ',name
			      :address-list ',address-list
			      :comments ',comments
          )
	)
       )
       (send address :Set-Property-List ',sys:property-list)
       address
  )
)

;-------------------------------------------------------------------------------

;;; Load/save rule base.


(defun Maybe-Save-Rule-base (&optional (force-p nil))
"Checks to see whether the rule base needs to be saved and does so
 if necessary.
"
  (declare (special *rule-base-lock*))
  (with-rule-base-locked (nil)
    (if (or force-p (and *rule-base-changed* *rule-base-path*))
	(let ((*temp* *all-rule-sets*))
	     (declare (special *temp*))
	     (if (not *rule-base-loaded*)
		 (Maybe-Load-Rule-Base)
		 nil
	     )
	     (if (and *rule-base-creation-date*
		      (not (equal *rule-base-creation-date*
				  (get (second (fs:directory-list
						 *rule-base-path*
					       )
				       )
				       :Creation-Date
				  )
			   )
		      )
		 )
		 (progn (tv:notify tv:selected-window
			 "~&The rule base has been modified ~
			    since ~&you read it.  The new version will be read ~
			    in before~&saving the rule base to make the ~
			    new version~&consistent."
			)
			(Maybe-Load-Rule-base t)
		 )
		 nil
	     )
	     (progn (tv:my-fasd-symbol-value *rule-base-path* '*temp*))
	     (setq *rule-base-creation-date*
		   (get (second
			  (fs:directory-list *rule-base-path*)
			)
			:Creation-Date
		   )
	     )
	     (setq *rule-base-changed* nil)
	)
	nil
    )
  )
)

(defun Maybe-Load-Rule-base (&optional (force-p nil) (lock-p t))
"Checks to see whether the rule base needs to be loaded and does
 so if necessary.
"
  (declare (special *rule-base-lock*))
  (with-rule-base-locked (lock-p)
    (if (or force-p
	    (and (boundp '*rule-base-path*)
		 (not *rule-base-loaded*) *rule-base-path*
		 (probe-file *rule-base-path*)
	    )
	)
	(let ((*temp* nil)
	      (was-updated *rule-base-changed*)
	     )
	     (declare (special *temp*))
	     (load *rule-base-path* nil nil nil t)
	     (setq *rule-base-loaded* t)
	     (setq *rule-base-creation-date*
	       (get (second (fs:directory-list *rule-base-path*))
		    :Creation-Date
	       )
	     )
	     (setq *rule-base-changed* was-updated)
	     (loop for rb in *temp* do
		   (loop for Rule in (send rb :Rules) do
			 (pushnew Rule *all-rules*)
		   )
	     )
	     (format-scroll-window nil
	       "~&Rule base loaded.  ~D rule~P found." (length *all-rules*)
	       (length *all-rules*)
	     )
	)
	nil
    )
  )
)

;-------------------------------------------------------------------------------