commander-s/scheme/cd.scm

;;cd
;;This command can be used on all platforms because it uses the 
;;scsh-Function "chdir"

(define-record-type cd-result-object cd-result-object
  (make-cd-result-object pos-y
			 pos-x
			 file-list
			 result-text
			 working-directory
			 width
			 initial-wd
			 marked-items
			 res-marked-items)
  cd-result-object?
  (pos-y cd-result-object-pos-y)
  (pos-x cd-result-object-pos-x)
  (file-list cd-result-object-file-list)
  (result-text cd-result-object-result-text)
  (working-directory cd-result-object-working-directory)
  (width cd-result-object-width)
  (initial-wd cd-result-object-initial-wd)
  (marked-items cd-result-object-marked-items)
  (res-marked-items cd-result-object-res-marked-items))

;;Layout of the result of cd
(define layout-result-cd
  (lambda (result-str result width)
    (begin
      (let ((printed-file-list (print-file-list result))
	    (directory (cwd))
	    (heading ""))
	(begin
	  (if (<= (string-length directory) (- width 27))
	      (set! heading (string-append "Directory-Content of " 
					   directory  " :"))
	      (let ((dir-string (substring directory 
					   (- (string-length directory) 
					      (- width 27))
					   (string-length directory))))
		(set! heading (string-append "Directory-Content of ..."
					     dir-string))))
	  (append (list heading) printed-file-list))))))

;;One File per-line
;;In case the object is a directory "/" is added
(define print-file-list
  (lambda (file-list)
    (let loop ((old file-list)
	       (new '()))
      (if (equal? '() old)
	  new
	  (let ((hd (list-ref old 0))
		(tl (cdr old)))
	    (if (file-directory? hd)
		(let ((new-str (string-append " " hd "/")))
		  (loop tl (append new (list new-str))))
		(loop tl (append new (list (string-append " " hd))))))))))

;;selection->descend
(define selected-cd
  (lambda (model)
    (let ((ln (cd-result-object-pos-y model))
	  (wd (cd-result-object-working-directory model)))
      (begin
	(chdir wd)
	(if (or (>= ln (+ (length (cd-result-object-result-text model)) 1))
		(<= ln 1))
	    model
	    (let* ((text (cd-result-object-result-text model))
		   (ent (list-ref text (- ln 1)))
		   (len (string-length ent))
		   (last-char (substring ent (- len 1) len))
		   (rest (substring ent 1 (- len 1))))
	      (if (equal? last-char "/")
		  (begin
		    (chdir rest)
		    (let* ((new-result (evaluate "(directory-files)"))
			   (new-result-string (exp->string new-result))
			   (width (cd-result-object-width model))
			   (new-text (layout-result-cd 
				      new-result-string new-result width))
			   (new-model (make-cd-result-object
				       2
				       1
				       new-result
				       new-text
				       (cwd)
				       width
				       (cd-result-object-initial-wd model)
				       (cd-result-object-marked-items model)
				       (cd-result-object-res-marked-items
					model))))
		      new-model))
		  model)))))))


(define cd-receiver
  (lambda (message)
    (cond 
     ((next-command-message? message)
      (let* ((command (next-command-string message))
	     (parameters (next-command-message-parameters message))
	     (result #f)
	     (width (next-command-message-width message)))
	     
	(begin
	  (if (null? parameters)
	      (begin
		(set! result (list "forgot parameters?"))
		(let* ((text
			(layout-result-standard "forgot parameters?" 
						result width))
		       (std-obj
			(make-cd-result-object 1 1 result text (cwd) width
					       (cwd) '() '())))
		  std-obj))
	      
	      (begin
		(evaluate (string-append "(chdir "
					 (exp->string (car parameters))
					 " )"))
		(set! result (evaluate "(directory-files)"))
		(let* ((result-string (exp->string result))
		       (width (next-command-message-width message))
		       (text 
			(layout-result-cd result-string result width))
		       (cd-obj 
			(make-cd-result-object 2 1 result text (cwd) width
					       (cwd) '() '())))
		 cd-obj))))))
     ((print-message? message)
      (let* ((model (print-message-object message))
	     (pos-y (cd-result-object-pos-y model))
	     (pos-x (cd-result-object-pos-x model))
	     (text (cd-result-object-result-text model))
	     (marked-pos (get-marked-positions-2
			  (cd-result-object-file-list model)
			  (cd-result-object-marked-items model))))
	(make-print-object pos-y pos-x text (list pos-y) marked-pos))) 
     ((key-pressed-message? message)
      (let* ((model (key-pressed-message-result-model message))
	     (key (key-pressed-message-key message)))
	(cond
	 ((= key key-up)
	  (let ((posy (cd-result-object-pos-y model)))
	    (if (<= posy 2)
		model
		(let* ((new-posy (- posy 1))
		       (new-model (make-cd-result-object 
				   new-posy
				   (cd-result-object-pos-x model)
				   (cd-result-object-file-list model)
				   (cd-result-object-result-text model)
				   (cd-result-object-working-directory model)
				   (cd-result-object-width model)
				   (cd-result-object-initial-wd model)
				   (cd-result-object-marked-items model)
				   (cd-result-object-res-marked-items model))))
		  new-model))))

	 ((= key key-down)
	  (let ((posy (cd-result-object-pos-y model))
		(num-lines (length 
			    (cd-result-object-result-text model))))
	    (if (>= posy num-lines)
		model
		(let* ((new-posy (+ posy 1))
		       (new-model (make-cd-result-object 
				   new-posy
				   (cd-result-object-pos-x model)
				   (cd-result-object-file-list model)
				   (cd-result-object-result-text model)
				   (cd-result-object-working-directory model)
				   (cd-result-object-width model)
				   (cd-result-object-initial-wd model)
				   (cd-result-object-marked-items model)
				   (cd-result-object-res-marked-items model))))
		  new-model))))

     ((= key 10)
	  (selected-cd model))
     (else model))))


     ((restore-message? message)
      values)
     ((selection-message? message)
      ""))))


(define cd-rec (make-receiver "cd" cd-receiver))

(set! receivers (cons cd-rec receivers))