diff --git a/README b/README new file mode 100644 index 0000000..bbb80d8 --- /dev/null +++ b/README @@ -0,0 +1,92 @@ +Commander S 0.0 README -*- outline -*- + + + Tuebingen, June 2005 + + + Commander S + =========== + +* Requirements + + Before installing Commander S, you need to install the following + software: + + - The current CVS version of scsh, the Scheme Shell. The latest + release, version 0.6.6, contains two small bugs that prevent + Commander S from running correctly. Alternativly, you may apply + the patches listed in the last section of this README to your scsh + 0.6.6 source tree. + (From ) + + - Version 1.1.0 of install-lib, the scsh installation library + (From ) + + - Version 0.6 of Sunterlib, the Scheme Untergrund library + (From ) + +* Installation + + Run the script install.scm from the top of the tarball: + + ./install.scm + + The only important option is --prefix to specify a directory where + files are installed. Use the --help options to see all possible + options. + +* Patches for scsh + + The following patches fix two little bugs in the scsh source tree + found during the development of Commander S. + +Index: scsh/procobj.scm +=================================================================== +RCS file: /cvsroot/scsh/scsh/scsh/procobj.scm,v +retrieving revision 1.22 +diff -u -r1.22 procobj.scm +--- scsh/procobj.scm 14 Aug 2002 14:45:33 -0000 1.22 ++++ scsh/procobj.scm 5 Jul 2005 15:11:50 -0000 +@@ -345,8 +345,10 @@ + + ;;; All you have to do, if a wait on proc was successful + (define (waited-by-wait proc status) +- (obituary proc status) +- (mark-proc-waited! proc)) ++ (if (not (status:stop-sig status)) ++ (begin ++ (obituary proc status) ++ (mark-proc-waited! proc)))) + + ;;; we know from somewhere that proc is dead + (define (obituary proc status) + +Index: scsh-interfaces.scm +=================================================================== +RCS file: /cvsroot/scsh/scsh/scsh/scsh-interfaces.scm,v +retrieving revision 1.55.2.5 +retrieving revision 1.55.2.6 +diff -u -c -r1.55.2.5 -r1.55.2.6 +*** scsh-interfaces.scm 15 Apr 2004 13:01:35 -0000 1.55.2.5 +--- scsh-interfaces.scm 30 May 2005 12:59:05 -0000 1.55.2.6 +*************** +*** 406,411 **** +--- 406,412 ---- + + (define-interface scsh-user/group-db-interface + (export user-info ++ user-info? + user-info:name + user-info:uid + user-info:gid +*************** +*** 416,421 **** +--- 417,423 ---- + ->username + + group-info ++ group-info? + group-info:name + group-info:gid + group-info:members + diff --git a/install.scm b/install.scm new file mode 100755 index 0000000..6365bab --- /dev/null +++ b/install.scm @@ -0,0 +1,27 @@ +#!/bin/sh +exec scsh -lel install-lib/load.scm -dm -o install-commander-s -e install-program-main -s "$0" "$@" +!# + +(define-structure install-commander-s (export install-program-main) + (open scheme-with-scsh + install-lib) + (begin + (define commander-s-template #<string file-names))) + ;; FIXME: quote file names containing space etc (define (prepare-selection-for-command-mode file-names) - (string-join - (map (lambda (file-name) - (string-append "\"" file-name "\"")) - file-names))) + (string-join file-names)) - (define (get-selection self for-scheme-mode? focus-object-table) + (define (get-selection-as-text self for-scheme-mode? focus-object-table) (let* ((marked (select-list-get-selection select-list)) (file-names (map fs-object-complete-path @@ -218,7 +216,7 @@ prepare-selection-for-command-mode) file-names))) - (define (get-focus-object self focus-object-table) + (define (get-selection-as-ref self focus-object-table) (let ((marked (select-list-get-selection select-list)) (make-reference (lambda (obj) (make-focus-object-reference @@ -242,11 +240,11 @@ (lambda (self key control-x-pressed?) (handle-key-press self key))) - ((eq? message 'get-selection) - get-selection) + ((eq? message 'get-selection-as-text) + get-selection-as-text) - ((eq? message 'get-focus-object) - get-focus-object) + ((eq? message 'get-selection-as-ref) + get-selection-as-ref) (else (error "fsobjects-viewer unknown message" message))))))) @@ -257,4 +255,7 @@ (register-plugin! (make-view-plugin make-fsobjects-viewer - list-of-fs-objects?)) + (lambda (thing) + (or (fs-object? thing) + (list-of-fs-objects? thing))))) + diff --git a/scheme/console.scm b/scheme/console.scm index d21c7a2..e9d8d1e 100644 --- a/scheme/console.scm +++ b/scheme/console.scm @@ -37,7 +37,7 @@ window terminal-buffer pty-channel) (spawn (lambda () - (let lp ((paint? #t)) + (let lp ((paint? #f)) (select (wrap (receive-rv pause-channel) (lambda (ignore) diff --git a/scheme/eval.scm b/scheme/eval.scm index effa317..132ce97 100644 --- a/scheme/eval.scm +++ b/scheme/eval.scm @@ -24,6 +24,6 @@ (define (focus-table) *focus-table*) -(define (focus-value id) +(define (focus-value-ref id) (get-focus-object (focus-table) id)) diff --git a/scheme/inspector.scm b/scheme/inspector.scm index 85650df..4cde4fe 100644 --- a/scheme/inspector.scm +++ b/scheme/inspector.scm @@ -152,7 +152,7 @@ (- num-lines (header-length header)) val))))) - (define (get-focus-object self focus-object-table) + (define (get-selection-as-ref self focus-object-table) (let ((marked (select-list-get-selection selection-list)) (make-reference (lambda (obj) (make-focus-object-reference @@ -165,7 +165,7 @@ (string-join (map exp->string (map make-reference marked))) ")")))) - (define (get-selection self for-scheme-mode? focus-object-table) + (define (get-selection-as-text self for-scheme-mode? focus-object-table) (if for-scheme-mode? (let ((marked (select-list-get-selection selection-list))) (prepare-selection-for-scheme-mode marked)) @@ -198,10 +198,10 @@ (select-list-handle-key-press selection-list key)))) self)) - ((get-focus-object) - get-focus-object) - ((get-selection) - get-selection) + ((get-selection-as-ref) + get-selection-as-ref) + ((get-selection-as-text) + get-selection-as-text) (else (debug-message "inspector did not handle message " message)))))) diff --git a/scheme/job-viewer.scm b/scheme/job-viewer.scm index 57a0062..bc129fa 100644 --- a/scheme/job-viewer.scm +++ b/scheme/job-viewer.scm @@ -62,12 +62,12 @@ jobs) (- (result-buffer-num-lines buffer) 1)))) - (define get-focus-object - (make-get-focus-object-method select-list)) + (define get-selection-as-ref + (make-get-selection-as-ref-method select-list)) - (define (get-selection self for-scheme-mode? focus-object-table) + (define (get-selection-as-text self for-scheme-mode? focus-object-table) (if for-scheme-mode? - (send self 'get-focus-object focus-object-table) + (send self 'get-selection-as-ref focus-object-table) (let ((marked (select-list-get-selection select-list))) (if (null? marked) (number->string @@ -93,9 +93,9 @@ (select-list-handle-key-press select-list key)) self)) - ((get-selection) get-selection) + ((get-selection-as-text) get-selection-as-text) - ((get-focus-object) get-focus-object) + ((get-selection-as-ref) get-selection-as-ref) (else (error "joblist-viewer unknown message" message)))))) @@ -111,7 +111,11 @@ (define (make-job-viewer job buffer) (let ((select-list #f) (num-cols - (- (result-buffer-num-cols buffer) 1))) + (- (result-buffer-num-cols buffer) 1)) + (console-viewer + (if (job-with-console? job) + (make-console-viewer (job-console job) buffer) + #f))) (define (make-job-select-list job) (make-select-list @@ -144,22 +148,24 @@ (#f "run status:" ,(format-job-run-state job)) ,@(if (job-with-console? job) - `((,(job-console job) "" "")) + `((,console-viewer "" "")) '()))) (- (result-buffer-num-lines buffer) 1))) (define (handle-key-press self key control-x-pressed?) (cond ((= key (char->ascii #\f)) - (continue-job-in-foreground job)) + (continue-job-in-foreground job) + self) ((= key (char->ascii #\g)) - (set! select-list (make-job-select-list job))) + (set! select-list (make-job-select-list job)) + self) ((= key (char->ascii #\newline)) (select-list-selected-entry select-list)) (else (set! select-list - (select-list-handle-key-press select-list key)))) - self) + (select-list-handle-key-press select-list key)) + self))) (set! select-list (make-job-select-list job)) @@ -178,11 +184,11 @@ ((key-press) handle-key-press) - ((get-selection) - (make-get-focus-object-method select-list)) + ((get-selection-as-text) + (make-get-selection-as-ref-method select-list)) - ((get-focus-object) - (make-get-focus-object-method select-list)) + ((get-selection-as-ref) + (make-get-selection-as-ref-method select-list)) (else (error "job viewer unknown message" message)))))) diff --git a/scheme/job.scm b/scheme/job.scm index 08d2d5c..86fe4c8 100644 --- a/scheme/job.scm +++ b/scheme/job.scm @@ -155,6 +155,11 @@ (send get-job-list-channel (cons 'ready answer-channel)) (receive answer-channel))) +(define (stopped-jobs) + (let ((answer-channel (make-channel))) + (send get-job-list-channel (cons 'stopped answer-channel)) + (receive answer-channel))) + (define (clear-ready-jobs!) (send clear-ready-jobs-channel 'ignored)) @@ -279,7 +284,7 @@ (thunk) (set-tty-info/now port settings))) -(define-syntax run-with-console +(define-syntax run/console (syntax-rules () ((_ epf) (call-with-values @@ -295,37 +300,45 @@ (- (result-buffer-num-cols (result-buffer)) 1) (- (result-buffer-num-lines (result-buffer)) 1)))))))) -(define-syntax go +(define-syntax run/fg + (syntax-rules () + ((_ epf) + (save-tty-excursion + (current-input-port) + (lambda () + (def-prog-mode) + (clear) + (endwin) + (restore-initial-tty-info! (current-input-port)) + (drain-tty (current-output-port)) + (obtain-lock paint-lock) + (let ((foreground-pgrp (tty-process-group (current-output-port))) + (proc + (fork + (lambda () + (set-process-group (pid) (pid)) + (set-tty-process-group (current-output-port) (pid)) + (exec-epf epf))))) + (job-status (make-job-sans-console (quote epf) proc)) + (set-tty-process-group (current-output-port) foreground-pgrp) + (display "Press any key to return to Commander S...") + (wait-for-key) + (release-lock paint-lock))))))) + +(define-syntax run/bg (syntax-rules () ((_ epf) (begin - (def-prog-mode) - (clear) - (endwin) (obtain-lock paint-lock) - (let ((proc - (fork - (lambda () - (set-process-group (pid) (pid)) - (set-tty-process-group - (current-output-port) (pid)) - (exec-epf epf))))) - (job-status - (make-job-sans-console (quote epf) proc)) - (set-tty-process-group - (current-output-port) (pid)) - (display "Press any key to return to Commander S...") - (wait-for-key) - (release-lock paint-lock)))))) - -(define-syntax go/bg - (syntax-rules () - ((_ epf) + (drain-tty (current-output-port)) + (set-tty-process-group (current-output-port) (pid)) (let ((proc (fork (lambda () (set-process-group (pid) (pid)) (exec-epf epf))))) - (make-job-sans-console (quote epf) proc))))) + (let ((job (make-job-sans-console (quote epf) proc))) + (release-lock paint-lock) + job)))))) -;;; EOF +;;; EOF \ No newline at end of file diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index 387ee99..077639f 100644 --- a/scheme/nuit-engine.scm +++ b/scheme/nuit-engine.scm @@ -118,9 +118,11 @@ ;;start the whole thing (define (nuit) (let ((tty-name (init-tty-debug-output!))) - (display "Debug messages will be on ") - (display tty-name) - (newline)) + (if tty-name + (begin + (display "Debug messages will be on ") + (display tty-name) + (newline)))) (with-inspecting-handler 8888 (lambda (condition) @@ -223,7 +225,7 @@ (define (paste-selection/refresh viewer) (add-string-to-command-buffer (send (current-viewer) - 'get-selection + 'get-selection-as-text (command-buffer-in-scheme-mode?) (focus-table))) (print-command-buffer (app-window-curses-win (command-window)) (command-buffer)) @@ -234,10 +236,10 @@ (add-string-to-command-buffer (if (command-buffer-in-command-mode?) (send (current-viewer) - 'get-selection + 'get-selection-as-text (command-buffer-in-scheme-mode?) (focus-table)) - (send (current-viewer) 'get-focus-object (focus-table)))) + (send (current-viewer) 'get-selection-as-ref (focus-table)))) (print-command-buffer (app-window-curses-win (command-window)) (command-buffer)) (move-cursor (command-buffer) (result-buffer)) @@ -459,7 +461,7 @@ (make-completion-set-for-executables (get-path-list))))))) (define (paint-bar-1) - (mvwaddstr (app-window-curses-win (bar-1)) 0 1 "SCSH-NUIT") + (mvwaddstr (app-window-curses-win (bar-1)) 0 1 "Commander S") (wrefresh (app-window-curses-win (bar-1)))) (define (paint-command-buffer-mode-indicator) @@ -570,6 +572,9 @@ (define (find/init-plugin-for-result result) (cond + ;; #### a hack + ((null? result) + (make-standard-viewer result (result-buffer))) ((determine-plugin-by-type result) => (lambda (view-plugin) ((view-plugin-constructor view-plugin) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 3164a2d..79b33a1 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -170,10 +170,13 @@ (open scheme-with-scsh afs-fs define-record-types - (subset srfi-1 (iota)) + (subset srfi-1 (iota delete)) + threads ncurses select-list + completion-sets + run-jobs plugin layout) (files afs)) @@ -227,8 +230,11 @@ signals srfi-1 srfi-13 - + srfi-37 + sorting + joblist + jobs layout fs-object pps @@ -290,7 +296,7 @@ select-list-navigation-key? select-list-marking-key? - make-get-focus-object-method)) + make-get-selection-as-ref-method)) (define-structure select-list select-list-interface (open scheme @@ -322,6 +328,7 @@ ncurses focus-table select-list + tty-debug plugin layout) (files job-viewer)) @@ -359,7 +366,7 @@ (define-structures ((nuit-eval (compound-interface (interface-of scheme-with-scsh) - (export focus-value) + (export focus-value-ref) run-jobs-interface)) (nuit-eval/focus-table (export focus-table))) (open @@ -454,6 +461,7 @@ (define-interface console-interface (export make-console + make-console-viewer console? view-console pause-console-output @@ -500,6 +508,7 @@ running-jobs ready-jobs + stopped-jobs clear-ready-jobs! jobs-with-new-output jobs-waiting-for-input @@ -512,9 +521,9 @@ (define-interface run-jobs-interface (export - (run-with-console :syntax) - (go :syntax) - (go/bg :syntax))) + (run/console :syntax) + (run/fg :syntax) + (run/bg :syntax))) (define-interface joblist-interface (export running-jobs diff --git a/scheme/process.scm b/scheme/process.scm index 56e9732..eb2b47c 100644 --- a/scheme/process.scm +++ b/scheme/process.scm @@ -48,14 +48,20 @@ processes)) (header (make-header-line (result-buffer-num-cols buffer)))) - (define (get-selection self for-scheme-mode? focus-object-table) - (let ((marked (select-list-get-selection select-list))) - (if (null? marked) - (number->string - (process-info-pid - (select-list-selected-entry select-list))) - (string-append - "'"(exp->string (map process-info-pid marked)))))) + (define (get-selection-as-text self for-scheme-mode? focus-object-table) + (let* ((marked (select-list-get-selection select-list))) + (cond + ((null? marked) + (number->string + (process-info-pid + (select-list-selected-entry select-list)))) + (for-scheme-mode? + (string-append + "'" (exp->string (map process-info-pid marked)))) + (else + (string-join + (map number->string + (map process-info-pid marked))))))) (lambda (message) @@ -73,10 +79,10 @@ (select-list-handle-key-press select-list key)) self)) - ((get-selection) get-selection) + ((get-selection-as-text) get-selection-as-text) - ((get-focus-object) - (make-get-focus-object-method select-list)) + ((get-selection-as-ref) + (make-get-selection-as-ref-method select-list)) (else (error "pps-viewer unknown message" message)))))) diff --git a/scheme/select-list.scm b/scheme/select-list.scm index 1b12e53..1e446ff 100644 --- a/scheme/select-list.scm +++ b/scheme/select-list.scm @@ -175,7 +175,7 @@ (list-ref (select-list-elements select-list) (select-list-cursor-index select-list)))) -(define (make-get-focus-object-method select-list) +(define (make-get-selection-as-ref-method select-list) (lambda (self focus-object-table) (let ((marked (select-list-get-selection select-list)) (make-reference (lambda (obj) diff --git a/scheme/std-command.scm b/scheme/std-command.scm index 9b13c79..ae6e51c 100644 --- a/scheme/std-command.scm +++ b/scheme/std-command.scm @@ -60,18 +60,69 @@ (define no-completer (lambda args #f)) +;; Parse options for ls command using args-fold (SRFI 37) +;; We don't care for options that format the output. + +(define defaults-ls-options + '((long . #t) (dot-files? . #t) + (sort-by-mtime . #f) (reverse-sort . #f))) + +(define (parse-ls-arguments args) + (let* ((on/off-option-processor + (lambda (name) + (lambda (option arg-name arg ops) + (cons (cons name #t) ops)))) + (long-option + (option '(#\l) #f #f + (on/off-option-processor 'long))) + (dotfiles-option + (option '(#\a) #f #f + (on/off-option-processor 'dot-files?))) + (sort-mtime-option + (option '(#\t) #f #f + (on/off-option-processor 'sort-by-mtime))) + (reverse-sort-option + (option '(#\r) #f #f + (on/off-option-processor 'reverse-sort)))) + (let ((given-args + (args-fold + args + (list long-option dotfiles-option + sort-mtime-option reverse-sort-option) + (lambda (option name args operands) + (error "Unknown ls option" name)) + cons '()))) + (map (lambda (p) + (or (assoc (car p) given-args) p)) + defaults-ls-options)))) + (register-plugin! (make-command-plugin "ls" no-completer (lambda (command args) - (if (null? args) - (directory-files (cwd)) - (let ((arg (file-name->fs-object - (expand-file-name (car args) (cwd))))) - (if (file-info-directory? (fs-object-info arg)) - (directory-files (fs-object-complete-path arg)) - arg)))))) + (let* ((options (parse-ls-arguments args)) + (set? (lambda (opt) (cdr (assoc opt options)))) + (sort + (if (set? 'sort-by-mtime) + (lambda (lst) + (list-sort + (lambda (f g) + (< (file-info:mtime (fs-object-info f)) + (file-info:mtime (fs-object-info g)))) + lst)) + (lambda (lst) + (list-sort + (lambda (f g) + (string (lambda (p) - ((cdr p)))))) - (delete-duplicates args))))) + (let ((selectors + `(("running" . ,running-jobs) + ("ready" . ,ready-jobs) + ("stopped" . ,stopped-jobs) + ("output" . ,jobs-with-new-output) + ("input" . ,jobs-waiting-for-input)))) + (append-map + (lambda (arg) + (cond + ((assoc arg selectors) + => (lambda (p) + ((cdr p)))))) + (if (null? args) + (map car selectors) + (delete-duplicates args))))))) (register-plugin! (make-command-plugin @@ -149,5 +203,5 @@ (else '("ftp.gnu.org" "ftp.x.org")))) (lambda (command args) - (run (,command ,@args))))) + (run/fg (,command ,@args))))) diff --git a/scheme/tty-debug.scm b/scheme/tty-debug.scm index dd6df28..66a3bf9 100644 --- a/scheme/tty-debug.scm +++ b/scheme/tty-debug.scm @@ -1,19 +1,24 @@ +(define debug-mode #t) + (define *tty-port* #f) (define (init-tty-debug-output!) - (call-with-values - open-pty - (lambda (input-port name) - (set! *tty-port* (dup->outport input-port)) - (close input-port) - (set-port-buffering *tty-port* bufpol/none) - name))) + (and debug-mode + (call-with-values + open-pty + (lambda (input-port name) + (set! *tty-port* (dup->outport input-port)) + (close input-port) + (set-port-buffering *tty-port* bufpol/block 8192) + name)))) (define debug-message (lambda args - (with-current-output-port* - *tty-port* - (lambda () - (for-each display args) - (newline))))) + (if debug-mode + (with-current-output-port* + *tty-port* + (lambda () + (for-each display args) + (newline) + (flush-tty/output *tty-port*))))))