;;; -*- Mode:LISP; Readtable:CL; Base:10 -*- (DEFUN WRITE-BUFFER (BUFFER) "Write BUFFER to a file, reading filename in mini buffer." (LET ((PATHNAME (READ-DEFAULTED-PATHNAME (FORMAT NIL "Write buffer ~A to File:" (BUFFER-NAME BUFFER)) (PATHNAME-DEFAULTS *PATHNAME-DEFAULTS* BUFFER) NIL NIL :WRITE))) (WRITE-FILE-INTERNAL PATHNAME BUFFER)) DIS-NONE) (DEFCOM COM-WRITE-FILE "Write out the buffer to the specified file." () (WRITE-BUFFER *INTERVAL*) (MAYBE-DISPLAY-DIRECTORY :WRITE) DIS-NONE) ;; Copied from LAD: RELEASE-3.ZWEI; ZMACS.LISP#558 on 2-Oct-86 02:29:19 (DEFUN WRITE-FILE-INTERNAL (PATHNAME &OPTIONAL (BUFFER *INTERVAL*)) "Save BUFFER in file PATHNAME and mark it as visiting that file. If the file holds the current ODM node, handle it appropriately." (if (and (boundp '*current-gateway-buffer*) (eq buffer *current-gateway-buffer*) (fboundp 'write-file-internal-odm)) (write-file-internal-odm pathname buffer) (SEND BUFFER :WRITE-FILE-INTERNAL PATHNAME))) ;in METH.LISP (DEFUN SET-BUFFER-PATHNAME (PATHNAME &OPTIONAL (BUFFER *INTERVAL*) &AUX STRING) "Set the pathname BUFFER is visiting to PATHNAME." (SETF (BUFFER-PATHNAME BUFFER) (SEND PATHNAME :TRANSLATED-PATHNAME)) (SETF (BUFFER-GENERIC-PATHNAME BUFFER) (SEND PATHNAME :GENERIC-PATHNAME)) (SETQ STRING (SEND PATHNAME :STRING-FOR-EDITOR)) (COND ((EQUALP (BUFFER-NAME BUFFER) STRING) NIL) ((CL:ASSOC STRING *ZMACS-BUFFER-NAME-ALIST* :TEST #'EQUALP) (FORMAT *QUERY-IO* "~&Not renaming the buffer! There is already a buffer named ~A" STRING)) (T (SIMILAR-BUFFER-FILES-WARNING BUFFER) (SEND BUFFER :RENAME STRING) ;Should no longer be necessary. ; ;; Transfer the attribute list info to the new pathname. ; (LET ((PKG (BUFFER-PACKAGE BUFFER))) ; (REPARSE-BUFFER-attribute-list BUFFER) ; (SETF (BUFFER-PACKAGE BUFFER) PKG)) ))) (DEFUN SIMILAR-BUFFER-FILES-WARNING (BUFFER &AUX SAME-NAME SAME-TYPE SAME-EVERYTHING) "Warn if any buffer other than BUFFER is visiting the same or a similar file." (DOLIST (ELT *ZMACS-BUFFER-NAME-ALIST*) (AND (NEQ (CDR ELT) BUFFER) (BUFFER-PATHNAME (CDR ELT)) (BUFFER-FILE-ID (CDR ELT)) (NOT (NODE-SPECIAL-TYPE (CDR ELT))) (IF (EQUALP (SEND (BUFFER-PATHNAME BUFFER) :STRING-FOR-EDITOR) (SEND (BUFFER-PATHNAME (CDR ELT)) :STRING-FOR-EDITOR)) (RETURN (SETQ SAME-EVERYTHING (CDR ELT))) (IF (EQUALP (SEND (BUFFER-PATHNAME BUFFER) :NAME) (SEND (BUFFER-PATHNAME (CDR ELT)) :NAME)) (COND ((EQUALP (SEND (BUFFER-PATHNAME BUFFER) :TYPE) (SEND (BUFFER-PATHNAME (CDR ELT)) :TYPE)) (SETQ SAME-TYPE (CDR ELT))) (T (SETQ SAME-NAME (CDR ELT)))))))) (IF SAME-EVERYTHING (FORMAT *QUERY-IO* "~&Warning: Buffer ~A~& is also visiting file ~A." (BUFFER-NAME SAME-EVERYTHING) (BUFFER-PATHNAME SAME-EVERYTHING)) (LET ((LOSER (OR SAME-TYPE SAME-NAME))) (IF LOSER (FORMAT *QUERY-IO* "~&Note: Another buffer ~A~& is visiting file ~A." (BUFFER-NAME LOSER) (BUFFER-PATHNAME LOSER)))))) (DEFUN SET-BUFFER-FILE-ID (BUFFER INFO) "Set the BUFFER-FILE-ID of BUFFER to INFO. Records the file BUFFER was last read or saved in." (SETF (BUFFER-FILE-ID BUFFER) INFO) (LET ((VERSION-STRING (AND (TYPEP (CAR-SAFE INFO) 'FS:PATHNAME) (BUFFER-PATHNAME BUFFER) (NOT (NUMBERP (SEND (BUFFER-PATHNAME BUFFER) :VERSION))) (LET ((VERSION (SEND (CAR INFO) :VERSION))) (AND (NUMBERP VERSION) (FORMAT NIL " (~D)" VERSION)))))) (SETF (BUFFER-VERSION-STRING BUFFER) VERSION-STRING) (AND (EQ BUFFER *INTERVAL*) (SETQ *ZMACS-BUFFER-VERSION-STRING* VERSION-STRING))) INFO) (defun buffer-file-version-if-known (buffer) "NIL or the version of the truename associated with this buffer" ;--unfortunately, the truename is not stored directly, it should be. --rg. (let ((info (buffer-file-id buffer))) (if (and (memq (type-of (car-safe info)) '(fs:pathname fs:lm-pathname)) (buffer-pathname buffer)) (let ((v (send (buffer-pathname buffer) :version))) (if (numberp v) v (send (car info) :version)))))) (DEFCOM COM-REVERT-BUFFER "Forgets changes to a specified buffer. Reads the name of the buffer from the mini-buffer and reads back in the file or function." () (LET ((BUFFER (READ-BUFFER-NAME "Buffer to revert:" *INTERVAL*))) (if (not *numeric-arg*) (progn (REVERT-BUFFER BUFFER) (MUST-REDISPLAY-BUFFER BUFFER DIS-TEXT) DIS-NONE) (let* ((assoc-file (condition-case () (send buffer :pathname) (fs:file-not-found (warn "The buffer ~A has no associated pathname.")))) (truename (send assoc-file :truename)) (most-recent-file (DEFUN REVERT-BUFFER (BUFFER &OPTIONAL (PATHNAME (BUFFER-PATHNAME BUFFER)) (CONNECT-FLAG (BUFFER-FILE-ID BUFFER)) SELECT-FLAG QUIETLY-FLAG) "Read file PATHNAME, or BUFFER's visited file into BUFFER. CONNECT-FLAG non-NIL means mark BUFFER as visiting the file. This may change the buffer's name. It defaults non-NIL if BUFFER is visiting a file now. If CONNECT-FLAG is NOSECTIONIZE, mark buffer as visiting but don't sectionize it. SELECT-FLAG non-NIL means select BUFFER. QUIETLY-FLAG means do not print a message about reading a file." (SEND BUFFER :REVERT PATHNAME CONNECT-FLAG SELECT-FLAG QUIETLY-FLAG)) ;; Only the :REVERT method for FILE-BUFFER calls this. (DEFUN REVERT-FILE-BUFFER (BUFFER PATHNAME CONNECT-FLAG SELECT-FLAG QUIETLY-FLAG &AUX GENERIC-PATHNAME PATHNAME-STRING TRUENAME NEW-MODE) (WHEN (AND (NULL (BUFFER-FILE-ID BUFFER)) (NULL PATHNAME)) (BARF "The buffer ~A is not associated with a file." (BUFFER-NAME BUFFER))) (MULTIPLE-VALUE-SETQ (PATHNAME PATHNAME-STRING) (EDITOR-FILE-NAME PATHNAME)) (WHEN CONNECT-FLAG (SETF (BUFFER-NAME BUFFER) PATHNAME-STRING) (SETF (BUFFER-PATHNAME BUFFER) PATHNAME)) (SETQ GENERIC-PATHNAME (SEND PATHNAME :GENERIC-PATHNAME)) (SETF (BUFFER-GENERIC-PATHNAME BUFFER) GENERIC-PATHNAME) (WITH-OPEN-FILE-CASE (STREAM PATHNAME :CHARACTERS T) (:NO-ERROR (SETQ TRUENAME (SEND STREAM :TRUENAME)) (WHEN (MEMQ (SEND PATHNAME :TYPE) '(NIL :UNSPECIFIC)) (MULTIPLE-VALUE-SETQ (PATHNAME PATHNAME-STRING) (EDITOR-FILE-NAME (IF (EQUALP (SEND TRUENAME :NAME) (SEND PATHNAME :NAME)) ;; This is in case user reads FOO > from an ITS, and it is reall FOO BAR. (SEND PATHNAME :NEW-TYPE (SEND TRUENAME :TYPE)) ;; This case if user read FOO BAR from an LMFILE, and truename is FOO|BAR. ;; Or if user reads FOO BAR from an ITS and it is a link to UGH QUUX. PATHNAME)))) (WHEN CONNECT-FLAG (SETF (BUFFER-NAME BUFFER) PATHNAME-STRING) (SETF (BUFFER-PATHNAME BUFFER) PATHNAME) (SIMILAR-BUFFER-FILES-WARNING BUFFER)) (WHEN (NOT QUIETLY-FLAG) (FORMAT *QUERY-IO* "~&Reading ~A" TRUENAME) (LET ((THIS-VERSION (SEND TRUENAME :VERSION)) (INSTALLED-TRUENAME (FILE-LOADED-TRUENAME TRUENAME)) INSTALLED-VERSION) (AND INSTALLED-TRUENAME (NUMBERP THIS-VERSION) (NUMBERP (SETQ INSTALLED-VERSION (SEND INSTALLED-TRUENAME :VERSION))) ( INSTALLED-VERSION THIS-VERSION) (FORMAT *QUERY-IO* " (installed version is ~D)" INSTALLED-VERSION)))) (FS:READ-ATTRIBUTE-LIST BUFFER STREAM) ;; Forget (and thereby override) and previouse Set Package in this buffer. (SETF (BUFFER-PACKAGE BUFFER) NIL) ;; And recompute from latest attribute list. (INITIALIZE-BUFFER-PACKAGE BUFFER) (UNLESS (SEND BUFFER :GET-ATTRIBUTE ':MODE) (SEND BUFFER :SET-ATTRIBUTE ':MODE (OR (CDR (SI:ASSOC-EQUAL (SEND PATHNAME :CANONICAL-TYPE) FS:*FILE-TYPE-MODE-ALIST*)) *DEFAULT-MAJOR-MODE*))) (SETQ NEW-MODE (OR (GET-FILE-MAJOR-MODE (SEND BUFFER :GET-ATTRIBUTE ':MODE)) 'FUNDAMENTAL-MODE)) (LET-IF QUIETLY-FLAG ((*INTERVAL* NIL)) (IF (EQ BUFFER *INTERVAL*) (COMPUTE-BUFFER-PACKAGE BUFFER)) (AND NEW-MODE (SEND BUFFER :SET-MAJOR-MODE NEW-MODE))) (PRESERVE-BUFFER-POINT (BUFFER) (WITH-READ-ONLY-SUPPRESSED (BUFFER) (LET ((*BATCH-UNDO-SAVE* T)) ;Don't save all this for undo! (DISCARD-UNDO-INFORMATION BUFFER) (DELETE-INTERVAL BUFFER) (SETF (BUFFER-TICK BUFFER) (TICK)) ;For SECTIONIZE-BUFFER (SETF (BUFFER-FILE-READ-TICK BUFFER) *TICK*) (LET ((FONTS (SET-BUFFER-FONTS BUFFER)) FONTS-P) (SETQ FONTS-P (OR (CDR FONTS) (SEND BUFFER :GET-ATTRIBUTE ':DIAGRAM))) (WHEN SELECT-FLAG (SEND BUFFER :ACTIVATE) (MAKE-BUFFER-CURRENT BUFFER) ;; If it is requested, read in the first screenful and then redisplay. (DOTIMES (I (+ 5 (WINDOW-N-PLINES *WINDOW*))) (MULTIPLE-VALUE-BIND (LINE EOFFLG) (SEND STREAM :LINE-IN LINE-LEADER-SIZE) (WHEN LINE (INSERT-LINE-WITH-LEADER LINE (BP-LINE (INTERVAL-LAST-BP BUFFER)))) (IF EOFFLG (RETURN)))) (REDISPLAY *WINDOW* :START (INTERVAL-FIRST-BP BUFFER) NIL)) (IF (NOT CONNECT-FLAG) (STREAM-INTO-BP STREAM (INTERVAL-FIRST-BP BUFFER) FONTS-P) (IF (EQ CONNECT-FLAG 'NOSECTIONIZE) (STREAM-INTO-BP STREAM (INTERVAL-FIRST-BP BUFFER) FONTS-P) (SECTIONIZE-FILE-BUFFER BUFFER *ZMACS-COMPLETION-AARRAY* 'ZMACS-BUFFERS NIL NIL STREAM FONTS-P)) (SET-BUFFER-FILE-ID BUFFER (SEND STREAM :INFO)) (DOLIST (WINDOW (SEND BUFFER :WINDOWS)) (AND FONTS (REDEFINE-FONTS WINDOW FONTS (SEND BUFFER :GET-ATTRIBUTE ':VSP))) (REDEFINE-WINDOW-OVERPRINTING-FLAG WINDOW (SEND BUFFER :GET-ATTRIBUTE ':BACKSPACE)) (REDEFINE-WINDOW-TAB-NCHARS WINDOW (SEND BUFFER :GET-ATTRIBUTE ':TAB-WIDTH)))) (SETF (BUFFER-FILE-READ-TICK BUFFER) *TICK*) (NOT-MODIFIED BUFFER))))) (UNLESS SELECT-FLAG ;else already done above (SEND BUFFER :ACTIVATE)) (UNLESS QUIETLY-FLAG (LET ((NCHARS (SEND-IF-HANDLES STREAM :READ-POINTER))) (COND ((NULL NCHARS) (FORMAT *QUERY-IO* " -- done.")) ((< NCHARS 5000.) (FORMAT *QUERY-IO* " -- ~D characters." NCHARS)) (T (FORMAT *QUERY-IO* " -- ~DK characters." (ROUND NCHARS 1024.))))))) (FS:FILE-NOT-FOUND (WHEN *FIND-FILE-NOT-FOUND-IS-AN-ERROR* (BARF STREAM)) (OR QUIETLY-FLAG (FORMAT *QUERY-IO* "(New File)")) (LET ((*BATCH-UNDO-SAVE* T)) (DISCARD-UNDO-INFORMATION BUFFER) (DELETE-INTERVAL BUFFER)) (AND CONNECT-FLAG (SET-BUFFER-FILE-ID BUFFER T)) (SEND BUFFER :SET-ATTRIBUTE ':MODE (OR (CDR (SI:ASSOC-EQUAL (SEND PATHNAME :CANONICAL-TYPE) FS:*FILE-TYPE-MODE-ALIST*)) *DEFAULT-MAJOR-MODE*)) (SETF (BUFFER-PACKAGE BUFFER) (PKG-FIND-PACKAGE (OR *DEFAULT-PACKAGE* *PACKAGE*))) (LET ((MODE (GET-FILE-MAJOR-MODE (SEND BUFFER :GET-ATTRIBUTE :MODE)))) (LET-IF QUIETLY-FLAG ((*INTERVAL* NIL)) (IF (EQ BUFFER *INTERVAL*) (COMPUTE-BUFFER-PACKAGE BUFFER)) (AND MODE (SEND BUFFER :SET-MAJOR-MODE MODE))))) (FS:FILE-ERROR (BARF STREAM))) (SETF (BUFFER-TICK BUFFER) (TICK))) ;Buffer is same as file (DEFUN FILE-LOADED-TRUENAME (PATHNAME) "Return the truename of the source of the version of PATHNAME which was LOADed." (OR (LET* ((GENERIC-PATHNAME (SEND PATHNAME :GENERIC-PATHNAME)) (SOURCE-PATHNAME (SEND GENERIC-PATHNAME :GET ':QFASL-SOURCE-FILE-UNIQUE-ID))) (COND ((STRINGP SOURCE-PATHNAME) ;Old versions of the compiler (SETQ SOURCE-PATHNAME (FS:MERGE-PATHNAME-DEFAULTS SOURCE-PATHNAME PATHNAME))) ((CONSP SOURCE-PATHNAME) (SETQ SOURCE-PATHNAME (FS:PATHNAME-FROM-COLD-LOAD-PATHLIST SOURCE-PATHNAME)))) (AND (NOT (NULL SOURCE-PATHNAME)) (LET ((TYPE-1 (SEND SOURCE-PATHNAME :TYPE)) (TYPE-2 (SEND PATHNAME :TYPE))) (OR (EQUAL TYPE-1 TYPE-2) (AND (OR (EQ TYPE-1 :UNSPECIFIC) (CL:MEMBER TYPE-1 FS:*ITS-UNINTERESTING-TYPES* :TEST #'STRING=)) (OR (EQ TYPE-2 :UNSPECIFIC) (CL:MEMBER TYPE-2 FS:*ITS-UNINTERESTING-TYPES* :TEST #'STRING=))))) SOURCE-PATHNAME)) (LET* ((NEWEST-PATHNAME (SEND PATHNAME :NEW-VERSION :NEWEST)) (ID (SI:GET-FILE-LOADED-ID NEWEST-PATHNAME PACKAGE))) (AND ID (CAR ID))))) (defmacro WITH-VERSION-AND-MODIFICATION-INFO (buffer body) `(let* ((buffer-version (or (buffer-file-version-if-known ,buffer) (error "Buffer ~A is not associated with a file."))) (file-spec (send ,buffer :pathname)) (file-truename (and file-spec (send file-spec :truename))) (file-version (send file-spec :version)) (file-number (or (numberp file-version) (send file-truename :version))) ;;anything is newer than a non-existent buffer version. (newer-version-exists (and file-number (< (or buffer-version -1) file-number))) ;;(this-version-is-newest (= buffer-version file-number)) (buffer-modified (buffer-modified-p ,buffer))) ,body)) (defun REFIND-FILE (&optional (buffer (read-buffer-name "File to refind: " *interval*))) (let ((act-automatically *numeric-arg-p*)) ;; this will give users choices unless they specify (through the use of an explicit numeric arg) ;; that they want REFIND-FILE to act on its own. (flet ((proceed-unless-no-arg (proceed-forms string &rest string-args) (if act-automatically proceed-forms (apply #'warn (cons string string-args))))) (with-version-and-modification-info buffer (cond (buffer-modified (cond ((numberp file-version) (proceed-unless-no-arg () "The file ~A, read in with explicit numeric version, has been modified." file-spec)) (newer-version-exists (proceed-unless-no-arg () "Read in most recent version of ~A, do a Source Compare Merge, or nothing." file-spec)) (t (proceed-unless-no-arg () "The current buffer contains a modified version of the latest version of ~A.~ ~%Do you want to Revert Buffer,~ ~%Source Compare Merge with buffer's original contents,~ ~%or do nothing?" file-spec)))) (t (cond ((numberp file-version) (proceed-unless-no-arg () "The current buffer contains an unmodified numeric file version, ~A.~ ~%Do you want to Refind version ~A,~ ~%Replace buffer contents with those of the newest version, namely ~A ~%Source Compare Merge with buffer's original contents,~ ~%or do nothing?" file-spec file-number (send file-spec :string-for-printing))) (newer-version-exists (find-file file-spec)) (t (format *query-io* "No action taken."))))))))) (with-version-and-modification-info *interval* (format *query-io* "~A ~A ~A ~A ~A ~A ~A ~A" (send file-spec :namestring) buffer-version file-truename file-version file-number newer-version-exists this-version-is-newest buffer-modified))