source: project/release/3/misc-extn/trunk/misc-extn-posix.scm @ 8075

Last change on this file since 8075 was 8075, checked in by Kon Lovett, 12 years ago

Rel 3.1, adds -directory stuff.

File size: 11.0 KB
Line 
1;;;; misc-extn-posix.scm
2;;;; Kon Lovett, Sep '06
3
4;; Issues
5;; - The termios struct interface is conditioned on macos, where I know the i/ospeed
6;; elements are defined.
7;;
8;; This can be done better - actually check for the field's existence in the
9;; .setup w/ a 'try-compile' & then pass info as a '-feature SYMBOL'.
10
11(use posix)
12(use misc-extn-directory) ; For Now
13
14(eval-when (compile)
15  (declare
16    (usual-integrations)
17        (inline)
18        (fixnum)
19                (no-procedure-checks)
20                (no-bound-checks)
21    (bound-to-procedure
22      ##core#immutable
23      ##sys#update-errno
24      ##sys#error
25      #;##sys#posix-error)
26        (export
27      priority/process
28      priority/process-group
29      priority/user
30      scheduling-priority
31      set-scheduling-priority!
32      alloc-termios
33      free-termios
34      termios-cc
35      termios-cc-set!
36      termios-cflag
37      termios-cflag-set!
38      termios-iflag
39      termios-iflag-set!
40      termios-ispeed
41      termios-ispeed-set!
42      termios-lflag
43      termios-lflag-set!
44      termios-oflag
45      termios-oflag-set!
46      termios-ospeed
47      termios-ospeed-set!
48      alloc-winsize
49      free-winsize
50      winsize-col
51      winsize-col-set!
52      winsize-row
53      winsize-row-set!
54      winsize-xpixel
55      winsize-xpixel-set!
56      winsize-ypixel
57      winsize-ypixel-set!
58      open-pty
59      login-tty
60      replace-fileno) ) )
61
62;;;
63
64;From "posixwin.scm"
65(define-macro (define-unimplemented name)
66  `(define (,name . _)
67     (error ',name
68       (##core#immutable '"this function is not available on this platform")) ) )
69
70;;; Spawn Stuff
71
72#|
73;; process-spawn
74
75#+(not windows)
76(begin
77  (define spawn/overlay   0)
78  (define spawn/wait      1)
79  (define spawn/nowait    2)
80  (define spawn/nowaito   3)
81  (define spawn/detach    4)
82
83  (define (process-spawn mode command #!optional arguments environment exact?)
84    )
85|#
86
87#|
88;; POSIX 'posix-spawn'
89;; Solaris  -
90;; Linux    -
91
92;;
93
94posix_spawn_file_actions_init(posix_spawn_file_actions_t *);
95posix_spawn_file_actions_destroy(posix_spawn_file_actions_t *);
96posix_spawn_file_actions_addclose(posix_spawn_file_actions_t *, int);
97posix_spawn_file_actions_adddup2(posix_spawn_file_actions_t *, int, int);
98posix_spawn_file_actions_addopen(posix_spawn_file_actions_t *restrict, int, const char *restrict, int, mode_t);
99
100; FILE-ACTIONS init
101; FILE-ACTIONS destroy   FILE-ACTIONS
102; FILE-ACTIONS add       open FILE-ACTIONS FILENO PATH OPEN-FLAG MODE
103; FILE-ACTIONS add       close FILE-ACTIONS FILENO
104; FILE-ACTIONS add       dup2 FILE-ACTIONS FILENO1 NEW-FILENO
105
106(define (posix-spawn-file-actions operation . rest)
107  )
108
109;;
110
111posix_spawnattr_posix_spawnattr_init(posix_spawnattr_t *);
112posix_spawnattr_posix_spawnattr_destroy(posix_spawnattr_t *);
113posix_spawnattr_getsigdefault(const posix_spawnattr_t *restrict, sigset_t *restrict);
114posix_spawnattr_getflags(const posix_spawnattr_t *restrict, short *restrict);
115posix_spawnattr_getpgroup(const posix_spawnattr_t *restrict, pid_t *restrict);
116posix_spawnattr_getschedparam(const posix_spawnattr_t *restrict, struct sched_param *restrict);
117posix_spawnattr_getschedpolicy(const posix_spawnattr_t *restrict, int *restrict);
118posix_spawnattr_getsigmask(const posix_spawnattr_t *restrict, sigset_t *restrict);
119posix_spawnattr_setsigdefault(posix_spawnattr_t *restrict, const sigset_t *restrict);
120posix_spawnattr_setflags(posix_spawnattr_t *, short);
121posix_spawnattr_setpgroup(posix_spawnattr_t *, pid_t);
122posix_spawnattr_setschedparam(posix_spawnattr_t *restrict, const struct sched_param *restrict);
123posix_spawnattr_setschedpolicy(posix_spawnattr_t *, int);
124posix_spawnattr_setsigmask(posix_spawnattr_t *restrict, const sigset_t *restrict);
125
126; ATTRIBUTES    init
127; ATTRIBUTES    destroy   ATTRIBUTES
128; SIGNAL-SET    get       sigmask ATTRIBUTES
129; ATTRIBUTES    set       sigmask ATTRIBUTES SIGNAL-SET
130; SIGNAL-SET    get       sigdefault ATTRIBUTES
131; ATTRIBUTES    set       sigdefault ATTRIBUTES SIGNAL-SET
132; FLAGS         get       flags ATTRIBUTES
133; ATTRIBUTES    set       flags ATTRIBUTES FLAGS
134; PID           get       pgroup ATTRIBUTES
135; ATTRIBUTES    set       pgroup ATTRIBUTES PID
136; ATTRIBUTES    get       schedparam ATTRIBUTES
137; SCHEDPARAM    set       schedparam ATTRIBUTES SCHEDPARAM
138; SCHEDPOLICY   get       schedpolicy ATTRIBUTES
139; ATTRIBUTES    set       schedpolicy ATTRIBUTES SCHEDPOLICY
140
141(define (posix-spawn-attributes operation . rest)
142  )
143
144;;
145
146int posix_spawn(pid_t *restrict pid, const char *restrict path,
147ÊÊÊÊÊÊ const posix_spawn_file_actions_t *file_actions,
148ÊÊÊÊÊÊ const posix_spawnattr_t *restrict attrp,
149ÊÊÊÊÊÊ char *const argv[restrict], char *const envp[restrict]);
150
151(define (posix-spawn command file-actions attributes arguments environment)
152  )
153
154;;
155
156int posix_spawnp(pid_t *restrict pid, const char *restrict file,
157ÊÊÊÊÊÊ const posix_spawn_file_actions_t *file_actions,
158ÊÊÊÊÊÊ const posix_spawnattr_t *restrict attrp,
159ÊÊÊÊÊÊ char *const argv[restrict], char * const envp[restrict]);
160
161(define (posix-spawnp command file-actions attributes arguments environment)
162  )
163|#
164
165#|
166;; BSD 'rfork'
167;; NetBSD   - not supplied?
168;; FreeBSD  -
169;; OpenBSD  -
170;; MacOS X  - not supplied
171|#
172
173#|
174;; Linux 'clone'
175|#
176
177;; Errno
178
179(cond-expand
180  [unix
181
182    #>
183    #include <errno.h>
184    <#
185
186    (define-foreign-variable _errno int "errno") ]
187
188  [else] )
189
190;; Process Priority
191
192(cond-expand
193  [unix
194
195    #>
196    #include <sys/time.h>
197    #include <sys/resource.h>
198    <#
199
200    (define priority/process (foreign-value "PRIO_PROCESS" int))
201    (define priority/process-group (foreign-value "PRIO_PGRP" int))
202    (define priority/user (foreign-value "PRIO_USER" int))
203
204    (define scheduling-priority
205      (let ([get-priority (foreign-lambda int getpriority int int)])
206        (lambda (which who)
207          (set! _errno 0)
208          (let ([res (get-priority which who)])
209            (when (and (negative? res) (not (zero? _errno)))
210              (##sys#update-errno)
211              (##sys#error 'scheduling-priority "get priority failed" which who))
212            res) ) ) )
213
214    (define set-scheduling-priority!
215      (let ([set-priority! (foreign-lambda int setpriority int int int)])
216        (lambda (which who prio)
217          (let ([res (set-priority! which who prio)])
218            (when (fx< res 0)
219              (##sys#update-errno)
220              (##sys#error 'set-scheduling-priority! "set priority failed" which who prio)) ) ) ) ) ]
221
222  [else
223
224    (define priority/process (void))
225    (define priority/process-group (void))
226    (define priority/user (void))
227    (define-unimplemented scheduling-priority)
228    (define-unimplemented set-scheduling-priority!) ] )
229
230;; Termios & Winsize Records
231
232(cond-expand
233  [unix
234
235    #>
236    #include <termios.h>
237    #include <unistd.h>
238    <#
239
240    ; ws_row        rows, in characters
241    ; ws_col        columns, in characters
242    ; ws_xpixel     horizontal size, in pixels
243    ; ws_ypixel     vertical size, in pixels
244
245    (define-foreign-record (winsize "struct winsize")
246      (rename: (cut string-translate* <> '(("ws_" . ""))))
247      (constructor: alloc-winsize)
248      (destructor: free-winsize)
249      (unsigned-short  ws_row)
250      (unsigned-short  ws_col)
251      (unsigned-short  ws_xpixel)
252      (unsigned-short  ws_ypixel) )
253
254    (define-foreign-type tcflag_t unsigned-long)
255    (define-foreign-type cc_t unsigned-char)
256    (define-foreign-type speed_t unsigned-long)
257    (define-foreign-variable NCCS int "NCCS")
258
259    (cond-expand
260      [macosx
261
262        ; c_iflag                 input flags
263        ; c_oflag                 output flags
264        ; c_cflag                 control flags
265        ; c_lflag                 local flags
266        ; c_cc            control chars
267        ; c_ispeed    input speed
268        ; c_ospeed    output speed
269
270        (define-foreign-record (termios "struct termios")
271          (rename: (cut string-translate* <> '(("c_" . ""))))
272          (constructor: alloc-termios)
273          (destructor: free-termios)
274          (tcflag_t c_iflag)
275          (tcflag_t c_oflag)
276          (tcflag_t c_cflag)
277          (tcflag_t c_lflag)
278          (cc_t c_cc NCCS)
279          (speed_t c_ispeed)
280          (speed_t c_ospeed) ) ]
281
282      [else
283
284        ; c_iflag                 input flags
285        ; c_oflag                 output flags
286        ; c_cflag                 control flags
287        ; c_lflag                 local flags
288        ; c_cc            control chars
289
290        (define-foreign-record (termios "struct termios")
291          (rename: (cut string-translate* <> '(("c_" . ""))))
292          (constructor: alloc-termios)
293          (destructor: free-termios)
294          (tcflag_t c_iflag)
295          (tcflag_t c_oflag)
296          (tcflag_t c_cflag)
297          (tcflag_t c_lflag)
298          (cc_t c_cc NCCS) )
299
300        (define-unimplemented termios-ispeed)
301        (define-unimplemented termios-ispeed-set!)
302        (define-unimplemented termios-ospeed)
303        (define-unimplemented termios-ospeed-set!) ] ) ]
304
305  [else
306
307    (define-unimplemented alloc-winsize)
308    (define-unimplemented free-winsize)
309    (define-unimplemented winsize-row)
310    (define-unimplemented winsize-col)
311    (define-unimplemented winsize-xpixel)
312    (define-unimplemented winsize-ypixel)
313    (define-unimplemented winsize-row-set!)
314    (define-unimplemented winsize-col-set!)
315    (define-unimplemented winsize-xpixel-set!)
316    (define-unimplemented winsize-ypixel-set!)
317    (define-unimplemented termios-cc-set!)
318    (define-unimplemented termios-ispeed)
319    (define-unimplemented termios-cflag)
320    (define-unimplemented termios-iflag)
321    (define-unimplemented termios-cc)
322    (define-unimplemented alloc-termios)
323    (define-unimplemented free-termios)
324    (define-unimplemented termios-oflag)
325    (define-unimplemented termios-ospeed-set!)
326    (define-unimplemented termios-ispeed-set!)
327    (define-unimplemented termios-ospeed)
328    (define-unimplemented termios-lflag)
329    (define-unimplemented termios-lflag-set!)
330    (define-unimplemented termios-cflag-set!)
331    (define-unimplemented termios-oflag-set!)
332    (define-unimplemented termios-iflag-set!) ] )
333
334;; Pseudo-tty
335
336#| Solaris open pty per pts(7D) manpage
337
338    int    fdm fds;
339    char   *slavename;
340    extern char *ptsname();
341
342    fdm = open("/dev/ptmx", O_RDWR);  /* open master */
343    grantpt(fdm);                     /* change permission of slave */
344    unlockpt(fdm);                    /* unlock slave */
345    slavename = ptsname(fdm);         /* get name of slave */
346    fds = open(slavename, O_RDWR);    /* open slave */
347    ioctl(fds, I_PUSH, "ptem");       /* push ptem */
348    ioctl(fds, I_PUSH, "ldterm");     /* push ldterm*/
349|#
350
351(cond-expand
352  [solaris
353
354    (define-unimplemented open-pty)
355    (define-unimplemented login-tty) ]
356
357  [unix
358
359    #>
360    #if defined(C_MACOSX) || defined(__NetBSD__) || defined(__OpenBSD__)
361    # include <util.h>
362    #elif defined(__FreeBSD__)
363    # include <libutil.h>
364    #else
365    # include <pty.h>
366    #endif
367    <#
368
369    (define open-pty
370      (foreign-lambda int "openpty" (nonnull-c-pointer int) (nonnull-c-pointer int)
371                                    c-string c-pointer c-pointer))
372
373    (define login-tty
374      (foreign-lambda int "login_tty" int)) ]
375
376  [else
377
378    (define-unimplemented open-pty)
379    (define-unimplemented login-tty) ] )
380
381;;
382
383(define (replace-fileno fd sfd)
384  (unless (= sfd fd)
385    (duplicate-fileno fd sfd)
386    (file-close fd) ) )
Note: See TracBrowser for help on using the repository browser.