reduce-historical/psl-1983/nmode/fileio.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% FileIO.SL
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        17 September 1982
% Revised:     4 February 1983
%
% File I/O for NMODE.
%
% 4-Feb-83 Alan Snyder
%   Added functions for deleting/undeleting files and writing a message.
%   Find-file-in-buffer changed incompatibly to make it more useful.
%   Use nmode-error to report errors.
% 1-Feb-83 Alan Snyder
%   Added separate default string for Insert File command.
% 27-Dec-82 Alan Snyder
%   Removed runtime LOAD statements, for portability.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects fast-strings pathnames))

% External Variables:

(fluid '(nmode-selectable-buffers nmode-current-buffer nmode-screen
	 nmode-command-argument-given nmode-current-window Text-Mode
	 ))

% Internal static variables:

(fluid '(text-io-default-fn insert-file-default-fn))
(setf text-io-default-fn NIL)
(setf insert-file-default-fn NIL)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% File commands:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de visit-file-command ()
  % Ask for and read in a file.
  (let ((fn (prompt-for-defaulted-filename "Visit File: " NIL)))
    (visit-file nmode-current-buffer fn)
    ))

(de insert-file-command ()
  % Ask for and read a file, inserting it into the current buffer.
  (setf insert-file-default-fn
    (prompt-for-file-name "Insert File: " insert-file-default-fn))
  (insert-file-into-buffer nmode-current-buffer insert-file-default-fn)
  )

(de write-file-command ()
  % Ask for filename, write out the buffer to the file.
  (write-buffer-to-file
   nmode-current-buffer
   (prompt-for-defaulted-filename "Write File:" NIL)))

(de save-file-command ()
  % Save current buffer on its associated file, ask for file if unknown.
  (cond
   ((not (=> nmode-current-buffer modified?))
    (write-prompt "(No changes need to be written)"))
   (t (save-file nmode-current-buffer))))

(de save-file-version-command ()
  % Save current buffer on its associated file, ask for file if unknown.
  % The file is written using the current version number.
  (cond
   ((not (=> nmode-current-buffer modified?))
    (write-prompt "(No changes need to be written)"))
   (t (save-file-version nmode-current-buffer))))

(de find-file-command ()
  % Ask for filename and then read it into a buffer created especially for that
  % file, or select already existing buffer containing the file.

  (find-file (prompt-for-defaulted-filename "Find file: " NIL))
  )

(de write-screen-photo-command ()
  % Ask for filename, write out the screen to the file.
  (write-screen-photo (prompt-for-file-name "Write Photo to File: " NIL)))

(de write-region-command ()
  % Ask for filename, write out the region to the file.
  (write-text-to-file
   (cdr (extract-region NIL (buffer-get-position) (current-mark)))
   (setf text-io-default-fn
     (prompt-for-file-name "Write Region to File:" text-io-default-fn))))

(de prepend-to-file-command ()
  % Ask for filename, prepend the region to the file.
  (prepend-text-to-file
   (cdr (extract-region NIL (buffer-get-position) (current-mark)))
   (setf text-io-default-fn
     (prompt-for-file-name "Prepend Region to File:" text-io-default-fn))))

(de append-to-file-command ()
  % Ask for filename, append the region to the file.
  (append-text-to-file
   (cdr (extract-region NIL (buffer-get-position) (current-mark)))
   (setf text-io-default-fn
     (prompt-for-file-name "Append Region to File:" text-io-default-fn))))

(de delete-file-command ()
  (nmode-delete-file (prompt-for-defaulted-filename "Delete File:" NIL)))

(de delete-and-expunge-file-command ()
  (nmode-delete-and-expunge-file
   (prompt-for-defaulted-filename "Delete and Expunge File:" NIL)))

(de undelete-file-command ()
  (nmode-undelete-file (prompt-for-defaulted-filename "Undelete File:" NIL)))

