Artifact 4eb5cc35272314e20b96787525e68ab49a0bc34ca9f2a04b595c2d41b8e8e206:

• File psl-1983/3-1/nmode/dired.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 19708) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% DIRED.SL - Directory Editor Subsystem
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        16 July 1982
% Revised:     11 April 1983
%
% This file implements a directory editor subsystem.
%
% 5-April-83 Jeff Soreff
%  Added filter functions to dired commands.
% 17-Mar-83 Alan Snyder
%  Bug fix: new item made by create command had wrong width.
% 14-Mar-83 Alan Snyder
%  Fix C-X D to view directory of current file, rather than connected
%  directory, when the current filename has only a device field.  Add Create
%  and Look commands.  Change to sort based on displayed name rather than full
%  name (since that's what the user sees).  Check for NIL dates in sort
%  functions.  Change to cleanup item when killed.  Convert for revised
%  browser mechanism.
% 4-Mar-83 Alan Snyder
%  Fix to work with files whose names are not valid pathnames.
% 3-Mar-83 Alan Snyder
%  Add Browse command to browse subdirectories.
% 16-Feb-83 Alan Snyder
%  Declare -> Declare-Flavor.
%  Fix cleanup method to NIL out the buffer variable to allow the buffer object
%  to be garbage collected.
% 11-Feb-83 Alan Snyder
%  Fix bug in previous change.
% 8-Feb-83 Alan Snyder
%  Enlarge width of size field in display.
% 4-Feb-83 Alan Snyder
%  Rewritten to use new browser support.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(BothTimes (load extended-char fast-strings numeric-operators))
(load directory stringx)
(on fast-integers)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% External variables:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(fluid '(
  nmode-current-buffer
  nmode-terminal
  nmode-command-argument
  nmode-command-argument-given
  ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Internal static variables:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(fluid '(file-browser-mode
	 file-browser-command-list
	 file-browser-documentation-text
	 file-browser-help-text
	 dired-argument-list
	 ))

(setf file-browser-help-text
  ["? View Edit Browse Create Filter Un/Delete Kill-now uN/Ignore Sort/Reverse Look Quit"])

(setf file-browser-documentation-text
  ["The File Browser displays the files in a directory."
   "Terminology: the current file is the file pointed at by the cursor." 
   "The View (V) and Edit (E) commands both display the current file." 
   "In split-screen mode, Edit selects the bottom window while View does not." 
   "The Create (C) command creates a new file, but does not select it." 
   "The Filter (F) command removes a set of files from the display."
   "The Delete (D) command marks the current file for deletion upon Quit." 
   "The Undelete (U) command removes the mark made by the Delete command." 
   "The Kill (K) command deletes the current file immediately." 
   "The Ignore (I) command removes the current file from the display."
   "The uNignore (N) command restores all Ignored files to the display."
   "The Sort (S) command sorts the files in various ways."
   "The Reverse (R) command sorts the files in reverse order."
   "The Look (L) command re-reads the directory to get up-to-date info."
   "The Quit (Q) command exits the browser and deletes any marked files,"
   "after first asking for permission."
   ])

(setf file-browser-mode (nmode-define-mode "File-Browser" '(
  (nmode-define-commands File-Browser-Command-List)
  (nmode-establish-mode Read-Only-Text-Mode)
  )))

