Added a README, an installation script, and various small fixes.
This commit is contained in:
parent
154db1fb92
commit
8376b8b9f7
|
@ -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 <http://www.scsh.net>)
|
||||
|
||||
- Version 1.1.0 of install-lib, the scsh installation library
|
||||
(From <http://lamp.epfl.ch/~schinz/scsh_packages/scsh-install-lib-1.1.0.tar.gz>)
|
||||
|
||||
- Version 0.6 of Sunterlib, the Scheme Untergrund library
|
||||
(From <http://savannah.nongnu.org/download/sunterlib/sunterlib-0.6.tar.gz>)
|
||||
|
||||
* 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
|
||||
|
|
@ -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 #<<END
|
||||
#!/bin/sh
|
||||
exec scsh -lel afs/load.scm -lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm ~a/debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm ~a/nuit-packages.scm -m nuit -s "$0"
|
||||
!#
|
||||
(nuit)
|
||||
|
||||
END
|
||||
)
|
||||
|
||||
(define-program "commander-s" (0 1) ((install-lib-version (1 1)))
|
||||
(install-directory-contents "scheme" 'scheme)
|
||||
(install-string (format #f commander-s-template
|
||||
(get-directory 'scheme #f) (get-directory 'scheme #f))
|
||||
"commander-s"
|
||||
'bin
|
||||
"."
|
||||
#o555))))
|
||||
|
||||
|
123
scheme/afs.scm
123
scheme/afs.scm
|
@ -1,3 +1,63 @@
|
|||
;; We are assuming that the vos and fs commands follow the OpenAFS
|
||||
;; syntax.
|
||||
|
||||
(define *afs-volumes-cs* (make-empty-completion-set))
|
||||
|
||||
(define (read-volume-names)
|
||||
(port-fold
|
||||
(run/port ("vos" "listvldb"))
|
||||
read-line
|
||||
(lambda (line s)
|
||||
(if-match
|
||||
(regexp-search
|
||||
(rx (submatch (: bos (+ alphanumeric) (* (| punctuation alphanumeric)))))
|
||||
line)
|
||||
(whole match)
|
||||
(cons match s)
|
||||
s))
|
||||
'()))
|
||||
|
||||
(spawn
|
||||
(lambda ()
|
||||
(set! *afs-volumes-cs* (make-completion-set (read-volume-names)))))
|
||||
|
||||
(define fs-command-cs
|
||||
(make-completion-set
|
||||
'("apropos" "checkservers" "checkvolumes" "cleanacl"
|
||||
"copyacl" "diskfree" "examine" "exportafs"
|
||||
"flush" "flushmount" "flushvolume"
|
||||
"getcacheparms" "getcellstatus"
|
||||
"getclientaddrs" "getcrypt" "getserverprefs"
|
||||
"help" "listacl" "listaliases" "listcells"
|
||||
"listquota" "lsmount" "messages" "mkmount"
|
||||
"newalias" "newcell" "quota" "rmmount"
|
||||
"rxstatpeer" "rxstatproc" "setacl"
|
||||
"setcachesize" "setcell" "setclientaddrs"
|
||||
"setcrypt" "setquota" "setserverprefs"
|
||||
"setvol" "storebehind" "sysname"
|
||||
"whereis" "whichcell" "wscell")))
|
||||
|
||||
(define vos-command-cs
|
||||
(make-completion-set
|
||||
'("addsite" "apropos" "backup" "backupsys"
|
||||
"changeaddr" "changeloc" "create" "delentry"
|
||||
"dump" "examine" "help" "listaddrs" "listpart"
|
||||
"listvldb" "listvol" "lock" "move" "partinfo"
|
||||
"release" "remove" "remsite" "rename" "restore"
|
||||
"setfields" "status" "syncserv" "syncvldb"
|
||||
"unlock" "unlockvldb" "zap")))
|
||||
|
||||
;; FIXME: Not all vos commands expect a volume argument
|
||||
(define (vos-command-completer command prefix args arg-pos)
|
||||
(if (= 1 arg-pos)
|
||||
(completions-for vos-command-cs prefix)
|
||||
(completions-for *afs-volumes-cs* prefix)))
|
||||
|
||||
;; FIXME: Not all fs commands expect a volume argument
|
||||
(define (fs-command-completer command prefix args arg-pos)
|
||||
(if (= 1 arg-pos)
|
||||
(completions-for fs-command-cs prefix)
|
||||
(completions-for *afs-volumes-cs* prefix)))
|
||||
|
||||
(define-record-type acl :acl
|
||||
(make-acl dir afs-perms)
|
||||
|
@ -5,6 +65,8 @@
|
|||
(dir acl-dir)
|
||||
(afs-perms acl-afs-perms))
|
||||
|
||||
(define key-d 100)
|
||||
(define delete-key key-d)
|
||||
|
||||
(define (make-header width dir)
|
||||
(list
|
||||
|
@ -30,12 +92,24 @@
|
|||
(define (make-acl-viewer acl buffer)
|
||||
(let* ((dir (acl-dir acl))
|
||||
(afs-perms (acl-afs-perms acl))
|
||||
(header (make-header (result-buffer-num-cols buffer) dir))
|
||||
(num-cols (result-buffer-num-cols buffer))
|
||||
(num-lines (result-buffer-num-lines buffer))
|
||||
(header (make-header num-cols dir))
|
||||
(select-list
|
||||
(make-afs-perms-select-list
|
||||
(result-buffer-num-cols buffer)
|
||||
(- (result-buffer-num-lines buffer) (length header))
|
||||
afs-perms)))
|
||||
num-cols
|
||||
(- num-lines (length header))
|
||||
afs-perms)))
|
||||
|
||||
(define (delete-selected-entry!)
|
||||
(let ((uid.afs-perms (select-list-selected-entry select-list)))
|
||||
(set! afs-perms (delete uid.afs-perms afs-perms eq?))
|
||||
(set! select-list
|
||||
(make-afs-perms-select-list num-lines
|
||||
(- num-lines (length header))
|
||||
afs-perms))
|
||||
(set-acl! dir afs-perms)))
|
||||
|
||||
(lambda (message)
|
||||
(case message
|
||||
|
||||
|
@ -51,9 +125,13 @@
|
|||
|
||||
((key-press)
|
||||
(lambda (self key control-x-pressed?)
|
||||
(set! select-list
|
||||
(select-list-handle-key-press select-list key))
|
||||
self))
|
||||
(cond
|
||||
((= key delete-key)
|
||||
(delete-selected-entry!))
|
||||
(else
|
||||
(set! select-list
|
||||
(select-list-handle-key-press select-list key))))
|
||||
self))
|
||||
|
||||
; ((get-selection) get-selection)
|
||||
|
||||
|
@ -63,17 +141,24 @@
|
|||
(error "acl viewer unknown message" message))))))
|
||||
|
||||
(register-plugin!
|
||||
(make-command-plugin "fs"
|
||||
(lambda args #f)
|
||||
(lambda (command args)
|
||||
(cond
|
||||
((or (string=? (car args) "la")
|
||||
(string=? (car args) "listacl"))
|
||||
(make-acl (cadr args)
|
||||
(get-acl (cadr args))))
|
||||
(else
|
||||
(display "unsupported fs command" (car args)))))))
|
||||
|
||||
(make-command-plugin
|
||||
"fs"
|
||||
fs-command-completer
|
||||
(lambda (command args)
|
||||
(cond
|
||||
((or (string=? (car args) "la")
|
||||
(string=? (car args) "listacl"))
|
||||
(let ((dir (if (null? (cdr args)) (cwd) (cadr args))))
|
||||
(make-acl dir (get-acl dir))))
|
||||
(else
|
||||
(display "unsupported fs command" (car args)))))))
|
||||
|
||||
(register-plugin!
|
||||
(make-view-plugin make-acl-viewer acl?))
|
||||
(make-view-plugin make-acl-viewer acl?))
|
||||
|
||||
(register-plugin!
|
||||
(make-command-plugin
|
||||
"vos"
|
||||
vos-command-completer
|
||||
(lambda (command args)
|
||||
(run/fg (,command ,@args)))))
|
||||
|
|
|
@ -200,13 +200,11 @@
|
|||
(define (prepare-selection-for-scheme-mode file-names)
|
||||
(string-append "'" (exp->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)))))
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -24,6 +24,6 @@
|
|||
(define (focus-table)
|
||||
*focus-table*)
|
||||
|
||||
(define (focus-value id)
|
||||
(define (focus-value-ref id)
|
||||
(get-focus-object (focus-table) id))
|
||||
|
||||
|
|
|
@ -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))))))
|
||||
|
||||
|
|
|
@ -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) "<View Console>" ""))
|
||||
`((,console-viewer "<View Console>" ""))
|
||||
'())))
|
||||
(- (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))))))
|
||||
|
|
|
@ -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
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))))))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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<? (fs-object-name f) (fs-object-name g)))
|
||||
lst))))
|
||||
(reverse
|
||||
(if (set? 'reverse-sort)
|
||||
reverse
|
||||
(lambda (l) l))))
|
||||
(reverse
|
||||
(sort
|
||||
(directory-files (cwd) (set? 'dot-files?))))))))
|
||||
|
||||
(register-plugin!
|
||||
(make-command-plugin "ps"
|
||||
|
@ -124,20 +175,23 @@
|
|||
(register-plugin!
|
||||
(make-command-plugin "jobs"
|
||||
(lambda (command prefix args arg-pos)
|
||||
'("running" "ready" "output" "waiting-for-input"))
|
||||
'("running" "ready" "stopped" "output" "waiting-for-input"))
|
||||
(lambda (command args)
|
||||
(append-map
|
||||
(lambda (arg)
|
||||
;; #### warn if argument is unknown
|
||||
(cond
|
||||
((assoc arg
|
||||
`(("running" . ,running-jobs)
|
||||
("ready" . ,ready-jobs)
|
||||
("output" . ,jobs-with-new-output)
|
||||
("input" . ,jobs-waiting-for-input)))
|
||||
=> (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)))))
|
||||
|
||||
|
|
|
@ -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*))))))
|
||||
|
||||
|
|
Loading…
Reference in New Issue