scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added a README, an installation script, and various small fixes.

This commit is contained in:
eknauel 2005-07-06 08:57:44 +00:00
parent 154db1fb92
commit 8376b8b9f7
15 changed files with 441 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
README Normal file
View File

@ -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

27
install.scm Executable file
View File

@ -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
View File

@ -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)))))

23
scheme/browse-directory-list.scm
View File

@ -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)))))

2
scheme/console.scm
View File

@ -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)

2
scheme/eval.scm
View File

@ -24,6 +24,6 @@
(define (focus-table)
*focus-table*)
(define (focus-value id)
(define (focus-value-ref id)
(get-focus-object (focus-table) id))

12
scheme/inspector.scm
View File

@ -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))))))

38
scheme/job-viewer.scm
View File

@ -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))))))

63
scheme/job.scm
View File

@ -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

19
scheme/nuit-engine.scm
View File

@ -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)

23
scheme/nuit-packages.scm
View File

@ -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

28
scheme/process.scm
View File

@ -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))))))

2
scheme/select-list.scm
View File

@ -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)

96
scheme/std-command.scm
View File

@ -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)))))

29
scheme/tty-debug.scm
View File

@ -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*))))))