(setf file-browser-command-list (list
    (cons (x-char ?) 'browser-help-command)
    (cons (x-char B) 'dired-browse-command)
    (cons (x-char C) 'dired-create-command)
    (cons (x-char D) 'browser-delete-command)
    (cons (x-char E) 'browser-edit-command)
    (cons (x-char F) 'dired-filter-command)
    (cons (x-char I) 'browser-ignore-command)
    (cons (x-char K) 'browser-kill-command)
    (cons (x-char L) 'dired-look-command)
    (cons (x-char N) 'browser-undo-filter-command)
    (cons (x-char Q) 'dired-exit)
    (cons (x-char R) 'dired-reverse-sort)
    (cons (x-char S) 'dired-sort)
    (cons (x-char U) 'browser-undelete-command)
    (cons (x-char V) 'browser-view-command)
    (cons (x-char X) 'dired-exit)
    (cons (x-char BACKSPACE) 'browser-undelete-backwards-command)
    (cons (x-char RUBOUT) 'browser-undelete-backwards-command)
    (cons (x-char SPACE) 'move-down-command)
    (cons (x-char control D) 'browser-delete-command)
    (cons (x-char control K) 'browser-kill-command)
    ))

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

(de dired-command ()
  (let ((fn (=> nmode-current-buffer file-name))
	directory-name
	)
    (cond
     ((or (not fn) (>= nmode-command-argument 4))
      (setf directory-name (prompt-for-string "Edit Directory: " NIL))
      )
     (nmode-command-argument-given
      (setf directory-name (namestring (pathname-without-version fn)))
      )
     (t
      (setf directory-name (namestring (pathname-without-name fn)))
      ))
    (directory-editor directory-name)
    ))

(de edit-directory-command ()
  (let* ((fn (=> nmode-current-buffer file-name))
	 (directory-name
	  (prompt-for-string
	   "Edit Directory:"
	   (and fn (directory-namestring fn))
	   )))
    (directory-editor directory-name)
    ))

(define-browser-prototype 'edit-directory-command
			  "File Directory Browser"
			  ["This prototype creates a browser for the"
			   "set of files in a directory."])

(de directory-editor (directory-name)
  % Put up a directory editor subsystem, containing all files that match the
  % specified string.  If the string specifies a directory, then all files in
  % that directory are displayed.

  (setf directory-name (fixup-directory-name directory-name))
  (write-prompt "Reading directory or directories...")
  (let ((file-list (find-matching-files directory-name t)))
    (if (null file-list)
      (write-prompt (BldMsg "No files match: %w" directory-name))
      % otherwise
      (let* ((browser (or (find-browser 'FILE-BROWSER directory-name)
			  (create-file-browser directory-name)
			  ))
	     (items (dired-create-items file-list (=> browser display-width)))
	     )
	(=> browser set-items items)
	(browser-enter browser)
	))))

(de create-file-browser (directory-name)
  (let* ((header-text (vector
		       (string-concat "Directory List of " directory-name)
		       ""
		       ))
	 (browser
	  (create-browser 'FILE-BROWSER "Files" directory-name
			  file-browser-mode NIL header-text
			  file-browser-documentation-text
			  file-browser-help-text
			  () #'dired-filename-sorter)
	  ))
    (=> browser put 'directory-name directory-name)
    browser
    ))

(de dired-create-items (file-list display-width)
  % Accepts a list containing one element per file, where each element is
  % a list.  Returns a list of file-browser-items.

  (when file-list
    (let* ((names (for (in f file-list)
		       (collect (fixup-file-name (nth f 1)))
		       ))
	   (prefix (trim-filename-to-prefix
		    (strings-largest-common-prefix names)))
	   (prefix-length (string-length prefix))
	   )
      (for (in f file-list)
	   (collect
	    (create-file-browser-item
	     display-width
	     (nth f 1) % full-name
	     (string-rest (fixup-file-name (nth f 1)) prefix-length) % nice-name
	     (nth f 2) % deleted?
	     (nth f 3) % size
	     (nth f 4) % write-date
	     (nth f 5) % read-date
	     ))))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% DIRED command procedures:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de dired-exit ()
  (let ((actions (dired-determine-actions nmode-current-buffer)))
    (if (and (null (first actions)) (null (second actions)))
      (browser-exit-command)
      % else
      (let ((command (dired-present-actions actions)))
	(cond
	 ((eq command 'exit)
	  (browser-exit-command)
	  )
	 ((eq command t)
	  (dired-perform-actions actions)
	  (browser-exit-command)
	  )
	 ))
    )))

(de dired-browse-command ()
  % Browse the current item (presumably, a subdirectory).

  (let* ((browser (current-browser))
	 (item (=> browser current-item))
	 )
    (if item
      (directory-editor (=> item full-name))
      (Ding)
      )))

(de dired-create-command ()
  (let* ((browser (current-browser))
	 (dir-pn (pathname-without-name (=> browser get 'directory-name)))
	 (fn (prompt-for-string "Create file whose name is:" NIL))
	 (pn (maybe-pathname fn))
	 sout
	 )
    (if (not pn)
      (nmode-error (bldmsg "Invalid pathname: %w" fn))
      % otherwise
      (if (not (and (null (pathname-device pn))
		    (null (pathname-directory pn))
		    ))
	(nmode-error "Device and directory may not be specified.")
	% otherwise
	(setf pn (merge-pathname-defaults dir-pn
					  (pathname-name pn)
					  (pathname-type pn)
					  (pathname-version pn)
					  ))
	(setf fn (namestring pn))
	(if (filep fn)
	  (nmode-error (bldmsg "File %w already exists." fn))
	  % otherwise
	  (setf fn (actualize-file-name fn))
	  (if (or (not fn) (not (setf sout (attempt-to-open-output fn))))
	    (nmode-error (bldmsg "Unable to create file: %w" (namestring pn)))
	    % otherwise
	    (=> sout close)
	    (let ((item (create-file-browser-item
			 (=> browser display-width)
			 fn
			 (file-namestring fn)
			 nil 0 nil nil)))
	      (browser-add-item-and-view item)
	      )))))))

(de dired-look-command ()
  % Reinitialize the file directory browser.

  (write-prompt "Reading directory or directories...")
  (let* ((browser (current-browser))
	 (directory-name (=> browser get 'directory-name))
	 (file-list (find-matching-files directory-name t))
	 (items (dired-create-items file-list (=> browser display-width)))
	 )
    (=> browser set-items items)
    ))

(de dired-filter-command ()
  (nmode-set-immediate-prompt "Flush or Keep matching filenames?")
  (dired-filter-dispatch))

(de dired-filter-dispatch ()
  (selectq (char-upcase (input-base-character))
    (#/F (dired-filter-compose t))
    (#/K (dired-filter-compose nil))
    (#/?
     (nmode-set-immediate-prompt
      "Type F to flush or K to keep matching filenames.")
     (dired-filter-dispatch))
    (t (write-prompt "") (Ding))))

(de dired-filter-compose (flag)
  (let ((browser (current-browser))
	(dired-argument-list
	 (list
	  (string-upcase
	   (prompt-for-string
	    (if flag
	      "Flush filenames matching what string?"
	      "Keep filenames matching what string?")
	    ""))
	  flag)))
    (=> browser filter-items #'dired-string-filter-predicate)))

(de dired-reverse-sort ()
  (nmode-set-immediate-prompt "Reverse Sort by ")
  (dired-reverse-sort-dispatch)
  )

(de dired-reverse-sort-dispatch ()
  (selectq (char-upcase (input-base-character))
   (#/F (browser-sort "Reverse Sort by Filename" 'dired-filename-reverser))
   (#/S (browser-sort "Reverse Sort by Size" 'dired-size-reverser))
   (#/W (browser-sort "Reverse Sort by Write date" 'dired-write-reverser))
   (#/R (browser-sort "Reverse Sort by Read date" 'dired-read-reverser))
   (#/?
     (nmode-set-immediate-prompt
      "Reverse Sort by (Filename, Size, Read date, Write date) ")
     (dired-reverse-sort-dispatch)
     )
   (t (write-prompt "") (Ding))
   ))

(de dired-sort ()
  (nmode-set-immediate-prompt "Sort by ")
  (dired-sort-dispatch)
  )

(de dired-sort-dispatch ()
  (selectq (char-upcase (input-base-character))
   (#/F (browser-sort "Sort by Filename" 'dired-filename-sorter))
   (#/S (browser-sort "Sort by Size" 'dired-size-sorter))
   (#/W (browser-sort "Sort by Write date" 'dired-write-sorter))
   (#/R (browser-sort "Sort by Read date" 'dired-read-sorter))
   (#/? (nmode-set-immediate-prompt
	 "Sort by (Filename, Size, Read date, Write date) ")
	(dired-sort-dispatch)
	)
   (t (write-prompt "") (Ding))
   ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% DIRED Support Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de dired-string-filter-predicate (file-browser-item)
  (let* ((nice-name (=> file-browser-item nice-name))
	 (match (forward-search-in-string 
		 nice-name (first dired-argument-list))))
    (when (second dired-argument-list)
      (setf match (not match)))
    match))

(de dired-determine-actions (b)
  % Return a list containing two lists: the first a list of file names to be
  % deleted, the second a list of file names to be undeleted.

  (let ((items (=> (=> b get 'browser) items))
	(delete-list ())
	(undelete-list ())
	)
    (for (in item items)
	 (do (selectq (=> item action-wanted)
	       (delete
		(setf delete-list (aconc delete-list (=> item full-name))))
	       (undelete
		(setf undelete-list (aconc undelete-list (=> item full-name))))
	       )))
    (list delete-list undelete-list)
    ))

(de dired-present-actions (action-list)
  (let ((delete-list (first action-list))
	(undelete-list (second action-list))
        )
    (nmode-begin-typeout)
    (dired-present-list delete-list "These files to be deleted:")
    (dired-present-list undelete-list "These files to be undeleted:")
    (while t
      (printf "%nDo It (YES, N, X)? ")
      (selectq (get-upchar)
       (#/Y
	(if (= (get-upchar) #/E)
	    (if (= (get-upchar) #/S)
		(exit T)
		(Ding) (next))
	    (Ding) (next))
	)
       (#/N (exit NIL))
       (#/X (exit 'EXIT))
       (#/? (printf "%n YES-Do it, N-Return to DIRED, X-Exit from DIRED."))
       (t (Ding))
       ))))

(de get-upchar ()
  % This function is used during "normal PSL" typeout, so we cannot use
  % the NMODE input functions, for they will refresh the NMODE windows.

  (let ((ch (X-Base (=> nmode-terminal get-character))))
    (when (AlphaP ch) (setf ch (char-upcase ch)) (WriteChar ch))
    ch))

(de dired-present-list (list prompt)
  (when list
    (printf "%w%n" prompt)
    (for (in item list)
         (for count 0 (if (= count 1) 0 (+ count 1)))
         (do (printf "%w" (string-pad-right item 38))
	     (if (= count 1) (printf "%n"))
	     )
         )
    (printf "%n")
    ))

(de dired-perform-actions (action-list)
  (let ((delete-list (first action-list))
	(undelete-list (second action-list))
        )
    (for (in file delete-list)
         (do (file-delete file)))
    (for (in file undelete-list)
         (do (file-undelete file)))
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Sorting predicates:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(declare-flavor file-browser-item f1 f2)

(de dired-filename-sorter (f1 f2)
  (let ((n1 (=> f1 sort-name))
	(n2 (=> f2 sort-name))
	)
    (if (string= n1 n2)
      (<= (=> f1 version-number) (=> f2 version-number))
      (string<= n1 n2)
      )))

(de dired-filename-reverser (f1 f2)
  (not (dired-filename-sorter f1 f2)))

(de dired-size-sorter (f1 f2)
  (let ((size1 (=> f1 size))
	(size2 (=> f2 size))
	)
    (or (< size1 size2)
	(and (= size1 size2)
	     (dired-filename-sorter f1 f2))
	)))

(de dired-size-reverser (f1 f2)
  (let ((size1 (=> f1 size))
	(size2 (=> f2 size))
	)
    (or (> size1 size2)
	(and (= size1 size2)
	     (dired-filename-sorter f1 f2))
	)))

(de dired-write-sorter (f1 f2)
  (let ((d1 (or (=> f1 write-date) 0))
	(d2 (or (=> f2 write-date) 0))
	)
       (or (LessP d1 d2)
	   (and (EqN d1 d2) (dired-filename-sorter f1 f2))
	   )))

(de dired-write-reverser (f1 f2)
  (let ((d1 (or (=> f1 write-date) 0))
	(d2 (or (=> f2 write-date) 0))
	)
       (or (GreaterP d1 d2)
	   (and (EqN d1 d2) (dired-filename-sorter f1 f2))
	   )))

(de dired-read-sorter (f1 f2)
  (let ((d1 (or (=> f1 read-date) 0))
	(d2 (or (=> f2 read-date) 0))
	)
       (or (LessP d1 d2)
	   (and (EqN d1 d2) (dired-filename-sorter f1 f2))
	   )))

(de dired-read-reverser (f1 f2)
  (let ((d1 (or (=> f1 read-date) 0))
	(d2 (or (=> f2 read-date) 0))
	)
       (or (GreaterP d1 d2)
	   (and (EqN d1 d2) (dired-filename-sorter f1 f2))
	   )))

(undeclare-flavor f1 f2)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The file-browser-item flavor:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de create-file-browser-item (width full-name nice-name deleted? size
				    write-date read-date)
  (make-instance 'file-browser-item
		 'full-name full-name
		 'nice-name nice-name
		 'deleted? deleted?
		 'size size
		 'write-date write-date
		 'read-date read-date
		 'display-width width
		 ))

(defflavor file-browser-item
  (
   display-text
   display-width
   full-name		% full name of file
   nice-name		% file name as displayed
   sort-name		% name without version (for sorting purposes)
   version-number	% version number (or 0) (for sorting purposes)
   size			% size of file (arbitrary units)
   write-date		% write date of file (or NIL)
   read-date		% read date of file (or NIL)
   deleted?		% file is actually deleted
   delete-flag		% user wants file deleted
   (buffer NIL)		% buffer created to view file
   )
  ()
  (gettable-instance-variables display-text full-name nice-name
			       sort-name version-number
			       size write-date read-date)
  (initable-instance-variables)
  )

(defmethod (file-browser-item init) (init-plist)
  (let ((pn (maybe-pathname nice-name)))
    (setf sort-name
      (if pn (namestring (pathname-without-version pn)) nice-name))
    (setf version-number (if pn (pathname-version pn) 0))
    (if (not (fixp version-number)) (setf version-number 0))
    )
  (setf display-text
    (string-concat
     (if deleted? "D " "  ")
     (string-pad-right nice-name (- display-width 48))
     (string-pad-left (BldMsg "%d" size) 8)
     (string-pad-left (if write-date (file-date-to-string write-date) "") 19)
     (string-pad-left (if read-date (file-date-to-string read-date) "") 19)
     ))
  (setf delete-flag deleted?)
  )

(defmethod (file-browser-item update) ()
  % Updating is too expensive, so we do nothing.
  T
  )

(defmethod (file-browser-item delete) ()
  (when (not delete-flag)
    (setf display-text (copystring display-text))
    (string-store display-text 0 #/D)
    (setf delete-flag T)
    ))

(defmethod (file-browser-item undelete) ()
  (when delete-flag
    (setf display-text (copystring display-text))
    (string-store display-text 0 #\space)
    (setf delete-flag NIL)
    ))

(defmethod (file-browser-item deleted?) ()
  delete-flag
  )

(defmethod (file-browser-item kill) ()
  (let ((result (nmode-delete-file full-name)))
    (when result
      (=> self cleanup)
      )
    result
    ))

(defmethod (file-browser-item view-buffer) (x)
  (or (find-file-in-existing-buffer full-name)
      (setf buffer (find-file-in-buffer full-name T))
      ))

(defmethod (file-browser-item cleanup) ()
  (when (and buffer (not (=> buffer modified?)))
    (when (buffer-is-selectable? buffer)
      (=> buffer set-previous-buffer NIL) % don't display the browser
      (buffer-kill-and-detach buffer)
      )
    (setf buffer NIL)
    ))

(defmethod (file-browser-item apply-filter) (filter)
  (apply filter (list self))
  )

(defmethod (file-browser-item action-wanted) ()
  % Return 'DELETE, 'UNDELETE, or NIL.
  (if (not (eq deleted? delete-flag)) % user wants some action taken
    (let ((file-status (file-deleted-status full-name)))
      (if file-status % File currently exists (otherwise, forget it)
	(let ((actually-deleted? (eq file-status 'deleted)))
	  (if (not (eq delete-flag actually-deleted?))
	    (if delete-flag 'DELETE 'UNDELETE)
	    ))))))

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

(off fast-integers)