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

Add a joblist-viewer, add a get-focus-object-method generator to 

select-list and make some plugins use it, added argument
focus-object-table to get-selection message (thus a get-selection
method can call a get-focus-object method).
This commit is contained in:
eknauel 2005-06-04 11:22:44 +00:00
parent 143d6bbccb
commit 8ae60787a7
9 changed files with 216 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -206,7 +206,7 @@
(string-append "\"" file-name "\""))
file-names)))
(define (get-selection self for-scheme-mode?)
(define (get-selection self for-scheme-mode? focus-object-table)
(let* ((marked (select-list-get-selection select-list))
(file-names
(map fs-object-complete-path

2
scheme/inspector.scm
View File

@ -165,7 +165,7 @@
(string-join (map exp->string (map make-reference marked)))
")"))))
(define (get-selection self for-scheme-mode?)
(define (get-selection 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))

107
scheme/job-viewer.scm Normal file
View File

@ -0,0 +1,107 @@
(define (job-name->string name)
(let ((port (open-output-string)))
(display name port)
(get-output-string port)))
(define (short-date date)
(fill-up-string 10
(format-date "~H:~M:~S" date)))
(define (format-job-run-state job)
(fill-up-string 12
(cond
((job-running? job) "running")
((job-ready? job) "ready")
((job-waiting-for-input? job) "stop/input")
((and (job-end-time job)
(job-has-new-output? job) "ready/output"))
(else "run/output"))))
(define (format-job job num-cols)
(cut-to-size num-cols
(string-append
(fill-up-string
20 (job-name->string (job-name job)))
" "
(format-job-run-state job)
" "
(short-date (job-start-time job))
" "
(if (job-end-time job)
(short-date (job-end-time job))
(fill-up-string 12 "-"))
" "
(fill-up-string
6 (if (job-end-time job)
(number->string (job-status job))
"-")))))
(define (make-joblist-headline num-cols)
(cut-to-size
num-cols
(string-append
(fill-up-string 20 "NAME")
" "
(fill-up-string 12 "RUN STATUS")
" "
(fill-up-string 10 "START")
" "
(fill-up-string 10 "END")
" "
(fill-up-string 6 "STATUS"))))
(define (make-joblist-viewer jobs buffer)
(let* ((jobs jobs)
(num-cols (- (result-buffer-num-cols buffer) 1))
(headline (make-joblist-headline num-cols))
(select-list
(make-select-list
(map (lambda (job)
(make-unmarked-element
job #t (format-job job num-cols)))
jobs)
(- (result-buffer-num-lines buffer) 1))))
(define get-focus-object
(make-get-focus-object-method select-list))
(define (get-selection self for-scheme-mode? focus-object-table)
(if for-scheme-mode?
(send self 'get-focus-object focus-object-table)
(let ((marked (select-list-get-selection select-list)))
(if (null? marked)
(number->string
(proc:pid (job-proc (select-list-selected-entry select-list))))
(string-join (map (lambda (job)
(number->string
(proc:pid (job-proc job))))
marked))))))
(lambda (message)
(case message
((paint)
(lambda (self win buffer have-focus?)
(mvwaddstr win 0 0 headline)
(paint-selection-list-at
select-list 0 1 win buffer have-focus?)))
((key-press)
(lambda (self key control-x-pressed?)
(set! select-list
(select-list-handle-key-press select-list key))
self))
((get-selection) get-selection)
((get-focus-object) get-focus-object)
(else
(error "joblist-viewer unknown message" message))))))
(define (list-of-jobs? thing)
(and (proper-list? thing) (every job? thing)))
(register-plugin!
(make-view-plugin make-joblist-viewer list-of-jobs?))

38
scheme/job.scm
View File

@ -1,19 +1,26 @@
(define-record-type job :job
(really-make-job name pty-in pty-out proc status)
(really-make-job name pty-in pty-out proc
status
start-time end-time
run-status)
job?
(name job-name)
(pty-in job-pty-in)
(pty-out job-pty-out)
(proc job-proc)
(status really-job-status))
(status really-job-status)
(start-time job-start-time)
(end-time job-end-time set-job-end-time!)
(run-status job-run-status set-job-run-status!))
(define-record-discloser :job
(lambda (r)
`(job ,(job-name r))))
`(job ,(job-name r) ,(job-run-status r))))
(define (make-job name pty-in pty-out proc)
(let ((job (really-make-job name pty-in pty-out proc
(make-placeholder))))
(let ((job (really-make-job
name pty-in pty-out proc (make-placeholder)
(date) #f 'running)))
(spawn-job-status-surveillant job)
(add-job! job)
job))
@ -28,8 +35,23 @@
(let ((channel (make-channel)))
(spawn
(lambda ()
(placeholder-set!
(really-job-status job) (wait (job-proc job)))))))
(let ((status (wait (job-proc job))))
(set-job-end-time! job (date))
(set-job-run-status! job 'ready)
(placeholder-set!
(really-job-status job) status))))))
(define (job-running? job)
(eq? (job-run-status job) 'running))
(define (job-ready? job)
(eq? (job-run-status job) 'ready))
(define (job-waiting-for-input? job)
(eq? (job-run-status job) 'waiting-for-input))
(define (job-has-new-output? job)
(eq? (job-run-status job) 'new-output))
(define (signal-job signal job)
(signal-process-group signal (job-proc job)))
@ -143,3 +165,5 @@
(exec-epf epf))))
(lambda (proc pty-in pty-out tty-name)
(make-job (quote epf) pty-in pty-out proc))))))
;;; EOF

9
scheme/nuit-engine.scm
View File

@ -292,7 +292,9 @@
(define (paste-selection/refresh viewer)
(add-string-to-command-buffer
(send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?)))
(send (current-viewer)
'get-selection
(command-buffer-in-scheme-mode?) (focus-table)))
(print-command-buffer (app-window-curses-win command-window)
command-buffer)
(move-cursor command-buffer result-buffer)
@ -301,7 +303,10 @@
(define (paste-focus-object/refresh viewer)
(add-string-to-command-buffer
(if (command-buffer-in-command-mode?)
(send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?))
(send (current-viewer)
'get-selection
(command-buffer-in-scheme-mode?)
(focus-table))
(send (current-viewer) 'get-focus-object (focus-table))))
(print-command-buffer (app-window-curses-win command-window)
command-buffer)

40
scheme/nuit-packages.scm
View File

@ -138,6 +138,7 @@
srfi-1
srfi-13
joblist
fs-object
pps
nuit-eval
@ -196,20 +197,43 @@
select-list-selected-entry
select-list-navigation-key?
select-list-marking-key?))
select-list-marking-key?
make-get-focus-object-method))
(define-structure select-list select-list-interface
(open scheme
srfi-1
(subset srfi-13 (string-join))
define-record-types
signals
(subset focus-table (make-focus-object-reference))
tty-debug
plugin
layout
ncurses)
(files select-list))
;;; joblist viewer
(define-structure joblist-viewer
(export)
(open scheme-with-scsh
srfi-1
srfi-6
(subset srfi-13 (string-join))
signals
objects
jobs
ncurses
focus-table
select-list
plugin
layout)
(files job-viewer))
;;; inspector
(define-interface nuit-inspector-interface
@ -336,6 +360,17 @@
(export make-job
job-status
job-status-rv
job?
job-running?
job-ready?
job-waiting-for-input?
job-has-new-output?
job-start-time
job-end-time
job-proc
job-name
signal-job
stop-job
continue-job
@ -409,6 +444,7 @@
jobs
joblist
;; the following modules are plugins
joblist-viewer
dirlist-view-plugin
user-group-info-plugin
process-viewer

18
scheme/process.scm
View File

@ -48,7 +48,7 @@
processes))
(header (make-header-line (result-buffer-num-cols buffer))))
(define (get-selection self for-scheme-mode?)
(define (get-selection self for-scheme-mode? focus-object-table)
(let ((marked (select-list-get-selection select-list)))
(if (null? marked)
(number->string
@ -57,19 +57,6 @@
(string-append
"'"(exp->string (map process-info-pid marked))))))
(define (get-focus-object self focus-object-table)
(let ((marked (select-list-get-selection select-list))
(make-reference (lambda (obj)
(make-focus-object-reference
focus-object-table obj))))
(if (null? marked)
(exp->string
(make-reference (select-list-selected-entry select-list)))
(string-append
"(list "
(string-join (map exp->string (map make-reference marked)))
")"))))
(lambda (message)
(case message
@ -88,7 +75,8 @@
((get-selection) get-selection)
((get-focus-object) get-focus-object)
((get-focus-object)
(make-get-focus-object-method select-list))
(else
(error "pps-viewer unknown message" message))))))

17
scheme/select-list.scm
View File

@ -173,4 +173,19 @@
(define (select-list-selected-entry select-list)
(element-value
(list-ref (select-list-elements select-list)
(select-list-cursor-index select-list))))
(select-list-cursor-index select-list))))
(define (make-get-focus-object-method select-list)
(lambda (self focus-object-table)
(let ((marked (select-list-get-selection select-list))
(make-reference (lambda (obj)
(make-focus-object-reference
focus-object-table obj))))
(if (null? marked)
(exp->string
(make-reference (select-list-selected-entry select-list)))
(string-append
"(list "
(string-join (map exp->string (map make-reference marked)))
")")))))

13
scheme/std-command.scm
View File

@ -139,6 +139,17 @@
(make-command-plugin "exit"
no-completer
(lambda (command args)
(clear)
(exit (if (null? args)
0
(string->number (car args)))))))
(string->number (car args)))))))
(register-plugin!
(make-command-plugin "jobs"
no-completer
(lambda (command args)
(append
(running-jobs) (ready-jobs)
(jobs-with-new-output)
(jobs-waiting-for-input)))))