source: project/release/3/posix-extensions/trunk/4unix.scm @ 13118

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

Added more terminal control. Chgd some names.

File size: 31.1 KB
Line 
1;;;; 4unix.scm
2;;;; Kon Lovett, Jan '09
3;;;; Alaric Snell-Pym, Jan '09
4
5;; Issues
6;;
7;; - HP-UX, SunOS & Solaris support is spotty.
8;;
9;; - Assumes whitespace before & after C pre-processor leading '#' is legal.
10;;
11;; - Should have OS specific extension module for stuff like MacOS X 'prio/darwin-thread'.
12;;
13;; - Assumes id_t, pid_t, gid_t, & uid_t all are representable by a FIXNUM!
14;;
15;; - The EINTR condition (system call interrupted) is not handled.
16;;
17;; Should retry operation until success/failure or retry count is exceeded.
18
19(declare
20  (usual-integrations)
21  (inline)
22  (fixnum)
23  (disable-interrupts) ; We have static data structures
24  (no-procedure-checks)
25  (no-bound-checks)
26  (bound-to-procedure
27    ##sys#make-string
28    ##sys#make-c-string
29    ##sys#expand-home-path
30    ##sys#update-errno
31    ##sys#error
32    ##sys#posix-error
33    ##sys#signal-hook )
34  (export
35    ;
36    posix-errno
37    ;
38    stat/ifmt
39    stat/ififo
40    stat/ifchr
41    stat/ifdir
42    stat/ifblk
43    stat/ifreg
44    stat/iflnk
45    stat/ifsock
46    change-link-mode
47    change-link-owner
48    create-special-file
49    change-file-times
50    ;
51    prio/process
52    prio/process-group
53    prio/user
54    prio/darwin-thread
55    prio/darwin-bg
56    scheduling-priority
57    set-scheduling-priority!
58    ;
59    make-winsize
60    alloc-winsize
61    free-winsize
62    winsize-col
63    winsize-col-set!
64    winsize-row
65    winsize-row-set!
66    winsize-xpixel
67    winsize-xpixel-set!
68    winsize-ypixel
69    winsize-ypixel-set!
70    ;
71    make-termios
72    alloc-termios
73    free-termios
74    termios-iflag
75    termios-iflag-set!
76    termios-oflag
77    termios-oflag-set!
78    termios-cflag
79    termios-cflag-set!
80    termios-lflag
81    termios-lflag-set!
82    termios-cc
83    termios-cc-set!
84    termios/nccs
85    ;
86    terminal-control-input-speed
87    terminal-control-output-speed
88    set-terminal-control-input-speed!
89    set-terminal-control-output-speed!
90    set-terminal-control-speed!
91    ;
92    terminal-control-attributes
93    set-terminal-control-attributes!
94    ;
95    terminal-control-drain
96    terminal-control-flow
97    terminal-control-flush
98    terminal-control-send-break
99    terminal-control-make-raw
100    ;
101    open-pseudo-tty
102    login-tty
103    fork-pseudo-tty
104    ;
105                terminal-type-device?
106                terminal-device-name
107                current-process-tty-number
108    ;
109    replace-fileno ) )
110
111(require-extension posix)
112(require-extension miscmacros)
113
114;;;
115
116;From "posixwin.scm"
117(cond-expand
118  [hygienic-macros
119
120    (define-syntax define-unimplemented
121      (syntax-rules ()
122        [(_ ?name)
123          (define (?name . _)
124            (error '?name
125                                (##core#immutable '"this function is not available on this platform")) ) ] ) )
126
127  ] [else
128
129    (define-macro (define-unimplemented name)
130      `(define (,name . _)
131         (error ',name
132           (##core#immutable '"this function is not available on this platform")) ) )
133
134  ] )
135
136;;;
137
138#<
139#define C_locative_address( l ) (C_block_item( (l), 0 ))
140
141#define C_locative_cast( t, l ) ((t *)C_locative_address( l ))
142
143#define C_pointer_cast( t, p )  ((t *)C_pointer_address( p ))
144>#
145
146(define _null (##sys#null-pointer))
147
148(define (##sys#check-pointer obj #!optional loc)
149  (unless (##sys#pointer? obj)
150    (##sys#signal-hook #:type-error loc "bad argument type - not a pointer" obj) ) )
151
152(define (##sys#check-pointer-argument obj #!optional loc)
153  (unless (or (##sys#pointer? obj) (not obj))
154    (##sys#signal-hook #:type-error loc "bad argument type - not a pointer or #f" obj) ) )
155
156;;; Errno
157
158#>
159#include <errno.h>
160<#
161
162(define-foreign-variable _errno int "errno")
163
164(define posix-errno _errno)
165
166;;; File metadata
167
168#>
169#include <sys/stat.h>
170#include <utime.h>
171
172static double C_utime_atime;
173static double C_utime_mtime;
174static struct utimbuf C_utime_buf;
175
176#define C_lchmod(fn, m)          C_fix(lchmod(C_data_pointer(fn), C_unfix(m)))
177#define C_lchown(fn, u, g) C_fix(lchown(C_data_pointer(fn), C_unfix(u), C_unfix(g)))
178#define C_mknod(fn, m, d)        C_fix(mknod(C_data_pointer(fn), C_unfix(m), C_unfix(d)))
179#define C_utime(fn)                              C_fix((C_utime_buf.actime = C_utime_atime, C_utime_buf.modtime = C_utime_mtime, utime(C_data_pointer(fn), &C_utime_buf)))
180<#
181
182(define-foreign-variable _utime_atime double "C_utime_atime")
183(define-foreign-variable _utime_mtime double "C_utime_mtime")
184
185(define-foreign-variable _s_ifmt int "S_IFMT")
186(define-foreign-variable _s_ififo int "S_IFIFO")
187(define-foreign-variable _s_ifchr int "S_IFCHR")
188(define-foreign-variable _s_ifdir int "S_IFDIR")
189(define-foreign-variable _s_ifblk int "S_IFBLK")
190(define-foreign-variable _s_ifreg int "S_IFREG")
191(define-foreign-variable _s_iflnk int "S_IFLNK")
192(define-foreign-variable _s_ifsock int "S_IFSOCK")
193
194(define stat/ifmt _s_ifmt)
195(define stat/ififo _s_ififo)
196(define stat/ifchr _s_ifchr)
197(define stat/ifdir _s_ifdir)
198(define stat/ifblk _s_ifblk)
199(define stat/ifreg _s_ifreg)
200(define stat/iflnk _s_iflnk)
201(define stat/ifsock _s_ifsock)
202
203(define (change-link-mode fname mode)
204  (##sys#check-string fname 'change-link-mode)
205  (##sys#check-exact mode 'change-link-mode)
206  (when (fx= -1 (##core#inline "C_lchmod" (##sys#make-c-string (##sys#expand-home-path fname)) mode))
207    (##sys#posix-error #:file-error 'change-link-mode "cannot change link mode" fname mode) ) )
208
209(define (change-link-owner fname uid gid)
210  (##sys#check-string fname 'change-link-owner)
211  (##sys#check-exact uid 'change-link-owner)
212  (##sys#check-exact gid 'change-link-owner)
213  (when (fx= -1 (##core#inline "C_lchown" (##sys#make-c-string (##sys#expand-home-path fname)) uid gid))
214    (##sys#posix-error #:file-error 'change-link-owner "cannot change link owner" fname uid gid) ) )
215
216(define (create-special-file fname mode devnum)
217  (##sys#check-string fname 'change-link-owner)
218  (##sys#check-exact mode 'change-link-owner)
219  (##sys#check-exact devnum 'change-link-owner)
220  (when (fx= -1 (##core#inline "C_mknod" (##sys#make-c-string (##sys#expand-home-path fname)) mode devnum))
221    (##sys#posix-error #:file-error 'make-special-file "cannot make special file" fname mode devnum) ) )
222
223(define (change-file-times fname atime mtime)
224  (##sys#check-string fname 'change-file-times)
225  (##sys#check-number atime 'change-file-times)
226  (##sys#check-number mtime 'change-file-times)
227  (set! _utime_atime atime)
228  (set! _utime_mtime mtime)
229  (when (fx= -1 (##core#inline "C_utime" (##sys#make-c-string (##sys#expand-home-path fname))))
230     (##sys#posix-error #:file-error 'change-file-times "cannot change file times" fname atime mtime) ) )
231
232;;; Process Priority
233
234#>
235#include <sys/time.h> /* for portability */
236#include <sys/resource.h>
237
238#define C_getpriority( wi, wo )     C_fix( getpriority( C_unfix( wi ), (id_t)C_unfix( wo ) ) )
239#define C_setpriority( wi, wo, pr ) C_fix( setpriority( C_unfix( wi ), (id_t)C_unfix( wo ), C_unfix( pr ) ) )
240<#
241
242(define prio/process (foreign-value "PRIO_PROCESS" int))
243(define prio/process-group (foreign-value "PRIO_PGRP" int))
244(define prio/user (foreign-value "PRIO_USER" int))
245(cond-expand
246  [macosx
247    (define prio/darwin-thread (foreign-value "PRIO_DARWIN_THREAD" int))
248    (define prio/darwin-bg (foreign-value "PRIO_DARWIN_BG" int))
249  ] [else
250    (define prio/darwin-thread 0)
251    (define prio/darwin-bg 0)
252  ] )
253
254(define (scheduling-priority which who)
255  (set! _errno 0)
256  (let ([res (##core#inline "C_getpriority" which who)])
257    (if (and (fx< res 0) (not (fx= 0 _errno)))
258      (##sys#posix-error #:process-error 'scheduling-priority "cannot get process priority" which who)
259      res ) ) )
260
261(define (set-scheduling-priority! which who prio)
262  (let ([res (##core#inline "C_setpriority" which who prio)])
263    (when (fx= -1 res 0)
264      (##sys#posix-error #:process-error 'set-scheduling-priority! "cannot set process priority" which who prio) ) ) )
265
266;;; Termios & Winsize Records
267
268#>
269#include <termios.h>
270#include <unistd.h>
271<#
272
273;; Winsize
274
275; ws_row                                rows, in characters
276; ws_col                                columns, in characters
277; ws_xpixel                     horizontal size, in pixels
278; ws_ypixel                     vertical size, in pixels
279
280(define-foreign-record (winsize "struct winsize")
281  (rename: (cut string-translate* <> '(("ws_" . ""))))
282  (constructor: alloc-winsize)
283  (destructor: free-winsize)
284  (unsigned-short        ws_row)
285  (unsigned-short        ws_col)
286  (unsigned-short        ws_xpixel)
287  (unsigned-short        ws_ypixel) )
288
289(define (make-winsize #!key (rows 0) (columns 0) (xpixels 0) (ypixels 0))
290  (##sys#check-exact rows 'make-winsize)
291  (##sys#check-exact columns 'make-winsize)
292  (##sys#check-exact xpixels 'make-winsize)
293  (##sys#check-exact ypixels 'make-winsize)
294  (let ([ws (alloc-winsize)])
295    (winsize-row-set! ws rows)
296    (winsize-col-set! ws columns)
297    (winsize-xpixel-set! ws xpixels)
298    (winsize-ypixel-set! ws ypixels)
299    (set-finalizer! ws free-winsize)
300    ws ) )
301
302;; Termios
303
304(define-foreign-type tcflag_t unsigned-long)
305(define-foreign-type cc_t unsigned-char)
306(define-foreign-type speed_t unsigned-long)
307
308(define-foreign-variable IGNBRK tcflag_t "IGNBRK")
309(define-foreign-variable BRKINT tcflag_t "BRKINT")
310(define-foreign-variable IGNPAR tcflag_t "IGNPAR")
311(define-foreign-variable PARMRK tcflag_t "PARMRK")
312(define-foreign-variable INPCK tcflag_t "INPCK")
313(define-foreign-variable ISTRIP tcflag_t "ISTRIP")
314(define-foreign-variable INLCR tcflag_t "INLCR")
315(define-foreign-variable IGNCR tcflag_t "IGNCR")
316(define-foreign-variable ICRNL tcflag_t "ICRNL")
317(define-foreign-variable IXON tcflag_t "IXON")
318(define-foreign-variable IXOFF tcflag_t "IXOFF")
319(define-foreign-variable IXANY tcflag_t "IXANY")
320(cond-expand
321  [macosx
322    (define-foreign-variable IMAXBEL tcflag_t "IMAXBEL")
323    (define-foreign-variable IUTF8 tcflag_t "IUTF8")
324  ] [else] )
325
326(define-foreign-variable OPOST tcflag_t "OPOST")
327(define-foreign-variable ONLCR tcflag_t "ONLCR")
328(define-foreign-variable OCRNL tcflag_t "OCRNL")
329(define-foreign-variable ONOCR tcflag_t "ONOCR")
330(define-foreign-variable ONLRET tcflag_t "ONLRET")
331(define-foreign-variable OFILL tcflag_t "OFILL")
332(define-foreign-variable NLDLY tcflag_t "NLDLY")
333    (define-foreign-variable NL0 tcflag_t "NL0")
334    (define-foreign-variable NL1 tcflag_t "NL1")
335(cond-expand
336  [macosx
337        (define-foreign-variable NL2 tcflag_t "NL2")
338        (define-foreign-variable NL3 tcflag_t "NL3")
339  ] [else] )
340(define-foreign-variable TABDLY tcflag_t "TABDLY")
341    (define-foreign-variable TAB0 tcflag_t "TAB0")
342    (define-foreign-variable TAB1 tcflag_t "TAB1")
343    (define-foreign-variable TAB2 tcflag_t "TAB2")
344    (define-foreign-variable TAB3 tcflag_t "TAB3")
345(define-foreign-variable CRDLY tcflag_t "CRDLY")
346    (define-foreign-variable CR0 tcflag_t "CR0")
347    (define-foreign-variable CR1 tcflag_t "CR1")
348    (define-foreign-variable CR2 tcflag_t "CR2")
349    (define-foreign-variable CR3 tcflag_t "CR3")
350(define-foreign-variable FFDLY tcflag_t "FFDLY")
351    (define-foreign-variable FF0 tcflag_t "FF0")
352    (define-foreign-variable FF1 tcflag_t "FF1")
353(define-foreign-variable BSDLY tcflag_t "BSDLY")
354    (define-foreign-variable BS0 tcflag_t "BS0")
355    (define-foreign-variable BS1 tcflag_t "BS1")
356(define-foreign-variable VTDLY tcflag_t "VTDLY")
357    (define-foreign-variable VT0 tcflag_t "VT0")
358    (define-foreign-variable VT1 tcflag_t "VT1")
359(define-foreign-variable OFDEL tcflag_t "OFDEL")
360(cond-expand
361  [macosx
362    (define-foreign-variable OXTABS tcflag_t "OXTABS")
363    (define-foreign-variable ONOEOT tcflag_t "ONOEOT")
364  ] [else] )
365
366(define-foreign-variable CSIZE tcflag_t "CSIZE")
367    (define-foreign-variable CS5 tcflag_t "CS5")
368    (define-foreign-variable CS6 tcflag_t "CS6")
369    (define-foreign-variable CS7 tcflag_t "CS7")
370    (define-foreign-variable CS8 tcflag_t "CS8")
371(define-foreign-variable CSTOPB tcflag_t "CSTOPB")
372(define-foreign-variable CREAD tcflag_t "CREAD")
373(define-foreign-variable PARENB tcflag_t "PARENB")
374(define-foreign-variable PARODD tcflag_t "PARODD")
375(define-foreign-variable HUPCL tcflag_t "HUPCL")
376(define-foreign-variable CLOCAL tcflag_t "CLOCAL")
377(cond-expand
378  [macosx
379    (define-foreign-variable CIGNORE tcflag_t "CIGNORE")
380    (define-foreign-variable CCTS_OFLOW tcflag_t "CCTS_OFLOW")
381    (define-foreign-variable CRTSCTS tcflag_t "CRTSCTS")
382    (define-foreign-variable CRTS_OFLOW tcflag_t "CRTS_OFLOW")
383    (define-foreign-variable CDTR_OFLOW tcflag_t "CDTR_OFLOW")
384    (define-foreign-variable CDSR_OFLOW tcflag_t "CDSR_OFLOW")
385    (define-foreign-variable CCAR_OFLOW tcflag_t "CCAR_OFLOW")
386    (define-foreign-variable MDMBUF tcflag_t "MDMBUF")
387  ] [else] )
388
389(define-foreign-variable ECHOE tcflag_t "ECHOE")
390(define-foreign-variable ECHOK tcflag_t "ECHOK")
391(define-foreign-variable ECHO tcflag_t "ECHO")
392(define-foreign-variable ECHONL tcflag_t "ECHONL")
393(define-foreign-variable ISIG tcflag_t "ISIG")
394(define-foreign-variable ICANON tcflag_t "ICANON")
395(define-foreign-variable IEXTEN tcflag_t "IEXTEN")
396(define-foreign-variable TOSTOP tcflag_t "TOSTOP")
397(define-foreign-variable NOFLSH tcflag_t "NOFLSH")
398(cond-expand
399  [macosx
400    (define-foreign-variable ECHOKE tcflag_t "ECHOKE")
401    (define-foreign-variable ECHOPRT tcflag_t "ECHOPRT")
402    (define-foreign-variable ECHOCTL tcflag_t "ECHOCTL")
403    (define-foreign-variable ALTWERASE tcflag_t "ALTWERASE")
404    (define-foreign-variable EXTPROC tcflag_t "EXTPROC")
405    (define-foreign-variable FLUSHO tcflag_t "FLUSHO")
406    (define-foreign-variable NOKERNINFO tcflag_t "NOKERNINFO")
407    (define-foreign-variable PENDIN tcflag_t "PENDIN")
408  ] [else] )
409
410(define-foreign-variable VEOF unsigned-short "VEOF")
411(define-foreign-variable VEOL unsigned-short "VEOL")
412(define-foreign-variable VERASE unsigned-short "VERASE")
413(define-foreign-variable VKILL unsigned-short "VKILL")
414(define-foreign-variable VINTR unsigned-short "VINTR")
415(define-foreign-variable VQUIT unsigned-short "VQUIT")
416(define-foreign-variable VSUSP unsigned-short "VSUSP")
417(define-foreign-variable VSTART unsigned-short "VSTART")
418(define-foreign-variable VSTOP unsigned-short "VSTOP")
419(define-foreign-variable VMIN unsigned-short "VMIN")
420(define-foreign-variable VTIME unsigned-short "VTIME")
421(cond-expand
422  [macosx
423    (define-foreign-variable VEOL2 unsigned-short "VEOL2")
424    (define-foreign-variable VWERASE unsigned-short "VWERASE")
425    (define-foreign-variable VREPRINT unsigned-short "VREPRINT")
426    (define-foreign-variable VDSUSP unsigned-short "VDSUSP")
427    (define-foreign-variable VLNEXT unsigned-short "VLNEXT")
428    (define-foreign-variable VDISCARD unsigned-short "VDISCARD")
429    (define-foreign-variable VSTATUS unsigned-short "VSTATUS")
430  ] [else] )
431(define-foreign-variable _nccs unsigned-short "NCCS")
432(define termios/nccs _nccs)
433
434; c_iflag                       input flags
435; c_oflag                       output flags
436; c_cflag                       control flags
437; c_lflag                       local flags
438; c_cc                          control chars
439
440(define-foreign-record (termios "struct termios")
441  (rename: (cut string-translate* <> '(("c_" . ""))))
442  (constructor: alloc-termios)
443  (destructor: free-termios)
444  (tcflag_t c_iflag)
445  (tcflag_t c_oflag)
446  (tcflag_t c_cflag)
447  (tcflag_t c_lflag)
448  (cc_t c_cc NCCS) )
449
450(define (make-termios #!key (iflags 0) (oflags 0) (cflags 0) (lflags 0) cc)
451  (##sys#check-exact iflags 'make-termios)
452  (##sys#check-exact oflags 'make-termios)
453  (##sys#check-exact cflags 'make-termios)
454  (##sys#check-exact lflags 'make-termios)
455  (let ([tr (alloc-termios)])
456
457    (define (setcc! len getter)
458      (dotimes (idx (fxmin _nccs len)) (termios-cc-set! tr idx val)) )
459
460    (termios-iflag-set! tr iflags)
461    (termios-oflag-set! tr oflags)
462    (termios-cflag-set! tr cflags)
463    (termios-lflag-set! tr lflags)
464    (set-finalizer! tr free-termios)
465    (cond
466      [(not cc)       (setcc! _nccs (lambda _ 0))]
467      [(list? cc)     (setcc! (length cc) list-ref)]
468      [(vector? cc)   (setcc! (vector-length cc) vector-ref)]
469      [(string? cc)   (setcc! (string-length cc) (lambda (x i) (char->integer (string-ref x i))))]
470      [else
471        (##sys#signal-hook #:type-error 'make-termios "bad argument type - not a list, vector, or string" cc) ] )
472    tr ) )
473
474;; Termios access
475
476(define-foreign-variable B0 speed_t "B0")
477(define-foreign-variable B50 speed_t "B50")
478(define-foreign-variable B75 speed_t "B75")
479(define-foreign-variable B110 speed_t "B110")
480(define-foreign-variable B134 speed_t "B134")
481(define-foreign-variable B150 speed_t "B150")
482(define-foreign-variable B200 speed_t "B200")
483(define-foreign-variable B300 speed_t "B300")
484(define-foreign-variable B600 speed_t "B600")
485(define-foreign-variable B1200 speed_t "B1200")
486(define-foreign-variable B1800 speed_t "B1800")
487(define-foreign-variable B2400 speed_t "B2400")
488(define-foreign-variable B4800 speed_t "B4800")
489(define-foreign-variable B9600 speed_t "B9600")
490(define-foreign-variable B19200 speed_t "B19200")
491(define-foreign-variable B38400 speed_t "B38400")
492(cond-expand
493  [macosx
494    (define-foreign-variable B7200 speed_t "B7200")
495    (define-foreign-variable B14400 speed_t "B14400")
496    (define-foreign-variable B28800 speed_t "B28800")
497    (define-foreign-variable B57600 speed_t "B57600")
498    (define-foreign-variable B76800 speed_t "B76800")
499    (define-foreign-variable B115200 speed_t "B115200")
500    (define-foreign-variable B230400 speed_t "B230400")
501    (define-foreign-variable EXTA speed_t "EXTA")
502    (define-foreign-variable EXTB speed_t "EXTB")
503  ] [else] )
504
505#>
506#define C_cfgetispeed( pt ) \
507    C_fix( cfgetispeed( C_pointer_cast( pt, (struct termios) ) ) )
508#define C_cfgetospeed( pt ) \
509    C_fix( cfgetospeed( C_pointer_cast( pt, (struct termios) ) ) )
510
511#define C_cfsetispeed( pt, sp ) \
512    C_fix( cfsetispeed( C_pointer_cast( pt, (struct termios) ), C_unfix( sp ) ) )
513#define C_cfsetospeed( pt, sp ) \
514    C_fix( cfsetospeed( C_pointer_cast( pt, (struct termios) ), C_unfix( sp ) ) )
515<#
516
517(define (terminal-control-input-speed ptermios)
518  (##sys#check-pointer ptermios 'terminal-control-input-speed)
519
520(define (terminal-control-output-speed ptermios)
521  (##sys#check-pointer ptermios 'terminal-control-output-speed)
522
523(define (set-terminal-control-input-speed! ptermios speed)
524  (##sys#check-pointer ptermios 'set-terminal-control-output-speed!)
525  (##sys#check-exact speed 'set-terminal-control-input-speed!)
526  (when (fx= -1 (##core#inline "C_cfsetispeed" ptermios speed))
527    (##sys#posix-error #:file-error 'set-terminal-control-input-speed! "cannot change termios input speed" speed) ) )
528
529(define (set-terminal-control-output-speed! ptermios speed)
530  (##sys#check-pointer ptermios 'set-terminal-control-output-speed!)
531  (##sys#check-exact speed 'set-terminal-control-output-speed!)
532  (when (fx= -1 (##core#inline "C_cfsetospeed" ptermios speed))
533    (##sys#posix-error #:file-error 'set-terminal-control-output-speed! "cannot change termios output speed" speed) ) )
534
535(cond-expand
536  [solaris
537    #>
538    static int
539    cfsetspeed( struct termios * options, speed_t speed )
540    {
541        if (0 == cfsetispeed( options, speed ))
542            return cfsetospeed( options, speed );
543        else
544            return -1;
545    }
546    <#
547  ] [else] )
548
549#<
550#define C_cfsetspeed( pt ) \
551    C_fix( cfsetspeed( C_pointer_cast( pt, (struct termios) ), C_unfix( sp ) ) )
552>#
553
554(define (set-terminal-control-speed! ptermios speed)
555  (##sys#check-pointer ptermios 'set-terminal-control-speed!)
556  (##sys#check-exact speed 'set-terminal-control-speed!)
557  (when (fx= -1 (##core#inline "C_cfsetspeed" ptermios speed))
558    (##sys#posix-error #:file-error 'set-terminal-control-speed! "cannot change termios speed" ptermios speed) ) )
559
560;; Terminal Control Get & Set
561
562bsd now drain flush soft
563solaris linux now drain flush
564
565(define-foreign-variable TCSANOW int "TCSANOW")
566(define-foreign-variable TCSADRAIN int "TCSADRAIN")
567(define-foreign-variable TCSAFLUSH int "TCSAFLUSH")
568
569(cond-expand
570  [(or macosx freebsd netbsd openbsd)
571    (define-foreign-variable TCSASOFT int "TCSASOFT")
572  ] [else] )
573
574#>
575#define C_tcgetattr( fd, pt ) \
576    C_fix( tcgetattr( C_unfix( fd ), C_pointer_cast( pt, (struct termios) ) ) )
577#define C_tcsetattr( fd, act, pt ) \
578    C_fix( tcsetattr( C_unfix( fd ), C_unfix( act ), C_pointer_cast( pt, (struct termios) ) ) )
579<#
580
581(define (terminal-control-attributes fd #!optional ptermios)
582  (##sys#check-exact fd 'terminal-control-attributes)
583  (unless ptermios
584    (set! ptermios (alloc-termios)) )
585  (##sys#check-pointer ptermios 'terminal-control-attributes)
586  (if (fx= -1 (##core#inline "C_tcgetattr" fd ptermios))
587    (##sys#posix-error #:file-error 'terminal-control-attributes "cannot copy terminal parameters" fd)
588     ptermios ) )
589
590(define (set-terminal-control-attributes! fd act ptermios)
591  (##sys#check-exact fd 'set-terminal-control-attributes!)
592  (##sys#check-exact act 'set-terminal-control-attributes!)
593  (##sys#check-pointer ptermios 'set-terminal-control-attributes!)
594  (when (fx= -1 (##core#inline "C_tcsetattr" fd act ptermios))
595    (##sys#posix-error #:file-error 'set-terminal-control-attributes! "cannot change terminal parameters" fd act) ) )
596
597;; Terminal Control Drain
598
599#>
600#define C_tcdrain( fd )  C_fix( tcdrain( C_unfix( fd ) ) )
601<#
602
603(define (terminal-control-drain fd)
604  (##sys#check-exact fd 'terminal-control-drain)
605  (when (fx= -1 (##core#inline "C_tcdrain" fd))
606    (##sys#posix-error #:file-error 'terminal-control-drain "cannot drain terminal input" fd) ) )
607
608;; Terminal Control Flow
609
610(define-foreign-variable TCOOFF int "TCOOFF")
611(define-foreign-variable TCOON int "TCOON")
612(define-foreign-variable TCIOFF int "TCIOFF")
613(define-foreign-variable TCION int "TCION")
614
615#>
616#define C_tcflow( fd, act )  C_fix( tcflow( C_unfix( fd ), C_unfix( act ) ) )
617<#
618
619(define (terminal-control-flow fd act)
620  (##sys#check-exact fd 'terminal-control-flow)
621  (##sys#check-exact act 'terminal-control-flow)
622  (when (fx= -1 (##core#inline "C_tcflow" fd act))
623    (##sys#posix-error #:file-error 'terminal-control-flow "cannot control terminal flow" fd act) ) )
624
625;; Terminal Control Flush
626
627(define-foreign-variable TCIFLUSH int "TCIFLUSH")
628(define-foreign-variable TCOFLUSH int "TCOFLUSH")
629(define-foreign-variable TCIOFLUSH int "TCIOFLUSH")
630
631#>
632#define C_tcflush( fd, act )  C_fix( tcflush( C_unfix( fd ), C_unfix( act ) ) )
633<#
634
635(define (terminal-control-flush fd act)
636  (##sys#check-exact fd 'terminal-control-flush)
637  (##sys#check-exact act 'terminal-control-flush)
638  (when (fx= -1 (##core#inline "C_tcflush" fd act))
639    (##sys#posix-error #:file-error 'terminal-control-flush "cannot perform terminal flush" fd act) ) )
640
641;; Terminal Control Send Break
642
643#>
644#define C_tcsendbreak( fd, dur )  C_fix( tcsendbreak( C_unfix( fd ), C_unfix( dur ) ) )
645<#
646
647(define (terminal-control-send-break fd dur)
648  (##sys#check-exact fd 'terminal-control-send-break)
649  (##sys#check-exact dur 'terminal-control-send-break)
650  (when (fx= -1 (##core#inline "C_tcsendbreak" fd dur))
651    (##sys#posix-error #:file-error 'terminal-control-send-break "cannot transmit terminal break" fd dur) ) )
652
653(cond-expand
654  [solaris
655    #>
656    static void
657    cfmakeraw( struct termios * options )
658    {
659        options->c_iflag &= ~(IGNBRK|BRKINT|PARMRK|ISTRIP|INLCR|IGNCR|ICRNL|IXON);
660        options->c_oflag &= ~OPOST;
661        options->c_lflag &= ~(ECHO|ECHONL|ICANON|ISIG|IEXTEN);
662        options->c_cflag &= ~(CSIZE|PARENB);
663        options->c_cflag |= CS8;
664
665        return 0;
666    }
667    <#
668  ] [else] )
669
670#<
671#define C_cfmakeraw( pt ) C_fix( cfmakeraw( C_pointer_cast( pt, (struct termios) ) ) )
672>#
673
674(define (terminal-control-make-raw ptermios)
675  (##sys#check-pointer ptermios 'terminal-control-make-raw)
676  (if (fx= -1 (##core#inline "C_cfmakeraw" ptermios))
677    (##sys#posix-error #:file-error 'terminal-control-make-raw "cannot set terminal raw I/O path" ptermios) ) )
678
679;;; Pseudo-tty
680
681#| Solaris open pty per pts(7D) manpage
682
683                int              fdm fds;
684                char     *slavename;
685                extern char *ptsname();
686
687                fdm = open("/dev/ptmx", O_RDWR);        /* open master */
688                grantpt(fdm);                                                                                   /* change permission of slave */
689                unlockpt(fdm);                                                                          /* unlock slave */
690                slavename = ptsname(fdm);                                       /* get name of slave */
691                fds = open(slavename, O_RDWR);          /* open slave */
692                ioctl(fds, I_PUSH, "ptem");                             /* push ptem */
693                ioctl(fds, I_PUSH, "ldterm");                   /* push ldterm*/
694|#
695
696(cond-expand
697        [solaris
698
699                (define-unimplemented open-pseudo-tty)
700                (define-unimplemented login-tty)
701                (define-unimplemented fork-pseudo-tty)
702
703        ] [else
704
705                #>
706                #if defined(C_MACOSX) || defined(__NetBSD__) || defined(__OpenBSD__)
707                # include <util.h>
708                #elif defined(__FreeBSD__)
709                # include <libutil.h>
710                #else
711                # include <pty.h>
712                # include <utmp.h>
713                #endif
714
715    #define C_openpty( pm, ps, pn, pt, pw ) \
716        C_fix( openpty( C_locative_cast( pm, int ), C_locative_cast( ps, int ), \
717                        C_pointer_cast( pn, char ), \
718                        C_pointer_cast( pt, (struct termios) ), \
719                        C_pointer_cast( pw, (struct winsize) ) ) )
720
721    #define C_login_tty( fd )   C_fix( login_tty( C_unfix( fd ) ) )
722
723    #define C_forkpty( pm, pn, pt, pw ) \
724        C_fix( forkpty( C_locative_cast( pm, int ), \
725                        C_pointer_cast( pn, char ), \
726                        C_pointer_cast( pt, (struct termios) ), \
727                        C_pointer_cast( pw, (struct winsize) ) ) )
728                <#
729
730                (define (open-pseudo-tty #!optional ptermios pwinsize)
731      (##sys#check-pointer-argument ptermios 'open-pseudo-tty)
732      (##sys#check-pointer-argument pwinsize 'open-pseudo-tty)
733      (let-location ([master int]
734                     [slave int])
735                    (if (fx= 0 (##core#inline "C_openpty" #$master #$slave _null (or ptermios _null) (or pwinsize _null)))
736                      (values master slave)
737                      (##sys#posix-error #:file-error 'open-pseudo-tty "cannot open pseudo-tty") ) ) )
738
739    (define (login-tty fd)
740      (##sys#check-exact fd 'login-tty)
741                        (when (fx= -1 (##core#inline "C_login_tty" fd))
742                          (##sys#posix-error #:file-error 'login-tty "cannot login tty device" fd) ) )
743
744    (define (fork-pseudo-tty thunk #!optional ptermios pwinsize)
745      (##sys#check-closure thunk 'fork-pseudo-tty)
746      (##sys#check-pointer-argument ptermios 'fork-pseudo-tty)
747      (##sys#check-pointer-argument pwinsize 'fork-pseudo-tty)
748      (let-location ([master int])
749        (let ([ret (##core#inline "C_forkpty" #$master _null (or ptermios _null) (or pwinsize _null))])
750          (cond
751            [(fx= -1 ret)
752              (##sys#posix-error #:file-error 'fork-pseudo-tty "cannot create child process in pseudo-tty") ]
753            [(fx= 0 ret)
754              (thunk)
755              ((foreign-lambda void "_exit" int) 0) ]
756            [else
757              (values ret master) ] ) ) ) )
758
759        ] )
760
761;;; Terminal Information
762
763#>
764#include <unistd.h>
765#include <stdlib.h> /* for Solaris */
766
767#define C_isatty( fd )    (isatty( C_unfix( fd ) )  ? C_SCHEME_TRUE : C_SCHEME_FALSE)
768
769#define C_ttyname( fd, b, l ) \
770  (strncpy( C_c_string( b ), (ttyname( C_unfix( fd ) ) || ""), (l) + 1 )[ (l) ] != '\0' \
771    ? C_SCHEME_FALSE \
772    : strlen( C_c_string( b ) ))
773
774#define C_ttyslot()   C_fix( ttyslot() )
775<#
776
777(define (terminal-type-device? fd)
778  (##sys#check-exact fd 'terminal-type-device?)
779  (##core#inline "C_isatty" fd) )
780
781(define-constant _devicename_max int 255) ; probably too generous
782
783#;
784(define terminal-device-name
785  (let ([string-length string-length]
786        [defbuf (##sys#make-string (fx+ _devicename_max 1))] )
787    (lambda (fd #!optional (buf defbuf))
788      (##sys#check-exact fd 'terminal-device-name)
789      (let ([buflen (if (eq? buf defbuf) _devicename_max (fx- (string-length buf) 1))])
790        (let ([len (##core#inline "C_ttyname" fd buf buflen)])
791          (cond
792            [(not len)
793              (##sys#signal-hook #:limit-error 'terminal-device-name "buffer overflow" fd) ]
794            [(fx= 0 len)
795              ; Cannot find device or not a tty.
796              #f ]
797            [else
798              (##sys#substring buf 0 len) ] ) ) ) ) ) )
799
800(define terminal-device-name
801  (let ([defbuf (##sys#make-string (fx+ _devicename_max 1))] )
802    (lambda (fd)
803      (##sys#check-exact fd 'terminal-device-name)
804      (let ([len (##core#inline "C_ttyname" fd defbuf _devicename_max)])
805        (cond
806          [(not len)
807            (##sys#signal-hook #:limit-error 'terminal-device-name "buffer overflow" fd) ]
808          [(fx= 0 len)
809            ; Cannot find device or not a tty.
810            #f ]
811          [else
812            (##sys#substring buf 0 len) ] ) ) ) ) )
813
814(define (current-process-tty-number)
815  (let ([fd (##core#inline "C_ttyslot")])
816    (if (fx= 0 fd)
817      (##sys#posix-error #:file-error 'current-process-tty-number "cannot fetch current process control terminal number")
818      fd ) ) )
819
820;;; Fileno
821
822(define (replace-fileno fd sfd)
823        (unless (fx= sfd fd)
824                (duplicate-fileno fd sfd)
825                (file-close fd) ) )
826
827;;; Spawn Stuff
828
829#|
830;; process-spawn
831
832(define spawn/overlay           0)
833(define spawn/wait                      1)
834(define spawn/nowait            2)
835(define spawn/nowaito           3)
836(define spawn/detach            4)
837
838(define (process-spawn mode command #!optional arguments environment exact?)
839  )
840
841|#
842
843#|
844;; POSIX 'posix-spawn'
845;; Solaris      -
846;; Linux                -
847
848;;
849
850posix_spawn_file_actions_init(posix_spawn_file_actions_t *);
851posix_spawn_file_actions_destroy(posix_spawn_file_actions_t *);
852posix_spawn_file_actions_addclose(posix_spawn_file_actions_t *, int);
853posix_spawn_file_actions_adddup2(posix_spawn_file_actions_t *, int, int);
854posix_spawn_file_actions_addopen(posix_spawn_file_actions_t *restrict, int, const char *restrict, int, mode_t);
855
856; FILE-ACTIONS init
857; FILE-ACTIONS destroy   FILE-ACTIONS
858; FILE-ACTIONS add                       open FILE-ACTIONS FILENO PATH OPEN-FLAG MODE
859; FILE-ACTIONS add                       close FILE-ACTIONS FILENO
860; FILE-ACTIONS add                       dup2 FILE-ACTIONS FILENO1 NEW-FILENO
861
862(define (posix-spawn-file-actions operation . rest)
863        )
864
865;;
866
867posix_spawnattr_posix_spawnattr_init(posix_spawnattr_t *);
868posix_spawnattr_posix_spawnattr_destroy(posix_spawnattr_t *);
869posix_spawnattr_getsigdefault(const posix_spawnattr_t *restrict, sigset_t *restrict);
870posix_spawnattr_getflags(const posix_spawnattr_t *restrict, short *restrict);
871posix_spawnattr_getpgroup(const posix_spawnattr_t *restrict, pid_t *restrict);
872posix_spawnattr_getschedparam(const posix_spawnattr_t *restrict, struct sched_param *restrict);
873posix_spawnattr_getschedpolicy(const posix_spawnattr_t *restrict, int *restrict);
874posix_spawnattr_getsigmask(const posix_spawnattr_t *restrict, sigset_t *restrict);
875posix_spawnattr_setsigdefault(posix_spawnattr_t *restrict, const sigset_t *restrict);
876posix_spawnattr_setflags(posix_spawnattr_t *, short);
877posix_spawnattr_setpgroup(posix_spawnattr_t *, pid_t);
878posix_spawnattr_setschedparam(posix_spawnattr_t *restrict, const struct sched_param *restrict);
879posix_spawnattr_setschedpolicy(posix_spawnattr_t *, int);
880posix_spawnattr_setsigmask(posix_spawnattr_t *restrict, const sigset_t *restrict);
881
882; ATTRIBUTES            init
883; ATTRIBUTES            destroy         ATTRIBUTES
884; SIGNAL-SET            get                             sigmask ATTRIBUTES
885; ATTRIBUTES            set                             sigmask ATTRIBUTES SIGNAL-SET
886; SIGNAL-SET            get                             sigdefault ATTRIBUTES
887; ATTRIBUTES            set                             sigdefault ATTRIBUTES SIGNAL-SET
888; FLAGS                                 get                             flags ATTRIBUTES
889; ATTRIBUTES            set                             flags ATTRIBUTES FLAGS
890; PID                                           get                             pgroup ATTRIBUTES
891; ATTRIBUTES            set                             pgroup ATTRIBUTES PID
892; ATTRIBUTES            get                             schedparam ATTRIBUTES
893; SCHEDPARAM            set                             schedparam ATTRIBUTES SCHEDPARAM
894; SCHEDPOLICY           get                             schedpolicy ATTRIBUTES
895; ATTRIBUTES            set                             schedpolicy ATTRIBUTES SCHEDPOLICY
896
897(define (posix-spawn-attributes operation . rest)
898        )
899
900;;
901
902int
903posix_spawn(
904  pid_t *restrict pid,
905  const char *restrict path,
906  const posix_spawn_file_actions_t *file_actions,
907  const posix_spawnattr_t *restrict attrp,
908  char *const argv[restrict], char *const envp[restrict] );
909
910(define (posix-spawn command file-actions attributes arguments environment)
911        )
912
913;;
914
915int
916posix_spawnp(
917  pid_t *restrict pid,
918  const char *restrict file,
919  const posix_spawn_file_actions_t *file_actions,
920  const posix_spawnattr_t *restrict attrp,
921  char *const argv[restrict], char * const envp[restrict] );
922
923(define (posix-spawnp command file-actions attributes arguments environment)
924        )
925|#
926
927#|
928;; BSD 'rfork'
929;; NetBSD               - not supplied?
930;; FreeBSD      -
931;; OpenBSD      -
932;; MacOS X      - not supplied
933|#
934
935#|
936;; Linux 'clone'
937|#
Note: See TracBrowser for help on using the repository browser.