Artifact 04bd61424fe34f3d40fa894bdb3dce3d5b00e47732b85eaea11f615984c1b9d7:

• File psl-1983/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: 13445) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% DIRED.SL - Directory Editor Subsystem
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        16 July 1982
% Revised:     16 February 1983
%
% This file implements a directory editor subsystem.
%
% 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))
(load directory stringx)

% External variables:

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

% Internal static variables:

(fluid '(File-Browser-Mode File-Browser-Command-List))

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

(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 ?) 'dired-help)
    (cons (x-char D) 'browser-delete-command)
    (cons (x-char E) 'browser-edit-command)
    (cons (x-char I) 'browser-ignore-command)
    (cons (x-char K) 'browser-kill-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 (directory-namestring 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)
    ))

(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 used.

  (setf directory-name (fixup-directory-name directory-name))
  (write-prompt "Reading directory or directories...")
  (let ((items (dired-create-items (find-matching-files directory-name t))))
    (if (null items)
      (write-prompt (BldMsg "No files match: %w" directory-name))
      % ELSE
      (let* ((b (buffer-create "+FILES" File-Browser-Mode))
	     (header-text (vector
	         (string-concat "Directory List of " directory-name)
		 ""
		 ))
	     )
	(=> b put 'directory-name directory-name)
	(create-browser b NIL header-text items #'dired-filename-sorter)
        (browser-enter b)
	(dired-help)
	))))

(de dired-create-items (file-list)
  % 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* ((display-width (=> nmode-current-window width))
	   (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-help ()
  (write-message
"View Edit Un/Delete Kill-now Ignore uN-ignore Sort Reverse-sort Quit"
  ))

(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-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 (=> f1 write-date))
	(d2 (=> f2 write-date))
	)
       (or (LessP d1 d2)
	   (and (EqN d1 d2) (dired-filename-sorter f1 f2))
	   )))

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

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

(de dired-read-reverser (f1 f2)
  (let ((d1 (=> f1 read-date))
	(d2 (=> f2 read-date))
	)
       (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 (pathname full-name)))
    (setf sort-name (namestring (pathname-without-version pn)))
    (setf version-number (pathname-version pn))
    (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 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) ()
  (nmode-delete-file full-name)
  )

(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?)))
    (if (buffer-is-selectable? buffer) (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)
	    ))))))