;;; -*- 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.

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

;;; Message descriptors...

(defflavor message-descriptor
	   (number			;;; The number of the message
	    (header nil)		;;; The header string for the message
	    (body nil)			;;; The body of the message
	    mailbox-name		;;; The mailbox name we came from
	    mailstream			;;; The stream pointing to the mailbox
	    (selected-p nil)		;;; Is true if the message is selected
	    (all-items nil)		;;; A list of window items for me
	    (ready-to-recompute nil)	;;; True when we must recompute display
	    (flags-used-for-display nil);;; The flag list used to compute header
	   )
	   ()
  :Initable-Instance-Variables
  :Settable-Instance-Variables
  :Gettable-Instance-Variables
  (:Documentation
"A descriptor for a message object.  Used to deal with
computing the displayed representation of the message
in header windows and to keep track of the window items
for the message.
"
  )
)

(defmethod (Message-Descriptor :After :Set-Number) (to)
  (setq header nil)
  (loop for (item window) in all-items
	for (-ignore- outer-array) = item
	for scroll-entry = (aref outer-array 0)
	do (setf (tv:scroll-entry-args scroll-entry) (list to))
	   (setf (tv:scroll-entry-data scroll-entry) self)
	   (setf (third (tv:scroll-entry-mouse-info scroll-entry)) self)
	   (setf (aref (send window :Value-Array) to) self)
  )
)

