Check-ins Using Download Hex

Artifact 787ffd7154f29bba2188c1baa72e6294a477f1d21e39e925d155573388690df5:

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% FileIO.SL
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        17 September 1982
% Revised:     31 March 1983
%
% File I/O for NMODE.
%
% 31-Mar-83 Alan Snyder
%  Fix bug: Print-Buffer didn't do tabs right (because the PSL manual
%  incorrectly described the Repeat macro!).
% 15-Mar-83 Alan Snyder
%  Create-buffer-unselectable -> Create-unnamed-buffer.  Add
%  print-buffer-command.  Rename write-screen-photo-command to
%  write-screen-command; Fix to work when there are multiple physical screens;
%  add a default file name.
% 4-Mar-83 Alan Snyder
%  Added error handling for bad pathname specified by user.  Added some
%  recovery for bad pathnames in general.  Pathname-without-version renamed to
%  Filename-without-version.
% 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 numeric-operators fast-strings pathnames))
(on fast-integers)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 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
	 nmode-print-device
	 write-screen-default-fn
	 ))

(setf nmode-print-device "PRINTER:") % probably override this in system file
(setf text-io-default-fn NIL)
(setf insert-file-default-fn NIL)
(setf write-screen-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-command ()
  % Ask for filename, write out the screen to the file.
  (setf write-screen-default-fn
    (prompt-for-file-name "Write Screen to File: " write-screen-default-fn))
  (write-screen write-screen-default-fn)
  )

(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))
	  ))))

(de print-buffer-command ()
  % Print the current buffer.  Translates tabs and control characters.
  (setf nmode-print-device
       (prompt-for-string "Print buffer to device:" nmode-print-device))
  (print-buffer nmode-print-device)
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 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 (filename-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* ((fn (prompt-for-string prompt default-name))
	 (pn (maybe-pathname fn))
	 )
    (when (not pn) 
     (nmode-error (bldmsg "Invalid pathname: %w" fn))
     (throw 'ABORT)
     )
    (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 (nmode-error 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 (create-unnamed-buffer 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 (filename-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 (create-unnamed-buffer Text-Mode)))
    (=> b insert-text text)
    (write-buffer-to-file b pn)
    ))

(de prepend-text-to-file (text pn)
  (let ((b (create-unnamed-buffer 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 (create-unnamed-buffer 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 (maybe-pathname file-name)))
    (when pn
      (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 (file-name)
  % Write the current screen to file.
  (let ((s (attempt-to-open-output file-name)))
    (if s
      (let ((screen (=> (=> nmode-current-window screen) screen)))
	(nmode-refresh)
	(=> screen write-to-stream s)
	(=> s close)
	(write-prompt (bldmsg "File written: %w" (=> s file-name)))
	)
      (nmode-error (bldmsg "Unable to write file: %w" file-name))
      )))

(de print-buffer (print-device)
  % Print the current buffer.  PSL output is used because it is probably more
  % general (less specialized) and will handle character output devices.  This
  % routine is likely to be redefined in the system file.

  (let ((result (errset (open print-device 'OUTPUT))))
    (if (not (pairp result))
      (nmode-error (bldmsg "Unable to write to %w" print-device))
      % otherwise
      (let* ((chn (car result))
	     (upper-bound (- (current-buffer-size) 1))
	     )
	(for (from i 0 upper-bound)
	     (do
	      (print-buffer-line chn (current-buffer-fetch i))
	      (channelterpri chn)
	      ))
	(close chn)
	))))
	     
(de print-buffer-line (chn line)
  % Used by print-buffer.
  (for (from i 0 (string-upper-bound line))
       (with (col 0))
       (do
	(let ((ch (string-fetch line i)))
	  (cond
	   ((= ch #\TAB)
	    % TABs are converted to an appropriate number of spaces.
	    (repeat
	      (channelwritechar chn #\space)
	      (setf col (+ col 1))
	      % until
	      (= (& col 7) 0)
	      ))
	   ((or (< ch #\space) (= ch #\rubout))
	    % Control characters are converted to "uparrow" form.
	    (channelwritechar chn #/^)
	    (channelwritechar chn (^ ch 8#100))
	    (setf col (+ col 2))
	    )
	   (t
	    (channelwritechar chn ch)
	    (setf col (+ col 1))
	    ))))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 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 (fn)
  % Convert from a pathname to the "default" corresponding buffer name.
  (let ((pn (maybe-pathname fn)))
    (if pn
      (string-upcase (file-namestring (pathname-without-version pn)))
      (string-upcase fn)
      )))

(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 filename-without-version (fn)
  (let ((pn (maybe-pathname fn)))
    (if pn 
      (namestring (pathname-without-version pn))
      fn
      )))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(off fast-integers)
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]