;;; -*- Mode: Common-Lisp; Package: zwei; Base: 10.; Patch-File: T -*-

;;; Reason: Fixes WRITE-MAIL-FILE-BUFFER. It needs to delete the old version of the file when renaming the mail file in order to save the current buffer. Also fixes MAIL-STREAM-OUT to work properly with the microExplorer.

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1988 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 11/30/88 06:46:04 by BERGER,
;;; while running on ARIES from band LOD1
;;; With SYSTEM 5.9, VIRTUAL-MEMORY 5.5, EH 5.3, MICRONET 5.5, LOCAL-FILE 5.0, BASIC-PATHNAME 5.2,
;;;  NETWORK-SUPPORT-COLD 5.1, BASIC-NAMESPACE 5.6, NETWORK-NAMESPACE 5.0, DISK-IO 5.9,
;;;  DISK-LABEL 5.1, BASIC-FILE 5.3, MAC-PATHNAME 5.0, NETWORK-PATHNAME 5.0, COMPILER 5.1,
;;;  MAKE-SYSTEM 5.2, TV 5.21, DATALINK 5.7, CHAOSNET 5.6, GC 5.3, MEMORY-AUX 5.1,
;;;  NVRAM 5.1, SYSLOG 5.0, STREAMER-TAPE 5.6, UCL 5.0, INPUT-EDITOR 5.0, METER 5.0,
;;;  ZWEI 5.9, DEBUG-TOOLS 5.1, NETWORK-SUPPORT 5.0, NETWORK-SERVICE 5.0, DATALINK-DISPLAYS 5.0,
;;;  FONT-EDITOR 5.0, SERIAL 5.0, PRINTER 5.11, PRINTER-TYPES 5.2, IMAGEN 5.1, SUGGESTIONS 5.0,
;;;  MAIL-DAEMON 5.1, MAIL-READER 5.3, TELNET 5.1, VT100 5.0, Experimental NAMESPACE-EDITOR 5.1,
;;;  PROFILE 5.1, VISIDOC 5.4, Experimental BUG 10.2, IP 3.33, VISIDOC-SERVER 5.2,
;;;  DECNET 1.45,  microcode 398, Band Name: Pre 5.0 +1p 9/23 +visidoc

#!C
; From file FILE.LISP#> MAIL-READER; sys:
#10R ZWEI#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "ZWEI"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "sys: MAIL-READER; FILE.É#É"


