123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429 |
- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- %
- % 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)
- ))
|