source: project/misc-extn/trunk/misc-extn-posix.scm @ 5437

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

Release 3.0, where misc-extn.scm is rmvd & macros split into sep files.

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