(de save-all-files-command ()
  % Save all files.  Ask first, unless arg given.
  (for
   (in b nmode-selectable-buffers)
   (do
    (cond ((and (=> b file-name)
		(=> b modified?)
		(or nmode-command-argument-given
		    (nmode-y-or-n?
		     (bldmsg "Save %w in %w (Y or N)?"
			     (=> b name) (=> b file-name)))
		    ))
	   (save-file b))
	  ))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% File functions:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de prompt-for-defaulted-filename (prompt b)
  % The default name is the name associated with the specified buffer (without
  % Version number).  Will throw 'ABORT if a bad file name is given.
  % If B is NIL, the "current" buffer is used.

  (let ((fn (=> (or b nmode-current-buffer) file-name)))
    (prompt-for-file-name prompt
			  (and fn (namestring (pathname-without-version fn)))
			  )))

(de prompt-for-file-name (prompt default-name)
  % Default-Name may be NIL.
  % Will throw 'ABORT if a bad file name is given.

  (let ((pn (pathname (prompt-for-string prompt default-name))))
    (if default-name
      (setf pn
	(attempt-to-merge-pathname-defaults pn default-name
					    (pathname-type default-name) NIL)))
    (namestring pn)
    ))

(de attempt-to-merge-pathname-defaults (pn dn type version)
  (let ((result (errset (merge-pathname-defaults pn dn type version) NIL)))
    (cond
     ((listp result) (car result))
     (t (write-prompt EMSG*)
	(throw 'ABORT)))))

(de read-file-into-buffer (b file-name)
  (=> b set-file-name file-name)
  (buffer-set-mode b (pathname-default-mode file-name))
  (let ((s (attempt-to-open-input file-name)))
    (if s
      (read-stream-into-buffer b s)
      % else
      (=> b reset)
      (=> b set-modified? NIL)
      (write-prompt "(New File)")
      )))

(de read-stream-into-buffer (b s)
  (let ((fn (=> s file-name)))
    (write-prompt (bldmsg "Reading file: %w" fn))
    (=> b read-from-stream s)
    (=> s close)
    (write-prompt (bldmsg "File read: %w (%d lines)" fn	(=> b visible-size)))
    ))

(de insert-file-into-buffer (buf pn)
  (let ((b (buffer-create-unselectable "FOO" Text-Mode)))
    (read-file-into-buffer b pn)
    (insert-buffer-into-buffer b buf)
    ))

(de insert-buffer-into-buffer (source destination)
  (let ((old-pos (=> destination position)))
    (=> destination insert-text (=> source contents))
    (=> destination set-mark-from-point)
    (=> destination set-position old-pos)
    ))

(de save-file (b)
  % Save the specified buffer on its associated file, ask for file if unknown.
  (let ((fn (=> b file-name)))
    (cond
     ((not (=> b modified?)) nil)
     (fn (write-buffer-to-file b (pathname-without-version fn)))
     (T (write-file b)))))

(de save-file-version (b)
  % Save the specified buffer on its associated file, ask for file if unknown.
  % The file is written to the current version number.
  (let ((fn (=> b file-name)))
    (cond
     ((not (=> b modified?)) nil)
     (fn (write-buffer-to-file b fn))
     (T (write-file b)))))

(de write-file (b)
  % Ask for filename, write out the buffer to the file.
  (let ((msg (bldmsg "Write Buffer %w to File: " (=> b name))))
    (write-buffer-to-file b (prompt-for-defaulted-filename msg b))))

(de write-buffer-to-file (b pn)
  % Write the specified buffer to a file.
  (write-prompt "")
  (let* ((file-name (namestring pn))
	 (s (attempt-to-open-output file-name))
	 )
    (if s
      (let ((fn (=> s file-name)))
	(write-prompt (bldmsg "Writing file: %w" fn))
	(=> b write-to-stream s)
	(=> s close)
	(write-prompt
	 (bldmsg "File written: %w (%d lines)" fn (=> b visible-size)))
	(=> b set-modified? NIL)
	(=> b set-file-name fn)
	)
      (nmode-error (bldmsg "Unable to write file: %w" file-name))
      )))

(de write-text-to-file (text pn)
  (let ((b (buffer-create-unselectable "FOO" Text-Mode)))
    (=> b insert-text text)
    (write-buffer-to-file b pn)
    ))

(de prepend-text-to-file (text pn)
  (let ((b (buffer-create-unselectable "FOO" Text-Mode)))
    (read-file-into-buffer b pn)
    (=> b move-to-buffer-start)
    (=> b insert-text text)
    (write-buffer-to-file b pn)
    ))

(de append-text-to-file (text pn)
  (let ((b (buffer-create-unselectable "FOO" Text-Mode)))
    (read-file-into-buffer b pn)
    (=> b move-to-buffer-end)
    (=> b insert-text text)
    (write-buffer-to-file b pn)
    ))

(de visit-file (b file-name)
  % If the specified file exists, read it into the specified buffer.
  % Otherwise, clear the buffer for a new file.
  % If the buffer contains precious data, offer to save it first.

  (if (=> b modified?)
    (let* ((fn (=> b file-name))
	   (msg (if fn (bldmsg "file %w" fn)
		  (bldmsg "buffer %w" (=> b name))))
	   )
      (if (nmode-yes-or-no? (bldmsg "Write out changes in %w?" msg))
	(save-file b)
	)))
  (let ((fn (actualize-file-name file-name)))
    (if fn
      (read-file-into-buffer b fn)
      (nmode-error (bldmsg "Unable to read or create file: %w" file-name))
      )))

(de find-file (file-name)
  % Select a buffer containing the specified file.  If the file exists in a
  % buffer already, then that buffer is selected.  Otherwise, a new buffer is
  % created and the file read into it (if the file exists).

  (find-file-in-window nmode-current-window file-name))

(de find-file-in-window (w file-name)
  % Attach a buffer to the specified window that contains the specified file.
  % If the file exists in a buffer already, then that buffer is used.
  % Otherwise, a new buffer is created and the file read into it (if the file
  % exists).

  (let ((b (find-file-in-buffer file-name nil)))
    (if b
      (window-select-buffer w b)
      % otherwise
      (nmode-error (bldmsg "Unable to read or create file: %w" file-name))
      )))

(de find-file-in-buffer (file-name existing-file-only?)
  % Return a buffer containing the specified file.  The buffer is not
  % selected.  If the file exists in a buffer already, then that buffer is
  % returned.  Otherwise, if the file exists and can be read, a new buffer is
  % created and the file read into it.  Otherwise, if EXISTING-FILE-ONLY? is
  % NIL and the file is potentially creatable, a new buffer is created and
  % returned.  Otherwise, NIL is returned.

  (setf file-name (actualize-file-name file-name))
  (if (and file-name (not (string-empty? file-name)))
    (or
     (find-file-in-existing-buffer file-name) % look for existing buffer
     (let ((s (attempt-to-open-input file-name)))
       (when (or s (not existing-file-only?)) % create a buffer
	 (let ((b (buffer-create-default
		   (buffer-make-unique-name
		    (filename-to-buffername file-name)))))
	   (=> b set-file-name file-name)
	   (buffer-set-mode b (pathname-default-mode file-name))
	   (if s
	     (read-stream-into-buffer b s)
	     (write-prompt "(New File)")
	     )
	   b
	   ))))))

(de find-file-in-existing-buffer (file-name)
  % Look for the specified file in an existing buffer.  If found, return
  % that buffer, otherwise return NIL.  The filename should be complete.

  (let ((pn (pathname file-name)))
    (for (in b nmode-selectable-buffers)
	 (do (if (pathnames-match pn (=> b file-name)) (exit b)))
	 (returns nil))
    ))

(de nmode-delete-file (fn)
  (let ((del-fn (file-delete fn)))
    (if del-fn
      (write-prompt (bldmsg "File deleted: %w" del-fn))
      (nmode-error (bldmsg "Unable to delete file: %w" fn))
      )
    del-fn
    ))

(de nmode-delete-and-expunge-file (fn)
  (let ((del-fn (file-delete-and-expunge fn)))
    (if del-fn
      (write-prompt (bldmsg "File deleted and expunged: %w" del-fn))
      (nmode-error (bldmsg "Unable to delete file: %w" fn))
      )
    del-fn
    ))

(de nmode-undelete-file (fn)
  (let ((del-fn (file-undelete fn)))
    (if del-fn
      (write-prompt (bldmsg "File undeleted: %w" del-fn))
      (nmode-error (bldmsg "Unable to undelete file: %w" fn))
      )
    del-fn
    ))

(de write-screen-photo (file-name)
  % Write the current screen to file.
  (let ((s (attempt-to-open-output file-name)))
    (cond (s
	   (nmode-refresh)
	   (=> nmode-screen write-to-stream s)
	   (=> s close)
	   (write-prompt (bldmsg "File written: %w" (=> s file-name)))
	   )
	  (t
	   (nmode-error (bldmsg "Unable to write file: %w" file-name))
	   ))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Auxiliary functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de actualize-file-name (file-name)
  % If the specified file exists, return its "true" (and complete) name.
  % Otherwise, return the "true" name of the file that would be created if one
  % were to do so.  (Unfortunately, we have no way to do this except by actually
  % creating the file and then deleting it!)  Return NIL if the file cannot be
  % read or created.

  (let ((s (attempt-to-open-input file-name)))
    (cond ((not s)
	   (setf s (attempt-to-open-output file-name))
	   (when s
	     (setf file-name (=> s file-name))
	     (=> s close)
	     (file-delete-and-expunge file-name)
	     file-name
	     )
	   )
	  (t
	   (setf file-name (=> s file-name))
	   (=> s close)
	   file-name
	   ))))

(de filename-to-buffername (pn)
  % Convert from a pathname to the "default" corresponding buffer name.
  (setf pn (pathname pn))
  (string-upcase (file-namestring (pathname-without-version pn)))
  )

(de pathnames-match (pn1 pn2)
  (setf pn1 (pathname pn1))
  (setf pn2 (pathname pn2))
  (and (equal (pathname-device pn1) (pathname-device pn2))
       (equal (pathname-directory pn1) (pathname-directory pn2))
       (equal (pathname-name pn1) (pathname-name pn2))
       (equal (pathname-type pn1) (pathname-type pn2))
       (or (null (pathname-version pn1))
	   (null (pathname-version pn2))
	   (equal (pathname-version pn1) (pathname-version pn2)))
       ))

(de pathname-without-version (pn)
  (setf pn (pathname pn))
  (make-pathname 'host (pathname-host pn)
		 'device (pathname-device pn)
		 'directory (pathname-directory pn)
		 'name (pathname-name pn)
		 'type (pathname-type pn)
		 ))