(defmethod format-header-date
	   ((value (eql :Date)) message-number message-flags message-date
	    message-from message-to message-subject message-length-in-chars
	    day month year date-mode-args
	   )
"A method for formatting the date of a message in a header display
for the :date display type.
"
  (ignore message-number message-flags message-from message-to
	  message-subject message-length-in-chars message-date date-mode-args
  )
  (format t "~?"
	  (get *yw-date-print-mode* 'time:date-format)
	  (list day month (time:month-string month :short)
		nil (mod year 100.)
	  )
  )
)

(defmethod format-header-date
	   ((value (eql :Date-And-Time))
	    message-number message-flags message-date
	    message-from message-to message-subject message-length-in-chars
	    day month year date-mode-args
	   )
"A method for formatting the date of a message in a header display
for the :date-and-time display type.
"
  (ignore message-number message-flags message-from message-to
	  message-subject message-length-in-chars message-date date-mode-args
	  day month year
  )
  (time:print-universal-time (time:parse-universal-time message-date))
)

(defmethod format-header-date
	   ((value (eql :Brief-Date))
	    message-number message-flags message-date
	    message-from message-to message-subject message-length-in-chars
	    day month year date-mode-args
	   )
"A method for formatting the date of a message in a header display
for the :brief-date display type.
"
  (ignore message-number message-flags message-from message-to
	  message-subject message-length-in-chars message-date date-mode-args
	  day month year
  )
  (format t "~?" (get *yw-date-print-mode* 'time:date-format) date-mode-args)
)

(defmethod format-header-date
	   ((value t)
	    message-number message-flags message-date
	    message-from message-to message-subject message-length-in-chars
	    day month year date-mode-args
	   )
"A method for formatting the date of a message in a header display
for a display type that we don't understand.
"
  (ignore message-number message-flags message-from message-to
	  message-subject message-length-in-chars message-date date-mode-args
	  day month year
  )
  (format t "???~S" value)
)

(defmethod format-header-date
	   ((value (eql :Date-or-Time))
	    message-number message-flags message-date
	    message-from message-to message-subject message-length-in-chars
	    day month year date-mode-args
	   )
"A method for formatting the date of a message in a header display
for the :date-or-time display type.
"
  (ignore message-number message-flags message-from message-to
	  message-subject message-length-in-chars message-date date-mode-args
	  day month year
  )
  (multiple-value-bind (ignore ignore ignore d m y)
      (time:decode-universal-time (time:get-universal-time))
    (if (and (= d day) (= m month) (= y year))
	(multiple-value-bind (ignore mins hours)
	    (time:decode-universal-time
	      (safe-parse-universal-time message-date)
	    )
	  (format t "~2,'0,D:~2,'0,D " hours mins)
	)
	(format t "~?" (get *yw-date-print-mode* 'time:date-format)
		date-mode-args
	)
    )
  )
)

(defmethod yw-header-display-spec
       ((type (eql :Date))
        value message-number message-flags message-date message-from message-to
	message-subject message-length-in-chars day month year date-mode-args
       )
"The function that deals with the printing of dates in message displays."
  (ignore message-number message-flags message-from message-to
	  message-subject message-length-in-chars
  )
  (typecase value
    (keyword
     (format-header-date value message-number message-flags message-date
			 message-from message-to message-subject
			 message-length-in-chars day month year date-mode-args
     )
    )
    ((or cons number)
     (maybe-max-width "~V?" value (get *yw-date-print-mode* 'time:date-format)
			date-mode-args
     )
    )
    (otherwise (format t "???~S" value))
  )
)

(defun coerce-to-thin-string (string)
"Given a string makes sure that it is a thin string."
  (let ((thin-string (make-string (length string))))
       (loop for i from 0 below (length string) do
	     (setf (aref thin-string i) (int-char (char-code (aref string i))))
       )
       thin-string
  )
)

(defun extract-tabs (string start)
"Starting at the start index Start, the string has all absolute tab denotations
removed.  Thus \"foo200bar\" -> \"foobar\".
"
  (let ((start-index (string-search-set '(#\) string start)))
       (if start-index
	   (let ((stop-index
		   (string-search-set '(#\) string (+ 1 start-index))
		 )
		)
		(if start-index
		    (string-append (subseq string start-index (+ 1 stop-index))
				   (extract-tabs string (+ 1 stop-index))
		    )
		    ""
		)
	   )
	   ""
       )
  )
)

(defun without-tabs-1 (string &optional (start 0))
"Starting at the start index Start, the string has all absolute tab denotations
removed.  Thus \"foo200bar\" -> \"foobar\".
"
  (let ((start-index (string-search-set '(#\) string start)))
       (if start-index
	   (let ((stop-index
		   (string-search-set '(#\) string (+ 1 start-index))
		 )
		)
		(if stop-index
		    (string-append (subseq string start start-index)
				   (without-tabs-1 string (+ 1 stop-index))
		    )
		    (subseq string start)
		)
	   )
	   (subseq string start)
       )
  )
)

(defun without-tabs (string &optional (length 20) (trailer "..."))
"Returns a string like String only with any tabbing removed.  It
abbreviates the string to max-length Length and sticks trailer at the
end if it was too long.
"
  (let ((string (Without-Tabs-1 string 0)))
       (if (> (length string) length)
	   (string-append (subseq string 0 length) trailer)
	   string
       )
  )
)

(defun parse-out-tabs (string stop-point)
"If string has any tabs between the beginning and stop-point then we strip
them out and return the original string and the stripped string, otherwise we
return the original string.
"
  (declare (values original-string untabified-string-or-nil-if-no-tabs))
  (if (string-search-set '(#\) string stop-point)
      (values string (extract-tabs string 0))
      (values string nil)
  )
)

(defun maybe-max-width (format-string arg &rest format-args)
"Formats the format string with the format args to standard-output using
arg.  If arg is not a cons then it is used as the first arg to format.  If it is
a cons then it is of the form:
   (arg-for-format &optional (max-length) :font <font-specifier>)
"
  (if (consp arg)
      (let ((font (second (member :Font arg))))
	   (let ((string
		   (apply #'format nil format-string (first arg) format-args)
		 )
		)
	        (let ((stop-point (if (numberp (second arg))
				      (min (second arg) (length string))
				      (length string)
				  )
		      )
		     )
		     (multiple-value-bind (string tabs)
			 (Parse-Out-Tabs string stop-point)
		       (send *standard-output* :String-Out
			     (if font (tv:fontify-string string font) string)  0
			     stop-point
		       )
		       (if tabs (send *standard-output* :String-Out tabs) nil)
		     )
		)
		
	   )
      )
      (apply #'format t format-string arg format-args)
  )
)

(defmethod Yw-Header-Display-Spec
       ((type (eql :Number))
        value message-number message-flags message-date message-from message-to
	message-subject message-length-in-chars day month year date-mode-args
       )
"The function that deals with the printing of message numbers
in message displays.
"
  (ignore message-from message-flags message-date message-subject message-to
	  message-length-in-chars day month year date-mode-args
  )
  (maybe-max-width *message-header-number-format-string* value message-number)
)

(defmethod Yw-Header-Display-Spec
       ((type (eql :From))
        value message-number message-flags message-date message-from message-to
	message-subject message-length-in-chars day month year date-mode-args
       )
"The function that deals with the printing of from fields
in message displays.
"
  (ignore message-number message-flags message-date message-subject
	  message-length-in-chars day month year date-mode-args message-to
  )
  (if (and *show-to-address-if-from-me-p*
	   (Address-Object-For-User-Address)
	   (let ((address (send self :Address-Object)))
	        (yw-zwei:address-equal (Address-Object-For-User-Address)
				       address
		)
	   )
      )
      (maybe-max-width (string-append "-> " *message-header-from-format-string*)
		       value message-to
      )
      (maybe-max-width *message-header-from-format-string* value message-from)
  )
)

(defmethod Yw-Header-Display-Spec
       ((type (eql :Subject))
        value message-number message-flags message-date message-from message-to
	message-subject message-length-in-chars day month year date-mode-args
       )
"The function that deals with the printing of subject fields
in message displays.
"
  (ignore message-number message-flags message-date message-from
	  message-length-in-chars day month year date-mode-args message-to
  )
  (maybe-max-width *message-header-subject-format-string* value message-subject)
)

(defmethod Yw-Header-Display-Spec
       ((type (eql :Keywords))
        value message-number message-flags message-date message-from message-to
	message-subject message-length-in-chars day month year date-mode-args
       )
"The function that deals with the printing of message keywords
in message displays.
"
  (ignore message-number message-flags message-date message-from message-subject
	  message-length-in-chars day month year date-mode-args message-to
  )
  (maybe-max-width *message-header-keywords-format-string*
		   value
		   (header-keywords-string
		     (set-difference Message-Flags *System-Flags*)
		   )
  )
)

(defmethod Yw-Header-Display-Spec
       ((type (eql :flags))
        value message-number message-flags message-date message-from message-to
	message-subject message-length-in-chars day month year date-mode-args
       )
"The function that deals with the printing of the message flags
in message displays.
"
  (ignore message-number message-flags message-date message-from message-subject
	  message-length-in-chars day month year date-mode-args message-to
  )
  (Maybe-Max-Width *message-header-flags-format-string*
		   value (with-output-to-string (stream)
			   (header-flags-string message-flags stream)
			 )
  )
)

(defmethod Yw-Header-Display-Spec
       ((type (eql :Length))
        value message-number message-flags message-date message-from message-to
	message-subject message-length-in-chars day month year date-mode-args
       )
"The function that deals with the printing of the message length
in message displays.
"
  (ignore message-number message-flags message-date message-from message-subject
	  message-length-in-chars day month year date-mode-args message-to
	  value
  )
  (Maybe-Max-Width *message-header-length-format-string*
		   (if (keywordp value)
		       *Message-Header-Message-Length-Field-Width*
		       value
		   )
		   Message-length-in-chars
  )
)

(defmethod Yw-Header-Display-Spec
       ((type (eql :Space))
        value message-number message-flags message-date message-from message-to
	message-subject message-length-in-chars day month year date-mode-args
       )
"The function that deals with the printing of a simple space
in message displays.  The value of Value must be either a number for the
number of spaces, T for one space or Nil for no space.
"
  (ignore message-number message-flags message-date message-from message-subject
	  message-length-in-chars day month year date-mode-args message-to
  )
  (if value
      (if (numberp value)
	  (format t "~VA" value " ")
	  (princ " ")
	  nil
      )
  )
)

(defmethod Yw-Header-Display-Spec
       ((type t)
        value message-number message-flags message-date message-from message-to
	message-subject message-length-in-chars day month year date-mode-args
       )
"The default method for header item display."
  (ignore message-number message-flags message-date message-from message-subject
	  message-length-in-chars day month year date-mode-args message-to
  )
  (format t "?~S, ~S" type value)
)

(defun safe-parse-universal-time (string)
"Parses a universal time out of String in a manner that won't result in
barfage.  If it really cannot compute a UT from the string it picks today.
"
  (or (loop for start from 0 below (length string)
	    for result = (loop for end from (length string) downto 0
			       for results = (catch-error
					       (multiple-value-list
						 (time:parse-universal-time
						   string start end
						 )
					       )
					       nil
					     )
			       when results
			       return results
			 )
	    when result
	    return (values-list result)
      )
      (time:parse-universal-time "Today")
  )
)

(defun format-header (message-number message-flags message-date message-from
		      message-to message-subject message-length-in-chars
		     )
"Formats the string for the display of a header in a summary window.  It does
this by using the specs in *Message-Header-Display-Specification*.  It puts a
space between each element unless it finds a :space spec entry.  If it finds
one of these it does whatever the :space specs says instead.
"
  (tv:with-output-to-fat-string (*standard-output*)
;  (with-output-to-string (*standard-output*)
    (multiple-value-bind (ignore ignore ignore day month year)
	(time:decode-universal-time (safe-parse-universal-time message-date))
      (multiple-value-bind (ignore ignore ignore ignore ignore this-year)
	  (time:decode-universal-time (time:parse-universal-time "today"))
	(with-stack-list (date-mode-args
			   day month (time:month-string month :short)
			   (= year this-year) (mod year 100.)
			 )
	  (loop for (key value) on *Message-Header-Display-Specification*
		By #'cddr
		for rest on *Message-Header-Display-Specification* by #'cddr
		Do (Yw-Header-Display-Spec key
		     value message-number
		     message-flags message-date message-from
		     message-to message-subject
		     message-length-in-chars day
		     month year date-mode-args
		     )
		     (if (or (equal key :Space)
			     (equal (third rest) :Space)
			 )
			 nil
			 (princ " ")
		     )
	  )
	)
      )
    )
  )
)



(defmethod (Message-Descriptor :get-and-format-header) ()
"Causes the header string to be computed.  If we have no envelope then
we return :wait, which is an indication to the caller to get the envelope
and wait for the response before retrying.  If we have the envelope then
if calls format-header to compute the header string.
"
  (let ((MsgRecord
	  (MAP-Elt (GETSTREAMPROP MailStream :MessageArray) number MailStream)
	)
       )
       (let ((maybe-subject (Cache-SubjectText MsgRecord))
	     (maybe-msgfrom (Cache-FromText MsgRecord))
	     (maybe-msgto   (Cache-ToText MsgRecord))
	    )
	    (if (equal (cache-envelope msgrecord) :Unbound)
		:Wait
		(let ((MsgSubject 
			(or (and (not (equal maybe-subject :Unbound))
				 maybe-subject
			    )
			    (MAP-Fetch-Subject MailStream number)
			)
		      )
		      (Message-number (Cache-Msg# MsgRecord))
		      (MsgFlags (copy-tree (Cache-Flags MsgRecord)))
		      (MsgChars (Cache-RFC822Size MsgRecord))
		      (msgfrom
			(or (and (not (equal maybe-msgfrom :Unbound))
				 maybe-msgfrom
			    )
			    (MAP-Fetch-From MailStream (Cache-Msg# MsgRecord))
			)
		      )
		      (msgto
			(or (and (not (equal maybe-msgto :Unbound))
				 maybe-msgto
			    )
			    (MAP-Fetch-To MailStream (Cache-Msg# MsgRecord))
			)
		      )
		     )
		     (setq flags-used-for-display msgflags)
		     (format-header message-number
				    MsgFlags
				    (Cache-InternalDate MsgRecord)
				    msgfrom msgto msgsubject msgchars
		     )
		)
	    )
       )
  )
)

(defmethod (Message-Descriptor :prepare-for-display) ()
"Prepares a descriptor for display.  Makes sure that we have already got and
cached the subject and from fields.
"
  (let ((MsgRecord
	  (MAP-Elt (getstreamprop MailStream :MessageArray) number MailStream)
	)
       )
       (let ((val (Cache-SubjectText MsgRecord)))
	    (or (and (not (equal val :Unbound)) val)
		(MAP-Fetch-Subject MailStream number)
	    )
       )
       (let ((val (Cache-FromText MsgRecord)))
	    (or (and (not (equal val :Unbound)) val)
		(MAP-Fetch-From MailStream number)
	    )
       )
       (setq ready-to-recompute t)
  )
)

(defmethod (Message-Descriptor :Print-Self) (stream depth slashify)
"A print method for message descriptors.  If we are princing then we want
to produce a header string for a header window.  If we don't have an envelope
yet then :get-and-format-header will return :wait.  This tells us to print out
the *waiting-message-text* instead and tell the task server to wait and'
recompute the header later.
"
  (declare (special *edit-server*))
  (ignore depth)
  (multiple-value-bind (result error-p)
    (catch-error
      (progn (if (boundp-in-instance self 'number)
		 (if (or slashify *dbg*)
		     (if header
			 (format stream "#<Msg ~A, ~>" number
				 (list header t (Without-Tabs header))
			 )
			 (format stream "#<Msg ~A, ~>" number)
		     )
		     (if (and header (not ready-to-recompute))
			 (format stream "~A" header)
			 (let ((result (send self :Get-And-Format-Header)))
			      (if (equal result :Wait)
				  (progn (setq header
					       (string-append
						 *waiting-message-text*
						 (format nil "~D" number)
					       )
					 )
					 (format stream "~A" header)
					 (send *edit-server* :Put-Task
					       :print-self
					       (list :Preempt-Header self)
					 )
				  )
				  (progn (setq header result)
					 (format stream "~A" header)
				  )
			      )
			      (setq ready-to-recompute nil)
			 )
		     )
		 )
		 (format stream "#<Msg {Uninitialised}>")
	     )
	   nil
      )
      nil
    )
    (if error-p
	(format stream "#<Error printing header>")
	result
    )
  )
)

(defmethod (message-descriptor :On-Screen-P) (window item)
"Is true if the item is visible on the screen in window (some items may have
scrolled off the top of the window.
"
  (let ((image (send window :screen-image)))
       (send window :Resynch nil)
       (loop for i from 0 to (- (first (array-dimensions image)) 1)
	     when (equal (second item) (aref image i 0))
	     do (return i)
	     finally (return nil)
       )
  )
)

(defmethod (message-descriptor :add-item) (item window)
"Adds a new item that is in the window to our list of items for self."
  (let ((items (remove-if #'(lambda (x) (equal window (second x))) all-items)))
       (setq all-items (cons (list item window) items))
  )
)

(defmethod (message-descriptor :remove-item) (item window)
"Removes an item that prints on Window from our list of items."
  (setq all-items (remove (list item window) all-items :Test #'equal))
)

(defmethod (message-descriptor :redisplay) (window item)
"Redisplays self on all interested windows."
  (let ((*force-redisplay* t))
       (declare (special *force-redisplay*))
       (send window :Redisplay-Selected-Items (list (second item)))
  )
)

(defmethod (message-descriptor :really-set-selected-p) (to)
"Sets the selected-p slot to true."
  (setq selected-p to)
  to
)

(defmethod (Message-Descriptor :refresh-on-all-windows) ()
"Refreshes self on all of the windows that have an item for it, being clever
about only redisplaying on the windows that actually have us visible.
"
  (let ((windows (all-summary-windows-for-message self)))
       (loop for entry in windows
	     when (and (lexpr-send self :On-Screen-P entry)
		       (equal self (message-from-display-item (second entry)))
		  )
	     do (send (message-from-display-item (second entry))
		      :Really-Set-Selected-P selected-p
		)
		(lexpr-send self :Redisplay entry)
       )
  )
)

(defmethod (Message-Descriptor :Add-Selected-Type) (type)
"Adds a selected type to the set of selected types in selected-p."
  (send self :Set-Selected-P (fs:cons-new type (send self :Selected-P)))
)

(defmethod (Message-Descriptor :Remove-Selected-Type) (type)
"Removes a selected type from the set of selected types in selected-p."
  (send self :Set-Selected-P (remove type (send self :Selected-P)))
)

(defwhopper (message-descriptor :set-selected-p) (&rest args)
"Makes sure that we redisplay ourselves when our selected status changes."
  (let ((old selected-p))
       (lexpr-continue-whopper args)
       (if (not (equal old selected-p))
	   (send self :Refresh-On-All-Windows)
	   nil
       )
  )
)

(defmethod (Message-Descriptor :Address-Object)
	   (&optional (accessor 'envelope-from))
  (let ((env (cache-envelope (cache-entry-of number mailstream))))
       (and (is-present env)
	    (let ((from (funcall accessor env)))
	         (and (is-present from)
		      from
		      (progn (parse-address-component (first from))
			     (address-address-object (first from))
		      )
		 )
	    )
       )
  )
)

(defun all-summary-windows-for-message (message)
"Returns the list of summary windows that have an item for Message."
   (let ((result nil))
        (loop for item in (send message :all-Items)
	      for window = (second item)
	      when (or (not window) (not (send window :Mailstream)))
	      do (lexpr-send message :Remove-Item item)
	      unless (or (or (not window) (not (send window :Mailstream)))
			 (member (second item) result)
		     )
	      do (push (list (second item) (first item)) result)
	)
	result
   )
)

(defun address-object-for-user-address ()
  (or *address-object-for-user-address*
      (and mail:*user-mail-address*
	   (progn (setq *address-object-for-user-address*
			(mail:parse-address mail:*user-mail-address*)
		  )
		  *address-object-for-user-address*
	   )
      )
  )
)