(defun WRITE-MAIL-FILE-BUFFER (pathname buffer &optional (in-background *numeric-arg-p*))
  "Write mail BUFFER to PATHNAME in the style specified by the mail buffer's file format.  If IN-BACKGROUND is T,
write the file using a separate process."
  
  (setq buffer (mail-file-buffer-of buffer))
  (unless (memeq (buffer-mail-file-format buffer) *writable-mail-file-formats*)
    (barf "~A is a ~A format mail file.~%This format can be read but not written."
	  buffer (buffer-mail-file-format buffer)))
  (let ((owner (get-mail-option buffer :owner)))
    (unless (or (null owner)
		(lisp:search user-id owner :test #'string-equal))
      (barf "~&This mail file belongs to ~A.  Not writing." owner)))	; Maybe just ask for confirmation?
  (unless pathname
    (setq pathname (buffer-pathname buffer)))
  (when (and (null (buffer-file-id buffer)) (null pathname))
    (barf "The buffer ~A is not associated with a file." (buffer-name buffer)))
  (when (stringp pathname)
    (setq pathname (parse-namestring pathname)))
  
  (let ((process (get buffer :background-save-process)))
    (when process
      (cond ((yes-or-no-p "~&A background save is in progress for ~A~%Do you want to abort the background process?"
			  buffer)
	     ;; Kill the process and wait fot its unwind protects to run.
	     (send process :reset :always)		
	     (unless 
	       (process-wait-with-timeout "Background Cleanup" (* 60 60)
					  #'(lambda (buffer) (null (get buffer :background-save-process)))
					  buffer)
	       ;; After a minute, Nuke it and continue.
	       (send process :kill))
	     (format *query-io* "~&Background save aborted."))
	    (t
	     (format *query-io* "~&Cannot do save until background process is complete or aborted.")
	     (return-from write-mail-file-buffer)))))
  
  ;; Always open the file in foreground -- want errors to happen now, not in background.
  (let ((close-flag :abort)
	(file-format (buffer-mail-file-format buffer))
	out-stream)
    (cond
      ((typep pathname 'fs:lispm-pathname) () )	;10-24-88 DAB
      ((eq (send pathname :version) :unspecific)	; Versionless filesystem, eg, Unix.
       ;;  Append to the right-hand end, wherever it is.
       (let ((rename-pathname (if (eq (send pathname :type) :unspecific)
				  (send pathname :new-name (string-append (send pathname :raw-name)
									  *backup-file-append-string*))
				  (send pathname :new-type (string-append (send pathname :raw-type)
									  *backup-file-append-string*)))))
	 (condition-case (err)
	   (progn
	    (when (probe-file rename-pathname) ;11-30-88 DAB delete old version ,if there is one.
	      (delete-file rename-pathname))
	    (multiple-value-bind (nil nil new-path)
		(rename-file pathname rename-pathname)
	      (format *query-io* "~&Existing mail file renamed to ~A" new-path))
	    )
	   ;;  Check for file-already-exists error - Needed for chaos server on Unix spr#6436 - nn 09/30/87
	   (fs:rename-to-existing-file  ;; dlc 
	    (condition-case (err)
		(progn
		 (send (truename rename-pathname) :delete-and-expunge t)
		 (multiple-value-bind (nil nil new-path)
		     (rename-file pathname rename-pathname)
		   (format *query-io* "~&Existing mail file renamed to ~A" new-path)))
	      ((sys:network-error fs:file-error)
	       (format *query-io* "~&Couldn't make a backup by renaming:  ~A." err)
	       (unless (yes-or-no-p "Save mail file anyway?")
		 (format *query-io* "Save aborted.")
		 (return-from write-mail-file-buffer)))
	      ))
	   ;;  Trap other file errors or network errors  - nn
	   (fs:file-not-found ())		;05-23-88 DAB
	   ((sys:network-error fs:file-error)
	    (format *query-io* "~&Couldn't make a backup by renaming:  ~A." err)
	    (unless (yes-or-no-p "Save mail file anyway?")
	      (format *query-io* "Save aborted.")
	      (return-from  write-mail-file-buffer)))))))

    (unwind-protect
	(progn
	  (file-retry-new-pathname (pathname fs:file-lookup-error system:network-error)
	    (setq out-stream (open pathname :direction :output :if-exists :new-version :characters t)))
	  
	  (cond (in-background
		 (setf (get buffer :background-save-process)
		       (process-run-function '(:name "Save Mail File" :priority -5)
					     #'mail-stream-out file-format buffer pathname out-stream t))
		 (setq close-flag :dont)
		 (format *query-io* "~&Proceed.  Writing ~A in background." (send out-stream :truename)))
		(t
		 (mail-stream-out file-format buffer pathname out-stream)
		 (setq close-flag :dont)
		 (print-file-written out-stream))))
      (when (and (streamp out-stream) (neq close-flag :dont))
	(close out-stream :abort close-flag)))))



(defun MAIL-STREAM-OUT (file-format buffer pathname out-stream &optional in-background)
  
  (let ((close-flag :abort)
	(tick *tick*)
	(*mail-background-p* in-background))
    (unwind-protect
	(progn
	  ;; Save off current tick so we know if buffer changes while saving
	  (setf (get buffer :start-mail-file-save-tick) tick)
	  (with-buffer-lock (buffer)
	    (send buffer :write-mail-file-start file-format out-stream))
	  (dolist (msg (message-list buffer))
	    (with-message-lock (msg)
	      (send msg :write-message-start file-format out-stream)
	      (send msg :write-message-headers file-format out-stream)
	      (send msg :write-message-body file-format out-stream)
	      (send msg :write-message-end file-format out-stream)))
	  (send buffer :write-mail-file-end file-format out-stream)
	  (close out-stream)
	  (setq close-flag :dont)
	  ;; writing to another file will not cause buffer name to change
	  (when (eq pathname (buffer-pathname buffer))
	    ;;(set-buffer-pathname pathname buffer)
	    (set-buffer-file-id buffer
				(if (and (typep pathname 'fs:mac-pathname)   ;09-19-88 DAB
					 (not (eq (send pathname :host) si:local-host)))
				    ;;This is a kludge but necessary because NFS on the microexplorer changes
				    ;;the creation date at close time. Chaosnet will return the time when the file is 
				    ;;opened. 09-19-88 DAB
				    (with-open-file (x  pathname :direction nil :error nil :characters t)
				      (send x :info))
				    (SEND out-STREAM :INFO))
				))
	  ;; We set the file tick at the time save began in case user modified buffer
	  ;; since then (e.g. during background save)
	  (setf (buffer-tick buffer) tick)
	  (delete-old-mail-files pathname)
	  (delete-old-inboxes buffer))
      (when (and (streamp out-stream) (neq close-flag :dont))
	(setf (get buffer :start-mail-file-save-tick) nil)
	(send out-stream :close close-flag))
      (setf (get buffer :background-save-process) nil))))

))
