;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for ZMail version 74.11
;;; Reason:
;;;  One more pass at the ZMAIL expunge behaviour...Last time, I *swear*.
;;; Written 20-Oct-88 14:33:11 by saz (David M.J. Saslav) at site Gigamos Cambridge
;;; while running on Wolfgang Amadeus Mozart from band 2
;;; with Experimental System 126.118, Experimental ZWEI 126.22, Experimental ZMail 74.10, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 8, 126.100 104.



; From modified file DJ: L.ZMAIL; COMNDS.LISP#599 at 20-Oct-88 14:33:12
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZMAIL; COMNDS  "

(DEFUN EXPUNGE-ZMAIL-BUFFER (ZMAIL-BUFFER &OPTIONAL (DELETED-MSGS T)
				    &AUX ARRAY INFS (*INTERVAL* *INTERVAL*))
  "Expunge ZMAIL-BUFFER, removing all messages marked as deleted.
If DELETED-MSGS is NIL, only remove messages that have been removed from their owning buffers.
After you expunge a file buffer, you should expunge all temporary buffers
 with DELETED-MSGS = NIL, but this function does not do that for you."
  (COND ((ZMAIL-BUFFER-DISK-P ZMAIL-BUFFER)
	 (SETQ *INTERVAL* (ZMAIL-DISK-BUFFER-INTERVAL ZMAIL-BUFFER))
	 (SETQ INFS (LOCF (NODE-INFERIORS *INTERVAL*)))
	 (FOREGROUND-BACKGROUND-FINISH ZMAIL-BUFFER)
	 (ZMAIL-BUFFER-DELETE-EXPIRED ZMAIL-BUFFER *DELETE-EXPIRED-MSGS*)
	 (AND *QUERY-BEFORE-EXPUNGE*
	      (ZMAIL-BUFFER-EXPUNGE-QUERY ZMAIL-BUFFER))))
  (SETQ ARRAY (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER))
  (DO ((NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))
       (I 0 (1+ I))
       (MSG))
      (( I NMSGS)
       (COND ((AND (PLUSP NMSGS) (ZMAIL-BUFFER-DISK-P ZMAIL-BUFFER))
	      ;; Kludge for babyl, make the last line of the file correct maybe.
	      (SEND ZMAIL-BUFFER :UPDATE-MSG-END (AREF ARRAY (1- NMSGS))))
	     ((AND (ZEROP NMSGS) (NOT (ZMAIL-BUFFER-DISK-P ZMAIL-BUFFER)))
	      ;; A temporary buffer goes away when it becomes empty.
	      (SEND ZMAIL-BUFFER :KILL))))
    ;; For speed, this does not call MSG-GET, which would parse the
    ;; message if need be.  If the message has never been parsed, it
    ;; probably isn't deleted.  Likewise, below it cannot be recent.
    (COND ((OR (EQ (MSG-PARSED-P (SETQ MSG (AREF ARRAY I))) :KILLED)
	       (AND DELETED-MSGS (GET (LOCF (MSG-STATUS MSG)) 'DELETED)))
	   (MSG-POINT-PDL-PURGE MSG (AND (NOT (EQ ZMAIL-BUFFER (MSG-MAIL-FILE-BUFFER MSG)))
					 ZMAIL-BUFFER))
	   (IF (EQ ZMAIL-BUFFER (MSG-MAIL-FILE-BUFFER MSG))
	       (LET ((REAL-INT (MSG-REAL-INTERVAL MSG)))
		 (UNLESS (EQ REAL-INT (CADR INFS))
		   (ZMAIL-ERROR "Node inferiors messed up, please report to BUG-ZMAIL"))
		 (DELETE-INTERVAL REAL-INT)
		 (UNCACHE-MSG-REFERENCES MSG)
		 ;; Now start really killing it.
		 (WITHOUT-INTERRUPTS
		   (RPLACD INFS (CDDR INFS))
		   (SETF (MSG-PARSED-P MSG) :KILLED)
		   (UNLESS (= (1+ I) NMSGS)
		     (%BLT (ALOC ARRAY (1+ I)) (ALOC ARRAY I)
			   (- NMSGS I 1) 1))
		   (DECF (FILL-POINTER ARRAY))
		   (DECF NMSGS)
		   (DECF I))	;Compensate for increment that DO-step will do.
		 ;; It's no disaster if these don't get done due to an abort.
		 (FLUSH-BP (INTERVAL-FIRST-BP REAL-INT))
		 (FLUSH-BP (INTERVAL-LAST-BP REAL-INT))
		 (LET ((INT (MSG-INTERVAL MSG)))
		   (FLUSH-BP (INTERVAL-FIRST-BP INT))
		   (FLUSH-BP (INTERVAL-LAST-BP INT))))
	     ;; Just remove the message from our array.
	     (WITHOUT-INTERRUPTS
	       (UNLESS (= (1+ I) NMSGS)
		 (%BLT (ALOC ARRAY (1+ I)) (ALOC ARRAY I)
		       (- NMSGS I 1) 1))
	       (DECF (FILL-POINTER ARRAY))
	       (DECF NMSGS)
	       (DECF I))))
	  (T
	   (COND ((EQ ZMAIL-BUFFER (MSG-MAIL-FILE-BUFFER MSG))
		  (AND (REMPROP (LOCF (MSG-STATUS MSG)) 'RECENT)
		       (SETF (MSG-TICK MSG) (TICK)))
		  (SETQ INFS (CDR INFS)))))))
  (COND ((EQ ZMAIL-BUFFER *ZMAIL-BUFFER*)
	 (SEND *SUMMARY-WINDOW* :NEED-FULL-REDISPLAY)
	 (ZMAIL-SELECT-MSG (COND ((ZEROP (ARRAY-ACTIVE-LENGTH ARRAY)) NIL)
				 ((OR (EQ (MSG-PARSED-P *MSG*) :KILLED)
				      (MSG-GET *MSG* 'DELETED))
				  (do* ((msg-no *msg-no* (1- msg-no))
				        (msg *msg* (aref array msg-no)))
				       ((zerop msg-no)
					;;in this case, all msgs before *msg*
					;;were deleted prior to the expunge,
					;;next clause searches forward thru msgs.
					nil)
				    (when (not (OR (EQ (MSG-PARSED-P MSG) :KILLED)
						   (MSG-GET MSG 'DELETED)))
				      (return msg))))
				 ;;note slightly differing logic here; from first
				 ;;clause we know that there are msgs, and from
				 ;;second clause we know that there are no previous
				 ;;msgs; therefore there must be future msgs...
				 (t (do* ((msg-no (1+ *msg-no*) (1+ msg-no))
					  (msg (aref array msg-no) (aref array msg-no)))
				       ((not (OR (EQ (MSG-PARSED-P *MSG*) :KILLED)
						 (MSG-GET *MSG* 'DELETED)))
					*msg*))))
			   T NIL))))

))