Artifact dc65a61f2554a3a6713a66d38a146722fb15f07adefdf8969c06e59fe4cbb910:

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

%
% DIRED.SL - Directory Editor Subsystem for EMODE
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        16 July 1982
%
% This file implements a directory editor subsystem.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(BothTimes (load common strings directory gsort))

(fluid '(CurrentLineIndex point WindowsBufferName BufferPreviousBuffer
	 BufferAuxiliaryInfo CurrentBufferName DefaultMode buffers_file))

(fluid '(DiredMode))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Macros
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro fi-full-name (fi) `(nth ,fi 1))   % string for file primitives
(defmacro fi-deleted? (fi) `(nth ,fi 2))    % is file marked 'deleted'?
(defmacro fi-size (fi) `(nth ,fi 3))        % "size" of file
(defmacro fi-write-date (fi) `(nth ,fi 4))  % date/time file last written
(defmacro fi-read-date (fi) `(nth ,fi 5))   % date/time file last read
(defmacro fi-nice-name (fi) `(nth ,fi 6))   % string to show user

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

(setf DiredMode
      '((SetKeys DiredDispatchList)
	(SetKeys ReadOnlyTextDispatchList)
	(SetKeys RlispDispatchList)
	(SetKeys BasicDispatchList)))

(setf DiredDispatchList (list

    % These are the DIRED-specific commands.

    (cons (char ?) 'dired-help)
    (cons (char C) 'dired-srccom-file)
    (cons (char D) 'dired-delete-file)
    (cons (char E) 'dired-edit-file)
    (cons (char H) 'dired-automatic-delete)
    (cons (char K) 'dired-delete-file)
    (cons (char N) 'dired-next-hog)
    (cons (char Q) 'dired-exit)
    (cons (char R) 'dired-reverse-sort)
    (cons (char S) 'dired-sort)
    (cons (char U) 'dired-undelete)
    (cons (char X) 'dired-exit)
    (cons (char rubout) 'dired-reverse-undelete)
    (cons (char space) '$ForwardLine)
    (cons (char (cntrl D)) 'dired-delete-file)
    (cons (char (cntrl K)) 'dired-delete-file)
    ))

(de dired-command ()
  (write-prompt "")
  (let* ((directory-name (prompt_for_string "Directory to edit: " buffers_file))
	 file-list
         )
    (write-prompt "Reading directory(ies)...")
    (setf file-list (find-matching-files directory-name t))
    (if (null file-list)
      (write-prompt (BldMsg "No files match: %w" directory-name))
      % ELSE
      (dired-fixup-file-list file-list)
      (SelectBuffer (buffer-create '*Dired DiredMode))
      (setf BufferPreviousBuffer WindowsBufferName)
      (setf BufferAuxiliaryInfo file-list)
      (setf buffers_file directory-name)
      (load-dired-buffer BufferAuxiliaryInfo)
      (setf WindowsBufferName CurrentBufferName)
      (EstablishCurrentMode)
      (write-prompt "")
      )
    )
  )

(de dired-fixup-file-list (file-list)
  % Adds to each element:
  % A cleaned-up file name for display and sorting purposes.

  (for (in file-info file-list)
       (do
	 (aconc file-info (fixup-file-name (fi-full-name file-info)))
	 ))
  (let ((prefix (if file-list (fi-nice-name (first file-list)) ""))
        prefix-length
        name)
    (for (in file-info file-list)
         (do (setf prefix
	       (string-largest-common-prefix prefix (fi-nice-name file-info))
	      ))
	 )
    (setf prefix (trim-filename-to-prefix prefix))
    (setf prefix-length (+ 1 (size prefix)))
    (for (in file-info file-list)
         (do (setf name (fi-nice-name file-info))
	     (setf (fi-nice-name file-info)
		   (sub name
			prefix-length
		        (- (size name) prefix-length))))
	 ))
  )

(de load-dired-buffer (file-list)
  ($DeleteBuffer)
  (for* (in file-info file-list)
        (do (insert_string (file-info-to-string file-info))
            ($CRLF))
        )
  (setf point 0)
  (SelectLine 0)
  )

(de file-info-to-string (file-info)
  (let ((first-part (if (fi-deleted? file-info) "D " "  "))
	(file-name (string-pad-right (fi-nice-name file-info) 34))
	(file-size (string-pad-left (BldMsg "%d" (fi-size file-info)) 4))
	(write-date (file-date-to-string (fi-write-date file-info)))
	(read-date (file-date-to-string (fi-read-date file-info))))
   (string-concat first-part file-name file-size " " write-date " " read-date)
   ))

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

(de dired-exit ()
  (let* ((actions (dired-determine-actions BufferAuxiliaryInfo))
         command
         )
    (if (and (null (first actions)) (null (second actions)))
      (window-kill-buffer)
      % else
      (setf command (dired-present-actions actions))
      (cond
        ((eq command 'exit) (window-kill-buffer))
        ((eq command t) (dired-perform-actions actions) (window-kill-buffer))
        )
    )))

(de dired-delete-file ()
  % Mark the current file as deleted.
  (cond ((current-line-empty) (Ding))
        (t
	  (if (= (current-line-fetch 0) (char space))
	    (current-line-store 0 (char D)))
	  (move-to-next-line)
	)))

(de dired-undelete ()
  % Unmark the current file.
  (cond ((current-line-empty) (Ding))
        (t
	  (if (= (current-line-fetch 0) (char D))
	    (current-line-store 0 (char space)))
	  (move-to-next-line)
	)))

(de dired-reverse-undelete ()
  % Unmark the previous file.
  (cond ((= CurrentLineIndex 0) (Ding))
        (t
          (move-to-previous-line)
	  (if (= (current-line-fetch 0) (char D))
	    (current-line-store 0 (char space)))
	)))

(de dired-help ()
  (write-prompt
 "DIRED: D-delete, U-undelete, E-edit file, S-sort, R-reverse sort, Q-exit")
  )

(de dired-next-hog ()
  (write-prompt "The DIRED NEXT HOG command is unimplemented.") (Ding)
  )

(de dired-automatic-delete ()
  (write-prompt "The DIRED AUTOMATIC DELETE command is unimplemented.") (Ding)
  )

(de dired-edit-file ()
  (write-prompt "")
  (if (not (dired-valid-line)) (Ding)
    (let* ((file-info (nth BufferAuxiliaryInfo (+ CurrentLineIndex 1)))
	   (file-name (fi-full-name file-info))
	   (old-buffer CurrentBufferName)
	   )

      (find-file file-name)
      (setf BufferPreviousBuffer old-buffer)
      (write-prompt "C-M-L returns to DIRED; C-X K kills buffer and returns.")
      )
    )
  )

(de dired-reverse-sort ()
  (write-prompt "Reverse Sort by ")
  (while t
    (let ((ch (RaiseChar (GetNextCommandCharacter))))
      (cond
        ((= ch (char F))
	  (dired-perform-sort "Reverse Sort by Filename" 'dired-filename-reverser)
	  (exit))
        ((= ch (char S))
	  (dired-perform-sort "Reverse Sort by Size" 'dired-size-reverser)
	  (exit))
        ((= ch (char W))
	  (dired-perform-sort "Reverse Sort by Write date" 'dired-write-reverser)
	  (exit))
        ((= ch (char R))
	  (dired-perform-sort "Reverse Sort by Read date" 'dired-read-reverser)
	  (exit))
        ((= ch (char ?))
	  (write-prompt "Reverse Sort by (Filename, Size, Read date, Write date) ")
	  (next))
	(t (write-prompt "") (Ding) (exit))
	))))

(de dired-sort ()
  (write-prompt "Sort by ")
  (while t
    (let ((ch (RaiseChar (GetNextCommandCharacter))))
      (cond
        ((= ch (char F))
	  (dired-perform-sort "Sort by Filename" 'dired-filename-sorter)
	  (exit))
        ((= ch (char S))
	  (dired-perform-sort "Sort by Size" 'dired-size-sorter)
	  (exit))
        ((= ch (char W))
	  (dired-perform-sort "Sort by Write date" 'dired-write-sorter)
	  (exit))
        ((= ch (char R))
	  (dired-perform-sort "Sort by Read date" 'dired-read-sorter)
	  (exit))
        ((= ch (char ?))
	  (write-prompt "Sort by (Filename, Size, Read date, Write date) ")
	  (next))
	(t (write-prompt "") (Ding) (exit))
	))))

(de dired-srccom-file ()
  (write-prompt "The DIRED SRCCOM command is unimplemented.") (Ding)
  )

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

(de dired-valid-line ()
  (and
    (>= CurrentLineIndex 0)
    (> (current-line-length) 60)
    (= (current-line-fetch 1) (char space))))

(de dired-determine-actions (file-list)
  % 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 ((old-line CurrentLineIndex))
    (SelectLine 0)
    (prog1
    (for*
      (in file-info file-list)
      (with delete-list undelete-list file-name file-status desired-status)
      (do
        (setf file-name (fi-full-name file-info))
        (setf file-status (file-deleted-status file-name))
        (setf desired-status (current-line-fetch 0))
        (move-to-next-line)
        (if file-status
          (cond
	    ((and (eq file-status 'deleted) (= desired-status (char space)))
	      (setf undelete-list (append undelete-list (list file-name))))
	    ((and (neq file-status 'deleted) (= desired-status (char D)))
	      (setf delete-list (append delete-list (list file-name))))
	    )))
      (returns (list delete-list undelete-list))
      )
    (SelectLine old-line))))

(de dired-present-actions (action-list)
  (let ((delete-list (first action-list))
	(undelete-list (second action-list))
        ch)

    % This is a terrible way of outputting information, but it is
    % the way EMODE already does it.

    (SelectOldChannels)
    (ClearScreen)
    (dired-present-list delete-list "These files to be deleted:")
    (dired-present-list undelete-list "These files to be undeleted:")
    (prog1
      (while t
        (printf "%nDo It (YES, N, X)? ")
        (setf ch (get-upchar))
        (cond
	  ((= ch (char Y))
	    (if (= (get-upchar) (char E))
	      (if (= (get-upchar) (char S))
	        (exit T)
	        (Ding) (next))
	      (Ding) (next))
	   )
          ((= ch (char N)) (exit NIL))
	  ((= ch (char X)) (exit 'EXIT))
          ((= ch (char ?))
             (printf "%n YES-Do it, N-Return to DIRED, X-Exit from DIRED.")
             )
	  (t (Ding))
	  ))
      (ClearScreen)
      )
    ))

(de get-upchar ()
  (let ((ch (GetNextCommandCharacter)))
    (cond ((AlphaP ch) (setf ch (char-upcase ch)) (WriteChar ch) ch)
          (t ch))))

(de dired-present-list (list prompt)
  (if list (progn
    (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)))
    ))

(de dired-perform-sort (prompt sorter)
  (write-prompt prompt)
  (setf BufferAuxiliaryInfo (GSort BufferAuxiliaryInfo sorter))
  (load-dired-buffer BufferAuxiliaryInfo)
  )

(de dired-filename-sorter (f1 f2)
  (StringSortFn (fi-nice-name f1) (fi-nice-name f2)))

(de dired-filename-reverser (f1 f2)
  (StringSortFn (fi-nice-name f2) (fi-nice-name f1)))

(de dired-size-sorter (f1 f2)
  (or (< (fi-size f1) (fi-size f2))
      (and (= (fi-size f1) (fi-size f2))
           (StringSortFn (fi-nice-name f1) (fi-nice-name f2)))
      ))

(de dired-size-reverser (f1 f2)
  (or (> (fi-size f1) (fi-size f2))
      (and (= (fi-size f1) (fi-size f2))
           (StringSortFn (fi-nice-name f1) (fi-nice-name f2)))
      ))

(de dired-write-sorter (f1 f2)
  (or (< (fi-write-date f1) (fi-write-date f2))
      (and (= (fi-write-date f1) (fi-write-date f2))
           (StringSortFn (fi-nice-name f1) (fi-nice-name f2)))
      ))

(de dired-write-reverser (f1 f2)
  (or (> (fi-write-date f1) (fi-write-date f2))
      (and (= (fi-write-date f1) (fi-write-date f2))
           (StringSortFn (fi-nice-name f1) (fi-nice-name f2)))
      ))

(de dired-read-sorter (f1 f2)
  (or (< (fi-read-date f1) (fi-read-date f2))
      (and (= (fi-read-date f1) (fi-read-date f2))
           (StringSortFn (fi-nice-name f1) (fi-nice-name f2)))
      ))

(de dired-read-reverser (f1 f2)
  (or (> (fi-read-date f1) (fi-read-date f2))
      (and (= (fi-read-date f1) (fi-read-date f2))
           (StringSortFn (fi-nice-name f1) (fi-nice-name f2)))
      ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Useful String Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de string-pad-right (s desired-length)
  (let ((len (string-length s)))
    (if (< len desired-length)
      (string-concat s (make-string (- desired-length len) (char space)))
      s)))

(de string-pad-left (s desired-length)
  (let ((len (string-length s)))
    (if (< len desired-length)
      (string-concat (make-string (- desired-length len) (char space)) s)
      s)))

(de string-largest-common-prefix (s1 s2)
  (for (from i 0 (min (size s1) (size s2)) 1)
       (while (= (indx s1 i) (indx s2 i)))
       (returns (sub s1 0 (- i 1)))
       ))