commander-s/scheme/browse-directory-list.scm

(define-option 'ls 'sort-up-key (char->ascii #\s))
(define-option 'ls 'sort-down-key (char->ascii #\S))

(define key-m 109)
(define key-u 117)
(define key-return 10)

(define (add-marks-to-special-file file-name fs-object)
  (let ((info (fs-object-info fs-object)))
    (cond
     ((not info)
      (string-append " " file-name ": error during file-info!"))
     ((file-info-directory? info)
      (string-append " " file-name "/"))
     ((file-info-executable? info)
      (string-append "*" file-name))
     ((file-info-symlink? info)
      (string-append "@" file-name))
     (else
      (string-append " " file-name)))))

(define (have-permission? mode perm-mask)
  (not (zero? (bitwise-and mode perm-mask))))

(define (format-permissions mode)
  (apply string-append
	 (cons
          (cond
           ((have-permission? mode #o1000) "t") ; sticky
           ((have-permission? mode #o2000) "s") ; setgit 
           ((have-permission? mode #o4000) "s") ; setuid
           (else "-"))
          (map (lambda (mask.symbol)
                 (if (have-permission? mode (car mask.symbol))
                     (cdr mask.symbol)
                     "-"))
               '((#o0400 . "r");; owner read
                 (#o0200 . "w");; owner write
                 (#o0100 . "x");; owner exec
                 (#o0040 . "r");; group read
                 (#o0020 . "w");; group write
                 (#o0010 . "x");; group exec
                 (#o0004 . "r");; others read
                 (#o0002 . "w");; others write
                 (#o0001 . "x"))))));; others exec

(define (digits-left-of-comma-as-string float)
  (string-drop-right 
   (number->string (truncate float)) 1))

(define (format-size/unit float unit)
  (string-append (digits-left-of-comma-as-string float) " " unit))

(define (format-size bytes)
  (let* ((kbyte 1024.0)
	 (mbyte (* 1024 kbyte))
	 (gbyte (* 1024 mbyte)))
    (cond
     ((>= bytes gbyte)
      (format-size/unit (/ bytes gbyte) "GB"))
     ((>= bytes mbyte)
      (format-size/unit (/ bytes mbyte) "MB"))
     ((>= bytes kbyte)
      (format-size/unit (/ bytes kbyte) "KB"))
     (else
      (number->string bytes)))))

(define (->username/save uid/name)
  (with-fatal-error-handler
   (lambda (condition more)
     (if (number? uid/name)
         (number->string uid/name)
         uid/name))
   (->username uid/name)))

(define (->groupname/save gid/name)
  (with-fatal-error-handler
   (lambda (condition more)
     (if (number? gid/name)
         (number->string gid/name)
         gid/name))
   (->groupname gid/name)))

(define (format-user/group fi)
  (fill-up-string 17
   (string-append
    (cut-to-size 8 (->username/save (file-info:uid fi)))
    ":"
    (cut-to-size 8 (->groupname/save (file-info:gid fi))))))

(define today (date))

(define (format-time t)
  (let ((d (date t)))
    (if (= (date:year today)
           (date:year d))
        (format-date/wo-year d)
        (format-date/w-year d))))

(define (format-date/w-year d)
  (format-date "~b ~d  ~Y" d))

(define (format-date/wo-year d)
  (format-date "~b ~d ~H:~M" d))

;; leave one line for the heading
(define (calculate-number-of-lines result-buffer)
  (- (result-buffer-num-lines result-buffer)
     1))

(define (make-file-select-line)
  (make-select-line
   (list
    (make-unmarked-text-element 'file-name #f 
                                (left-align-string 31 "File name"))
    (make-unmarked-text-element 'size #f 
                                (right-align-string 8 "Size "))
    (make-unmarked-text-element 'user/group #f
                                (left-align-string 18 "User:Group "))
    (make-unmarked-text-element 'mode #f (left-align-string 10 "Mode "))
    (make-unmarked-text-element 'mtime #f
                                (left-align-string 13 " Mod time")))))


(define (layout-fsobject parent-dir-len fsobject num-cols)
  (let ((file-name (combine-path (string-drop
                                  (fs-object-path fsobject)
                                  parent-dir-len)                    
                                 (fs-object-name fsobject)))
	(fi (fs-object-info fsobject)))
    (cut-to-size num-cols
     (string-append
      (fill-up-string 
       30 (add-marks-to-special-file file-name fsobject))
      " "
      (right-align-string 7 (format-size (file-info:size fi)))
      " "
      (format-user/group fi)
      " "
      (format-permissions 
       (file-info:mode fi))
      " "
      (format-time
       (file-info:mtime fi))))))

(define (make-file-select-list fsobjects parent-dir num-lines num-cols)
  (let ((parent-dir-len (string-length parent-dir)))
    (make-select-list
     (cons (make-unmarked-text-element 'parent-dir #f " ..")
           (map (lambda (fs-object)
                  (make-unmarked-text-element 
                   fs-object #t (layout-fsobject parent-dir-len 
						 fs-object num-cols)))
                fsobjects))
     num-lines)))

;;; lacks some coolness
(define (abbrev-path path length)
  (if (< (string-length path) length)
      path
      (string-copy path 
		   (- (string-length path) length))))

(define header-line-path
  "Paths relative to ")

(define (make-header-line wdir width)
  (string-append 
   header-line-path
   (if wdir
       (abbrev-path 
	wdir (- width (string-length header-line-path)))
       "<unknown>")))

(define (paint-browser wdir select-line select-list win buffer have-focus?)
  (wattron win (A-BOLD))
  (mvwaddstr win 0 0
	     (make-header-line 
	      wdir (result-buffer-num-cols buffer)))
  (wattrset win (A-NORMAL))
  (paint-select-line-at select-line 1 1 win buffer)
  (paint-selection-list-at select-list 1 2 win
			   (result-buffer-num-cols buffer) have-focus?))

(define (find-common-parent paths)
  (if (null? paths)
      ""
      (let lp ((paths (cdr paths))
               (common (car paths))
               (common-len (string-length (car paths))))
        (if (null? paths)
            common
            (let ((prefix-len (string-prefix-length common (car paths))))
              (cond
               ((= 0 prefix-len) (error "no prefix??" common (car paths)))
               ((= 1 prefix-len) "/") ; search ends here
               ((= prefix-len common-len) ; short cut
                (lp (cdr paths)
                    common
                    common-len))
               (else
                (lp (cdr paths)
                    (substring common
                               0
                               prefix-len)
                    prefix-len))))))))

(define (make-browser-for-dir dir buffer)
  (with-cwd dir
    (make-fsobjects-viewer (directory-files)
                           buffer
                           (cwd))))
  
(define (make-fsobjects-viewer fs-objects buffer . maybe-parent)
  (let-optionals maybe-parent
      ((working-dir (find-common-parent
                     (map fs-object-path fs-objects))))
    (let ((fs-objects fs-objects)
          (buffer buffer)
          (select-list
           (make-file-select-list
	    fs-objects working-dir
	    ;; we need one line for the header
	    (- (result-buffer-num-lines buffer) 1)
	    (result-buffer-num-cols buffer)))
          (select-line (make-file-select-line)))

      (define (handle-return-key self selected-entry num-lines)
	(cond
	 ((eq? selected-entry 'parent-dir)
	  (let* ((maybe-parent (file-name-directory working-dir))
		 (parent (if (string=? maybe-parent "") "/" maybe-parent)))
	    (make-browser-for-dir parent buffer)))
	 (else
	  (let ((fi (fs-object-info selected-entry)))
	    (if (and fi (file-info-directory? fi))
		(with-errno-handler 
		 ((errno packet) 
		  (else
		   (display packet)
		   (newline)
		   self))
		 (make-browser-for-dir (fs-object-complete-path selected-entry)
				       buffer))
		self)))))

      (define (set-fs-objects! new-fs-objects)
        (set! fs-objects new-fs-objects)
        (set! select-list
              (make-file-select-list
               fs-objects working-dir
               ;; we need one line for the header
               (- (result-buffer-num-lines buffer) 1)
               (result-buffer-num-cols buffer))))

      (define sort-up-key (config 'ls 'sort-up-key))
      (define sort-down-key (config 'ls 'sort-down-key))
      
      (define (handle-key-press self key)
	(cond
	 ((= key key-return)
	  (handle-return-key
	   self (select-list-selected-entry select-list)
	   (calculate-number-of-lines buffer)))
         ((or (= key sort-up-key)
              (= key sort-down-key))
          (let ((column (select-line-selected-entry select-line)))
            (receive (compare-up compare-down select)
                (case column
                  ((file-name) 
                   ;; TODO: use path stripped by parent
                   (values string<? string>? fs-object-complete-path))
                  ((size) 
                   (values < 
                           > 
                           (lambda (fso)
                             (file-info:size (fs-object-info fso)))))
                  ((user/group) 
                   (values string<? 
                           string>? 
                           (lambda (fso)
                             (format-user/group (fs-object-info fso)))))
                  ((mode) 
                   (values < 
                           > 
                           (lambda (fso)
                             (file-info:mode (fs-object-info fso)))))
                  ((mtime)
                   (values <
                           >
                           (lambda (fso)
                             (file-info:mtime (fs-object-info fso)))))
                  (else
                   (error "unknown column" column)))
              (let ((compare (if (= key sort-up-key)
                                 compare-up
                                 compare-down)))
                (set-fs-objects!
                 (list-sort
                  (lambda (p1 p2)
                    (compare (select p1) (select p2)))
                  fs-objects))
                self))))
         ((select-list-key? key)
	  (set! select-list
		(select-list-handle-key-press select-list key))
	  self)
         ((select-line-key? key)
          (select-line-handle-key-press! select-line key)
          self)
         (else self)))

      (define (prepare-selection-for-scheme-mode file-names)
	(string-append "'" (write-to-string file-names)))

      ;; FIXME: quote file names containing space etc
      (define (prepare-selection-for-command-mode file-names)
	(string-join file-names))

      (define (get-selection-as-text self for-scheme-mode? focus-object-table)
	(let* ((marked (select-list-get-marked select-list))
	       (file-names
		(map fs-object-complete-path
		     (if (null? marked)
			 (list (select-list-selected-entry select-list))
			 marked))))
	  ((if for-scheme-mode?
	       prepare-selection-for-scheme-mode
	       prepare-selection-for-command-mode)
	   file-names)))

      (define (get-selection-as-ref self focus-object-table)
	(let ((marked (select-list-get-marked select-list))
	      (make-reference (lambda (obj)
				(make-focus-object-reference 
				 focus-object-table obj))))
	  (if (null? marked)
	      (write-to-string 
	       (make-reference (select-list-selected-entry select-list)))
	      (string-append
	       "(list " 
	       (string-join (map write-to-string (map make-reference marked)))
	       ")"))))

      (lambda (message)
	(cond
	 ((eq? message 'paint)
	  (lambda (self win buffer have-focus?)
	    (paint-browser working-dir select-line select-list 
                           win buffer have-focus?)))

	 ((eq? message 'key-press)
	  (lambda (self key control-x-pressed?)
	    (handle-key-press self key)))

	 ((eq? message 'get-selection-as-text)
	  get-selection-as-text)

	 ((eq? message 'get-selection-as-ref)
	  get-selection-as-ref)
       
	 (else
	  (error "fsobjects-viewer unknown message" message)))))))

(define (list-of-fs-objects? thing)
  (and (proper-list? thing)
       (every fs-object? thing)))

(register-plugin! 
 (make-view-plugin make-fsobjects-viewer
		   (lambda (thing)
                     (list-of-fs-objects? thing))))