source: project/release/3/osprocess/trunk/osprocess.scm @ 11878

Last change on this file since 11878 was 11878, checked in by Kon Lovett, 13 years ago

Needs Unit files.

File size: 17.1 KB
Line 
1;;;; osprocess.scm
2;;;; Kon Lovett, Dec '06
3
4;; Issues
5;;
6;; - osprocess-reaper-period is only useful before the reaper starts up. While
7;; explicitly stopping & starting by the user will work, should do this when
8;; the period is changed.
9
10(use srfi-1 posix utils)
11(use miscmacros misc-extn-dsssl)
12(use osprocess-support)
13
14(eval-when (compile)
15  (declare
16    (usual-integrations)
17    (inline)
18    (generic)
19    (no-procedure-checks)
20    (no-bound-checks)
21    (export
22      osprocess-reaper-period
23      osprocess-input-buffer-size
24      osprocess-output-buffer-size
25      make-osprocess
26      osprocess
27      osprocess?
28      osprocess-pseudo-tty?
29      osprocess-shell?
30      osprocess-forked?
31      osprocess-waited?
32      osprocess-started?
33      osprocess-running?
34      osprocess-alive?
35      osprocess-exited?
36      osprocess-reaping?
37      osprocess-reap
38      osprocess-priority
39      osprocess-pid
40      osprocess-list
41      osprocess-start-seconds
42      osprocess-exit-seconds
43      osprocess-exit-normal?
44      osprocess-exit-code
45      osprocess-exit-status
46      osprocess-exit-signal
47      osprocess-input-port
48      osprocess-output-port
49      osprocess-error-port
50      osprocess-ports
51      osprocess-connection
52      osprocess-command
53      osprocess-arguments
54      osprocess-environment
55      osprocess-input-port-collection
56      osprocess-error-port-collection
57      osprocess-error
58      osprocess-autoclose-input-port
59      osprocess-autoclose-output-port
60      osprocess-autoclose-error-port
61      osprocess-autoclose-ports
62      osprocess-collect-input-port
63      osprocess-collect-error-port
64      osprocess-collect-ports
65      osprocess-empty-input-port
66      osprocess-empty-error-port
67      osprocess-empty-ports
68      osprocess-close-input-port
69      osprocess-close-output-port
70      osprocess-close-error-port
71      osprocess-close-ports
72      osprocess-run
73      osprocess-wait
74      osprocess-wait-any
75      osprocess-kill
76      osprocess-stop
77      osprocess-continue
78      osprocess-signal) ) )
79
80;;;
81
82(include "osprocess-common")
83
84#; ; Debugging
85(define-record-printer (ospp obj out)
86  (fprintf out "#<ossp ~S ~S ~S ~S ~S ~S ~S ~S>"
87    (ospp-port obj)
88    (ospp-user? obj)
89    (ospp-auto? obj)
90    (ospp-bufs obj)
91    (ospp-input? obj)
92    (ospp-modes obj)
93    (ospp-stdfd obj)
94    (ospp-closed? obj) ) )
95
96#; ; Debugging
97(define (print-osp osp out)
98  (fprintf out "#<osp ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S>"
99    (osp-status osp)
100    (osp-enorm? osp)
101    (osp-ecode osp)
102    (osp-mode osp)
103    (osp-data osp)
104    (osp-reap? osp)
105    (osp-abexit? osp)
106    (osp-wait? osp)
107    (osp-exact? osp)
108    (osp-fork? osp)
109    (osp-pid osp)
110    (osp-ssec osp)
111    (osp-esec osp)
112    (osp-inp osp)
113    (osp-outp osp)
114    (osp-errp osp)
115    (osp-cmd osp)
116    (osp-args osp)
117    (osp-env osp)
118    (osp-collectors osp)
119    (osp-collections osp)
120    (osp-last-error osp)) )
121
122(define-record-printer (osp obj out)
123  #; ; Debugging
124  (print-osp obj out)
125  (fprintf out "#<osprocess ~S>" (osp-cmd obj)) )
126
127;;; Reaper
128
129(define-parameter osprocess-reaper-period DEFAULT-REAPER-PERIOD
130  (lambda (x)
131    (if (and (number? x) (positive? x))
132        x
133        (begin
134          (warning 'osprocess-reaper-period "invalid positive integer" x)
135          (osprocess-reaper-period) ) ) ) )
136
137;;; Buffer
138
139(define-parameter osprocess-input-buffer-size DEFAULT-INPUT-BUFFER-SIZE
140  (lambda (x)
141    (if (io-buffer-size? x)
142        x
143        (begin
144          (warning 'osprocess-input-buffer-size "invalid buffer size" x)
145          (osprocess-input-buffer-size) ) ) ) )
146
147(define-parameter osprocess-output-buffer-size DEFAULT-OUTPUT-BUFFER-SIZE
148  (lambda (x)
149    (if (io-buffer-size? x)
150        x
151        (begin
152          (warning 'osprocess-output-buffer-size "invalid buffer size" x)
153          (osprocess-output-buffer-size) ) ) ) )
154
155;;; Argument Checking/Handling
156
157(define (check-osp loc obj)
158  (unless (osp? obj)
159    (error loc "invalid osprocess" obj)) )
160
161(define (check-collector loc obj)
162  (unless (or (boolean? obj) (procedure? obj))
163    (error loc "invalid collector specification" obj)) )
164
165(define (check-started loc osp)
166  (when (osp-created? osp)
167    (error loc "osprocess not started" osp)) )
168
169(define (check-started-osp loc obj)
170  (check-osp loc obj)
171  (check-started loc obj) )
172
173(cond-expand
174  [unix
175    (define (check-signal loc obj)
176      (unless (and (fixnum? obj) (fx< -1 obj))
177        (error loc "invalid signal" obj)) )
178
179    (define (check-priority loc obj)
180      (unless (and (fixnum? obj) (fx<= -20 obj) (fx<= obj 20))
181        (error loc "invalid priority" obj)) ) ]
182  [else] )
183
184(define (filter-rest rest)
185  (fixup-extended-lambda-list-rest
186    '(#:shell? #:pseudo-tty?
187      #:reap? #:fork? #:wait?
188      #:exact? #:search? #:collect?
189      #:abnormal-exit-error?
190      #:signal-mask
191      #:current-user-id #:effective-user-id
192      #:current-group-id #:effective-group-id
193      #:output #:input #:error
194      #:output-buffer #:input-buffer #:error-buffer
195      #:output-mode #:input-mode #:error-mode
196      #:arguments #:environment)
197     rest) )
198
199;;;
200
201(define (osp$connection osp)
202  (values (osp-pid osp)
203          (osp-inp-port/shared osp)
204          (osp-outp-port/shared osp)
205          (osp-errp-port/shared osp)) )
206
207;;; Globals
208
209;; Constructors
210
211(define (make-osprocess cmd #!rest args
212          #!key
213          (shell? #f) (pseudo-tty? #f)
214          (reap? #t) (fork? #t) (wait? #f)
215          (exact? #f) (search? #t) (collect? #f)
216          (abnormal-exit-error? #f)
217          (signal-mask #f)
218          (current-user-id #f) (effective-user-id #f)
219          (current-group-id #f) (effective-group-id #f)
220          (output #t) (input #t) (error #t)
221          (output-buffer #f) (input-buffer #f) (error-buffer #f)
222          (output-mode '()) (input-mode '()) (error-mode '())
223          (arguments #f) (environment #f))
224
225  ; Just create
226  (osp$make 'make-osprocess
227    shell? pseudo-tty? reap? abnormal-exit-error?
228    fork? wait? exact? search? collect?
229    signal-mask
230    current-user-id effective-user-id
231    current-group-id effective-group-id
232    input output error
233    input-buffer output-buffer error-buffer
234    input-mode output-mode error-mode
235    cmd arguments environment
236    (filter-rest args)
237    '()) )
238
239(define (osprocess cmd #!rest args
240          #!key
241          (shell? (void)) (pseudo-tty? #f)
242          (reap? #t) (fork? #t) (wait? #f)
243          (exact? #f) (search? #t) (collect? #f)
244          (abnormal-exit-error? #f)
245          (signal-mask #f)
246          (current-user-id #f) (effective-user-id #f)
247          (current-group-id #f) (effective-group-id #f)
248          (output #t) (input #t) (error #t)
249          (output-buffer #f) (input-buffer #f) (error-buffer #f)
250          (output-mode '()) (input-mode '()) (error-mode '())
251          (arguments #f) (environment #f))
252
253  ; Check for implicit shell usage
254  (set! args (filter-rest args))
255  (when (eq? (void) shell?)
256    (set! shell? (and (null? args)
257                      (or (not arguments) (null? arguments)))) )
258
259  ; Create & run
260  (let ([osp
261          (osp$make 'osprocess
262            shell? pseudo-tty? reap? abnormal-exit-error?
263            fork? wait? exact? search? collect?
264            signal-mask
265            current-user-id effective-user-id
266            current-group-id effective-group-id
267            input output error
268            input-buffer output-buffer error-buffer
269            input-mode output-mode error-mode
270            cmd arguments environment
271            args
272            '())])
273    (osp$run 'osprocess osp)
274    (values (osp-pid osp)
275            (osp-inp-port/shared osp)
276            (osp-outp-port/shared osp)
277            (osp-errp-port/shared osp)
278            osp) ) )
279
280;; Predicates
281
282(define (osprocess? obj)
283  (osp? obj) )
284
285(define (osprocess-pseudo-tty? osp)
286  (check-osp 'osprocess-pseudo-tty? osp)
287  (and (osp-mode-pty? osp)
288       (osp-pty-specification osp)) )
289
290(define (osprocess-shell? osp)
291  (check-osp 'osprocess-shell? osp)
292  (osp-mode-shell? osp) )
293
294(define (osprocess-forked? osp)
295  (check-osp 'osprocess-forked? osp)
296  (osp-fork? osp) )
297
298(define (osprocess-waited? osp)
299  (check-osp 'osprocess-waited? osp)
300  (osp-wait? osp) )
301
302(define (osprocess-started? osp)
303  (check-osp 'osprocess-started? osp)
304  (not (osp-created? osp)) )
305
306(define (osprocess-running? osp)
307  (check-osp 'osprocess-running? osp)
308  (osp$running? 'osprocess-running? osp) )
309
310(define (osprocess-alive? osp)
311  (check-osp 'osprocess-alive? osp)
312  (osp$running? 'osprocess-alive? osp) )
313
314(define (osprocess-exited? osp)
315  (check-osp 'osprocess-exited? osp)
316  (osp$exited? 'osprocess-exited? osp) )
317
318(define (osprocess-reaping? osp)
319  (check-osp 'osprocess-reaping? osp)
320  (osp-reap? osp) )
321
322;; Accessors
323
324(define (osprocess-list)
325  (osp$list) )
326
327(define (osprocess-pid osp)
328  (check-osp 'osprocess-pid osp)
329  (if (osp-created? osp)
330      (void)
331      (osp-pid osp)) )
332
333(define (osprocess-start-seconds osp)
334  (check-osp 'osprocess-start-seconds osp)
335  (if (osp-created? osp)
336      (void)
337      (osp-ssec osp)) )
338
339(define (osprocess-exit-seconds osp)
340  (check-osp 'osprocess-exit-seconds osp)
341  (if (osp$exited? 'osprocess-exit-seconds osp)
342      (osp-esec osp)
343      (void)) )
344
345(define (osprocess-exit-normal? osp)
346  (check-osp 'osprocess-exit-normal? osp)
347  (if (osp$exited? 'osprocess-exit-normal? osp)
348      (osp-enorm? osp)
349      (void)) )
350
351(define (osprocess-exit-code osp)
352  (check-osp 'osprocess-exit-code osp)
353  (if (osp$exited? 'osprocess-exit-code osp)
354      (osp-ecode osp)
355      (void)) )
356
357(define (osprocess-exit-status osp)
358  (check-osp 'osprocess-exit-status osp)
359  (if (osp$exited? 'osprocess-exit-status osp)
360      (and (osp-enorm? osp)
361           (osp-ecode osp))
362      (void)) )
363
364(define (osprocess-exit-signal osp)
365  (check-osp 'osprocess-exit-signal osp)
366  (if (osp$exited? 'osprocess-exit-signal osp)
367      (and (not (osp-enorm? osp))
368           (osp-ecode osp))
369      (void)) )
370
371(define (osprocess-input-port osp)
372  (check-osp 'osprocess-input-port osp)
373  (if (osp-created? osp)
374      (void)
375      (osp-inp-port/shared osp)) )
376
377(define (osprocess-output-port osp)
378  (check-osp 'osprocess-output-port osp)
379  (if (osp-created? osp)
380      (void)
381      (osp-outp-port/shared osp)) )
382
383(define (osprocess-error-port osp)
384  (check-osp 'osprocess-error-port osp)
385  (if (osp-created? osp)
386      (void)
387      (osp-errp-port/shared osp)) )
388
389(define (osprocess-ports osp)
390  (check-osp 'osprocess-ports osp)
391  (if (osp-created? osp)
392      (values (void) (void) (void))
393      (values (osp-inp-port/shared osp)
394              (osp-outp-port/shared osp)
395              (osp-errp-port/shared osp)) ) )
396
397(define (osprocess-connection osp)
398  (check-osp 'osprocess-connection osp)
399  (if (osp-created? osp)
400      (values (void) (void) (void) (void))
401      (osp$connection osp) ) )
402
403(define (osprocess-command osp)
404  (check-osp 'osprocess-command osp)
405  (osp-cmd osp) )
406
407(define (osprocess-arguments osp)
408  (check-osp 'osprocess-arguments osp)
409  (osp-args osp) )
410
411(define (osprocess-environment osp)
412  (check-osp 'osprocess-environment osp)
413  (osp-env osp) )
414
415(define (osprocess-input-port-collection osp)
416  (check-osp 'osprocess-input-port-collection osp)
417  (osp-inp-collection osp) )
418
419(define (osprocess-error-port-collection osp)
420  (check-osp 'osprocess-error-port-collection osp)
421  (osp-errp-collection osp) )
422
423(define (osprocess-error osp)
424  (check-osp 'osprocess-error osp)
425  (let ([err (osp-last-error osp)])
426    (osp-last-error-set! osp #f)
427    err) )
428
429;; Queries & Modifiers
430
431(define (osprocess-reap osp . rest)
432  (check-osp 'osprocess-reap osp)
433  (unless (null? rest)
434    (let ([flag (car rest)])
435      (if flag
436          (unless (osp-reap? osp) (osp$start-reaping osp))
437          (when (osp-reap? osp) (osp$stop-reaping osp)) ) ) )
438  (osp-reap? osp) )
439
440(cond-expand
441  [unix
442    (define (osprocess-priority osp . rest)
443      (check-started-osp 'osprocess-priority osp)
444      (if (osp$running? 'osprocess-priority osp)
445          (begin
446            (unless (null? rest)
447              (let ([prio (car rest)])
448                (check-priority 'osprocess-priority prio)
449                (osp$priority 'osprocess-priority osp prio) ) )
450            (osp$priority 'osprocess-priority osp) ) )
451          (void) ) ]
452  [windows
453    (define (osprocess-priority osp . rest)
454      (unimplemented-warning 'osprocess-priority) ) ] )
455
456(define (osprocess-autoclose-input-port osp . rest)
457  (check-osp 'osprocess-autoclose-input osp)
458  (unless (null? rest)
459    (let ([flag (car rest)])
460      (osp-inp-auto-set! osp flag) ) )
461  (osp-inp-auto? osp) )
462
463(define (osprocess-autoclose-output-port osp . rest)
464  (check-osp 'osprocess-autoclose-output-port osp)
465  (unless (null? rest)
466    (let ([flag (car rest)])
467      (osp-outp-auto-set! osp flag) ) )
468  (osp-outp-auto? osp) )
469
470(define (osprocess-autoclose-error-port osp . rest)
471  (check-osp 'osprocess-autoclose-error-port osp)
472  (unless (null? rest)
473    (let ([flag (car rest)])
474      (osp-errp-auto-set! osp flag) ) )
475  (osp-errp-auto? osp) )
476
477(define (osprocess-autoclose-ports osp . rest)
478  (check-osp 'osprocess-autoclose-ports osp)
479  (unless (null? rest)
480    (let ([flag (car rest)])
481      (osp-inp-auto-set! osp flag)
482      (osp-outp-auto-set! osp flag)
483      (osp-errp-auto-set! osp flag) ) )
484  (values (osp-inp-auto? osp) (osp-outp-auto? osp) (osp-errp-auto? osp)) )
485
486(define (osprocess-collect-input-port osp . rest)
487  (check-osp 'osprocess-collect-input-port osp)
488  (unless (null? rest)
489    (let ([collector (car rest)])
490      (check-collector 'osprocess-collect-input-port collector)
491      (when (and collector (boolean? collector)) (set! collector read-all))
492      (osp-inp-collector-set! osp collector) ) )
493  (osp-inp-collector osp) )
494
495(define (osprocess-collect-error-port osp . rest)
496  (check-osp 'osprocess-collect-error-port osp)
497  (unless (null? rest)
498    (let ([collector (car rest)])
499      (check-collector 'osprocess-collect-error-port collector)
500      (when (and collector (boolean? collector)) (set! collector read-all))
501      (osp-errp-collector-set! osp collector) ) )
502  (osp-errp-collector osp) )
503
504(define (osprocess-collect-ports osp . rest)
505  (check-osp 'osprocess-collect-ports osp)
506  (unless (null? rest)
507    (let ([collector (car rest)])
508      (check-collector 'osprocess-collect-ports collector)
509      (when (and collector (boolean? collector)) (set! collector read-all))
510      (osp-inp-collector-set! osp collector)
511      (osp-errp-collector-set! osp collector) ) )
512  (values (osp-inp-collector osp) (osp-errp-collector osp)) )
513
514;; Actions
515
516(define (osprocess-empty-input-port osp)
517  (check-started-osp 'osprocess-empty-input-port osp)
518  (osp$empty-inp 'osprocess-empty-input-port osp) )
519
520(define (osprocess-empty-error-port osp)
521  (check-started-osp 'osprocess-empty-error-port osp)
522  (osp$empty-errp 'osprocess-empty-error-port osp) )
523
524(define (osprocess-empty-ports osp)
525  (check-started-osp 'osprocess-empty-ports osp)
526  (osp$empty-all 'osprocess-empty-ports osp) )
527
528(define (osprocess-close-input-port osp)
529  (check-started-osp 'osprocess-close-input-port osp)
530  (osp$close-inp 'osprocess-close-input-port osp) )
531
532(define (osprocess-close-output-port osp)
533  (check-started-osp 'osprocess-close-output-port osp)
534  (osp$close-outp 'osprocess-close-output-port osp) )
535
536(define (osprocess-close-error-port osp)
537  (check-started-osp 'osprocess-close-error-port osp)
538  (osp$close-errp 'osprocess-close-error-port osp) )
539
540(define (osprocess-close-ports osp)
541  (check-started-osp 'osprocess-close-ports osp)
542  (osp$close-all 'osprocess-close-ports osp) )
543
544(define (osprocess-run osp)
545  (check-osp 'osprocess-run osp)
546  (if (osp-created? osp)
547      (begin
548        (osp$run 'osprocess-run osp)
549        (osp$connection osp))
550      (warning 'osprocess-run "osprocess started" osp) ) )
551
552(define (osprocess-wait osp #!optional nohang)
553  (check-started-osp 'osprocess-wait osp)
554  (if (or (osp$exited? 'osprocess-wait osp)
555          (osp$wait 'osprocess-wait osp nohang))
556      (values (osp-pid osp) (osp-enorm? osp) (osp-ecode osp))
557      (values 0 (void) (void))) )
558
559(define (osprocess-wait-any #!optional nohang)
560  (osp$wait 'osprocess-wait-any #f nohang) )
561
562(cond-expand
563  [unix
564    (define (osprocess-kill osp #!optional (force? #f))
565      (check-started-osp 'osprocess-kill osp)
566      (unless (osp$exited? 'osprocess-kill osp)
567        (process-signal (osp-pid osp)
568                        (if force? signal/kill signal/term)) ) )
569
570    (define (osprocess-stop osp)
571      (check-started-osp 'osprocess-stop osp)
572      (when (osp$running? 'osprocess-stop osp)
573        (process-signal (osp-pid osp) signal/stop)
574        (osp-status-set! osp 'stopped) ) )
575
576    (define (osprocess-continue osp)
577      (check-started-osp 'osprocess-continue osp)
578      (when (osp$stopped? 'osprocess-continue osp)
579        (process-signal (osp-pid osp) signal/cont)
580        (osp-status-set! osp 'running) ) )
581
582    (define (osprocess-signal osp sig)
583      (check-started-osp 'osprocess-signal osp)
584      (check-signal 'osprocess-signal sig)
585      (unless (osp$exited? 'osprocess-signal osp)
586        (process-signal (osp-pid osp) sig) ) ) ]
587  [windows
588    (define (osprocess-kill osp #!optional (force? #t))
589      (unimplemented-warning 'osprocess-kill) )
590
591    (define (osprocess-stop osp)
592      (unimplemented-warning 'osprocess-stop) )
593
594    (define (osprocess-continue osp)
595      (unimplemented-warning 'osprocess-continue) )
596
597    (define (osprocess-signal osp sig)
598      (unimplemented-warning 'osprocess-signal) ) ] )
Note: See TracBrowser for help on using the repository browser.