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

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

Added user/group id setting.

File size: 17.0 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#+unix
174(define (check-signal loc obj)
175  (unless (and (fixnum? obj) (fx< -1 obj))
176    (error loc "invalid signal" obj)) )
177
178#+unix
179(define (check-priority loc obj)
180  (unless (and (fixnum? obj) (fx<= -20 obj) (fx<= obj 20))
181    (error loc "invalid priority" obj)) )
182
183(define (filter-rest rest)
184  (fixup-extended-lambda-list-rest
185    '(#:shell? #:pseudo-tty?
186      #:reap? #:fork? #:wait?
187      #:exact? #:search? #:collect?
188      #:abnormal-exit-error?
189      #:signal-mask
190      #:current-user-id #:effective-user-id
191      #:current-group-id #:effective-group-id
192      #:output #:input #:error
193      #:output-buffer #:input-buffer #:error-buffer
194      #:output-mode #:input-mode #:error-mode
195      #:arguments #:environment)
196     rest) )
197
198;;;
199
200(define (osp$connection osp)
201  (values (osp-pid osp)
202          (osp-inp-port/shared osp)
203          (osp-outp-port/shared osp)
204          (osp-errp-port/shared osp)) )
205
206;;; Globals
207
208;; Constructors
209
210(define (make-osprocess cmd #!rest args
211          #!key
212          (shell? #f) (pseudo-tty? #f)
213          (reap? #t) (fork? #t) (wait? #f)
214          (exact? #f) (search? #t) (collect? #f)
215          (abnormal-exit-error? #f)
216          (signal-mask #f)
217          (current-user-id #f) (effective-user-id #f)
218          (current-group-id #f) (effective-group-id #f)
219          (output #t) (input #t) (error #t)
220          (output-buffer #f) (input-buffer #f) (error-buffer #f)
221          (output-mode '()) (input-mode '()) (error-mode '())
222          (arguments #f) (environment #f))
223
224  ; Just create
225  (osp$make 'make-osprocess
226    shell? pseudo-tty? reap? abnormal-exit-error?
227    fork? wait? exact? search? collect?
228    signal-mask
229    current-user-id effective-user-id
230    current-group-id effective-group-id
231    input output error
232    input-buffer output-buffer error-buffer
233    input-mode output-mode error-mode
234    cmd arguments environment
235    (filter-rest args)
236    '()) )
237
238(define (osprocess cmd #!rest args
239          #!key
240          (shell? (void)) (pseudo-tty? #f)
241          (reap? #t) (fork? #t) (wait? #f)
242          (exact? #f) (search? #t) (collect? #f)
243          (abnormal-exit-error? #f)
244          (signal-mask #f)
245          (current-user-id #f) (effective-user-id #f)
246          (current-group-id #f) (effective-group-id #f)
247          (output #t) (input #t) (error #t)
248          (output-buffer #f) (input-buffer #f) (error-buffer #f)
249          (output-mode '()) (input-mode '()) (error-mode '())
250          (arguments #f) (environment #f))
251
252  ; Check for implicit shell usage
253  (set! args (filter-rest args))
254  (when (eq? (void) shell?)
255    (set! shell? (and (null? args)
256                      (or (not arguments) (null? arguments)))) )
257
258  ; Create & run
259  (let ([osp
260          (osp$make 'osprocess
261            shell? pseudo-tty? reap? abnormal-exit-error?
262            fork? wait? exact? search? collect?
263            signal-mask
264            current-user-id effective-user-id
265            current-group-id effective-group-id
266            input output error
267            input-buffer output-buffer error-buffer
268            input-mode output-mode error-mode
269            cmd arguments environment
270            args
271            '())])
272    (osp$run 'osprocess osp)
273    (values (osp-pid osp)
274            (osp-inp-port/shared osp)
275            (osp-outp-port/shared osp)
276            (osp-errp-port/shared osp)
277            osp) ) )
278
279;; Predicates
280
281(define (osprocess? obj)
282  (osp? obj) )
283
284(define (osprocess-pseudo-tty? osp)
285  (check-osp 'osprocess-pseudo-tty? osp)
286  (and (osp-mode-pty? osp)
287       (osp-pty-specification osp)) )
288
289(define (osprocess-shell? osp)
290  (check-osp 'osprocess-shell? osp)
291  (osp-mode-shell? osp) )
292
293(define (osprocess-forked? osp)
294  (check-osp 'osprocess-forked? osp)
295  (osp-fork? osp) )
296
297(define (osprocess-waited? osp)
298  (check-osp 'osprocess-waited? osp)
299  (osp-wait? osp) )
300
301(define (osprocess-started? osp)
302  (check-osp 'osprocess-started? osp)
303  (not (osp-created? osp)) )
304
305(define (osprocess-running? osp)
306  (check-osp 'osprocess-running? osp)
307  (osp$running? 'osprocess-running? osp) )
308
309(define (osprocess-alive? osp)
310  (check-osp 'osprocess-alive? osp)
311  (osp$running? 'osprocess-alive? osp) )
312
313(define (osprocess-exited? osp)
314  (check-osp 'osprocess-exited? osp)
315  (osp$exited? 'osprocess-exited? osp) )
316
317(define (osprocess-reaping? osp)
318  (check-osp 'osprocess-reaping? osp)
319  (osp-reap? osp) )
320
321;; Accessors
322
323(define (osprocess-list)
324  (osp$list) )
325
326(define (osprocess-pid osp)
327  (check-osp 'osprocess-pid osp)
328  (if (osp-created? osp)
329      (void)
330      (osp-pid osp)) )
331
332(define (osprocess-start-seconds osp)
333  (check-osp 'osprocess-start-seconds osp)
334  (if (osp-created? osp)
335      (void)
336      (osp-ssec osp)) )
337
338(define (osprocess-exit-seconds osp)
339  (check-osp 'osprocess-exit-seconds osp)
340  (if (osp$exited? 'osprocess-exit-seconds osp)
341      (osp-esec osp)
342      (void)) )
343
344(define (osprocess-exit-normal? osp)
345  (check-osp 'osprocess-exit-normal? osp)
346  (if (osp$exited? 'osprocess-exit-normal? osp)
347      (osp-enorm? osp)
348      (void)) )
349
350(define (osprocess-exit-code osp)
351  (check-osp 'osprocess-exit-code osp)
352  (if (osp$exited? 'osprocess-exit-code osp)
353      (osp-ecode osp)
354      (void)) )
355
356(define (osprocess-exit-status osp)
357  (check-osp 'osprocess-exit-status osp)
358  (if (osp$exited? 'osprocess-exit-status osp)
359      (and (osp-enorm? osp)
360           (osp-ecode osp))
361      (void)) )
362
363(define (osprocess-exit-signal osp)
364  (check-osp 'osprocess-exit-signal osp)
365  (if (osp$exited? 'osprocess-exit-signal osp)
366      (and (not (osp-enorm? osp))
367           (osp-ecode osp))
368      (void)) )
369
370(define (osprocess-input-port osp)
371  (check-osp 'osprocess-input-port osp)
372  (if (osp-created? osp)
373      (void)
374      (osp-inp-port/shared osp)) )
375
376(define (osprocess-output-port osp)
377  (check-osp 'osprocess-output-port osp)
378  (if (osp-created? osp)
379      (void)
380      (osp-outp-port/shared osp)) )
381
382(define (osprocess-error-port osp)
383  (check-osp 'osprocess-error-port osp)
384  (if (osp-created? osp)
385      (void)
386      (osp-errp-port/shared osp)) )
387
388(define (osprocess-ports osp)
389  (check-osp 'osprocess-ports osp)
390  (if (osp-created? osp)
391      (values (void) (void) (void))
392      (values (osp-inp-port/shared osp)
393              (osp-outp-port/shared osp)
394              (osp-errp-port/shared osp)) ) )
395
396(define (osprocess-connection osp)
397  (check-osp 'osprocess-connection osp)
398  (if (osp-created? osp)
399      (values (void) (void) (void) (void))
400      (osp$connection osp) ) )
401
402(define (osprocess-command osp)
403  (check-osp 'osprocess-command osp)
404  (osp-cmd osp) )
405
406(define (osprocess-arguments osp)
407  (check-osp 'osprocess-arguments osp)
408  (osp-args osp) )
409
410(define (osprocess-environment osp)
411  (check-osp 'osprocess-environment osp)
412  (osp-env osp) )
413
414(define (osprocess-input-port-collection osp)
415  (check-osp 'osprocess-input-port-collection osp)
416  (osp-inp-collection osp) )
417
418(define (osprocess-error-port-collection osp)
419  (check-osp 'osprocess-error-port-collection osp)
420  (osp-errp-collection osp) )
421
422(define (osprocess-error osp)
423  (check-osp 'osprocess-error osp)
424  (let ([err (osp-last-error osp)])
425    (osp-last-error-set! osp #f)
426    err) )
427
428;; Queries & Modifiers
429
430(define (osprocess-reap osp . rest)
431  (check-osp 'osprocess-reap osp)
432  (unless (null? rest)
433    (let ([flag (car rest)])
434      (if flag
435          (unless (osp-reap? osp) (osp$start-reaping osp))
436          (when (osp-reap? osp) (osp$stop-reaping osp)) ) ) )
437  (osp-reap? osp) )
438
439(cond-expand
440  [unix
441    (define (osprocess-priority osp . rest)
442      (check-started-osp 'osprocess-priority osp)
443      (if (osp$running? 'osprocess-priority osp)
444          (begin
445            (unless (null? rest)
446              (let ([prio (car rest)])
447                (check-priority 'osprocess-priority prio)
448                (osp$priority 'osprocess-priority osp prio) ) )
449            (osp$priority 'osprocess-priority osp) ) )
450          (void) ) ]
451  [windows
452    (define (osprocess-priority osp . rest)
453      (unimplemented-warning 'osprocess-priority) ) ] )
454
455(define (osprocess-autoclose-input-port osp . rest)
456  (check-osp 'osprocess-autoclose-input osp)
457  (unless (null? rest)
458    (let ([flag (car rest)])
459      (osp-inp-auto-set! osp flag) ) )
460  (osp-inp-auto? osp) )
461
462(define (osprocess-autoclose-output-port osp . rest)
463  (check-osp 'osprocess-autoclose-output-port osp)
464  (unless (null? rest)
465    (let ([flag (car rest)])
466      (osp-outp-auto-set! osp flag) ) )
467  (osp-outp-auto? osp) )
468
469(define (osprocess-autoclose-error-port osp . rest)
470  (check-osp 'osprocess-autoclose-error-port osp)
471  (unless (null? rest)
472    (let ([flag (car rest)])
473      (osp-errp-auto-set! osp flag) ) )
474  (osp-errp-auto? osp) )
475
476(define (osprocess-autoclose-ports osp . rest)
477  (check-osp 'osprocess-autoclose-ports osp)
478  (unless (null? rest)
479    (let ([flag (car rest)])
480      (osp-inp-auto-set! osp flag)
481      (osp-outp-auto-set! osp flag)
482      (osp-errp-auto-set! osp flag) ) )
483  (values (osp-inp-auto? osp) (osp-outp-auto? osp) (osp-errp-auto? osp)) )
484
485(define (osprocess-collect-input-port osp . rest)
486  (check-osp 'osprocess-collect-input-port osp)
487  (unless (null? rest)
488    (let ([collector (car rest)])
489      (check-collector 'osprocess-collect-input-port collector)
490      (when (and collector (boolean? collector)) (set! collector read-all))
491      (osp-inp-collector-set! osp collector) ) )
492  (osp-inp-collector osp) )
493
494(define (osprocess-collect-error-port osp . rest)
495  (check-osp 'osprocess-collect-error-port osp)
496  (unless (null? rest)
497    (let ([collector (car rest)])
498      (check-collector 'osprocess-collect-error-port collector)
499      (when (and collector (boolean? collector)) (set! collector read-all))
500      (osp-errp-collector-set! osp collector) ) )
501  (osp-errp-collector osp) )
502
503(define (osprocess-collect-ports osp . rest)
504  (check-osp 'osprocess-collect-ports osp)
505  (unless (null? rest)
506    (let ([collector (car rest)])
507      (check-collector 'osprocess-collect-ports collector)
508      (when (and collector (boolean? collector)) (set! collector read-all))
509      (osp-inp-collector-set! osp collector)
510      (osp-errp-collector-set! osp collector) ) )
511  (values (osp-inp-collector osp) (osp-errp-collector osp)) )
512
513;; Actions
514
515(define (osprocess-empty-input-port osp)
516  (check-started-osp 'osprocess-empty-input-port osp)
517  (osp$empty-inp 'osprocess-empty-input-port osp) )
518
519(define (osprocess-empty-error-port osp)
520  (check-started-osp 'osprocess-empty-error-port osp)
521  (osp$empty-errp 'osprocess-empty-error-port osp) )
522
523(define (osprocess-empty-ports osp)
524  (check-started-osp 'osprocess-empty-ports osp)
525  (osp$empty-all 'osprocess-empty-ports osp) )
526
527(define (osprocess-close-input-port osp)
528  (check-started-osp 'osprocess-close-input-port osp)
529  (osp$close-inp 'osprocess-close-input-port osp) )
530
531(define (osprocess-close-output-port osp)
532  (check-started-osp 'osprocess-close-output-port osp)
533  (osp$close-outp 'osprocess-close-output-port osp) )
534
535(define (osprocess-close-error-port osp)
536  (check-started-osp 'osprocess-close-error-port osp)
537  (osp$close-errp 'osprocess-close-error-port osp) )
538
539(define (osprocess-close-ports osp)
540  (check-started-osp 'osprocess-close-ports osp)
541  (osp$close-all 'osprocess-close-ports osp) )
542
543(define (osprocess-run osp)
544  (check-osp 'osprocess-run osp)
545  (if (osp-created? osp)
546      (begin
547        (osp$run 'osprocess-run osp)
548        (osp$connection osp))
549      (warning 'osprocess-run "osprocess started" osp) ) )
550
551(define (osprocess-wait osp #!optional nohang)
552  (check-started-osp 'osprocess-wait osp)
553  (if (or (osp$exited? 'osprocess-wait osp)
554          (osp$wait 'osprocess-wait osp nohang))
555      (values (osp-pid osp) (osp-enorm? osp) (osp-ecode osp))
556      (values 0 (void) (void))) )
557
558(define (osprocess-wait-any #!optional nohang)
559  (osp$wait 'osprocess-wait-any #f nohang) )
560
561(cond-expand
562  [unix
563    (define (osprocess-kill osp #!optional (force? #f))
564      (check-started-osp 'osprocess-kill osp)
565      (unless (osp$exited? 'osprocess-kill osp)
566        (process-signal (osp-pid osp)
567                        (if force? signal/kill signal/term)) ) )
568
569    (define (osprocess-stop osp)
570      (check-started-osp 'osprocess-stop osp)
571      (when (osp$running? 'osprocess-stop osp)
572        (process-signal (osp-pid osp) signal/stop)
573        (osp-status-set! osp 'stopped) ) )
574
575    (define (osprocess-continue osp)
576      (check-started-osp 'osprocess-continue osp)
577      (when (osp$stopped? 'osprocess-continue osp)
578        (process-signal (osp-pid osp) signal/cont)
579        (osp-status-set! osp 'running) ) )
580
581    (define (osprocess-signal osp sig)
582      (check-started-osp 'osprocess-signal osp)
583      (check-signal 'osprocess-signal sig)
584      (unless (osp$exited? 'osprocess-signal osp)
585        (process-signal (osp-pid osp) sig) ) ) ]
586  [windows
587    (define (osprocess-kill osp #!optional (force? #t))
588      (unimplemented-warning 'osprocess-kill) )
589
590    (define (osprocess-stop osp)
591      (unimplemented-warning 'osprocess-stop) )
592
593    (define (osprocess-continue osp)
594      (unimplemented-warning 'osprocess-continue) )
595
596    (define (osprocess-signal osp sig)
597      (unimplemented-warning 'osprocess-signal) ) ] )
Note: See TracBrowser for help on using the repository browser.