/[cmucl]/src/code/unix-glibc2.lisp
ViewVC logotype

Contents of /src/code/unix-glibc2.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (hide annotations)
Fri Oct 3 13:30:15 2008 UTC (5 years, 6 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2008-12, snapshot-2008-11, merge-sse2-packed, snapshot-2008-10, snapshot-2009-01
Changes since 1.44: +9 -5 lines
Fix unix-openpty.  The parameters should not include amaster and
aalave, which are returned by openpty.  This matches the
implementation in unix.lisp.
<
1 dtc 1.1 ;;; -*- Package: UNIX -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.45 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/unix-glibc2.lisp,v 1.45 2008/10/03 13:30:15 rtoy Exp $")
9 dtc 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; This file contains the UNIX low-level support for glibc2. Based
13 dtc 1.5 ;;; on unix.lisp 1.56, converted for glibc2 by Peter Van Eynde (1998).
14     ;;; Alpha support by Julian Dolby, 1999.
15 dtc 1.1 ;;;
16 toy 1.28 ;;; All the functions with #+(or) in front are work in progress,
17 dtc 1.2 ;;; and mostly don't work.
18     ;;;
19 toy 1.28 ;; Todo: #+(or)'ed stuff and ioctl's
20 dtc 1.2 ;;
21 emarsden 1.21 ;;
22     ;; Large File Support (LFS) added by Pierre Mai and Eric Marsden, Feb
23     ;; 2003. This is necessary to be able to read/write/stat files that
24     ;; are larger than 2GB on a 32-bit system. From a C program, defining
25     ;; a preprocessor macro _LARGEFILE64_SOURCE makes the preproccessor
26     ;; replace a call to open() by open64(), and similarly for stat,
27     ;; fstat, lstat, lseek, readdir and friends. Furthermore, certain data
28     ;; types, that are normally 32 bits wide, are replaced by 64-bit wide
29     ;; equivalents: off_t -> off64_t etc. The libc.so fiddles around with
30     ;; weak symbols to support this mess.
31     ;;
32     ;; From CMUCL, we make FFI calls to the xxx64 functions, and use the
33     ;; 64-bit wide versions of the data structures. The most ugly aspect
34     ;; is that some of the stat functions are not available via dlsym, so
35     ;; we reference them explicitly from linux-stubs.S. Another amusing
36 pmai 1.24 ;; fact is that on glibc 2.2, stat64() returns a struct stat with a
37     ;; 32-bit ino_t, whereas readdir64() returns a struct dirent that
38     ;; contains a 64-bit ino_t. On glibc 2.1, OTOH, both stat64 and
39     ;; readdir64 use structs with 32-bit ino_t.
40     ;;
41     ;; The current version deals with this by going with the glibc 2.2
42     ;; definitions, unless the keyword :glibc2.1 also occurs on *features*,
43     ;; in addition to :glibc2, in which case we go with the glibc 2.1
44     ;; definitions. Note that binaries compiled against glibc 2.1 do in
45     ;; fact work fine on glibc 2.2, because readdir64 is available in both
46     ;; glibc 2.1 and glibc 2.2 versions in glibc 2.2, disambiguated through
47     ;; ELF symbol versioning. We use an entry for readdir64 in linux-stubs.S
48     ;; in order to force usage of the correct version of readdir64 at runtime.
49     ;;
50     ;; So in order to compile for glibc 2.2 and newer, just compile CMUCL
51     ;; on a glibc 2.2 system, and make sure that :glibc2.1 doesn't appear
52     ;; on the *features* list. In order to compile for glibc 2.1 and newer,
53     ;; compile CMUCL on a glibc 2.1 system, and make sure that :glibc2.1 does
54     ;; appear on the *features* list.
55 emarsden 1.21
56 dtc 1.1 (in-package "UNIX")
57     (use-package "ALIEN")
58     (use-package "C-CALL")
59     (use-package "SYSTEM")
60     (use-package "EXT")
61    
62     (export '(
63     daddr-t caddr-t ino-t swblk-t size-t time-t dev-t off-t uid-t gid-t
64 emarsden 1.21 blkcnt-t fsblkcnt-t fsfilcnt-t
65 pmai 1.22 unix-lockf f_ulock f_lock f_tlock f_test
66 dtc 1.1 timeval tv-sec tv-usec timezone tz-minuteswest tz-dsttime
67     itimerval it-interval it-value tchars t-intrc t-quitc t-startc
68     t-stopc t-eofc t-brkc ltchars t-suspc t-dsuspc t-rprntc t-flushc
69     t-werasc t-lnextc sgttyb sg-ispeed sg-ospeed sg-erase sg-kill
70     sg-flags winsize ws-row ws-col ws-xpixel ws-ypixel
71     direct d-off d-ino d-reclen d-name
72     stat st-dev st-mode st-nlink st-uid st-gid st-rdev st-size
73     st-atime st-mtime st-ctime st-blksize st-blocks
74     s-ifmt s-ifdir s-ifchr s-ifblk s-ifreg s-iflnk s-ifsock
75     s-isuid s-isgid s-isvtx s-iread s-iwrite s-iexec
76     ruseage ru-utime ru-stime ru-maxrss ru-ixrss ru-idrss
77     ru-isrss ru-minflt ru-majflt ru-nswap ru-inblock ru-oublock
78     ru-msgsnd ru-msgrcv ru-nsignals ru-nvcsw ru-nivcsw
79     rlimit rlim-cur rlim-max sc-onstack sc-mask sc-pc
80     unix-errno get-unix-error-msg
81 toy 1.27 prot_read prot_write prot_exec prot_none
82     map_shared map_private map_fixed map_anonymous
83 toy 1.28 ms_async ms_sync ms_invalidate
84 rtoy 1.41 unix-mmap unix-munmap unix-msync unix-mprotect
85 dtc 1.1 unix-pathname unix-file-mode unix-fd unix-pid unix-uid unix-gid
86     unix-setitimer unix-getitimer
87     unix-access r_ok w_ok x_ok f_ok unix-chdir unix-chmod setuidexec
88     setgidexec savetext readown writeown execown readgrp writegrp
89     execgrp readoth writeoth execoth unix-fchmod unix-chown unix-fchown
90     unix-getdtablesize unix-close unix-creat unix-dup unix-dup2
91     unix-fcntl f-dupfd f-getfd f-setfd f-getfl f-setfl f-getown f-setown
92     fndelay fappend fasync fcreat ftrunc fexcl unix-link unix-lseek
93     l_set l_incr l_xtnd unix-mkdir unix-open o_rdonly o_wronly o_rdwr
94     o_ndelay
95     o_noctty
96     o_append o_creat o_trunc o_excl unix-pipe unix-read unix-readlink
97     unix-rename unix-rmdir unix-fast-select fd-setsize fd-set fd-clr
98     fd-isset fd-zero unix-select unix-sync unix-fsync unix-truncate
99     unix-ftruncate unix-symlink unix-unlink unix-write unix-ioctl
100 dtc 1.13 unix-uname utsname
101 dtc 1.1 tcsetpgrp tcgetpgrp tty-process-group
102     terminal-speeds tty-raw tty-crmod tty-echo tty-lcase
103     tty-cbreak
104     termios
105     c-lflag
106     c-iflag
107     c-oflag
108     tty-icrnl
109     tty-ocrnl
110     veof
111     vintr
112     vquit
113     vstart
114     vstop
115     vsusp
116     c-cflag
117     c-cc
118     tty-icanon
119     vmin
120     vtime
121     tty-ixon
122     tcsanow
123     tcsadrain
124     tciflush
125     tcoflush
126     tcioflush
127     tcsaflush
128     unix-tcgetattr
129     unix-tcsetattr
130     tty-ignbrk
131     tty-brkint
132     tty-ignpar
133     tty-parmrk
134     tty-inpck
135     tty-istrip
136     tty-inlcr
137     tty-igncr
138     tty-iuclc
139     tty-ixany
140     tty-ixoff
141     tty-imaxbel
142     tty-opost
143     tty-olcuc
144     tty-onlcr
145     tty-onocr
146     tty-onlret
147     tty-ofill
148     tty-ofdel
149     tty-isig
150     tty-xcase
151     tty-echoe
152     tty-echok
153     tty-echonl
154     tty-noflsh
155     tty-iexten
156     tty-tostop
157     tty-echoctl
158     tty-echoprt
159     tty-echoke
160     tty-pendin
161     tty-cstopb
162     tty-cread
163     tty-parenb
164     tty-parodd
165     tty-hupcl
166     tty-clocal
167     vintr
168     verase
169     vkill
170     veol
171     veol2
172     TIOCGETP TIOCSETP TIOCFLUSH TIOCSETC TIOCGETC TIOCSLTC
173     TIOCGLTC TIOCNOTTY TIOCSPGRP TIOCGPGRP TIOCGWINSZ TIOCSWINSZ
174     TIOCSIGSEND
175    
176     KBDCGET KBDCSET KBDCRESET KBDCRST KBDCSSTD KBDSGET KBDGCLICK
177     KBDSCLICK FIONREAD unix-exit unix-stat unix-lstat unix-fstat
178     unix-getrusage unix-fast-getrusage rusage_self rusage_children
179     unix-gettimeofday
180 dtc 1.8 unix-utimes unix-sched-yield unix-setreuid
181 dtc 1.1 unix-setregid
182     unix-getpid unix-getppid
183     unix-getgid unix-getegid unix-getpgrp unix-setpgrp unix-getuid
184     unix-getpagesize unix-gethostname unix-gethostid unix-fork
185     unix-current-directory unix-isatty unix-ttyname unix-execve
186     unix-socket unix-connect unix-bind unix-listen unix-accept
187 dtc 1.9 unix-recv unix-send unix-getpeername unix-getsockname
188 cshapiro 1.44 unix-getsockopt unix-setsockopt unix-openpty
189 toy 1.17
190 rtoy 1.35 unix-recvfrom unix-sendto unix-shutdown
191    
192 toy 1.17 unix-getpwnam unix-getpwuid unix-getgrnam unix-getgrgid
193     user-info user-info-name user-info-password user-info-uid
194     user-info-gid user-info-gecos user-info-dir user-info-shell
195     group-info group-info-name group-info-gid group-info-members))
196 dtc 1.1
197     (pushnew :unix *features*)
198 dtc 1.2 (pushnew :glibc2 *features*)
199 dtc 1.1
200     ;;;; Common machine independent structures.
201    
202 dtc 1.2 (eval-when (compile eval)
203 dtc 1.1
204 dtc 1.2 (defparameter *compiler-unix-errors* nil)
205 dtc 1.1
206 dtc 1.2 (defmacro def-unix-error (name number description)
207     `(progn
208     (eval-when (compile eval)
209     (push (cons ,number ,description) *compiler-unix-errors*))
210     (defconstant ,name ,number ,description)
211     (export ',name)))
212 dtc 1.1
213 dtc 1.2 (defmacro emit-unix-errors ()
214     (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*)))
215     (array (make-array (1+ max) :initial-element nil)))
216     (dolist (error *compiler-unix-errors*)
217     (setf (svref array (car error)) (cdr error)))
218     `(progn
219     (defvar *unix-errors* ',array)
220 pw 1.15 (declaim (simple-vector *unix-errors*)))))
221 dtc 1.1
222 dtc 1.2 )
223 dtc 1.1
224 dtc 1.2 (defmacro def-enum (inc cur &rest names)
225     (flet ((defform (name)
226     (prog1 (when name `(defconstant ,name ,cur))
227     (setf cur (funcall inc cur 1)))))
228     `(progn ,@(mapcar #'defform names))))
229 dtc 1.1
230 toy 1.27 ;;;; Memory-mapped files
231    
232     (defconstant +null+ (sys:int-sap 0))
233    
234     (defconstant prot_read 1)
235     (defconstant prot_write 2)
236     (defconstant prot_exec 4)
237     (defconstant prot_none 0)
238    
239     (defconstant map_shared 1)
240     (defconstant map_private 2)
241     (defconstant map_fixed 16)
242     (defconstant map_anonymous 32)
243    
244 toy 1.28 (defconstant ms_async 1)
245     (defconstant ms_sync 4)
246     (defconstant ms_invalidate 2)
247    
248 rtoy 1.37 ;; The return value from mmap that means mmap failed.
249 cshapiro 1.40 (defconstant map_failed (int-sap (1- (ash 1 vm:word-bits))))
250 rtoy 1.37
251 toy 1.27 (defun unix-mmap (addr length prot flags fd offset)
252     (declare (type (or null system-area-pointer) addr)
253 toy 1.28 (type (unsigned-byte 32) length)
254 toy 1.27 (type (integer 1 7) prot)
255 toy 1.28 (type (unsigned-byte 32) flags)
256 gerd 1.30 (type (or null unix-fd) fd)
257 rtoy 1.43 (type (signed-byte 32) offset))
258 rtoy 1.37 ;; Can't use syscall, because the address that is returned could be
259     ;; "negative". Hence we explicitly check for mmap returning
260     ;; MAP_FAILED.
261     (let ((result
262 cshapiro 1.40 (alien-funcall (extern-alien "mmap" (function system-area-pointer
263     system-area-pointer
264 rtoy 1.37 size-t int int int off-t))
265     (or addr +null+) length prot flags (or fd -1) offset)))
266 cshapiro 1.40 (if (sap= result map_failed)
267 rtoy 1.37 (values nil (unix-errno))
268 cshapiro 1.40 (values result 0))))
269 toy 1.27
270     (defun unix-munmap (addr length)
271     (declare (type system-area-pointer addr)
272 toy 1.28 (type (unsigned-byte 32) length))
273 toy 1.27 (syscall ("munmap" system-area-pointer size-t) t addr length))
274    
275 toy 1.28 (defun unix-msync (addr length flags)
276     (declare (type system-area-pointer addr)
277     (type (unsigned-byte 32) length)
278     (type (signed-byte 32) flags))
279     (syscall ("msync" system-area-pointer size-t int) t addr length flags))
280    
281 rtoy 1.41 (defun unix-mprotect (addr length prot)
282     (declare (type system-area-pointer addr)
283     (type (unsigned-byte 32) length)
284     (type (integer 1 7) prot))
285     (syscall ("mprotect" system-area-pointer size-t int)
286     t addr length prot))
287    
288 dtc 1.2 ;;;; Lisp types used by syscalls.
289 dtc 1.1
290 dtc 1.2 (deftype unix-pathname () 'simple-string)
291     (deftype unix-fd () `(integer 0 ,most-positive-fixnum))
292 dtc 1.1
293 dtc 1.2 (deftype unix-file-mode () '(unsigned-byte 32))
294     (deftype unix-pid () '(unsigned-byte 32))
295     (deftype unix-uid () '(unsigned-byte 32))
296     (deftype unix-gid () '(unsigned-byte 32))
297 dtc 1.1
298 toy 1.17
299     ;;;; User and group database structures: <pwd.h> and <grp.h>
300    
301     (defstruct user-info
302     (name "" :type string)
303     (password "" :type string)
304     (uid 0 :type unix-uid)
305     (gid 0 :type unix-gid)
306     (gecos "" :type string)
307     (dir "" :type string)
308     (shell "" :type string))
309    
310     (defstruct group-info
311     (name "" :type string)
312     (password "" :type string)
313     (gid 0 :type unix-gid)
314     (members nil :type list)) ; list of logins as strings
315    
316     (def-alien-type nil
317     (struct passwd
318     (pw-name (* char)) ; user's login name
319     (pw-passwd (* char)) ; no longer used
320     (pw-uid uid-t) ; user id
321     (pw-gid gid-t) ; group id
322     (pw-gecos (* char)) ; typically user's full name
323     (pw-dir (* char)) ; user's home directory
324     (pw-shell (* char)))) ; user's login shell
325    
326     (def-alien-type nil
327     (struct group
328     (gr-name (* char)) ; name of the group
329     (gr-passwd (* char)) ; encrypted group password
330     (gr-gid gid-t) ; numerical group ID
331     (gr-mem (* (* char))))) ; vector of pointers to member names
332    
333    
334 dtc 1.2 ;;;; System calls.
335 dtc 1.1
336 cshapiro 1.38 (def-alien-routine ("os_get_errno" unix-get-errno) int)
337     (def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int))
338     (defun unix-errno () (unix-get-errno))
339     (defun (setf unix-errno) (newvalue) (unix-set-errno newvalue))
340 pmai 1.32
341 dtc 1.2 ;;; GET-UNIX-ERROR-MSG -- public.
342     ;;;
343 pmai 1.32 (defun get-unix-error-msg (&optional (error-number (unix-errno)))
344 dtc 1.2 "Returns a string describing the error number which was returned by a
345     UNIX system call."
346     (declare (type integer error-number))
347    
348     (if (array-in-bounds-p *unix-errors* error-number)
349     (svref *unix-errors* error-number)
350     (format nil "Unknown error [~d]" error-number)))
351 dtc 1.1
352 dtc 1.2 (defmacro syscall ((name &rest arg-types) success-form &rest args)
353 cshapiro 1.42 `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
354     ,@args)))
355     (if (minusp result)
356     (values nil (unix-errno))
357     ,success-form)))
358 dtc 1.1
359 toy 1.17 ;;; Like syscall, but if it fails, signal an error instead of returning error
360 dtc 1.2 ;;; codes. Should only be used for syscalls that will never really get an
361     ;;; error.
362     ;;;
363     (defmacro syscall* ((name &rest arg-types) success-form &rest args)
364 cshapiro 1.42 `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
365     ,@args)))
366     (if (minusp result)
367     (error "Syscall ~A failed: ~A" ,name (get-unix-error-msg))
368     ,success-form)))
369 dtc 1.1
370 dtc 1.2 (defmacro void-syscall ((name &rest arg-types) &rest args)
371     `(syscall (,name ,@arg-types) (values t 0) ,@args))
372 dtc 1.1
373 dtc 1.2 (defmacro int-syscall ((name &rest arg-types) &rest args)
374     `(syscall (,name ,@arg-types) (values result 0) ,@args))
375 dtc 1.1
376 dtc 1.2 ;;; From stdio.h
377 dtc 1.1
378 dtc 1.2 ;;; Unix-rename accepts two files names and renames the first to the second.
379 dtc 1.1
380 dtc 1.2 (defun unix-rename (name1 name2)
381     "Unix-rename renames the file with string name1 to the string
382     name2. NIL and an error code is returned if an error occured."
383     (declare (type unix-pathname name1 name2))
384     (void-syscall ("rename" c-string c-string) name1 name2))
385 dtc 1.1
386 dtc 1.2 ;;; From sys/types.h
387     ;;; and
388     ;;; gnu/types.h
389 dtc 1.1
390 dtc 1.2 (defconstant +max-s-long+ 2147483647)
391     (defconstant +max-u-long+ 4294967295)
392 dtc 1.1
393 toy 1.18 (def-alien-type quad-t #+alpha long #-alpha (array long 2))
394     (def-alien-type uquad-t #+alpha unsigned-long
395     #-alpha (array unsigned-long 2))
396 dtc 1.2 (def-alien-type qaddr-t (* quad-t))
397     (def-alien-type daddr-t int)
398     (def-alien-type caddr-t (* char))
399     (def-alien-type swblk-t long)
400 pw 1.4 (def-alien-type size-t #-alpha unsigned-int #+alpha long)
401 dtc 1.2 (def-alien-type time-t long)
402     (def-alien-type clock-t long)
403     (def-alien-type uid-t unsigned-int)
404 pw 1.4 (def-alien-type ssize-t #-alpha int #+alpha long)
405 dtc 1.2 (def-alien-type key-t int)
406     (def-alien-type int8-t char)
407     (def-alien-type u-int8-t unsigned-char)
408     (def-alien-type int16-t short)
409     (def-alien-type u-int16-t unsigned-short)
410     (def-alien-type int32-t int)
411     (def-alien-type u-int32-t unsigned-int)
412 emarsden 1.19 (def-alien-type int64-t (signed 64))
413     (def-alien-type u-int64-t (unsigned 64))
414 pw 1.4 (def-alien-type register-t #-alpha int #+alpha long)
415 dtc 1.1
416 cwang 1.31 (def-alien-type dev-t #-amd64 uquad-t #+amd64 u-int64-t)
417 dtc 1.2 (def-alien-type uid-t unsigned-int)
418     (def-alien-type gid-t unsigned-int)
419 cwang 1.31 (def-alien-type ino-t #-amd64 u-int32-t #+amd64 u-int64-t)
420 emarsden 1.21 (def-alien-type ino64-t u-int64-t)
421 emarsden 1.26 (def-alien-type mode-t u-int32-t)
422 cwang 1.31 (def-alien-type nlink-t #-amd64 unsigned-int #+amd64 u-int64-t)
423 emarsden 1.21 (def-alien-type off-t int64-t)
424     (def-alien-type blkcnt-t u-int64-t)
425     (def-alien-type fsblkcnt-t u-int64-t)
426     (def-alien-type fsfilcnt-t u-int64-t)
427 dtc 1.2 (def-alien-type pid-t int)
428 toy 1.18 ;(def-alien-type ssize-t #-alpha int #+alpha long)
429 dtc 1.1
430 dtc 1.2 (def-alien-type fsid-t (array int 2))
431 dtc 1.1
432 pw 1.4 (def-alien-type fd-mask #-alpha unsigned-long #+alpha unsigned-int)
433    
434 dtc 1.2 (defconstant fd-setsize 1024)
435 pw 1.4 (defconstant nfdbits 32)
436    
437 dtc 1.2 (def-alien-type nil
438     (struct fd-set
439 pw 1.4 (fds-bits (array fd-mask #.(/ fd-setsize nfdbits)))))
440 dtc 1.1
441 dtc 1.2 (def-alien-type key-t int)
442 dtc 1.1
443 dtc 1.2 (def-alien-type ipc-pid-t unsigned-short)
444 dtc 1.1
445 dtc 1.2 ;;; direntry.h
446 dtc 1.1
447     (def-alien-type nil
448 emarsden 1.21 (struct dirent
449 pmai 1.24 #+glibc2.1
450     (d-ino ino-t) ; inode number of entry
451     #-glibc2.1
452 emarsden 1.21 (d-ino ino64-t) ; inode number of entry
453     (d-off off-t) ; offset of next disk directory entry
454 dtc 1.1 (d-reclen unsigned-short) ; length of this record
455 dtc 1.2 (d_type unsigned-char)
456 dtc 1.1 (d-name (array char 256)))) ; name must be no longer than this
457 dtc 1.2 ;;; dirent.h
458 dtc 1.1
459 dtc 1.2 ;;; Operations on Unix Directories.
460 dtc 1.1
461 dtc 1.2 (export '(open-dir read-dir close-dir))
462 dtc 1.1
463 gerd 1.25 (defstruct (%directory
464     (:constructor make-directory)
465     (:conc-name directory-)
466     (:print-function %print-directory))
467 dtc 1.2 name
468     (dir-struct (required-argument) :type system-area-pointer))
469 dtc 1.1
470 dtc 1.2 (defun %print-directory (dir stream depth)
471     (declare (ignore depth))
472     (format stream "#<Directory ~S>" (directory-name dir)))
473 dtc 1.1
474 dtc 1.2 (defun open-dir (pathname)
475     (declare (type unix-pathname pathname))
476     (when (string= pathname "")
477     (setf pathname "."))
478     (let ((kind (unix-file-kind pathname)))
479     (case kind
480     (:directory
481     (let ((dir-struct
482     (alien-funcall (extern-alien "opendir"
483     (function system-area-pointer
484     c-string))
485     pathname)))
486     (if (zerop (sap-int dir-struct))
487 pmai 1.32 (values nil (unix-errno))
488 dtc 1.2 (make-directory :name pathname :dir-struct dir-struct))))
489     ((nil)
490     (values nil enoent))
491     (t
492     (values nil enotdir)))))
493 dtc 1.1
494 dtc 1.2 (defun read-dir (dir)
495 emarsden 1.26 (declare (type %directory dir))
496 emarsden 1.21 (let ((daddr (alien-funcall (extern-alien "readdir64"
497 dtc 1.2 (function system-area-pointer
498     system-area-pointer))
499     (directory-dir-struct dir))))
500     (declare (type system-area-pointer daddr))
501     (if (zerop (sap-int daddr))
502     nil
503 emarsden 1.21 (with-alien ((dirent (* (struct dirent)) daddr))
504     (values (cast (slot dirent 'd-name) c-string)
505     (slot dirent 'd-ino))))))
506 dtc 1.1
507 dtc 1.2 (defun close-dir (dir)
508 emarsden 1.26 (declare (type %directory dir))
509 dtc 1.2 (alien-funcall (extern-alien "closedir"
510     (function void system-area-pointer))
511     (directory-dir-struct dir))
512     nil)
513 dtc 1.1
514 dtc 1.2 ;;; dlfcn.h -> in foreign.lisp
515 dtc 1.1
516 dtc 1.2 ;;; fcntl.h
517     ;;;
518     ;;; POSIX Standard: 6.5 File Control Operations <fcntl.h>
519 dtc 1.1
520 dtc 1.2 (defconstant r_ok 4 "Test for read permission")
521     (defconstant w_ok 2 "Test for write permission")
522     (defconstant x_ok 1 "Test for execute permission")
523     (defconstant f_ok 0 "Test for presence of file")
524 dtc 1.1
525 dtc 1.2 (defun unix-fcntl (fd cmd arg)
526     "Unix-fcntl manipulates file descriptors accoridng to the
527     argument CMD which can be one of the following:
528 dtc 1.1
529 dtc 1.2 F-DUPFD Duplicate a file descriptor.
530     F-GETFD Get file descriptor flags.
531     F-SETFD Set file descriptor flags.
532     F-GETFL Get file flags.
533     F-SETFL Set file flags.
534     F-GETOWN Get owner.
535     F-SETOWN Set owner.
536 dtc 1.1
537 dtc 1.2 The flags that can be specified for F-SETFL are:
538 dtc 1.1
539 dtc 1.2 FNDELAY Non-blocking reads.
540     FAPPEND Append on each write.
541     FASYNC Signal pgrp when data ready.
542     FCREAT Create if nonexistant.
543     FTRUNC Truncate to zero length.
544     FEXCL Error if already created.
545     "
546     (declare (type unix-fd fd)
547 pw 1.11 (type (unsigned-byte 32) cmd)
548     (type (unsigned-byte 32) arg))
549 pw 1.12 (int-syscall ("fcntl" int unsigned-int unsigned-int) fd cmd arg))
550 dtc 1.1
551 dtc 1.2 (defun unix-open (path flags mode)
552 emarsden 1.19 "Unix-open opens the file whose pathname is specified by PATH
553     for reading and/or writing as specified by the FLAGS argument.
554     Returns an integer file descriptor.
555 dtc 1.2 The flags argument can be:
556 dtc 1.1
557 dtc 1.2 o_rdonly Read-only flag.
558     o_wronly Write-only flag.
559     o_rdwr Read-and-write flag.
560     o_append Append flag.
561     o_creat Create-if-nonexistant flag.
562     o_trunc Truncate-to-size-0 flag.
563 emarsden 1.19 o_excl Error if the file already exists
564 dtc 1.2 o_noctty Don't assign controlling tty
565     o_ndelay Non-blocking I/O
566     o_sync Synchronous I/O
567     o_async Asynchronous I/O
568 dtc 1.1
569 dtc 1.2 If the o_creat flag is specified, then the file is created with
570 emarsden 1.19 a permission of argument MODE if the file doesn't exist."
571 dtc 1.2 (declare (type unix-pathname path)
572     (type fixnum flags)
573     (type unix-file-mode mode))
574 emarsden 1.19 (int-syscall ("open64" c-string int int) path flags mode))
575 dtc 1.1
576 dtc 1.2 (defun unix-getdtablesize ()
577     "Unix-getdtablesize returns the maximum size of the file descriptor
578     table. (i.e. the maximum number of descriptors that can exist at
579     one time.)"
580     (int-syscall ("getdtablesize")))
581 dtc 1.1
582 dtc 1.2 ;;; Unix-close accepts a file descriptor and attempts to close the file
583     ;;; associated with it.
584 dtc 1.1
585 dtc 1.2 (defun unix-close (fd)
586     "Unix-close takes an integer file descriptor as an argument and
587     closes the file associated with it. T is returned upon successful
588     completion, otherwise NIL and an error number."
589     (declare (type unix-fd fd))
590     (void-syscall ("close" int) fd))
591 dtc 1.1
592 dtc 1.2 ;;; Unix-creat accepts a file name and a mode. It creates a new file
593     ;;; with name and sets it mode to mode (as for chmod).
594 dtc 1.1
595 dtc 1.2 (defun unix-creat (name mode)
596     "Unix-creat accepts a file name and a mode (same as those for
597     unix-chmod) and creates a file by that name with the specified
598     permission mode. It returns a file descriptor on success,
599     or NIL and an error number otherwise.
600 dtc 1.1
601 dtc 1.2 This interface is made obsolete by UNIX-OPEN."
602 dtc 1.1
603 dtc 1.2 (declare (type unix-pathname name)
604     (type unix-file-mode mode))
605 emarsden 1.19 (int-syscall ("creat64" c-string int) name mode))
606 dtc 1.2
607     ;;; fcntlbits.h
608 dtc 1.1
609 dtc 1.2 (defconstant o_read o_rdonly "Open for reading")
610     (defconstant o_write o_wronly "Open for writing")
611 dtc 1.1
612 dtc 1.2 (defconstant o_rdonly 0 "Read-only flag.")
613     (defconstant o_wronly 1 "Write-only flag.")
614     (defconstant o_rdwr 2 "Read-write flag.")
615     (defconstant o_accmode 3 "Access mode mask.")
616 pw 1.4
617     #-alpha
618     (progn
619     (defconstant o_creat #o100 "Create if nonexistant flag. (not fcntl)")
620     (defconstant o_excl #o200 "Error if already exists. (not fcntl)")
621     (defconstant o_noctty #o400 "Don't assign controlling tty. (not fcntl)")
622     (defconstant o_trunc #o1000 "Truncate flag. (not fcntl)")
623     (defconstant o_append #o2000 "Append flag.")
624     (defconstant o_ndelay #o4000 "Non-blocking I/O")
625     (defconstant o_nonblock #o4000 "Non-blocking I/O")
626     (defconstant o_ndelay o_nonblock)
627     (defconstant o_sync #o10000 "Synchronous writes (on ext2)")
628     (defconstant o_fsync o_sync)
629     (defconstant o_async #o20000 "Asynchronous I/O"))
630     #+alpha
631     (progn
632     (defconstant o_creat #o1000 "Create if nonexistant flag. (not fcntl)")
633     (defconstant o_trunc #o2000 "Truncate flag. (not fcntl)")
634     (defconstant o_excl #o4000 "Error if already exists. (not fcntl)")
635     (defconstant o_noctty #o10000 "Don't assign controlling tty. (not fcntl)")
636     (defconstant o_nonblock #o4 "Non-blocking I/O")
637     (defconstant o_append #o10 "Append flag.")
638     (defconstant o_ndelay o_nonblock)
639     (defconstant o_sync #o40000 "Synchronous writes (on ext2)")
640     (defconstant o_fsync o_sync)
641     (defconstant o_async #o20000 "Asynchronous I/O"))
642 dtc 1.1
643 dtc 1.2 (defconstant f-dupfd 0 "Duplicate a file descriptor")
644     (defconstant f-getfd 1 "Get file desc. flags")
645     (defconstant f-setfd 2 "Set file desc. flags")
646     (defconstant f-getfl 3 "Get file flags")
647     (defconstant f-setfl 4 "Set file flags")
648 pw 1.4
649     #-alpha
650     (progn
651     (defconstant f-getlk 5 "Get lock")
652     (defconstant f-setlk 6 "Set lock")
653     (defconstant f-setlkw 7 "Set lock, wait for release")
654     (defconstant f-setown 8 "Set owner (for sockets)")
655     (defconstant f-getown 9 "Get owner (for sockets)"))
656     #+alpha
657     (progn
658     (defconstant f-getlk 7 "Get lock")
659     (defconstant f-setlk 8 "Set lock")
660     (defconstant f-setlkw 9 "Set lock, wait for release")
661     (defconstant f-setown 5 "Set owner (for sockets)")
662     (defconstant f-getown 6 "Get owner (for sockets)"))
663    
664    
665 dtc 1.2
666     (defconstant F-CLOEXEC 1 "for f-getfl and f-setfl")
667    
668 pw 1.4 #-alpha
669     (progn
670     (defconstant F-RDLCK 0 "for fcntl and lockf")
671 toy 1.27 (defconstant F-WRLCK 1 "for fcntl and lockf")
672 pw 1.4 (defconstant F-UNLCK 2 "for fcntl and lockf")
673     (defconstant F-EXLCK 4 "old bsd flock (depricated)")
674     (defconstant F-SHLCK 8 "old bsd flock (depricated)"))
675     #+alpha
676     (progn
677     (defconstant F-RDLCK 1 "for fcntl and lockf")
678 toy 1.27 (defconstant F-WRLCK 2 "for fcntl and lockf")
679 pw 1.4 (defconstant F-UNLCK 8 "for fcntl and lockf")
680     (defconstant F-EXLCK 16 "old bsd flock (depricated)")
681     (defconstant F-SHLCK 32 "old bsd flock (depricated)"))
682 dtc 1.1
683 dtc 1.2 (defconstant F-LOCK-SH 1 "Shared lock for bsd flock")
684     (defconstant F-LOCK-EX 2 "Exclusive lock for bsd flock")
685     (defconstant F-LOCK-NB 4 "Don't block. Combine with F-LOCK-SH or F-LOCK-EX")
686     (defconstant F-LOCK-UN 8 "Remove lock for bsd flock")
687 dtc 1.1
688 dtc 1.2 (def-alien-type nil
689     (struct flock
690     (l-type short)
691     (l-whence short)
692     (l-start off-t)
693     (l-len off-t)
694     (l-pid pid-t)))
695 dtc 1.1
696 dtc 1.2 ;;; Define some more compatibility macros to be backward compatible with
697     ;;; BSD systems which did not managed to hide these kernel macros.
698 dtc 1.1
699 dtc 1.2 (defconstant FAPPEND o_append "depricated stuff")
700     (defconstant FFSYNC o_fsync "depricated stuff")
701     (defconstant FASYNC o_async "depricated stuff")
702     (defconstant FNONBLOCK o_nonblock "depricated stuff")
703     (defconstant FNDELAY o_ndelay "depricated stuff")
704 dtc 1.1
705    
706 dtc 1.2 ;;; grp.h
707 dtc 1.1
708 dtc 1.2 ;;; POSIX Standard: 9.2.1 Group Database Access <grp.h>
709 dtc 1.1
710 toy 1.28 #+(or)
711 dtc 1.2 (defun unix-setgrend ()
712     "Rewind the group-file stream."
713     (void-syscall ("setgrend")))
714 dtc 1.1
715 toy 1.28 #+(or)
716 dtc 1.2 (defun unix-endgrent ()
717     "Close the group-file stream."
718     (void-syscall ("endgrent")))
719 dtc 1.1
720 toy 1.28 #+(or)
721 dtc 1.2 (defun unix-getgrent ()
722     "Read an entry from the group-file stream, opening it if necessary."
723    
724     (let ((result (alien-funcall (extern-alien "getgrent"
725     (function (* (struct group)))))))
726     (declare (type system-area-pointer result))
727     (if (zerop (sap-int result))
728     nil
729     result)))
730 dtc 1.1
731 dtc 1.2 ;;; ioctl-types.h
732 dtc 1.1
733 dtc 1.2 (def-alien-type nil
734     (struct winsize
735     (ws-row unsigned-short) ; rows, in characters
736     (ws-col unsigned-short) ; columns, in characters
737     (ws-xpixel unsigned-short) ; horizontal size, pixels
738     (ws-ypixel unsigned-short))) ; veritical size, pixels
739 dtc 1.1
740 dtc 1.2 (defconstant +NCC+ 8
741     "Size of control character vector.")
742 dtc 1.1
743 dtc 1.2 (def-alien-type nil
744     (struct termio
745     (c-iflag unsigned-int) ; input mode flags
746     (c-oflag unsigned-int) ; output mode flags
747     (c-cflag unsigned-int) ; control mode flags
748     (c-lflag unsigned-int) ; local mode flags
749     (c-line unsigned-char) ; line discipline
750     (c-cc (array unsigned-char #.+NCC+)))) ; control characters
751 dtc 1.1
752 dtc 1.2 ;;; modem lines
753     (defconstant tiocm-le 1)
754     (defconstant tiocm-dtr 2)
755     (defconstant tiocm-rts 4)
756     (defconstant tiocm-st 8)
757     (defconstant tiocm-sr #x10)
758     (defconstant tiocm-cts #x20)
759     (defconstant tiocm-car #x40)
760     (defconstant tiocm-rng #x80)
761     (defconstant tiocm-dsr #x100)
762     (defconstant tiocm-cd tiocm-car)
763     (defconstant tiocm-ri #x80)
764 dtc 1.1
765 dtc 1.2 ;;; ioctl (fd, TIOCSERGETLSR, &result) where result may be as below
766 dtc 1.1
767 dtc 1.2 ;;; line disciplines
768     (defconstant N-TTY 0)
769     (defconstant N-SLIP 1)
770     (defconstant N-MOUSE 2)
771     (defconstant N-PPP 3)
772     (defconstant N-STRIP 4)
773     (defconstant N-AX25 5)
774    
775    
776     ;;; ioctls.h
777    
778     ;;; Routing table calls.
779     (defconstant siocaddrt #x890B) ;; add routing table entry
780     (defconstant siocdelrt #x890C) ;; delete routing table entry
781     (defconstant siocrtmsg #x890D) ;; call to routing system
782    
783     ;;; Socket configuration controls.
784     (defconstant siocgifname #x8910) ;; get iface name
785     (defconstant siocsiflink #x8911) ;; set iface channel
786     (defconstant siocgifconf #x8912) ;; get iface list
787     (defconstant siocgifflags #x8913) ;; get flags
788     (defconstant siocsifflags #x8914) ;; set flags
789     (defconstant siocgifaddr #x8915) ;; get PA address
790     (defconstant siocsifaddr #x8916) ;; set PA address
791     (defconstant siocgifdstaddr #x8917 ) ;; get remote PA address
792     (defconstant siocsifdstaddr #x8918 ) ;; set remote PA address
793     (defconstant siocgifbrdaddr #x8919 ) ;; get broadcast PA address
794     (defconstant siocsifbrdaddr #x891a ) ;; set broadcast PA address
795     (defconstant siocgifnetmask #x891b ) ;; get network PA mask
796     (defconstant siocsifnetmask #x891c ) ;; set network PA mask
797     (defconstant siocgifmetric #x891d ) ;; get metric
798     (defconstant siocsifmetric #x891e ) ;; set metric
799     (defconstant siocgifmem #x891f ) ;; get memory address (BSD)
800     (defconstant siocsifmem #x8920 ) ;; set memory address (BSD)
801     (defconstant siocgifmtu #x8921 ) ;; get MTU size
802     (defconstant siocsifmtu #x8922 ) ;; set MTU size
803     (defconstant siocsifhwaddr #x8924 ) ;; set hardware address
804     (defconstant siocgifencap #x8925 ) ;; get/set encapsulations
805     (defconstant siocsifencap #x8926)
806     (defconstant siocgifhwaddr #x8927 ) ;; Get hardware address
807     (defconstant siocgifslave #x8929 ) ;; Driver slaving support
808     (defconstant siocsifslave #x8930)
809     (defconstant siocaddmulti #x8931 ) ;; Multicast address lists
810     (defconstant siocdelmulti #x8932)
811     (defconstant siocgifindex #x8933 ) ;; name -> if_index mapping
812     (defconstant siogifindex SIOCGIFINDEX ) ;; misprint compatibility :-)
813     (defconstant siocsifpflags #x8934 ) ;; set/get extended flags set
814     (defconstant siocgifpflags #x8935)
815     (defconstant siocdifaddr #x8936 ) ;; delete PA address
816     (defconstant siocsifhwbroadcast #x8937 ) ;; set hardware broadcast addr
817     (defconstant siocgifcount #x8938 ) ;; get number of devices
818    
819     (defconstant siocgifbr #x8940 ) ;; Bridging support
820     (defconstant siocsifbr #x8941 ) ;; Set bridging options
821    
822     (defconstant siocgiftxqlen #x8942 ) ;; Get the tx queue length
823     (defconstant siocsiftxqlen #x8943 ) ;; Set the tx queue length
824    
825    
826     ;;; ARP cache control calls.
827     ;; 0x8950 - 0x8952 * obsolete calls, don't re-use
828     (defconstant siocdarp #x8953 ) ;; delete ARP table entry
829     (defconstant siocgarp #x8954 ) ;; get ARP table entry
830     (defconstant siocsarp #x8955 ) ;; set ARP table entry
831    
832     ;;; RARP cache control calls.
833     (defconstant siocdrarp #x8960 ) ;; delete RARP table entry
834     (defconstant siocgrarp #x8961 ) ;; get RARP table entry
835     (defconstant siocsrarp #x8962 ) ;; set RARP table entry
836    
837     ;;; Driver configuration calls
838    
839     (defconstant siocgifmap #x8970 ) ;; Get device parameters
840     (defconstant siocsifmap #x8971 ) ;; Set device parameters
841    
842     ;;; DLCI configuration calls
843    
844     (defconstant siocadddlci #x8980 ) ;; Create new DLCI device
845     (defconstant siocdeldlci #x8981 ) ;; Delete DLCI device
846    
847     ;;; Device private ioctl calls.
848    
849     ;; These 16 ioctls are available to devices via the do_ioctl() device
850     ;; vector. Each device should include this file and redefine these
851     ;; names as their own. Because these are device dependent it is a good
852     ;; idea _NOT_ to issue them to random objects and hope.
853 dtc 1.1
854 dtc 1.2 (defconstant siocdevprivate #x89F0 ) ;; to 89FF
855 dtc 1.1
856    
857 dtc 1.2 ;;; mathcalls.h
858 dtc 1.1
859 toy 1.28 #+(or)
860 dtc 1.2 (defmacro def-math-rtn (name num-args)
861     (let ((function (intern (concatenate 'simple-string
862     "%"
863     (string-upcase name)))))
864     `(progn
865 pw 1.15 (declaim (inline ,function))
866 dtc 1.2 (export ',function)
867     (alien:def-alien-routine (,name ,function) double-float
868     ,@(let ((results nil))
869     (dotimes (i num-args (nreverse results))
870     (push (list (intern (format nil "ARG-~D" i))
871     'double-float)
872     results)))))))
873 dtc 1.1
874 toy 1.28 #+(or)
875 dtc 1.2 (defmacro def-math-rtn-int-double (name num-args)
876     (let ((function (intern (concatenate 'simple-string
877     "%"
878     (string-upcase name)))))
879     `(progn
880 pw 1.15 (declaim (inline ,function))
881 dtc 1.2 (export ',function)
882     (alien:def-alien-routine (,name ,function) double-float
883     (ARG-1 'integer)
884     (ARG-2 'double)))))
885 dtc 1.1
886 toy 1.28 #+(or)
887 dtc 1.2 (def-math-rtn "expm1" 1) ;Return exp(X) - 1.
888 dtc 1.1
889 toy 1.28 #+(or)
890 dtc 1.2 (def-math-rtn "log1p" 1) ;Return log(1 + X).
891 dtc 1.1
892    
893 toy 1.28 #+(or)
894 dtc 1.2 (def-math-rtn "logb" 1) ;Return the base 2 signed integral exponent of X.
895 dtc 1.1
896 toy 1.28 #+(or)
897 dtc 1.2 (def-math-rtn "cbrt" 1) ; returns cuberoot
898 dtc 1.1
899 toy 1.28 #+(or)
900 dtc 1.2 (def-math-rtn "copysign" 2) ;Return X with its signed changed to Y's.
901 dtc 1.1
902 toy 1.28 #+(or)
903 dtc 1.2 (def-math-rtn "cabs" 2) ;Return `sqrt(X*X + Y*Y)'.
904 dtc 1.1
905 toy 1.28 #+(or)
906 dtc 1.2 (def-math-rtn "erf" 1)
907 dtc 1.1
908 toy 1.28 #+(or)
909 dtc 1.2 (def-math-rtn "erfc" 1)
910 dtc 1.1
911 toy 1.28 #+(or)
912 dtc 1.2 (def-math-rtn "gamma" 1)
913 dtc 1.1
914 toy 1.28 #+(or)
915 dtc 1.2 (def-math-rtn "j0" 1)
916 dtc 1.1
917 toy 1.28 #+(or)
918 dtc 1.2 (def-math-rtn "j1" 1)
919 dtc 1.1
920 toy 1.28 #+(or)
921 dtc 1.2 (def-math-rtn-int-double "jn")
922 dtc 1.1
923 toy 1.28 #+(or)
924 dtc 1.2 (def-math-rtn "lgamma" 1)
925 dtc 1.1
926 toy 1.28 #+(or)
927 dtc 1.2 (def-math-rtn "y0" 1)
928 dtc 1.1
929 toy 1.28 #+(or)
930 dtc 1.2 (def-math-rtn "y1" 1)
931 dtc 1.1
932 toy 1.28 #+(or)
933 dtc 1.2 (def-math-rtn-int-double "yn")
934 dtc 1.1
935 dtc 1.2 ;;; netdb.h
936 dtc 1.1
937 dtc 1.2 ;; All data returned by the network data base library are supplied in
938     ;; host order and returned in network order (suitable for use in
939     ;; system calls).
940    
941     ;;; Absolute file name for network data base files.
942     (defconstant path-hequiv "/etc/hosts.equiv")
943     (defconstant path-hosts "/etc/hosts")
944     (defconstant path-networks "/etc/networks")
945     (defconstant path-nsswitch_conf "/etc/nsswitch.conf")
946     (defconstant path-protocols "/etc/protocols")
947     (defconstant path-services "/etc/services")
948    
949    
950     ;;; Possible values left in `h_errno'.
951     (defconstant netdb-internal -1 "See errno.")
952     (defconstant netdb-success 0 "No problem.")
953     (defconstant host-not-found 1 "Authoritative Answer Host not found.")
954     (defconstant try-again 2 "Non-Authoritative Host not found,or SERVERFAIL.")
955     (defconstant no-recovery 3 "Non recoverable errors, FORMERR, REFUSED, NOTIMP.")
956     (defconstant no-data 4 "Valid name, no data record of requested type.")
957     (defconstant no-address no-data "No address, look for MX record.")
958 dtc 1.1
959 dtc 1.2 ;;; Description of data base entry for a single host.
960 dtc 1.1
961 dtc 1.2 (def-alien-type nil
962     (struct hostent
963     (h-name c-string) ; Official name of host.
964     (h-aliases (* c-string)) ; Alias list.
965     (h-addrtype int) ; Host address type.
966     (h_length int) ; Length of address.
967     (h-addr-list (* c-string)))) ; List of addresses from name server.
968 dtc 1.1
969 toy 1.28 #+(or)
970 dtc 1.2 (defun unix-sethostent (stay-open)
971     "Open host data base files and mark them as staying open even after
972     a later search if STAY_OPEN is non-zero."
973     (void-syscall ("sethostent" int) stay-open))
974 dtc 1.1
975 toy 1.28 #+(or)
976 dtc 1.2 (defun unix-endhostent ()
977     "Close host data base files and clear `stay open' flag."
978     (void-syscall ("endhostent")))
979 dtc 1.1
980 toy 1.28 #+(or)
981 dtc 1.2 (defun unix-gethostent ()
982     "Get next entry from host data base file. Open data base if
983     necessary."
984     (let ((result (alien-funcall (extern-alien "gethostent"
985     (function (* (struct hostent)))))))
986     (declare (type system-area-pointer result))
987     (if (zerop (sap-int result))
988     nil
989     result)))
990 dtc 1.1
991 toy 1.28 #+(or)
992 dtc 1.2 (defun unix-gethostbyaddr(addr length type)
993     "Return entry from host data base which address match ADDR with
994     length LEN and type TYPE."
995     (let ((result (alien-funcall (extern-alien "gethostbyaddr"
996     (function (* (struct hostent))
997     c-string int int))
998     addr len type)))
999     (declare (type system-area-pointer result))
1000     (if (zerop (sap-int result))
1001     nil
1002     result)))
1003 dtc 1.1
1004 toy 1.28 #+(or)
1005 dtc 1.2 (defun unix-gethostbyname (name)
1006     "Return entry from host data base for host with NAME."
1007     (let ((result (alien-funcall (extern-alien "gethostbyname"
1008     (function (* (struct hostent))
1009     c-string))
1010     name)))
1011     (declare (type system-area-pointer result))
1012     (if (zerop (sap-int result))
1013     nil
1014     result)))
1015 dtc 1.1
1016 toy 1.28 #+(or)
1017 dtc 1.2 (defun unix-gethostbyname2 (name af)
1018     "Return entry from host data base for host with NAME. AF must be
1019     set to the address type which as `AF_INET' for IPv4 or `AF_INET6'
1020     for IPv6."
1021     (let ((result (alien-funcall (extern-alien "gethostbyname2"
1022     (function (* (struct hostent))
1023     c-string int))
1024     name af)))
1025     (declare (type system-area-pointer result))
1026     (if (zerop (sap-int result))
1027     nil
1028     result)))
1029 dtc 1.1
1030 dtc 1.2 ;; Description of data base entry for a single network. NOTE: here a
1031     ;; poor assumption is made. The network number is expected to fit
1032     ;; into an unsigned long int variable.
1033 dtc 1.1
1034 dtc 1.2 (def-alien-type nil
1035     (struct netent
1036     (n-name c-string) ; Official name of network.
1037     (n-aliases (* c-string)) ; Alias list.
1038     (n-addrtype int) ; Net address type.
1039     (n-net unsigned-long))) ; Network number.
1040 dtc 1.1
1041 toy 1.28 #+(or)
1042 dtc 1.2 (defun unix-setnetent (stay-open)
1043     "Open network data base files and mark them as staying open even
1044     after a later search if STAY_OPEN is non-zero."
1045     (void-syscall ("setnetent" int) stay-open))
1046 dtc 1.1
1047    
1048 toy 1.28 #+(or)
1049 dtc 1.2 (defun unix-endnetent ()
1050     "Close network data base files and clear `stay open' flag."
1051     (void-syscall ("endnetent")))
1052 dtc 1.1
1053    
1054 toy 1.28 #+(or)
1055 dtc 1.2 (defun unix-getnetent ()
1056     "Get next entry from network data base file. Open data base if
1057     necessary."
1058     (let ((result (alien-funcall (extern-alien "getnetent"
1059     (function (* (struct netent)))))))
1060     (declare (type system-area-pointer result))
1061     (if (zerop (sap-int result))
1062     nil
1063     result)))
1064 dtc 1.1
1065    
1066 toy 1.28 #+(or)
1067 dtc 1.2 (defun unix-getnetbyaddr (net type)
1068     "Return entry from network data base which address match NET and
1069     type TYPE."
1070     (let ((result (alien-funcall (extern-alien "getnetbyaddr"
1071     (function (* (struct netent))
1072     unsigned-long int))
1073     net type)))
1074     (declare (type system-area-pointer result))
1075     (if (zerop (sap-int result))
1076     nil
1077     result)))
1078 dtc 1.1
1079 toy 1.28 #+(or)
1080 dtc 1.2 (defun unix-getnetbyname (name)
1081     "Return entry from network data base for network with NAME."
1082     (let ((result (alien-funcall (extern-alien "getnetbyname"
1083     (function (* (struct netent))
1084     c-string))
1085     name)))
1086     (declare (type system-area-pointer result))
1087     (if (zerop (sap-int result))
1088     nil
1089     result)))
1090 dtc 1.1
1091 dtc 1.2 ;; Description of data base entry for a single service.
1092     (def-alien-type nil
1093     (struct servent
1094     (s-name c-string) ; Official service name.
1095     (s-aliases (* c-string)) ; Alias list.
1096     (s-port int) ; Port number.
1097     (s-proto c-string))) ; Protocol to use.
1098 dtc 1.1
1099 toy 1.28 #+(or)
1100 dtc 1.2 (defun unix-setservent (stay-open)
1101     "Open service data base files and mark them as staying open even
1102     after a later search if STAY_OPEN is non-zero."
1103     (void-syscall ("setservent" int) stay-open))
1104 dtc 1.1
1105 toy 1.28 #+(or)
1106 dtc 1.2 (defun unix-endservent (stay-open)
1107     "Close service data base files and clear `stay open' flag."
1108     (void-syscall ("endservent")))
1109 dtc 1.1
1110    
1111 toy 1.28 #+(or)
1112 dtc 1.2 (defun unix-getservent ()
1113     "Get next entry from service data base file. Open data base if
1114     necessary."
1115     (let ((result (alien-funcall (extern-alien "getservent"
1116     (function (* (struct servent)))))))
1117     (declare (type system-area-pointer result))
1118     (if (zerop (sap-int result))
1119     nil
1120     result)))
1121 dtc 1.1
1122 toy 1.28 #+(or)
1123 dtc 1.2 (defun unix-getservbyname (name proto)
1124     "Return entry from network data base for network with NAME and
1125     protocol PROTO."
1126     (let ((result (alien-funcall (extern-alien "getservbyname"
1127     (function (* (struct netent))
1128     c-string (* char)))
1129     name proto)))
1130     (declare (type system-area-pointer result))
1131     (if (zerop (sap-int result))
1132     nil
1133     result)))
1134 dtc 1.1
1135 toy 1.28 #+(or)
1136 dtc 1.2 (defun unix-getservbyport (port proto)
1137     "Return entry from service data base which matches port PORT and
1138     protocol PROTO."
1139     (let ((result (alien-funcall (extern-alien "getservbyport"
1140     (function (* (struct netent))
1141     int (* char)))
1142     port proto)))
1143     (declare (type system-area-pointer result))
1144     (if (zerop (sap-int result))
1145     nil
1146     result)))
1147 dtc 1.1
1148 dtc 1.2 ;; Description of data base entry for a single service.
1149 dtc 1.1
1150 dtc 1.2 (def-alien-type nil
1151     (struct protoent
1152     (p-name c-string) ; Official protocol name.
1153     (p-aliases (* c-string)) ; Alias list.
1154     (p-proto int))) ; Protocol number.
1155 dtc 1.1
1156 toy 1.28 #+(or)
1157 dtc 1.2 (defun unix-setprotoent (stay-open)
1158     "Open protocol data base files and mark them as staying open even
1159     after a later search if STAY_OPEN is non-zero."
1160     (void-syscall ("setprotoent" int) stay-open))
1161 dtc 1.1
1162 toy 1.28 #+(or)
1163 dtc 1.2 (defun unix-endprotoent ()
1164     "Close protocol data base files and clear `stay open' flag."
1165     (void-syscall ("endprotoent")))
1166 dtc 1.1
1167 toy 1.28 #+(or)
1168 dtc 1.2 (defun unix-getprotoent ()
1169     "Get next entry from protocol data base file. Open data base if
1170     necessary."
1171     (let ((result (alien-funcall (extern-alien "getprotoent"
1172     (function (* (struct protoent)))))))
1173     (declare (type system-area-pointer result))
1174     (if (zerop (sap-int result))
1175     nil
1176     result)))
1177 dtc 1.1
1178 toy 1.28 #+(or)
1179 dtc 1.2 (defun unix-getprotobyname (name)
1180     "Return entry from protocol data base for network with NAME."
1181     (let ((result (alien-funcall (extern-alien "getprotobyname"
1182     (function (* (struct protoent))
1183     c-string))
1184     name)))
1185     (declare (type system-area-pointer result))
1186     (if (zerop (sap-int result))
1187     nil
1188     result)))
1189 dtc 1.1
1190 toy 1.28 #+(or)
1191 dtc 1.2 (defun unix-getprotobynumber (proto)
1192     "Return entry from protocol data base which number is PROTO."
1193     (let ((result (alien-funcall (extern-alien "getprotobynumber"
1194     (function (* (struct protoent))
1195     int))
1196     proto)))
1197     (declare (type system-area-pointer result))
1198     (if (zerop (sap-int result))
1199     nil
1200     result)))
1201 dtc 1.1
1202 toy 1.28 #+(or)
1203 dtc 1.2 (defun unix-setnetgrent (netgroup)
1204     "Establish network group NETGROUP for enumeration."
1205     (int-syscall ("setservent" c-string) netgroup))
1206 dtc 1.1
1207 toy 1.28 #+(or)
1208 dtc 1.2 (defun unix-endnetgrent ()
1209     "Free all space allocated by previous `setnetgrent' call."
1210     (void-syscall ("endnetgrent")))
1211 dtc 1.1
1212 toy 1.28 #+(or)
1213 dtc 1.2 (defun unix-getnetgrent (hostp userp domainp)
1214     "Get next member of netgroup established by last `setnetgrent' call
1215     and return pointers to elements in HOSTP, USERP, and DOMAINP."
1216     (int-syscall ("getnetgrent" (* c-string) (* c-string) (* c-string))
1217     hostp userp domainp))
1218 dtc 1.1
1219 toy 1.28 #+(or)
1220 dtc 1.2 (defun unix-innetgr (netgroup host user domain)
1221     "Test whether NETGROUP contains the triple (HOST,USER,DOMAIN)."
1222     (int-syscall ("innetgr" c-string c-string c-string c-string)
1223     netgroup host user domain))
1224 dtc 1.1
1225 dtc 1.2 (def-alien-type nil
1226     (struct addrinfo
1227     (ai-flags int) ; Input flags.
1228     (ai-family int) ; Protocol family for socket.
1229     (ai-socktype int) ; Socket type.
1230     (ai-protocol int) ; Protocol for socket.
1231     (ai-addrlen int) ; Length of socket address.
1232     (ai-addr (* (struct sockaddr)))
1233     ; Socket address for socket.
1234     (ai-cononname c-string)
1235     ; Canonical name for service location.
1236     (ai-net (* (struct addrinfo))))) ; Pointer to next in list.
1237    
1238     ;; Possible values for `ai_flags' field in `addrinfo' structure.
1239    
1240     (defconstant ai_passive 1 "Socket address is intended for `bind'.")
1241     (defconstant ai_canonname 2 "Request for canonical name.")
1242    
1243     ;; Error values for `getaddrinfo' function.
1244     (defconstant eai_badflags -1 "Invalid value for `ai_flags' field.")
1245     (defconstant eai_noname -2 "NAME or SERVICE is unknown.")
1246     (defconstant eai_again -3 "Temporary failure in name resolution.")
1247     (defconstant eai_fail -4 "Non-recoverable failure in name res.")
1248     (defconstant eai_nodata -5 "No address associated with NAME.")
1249     (defconstant eai_family -6 "ai_family not supported.")
1250     (defconstant eai_socktype -7 "ai_socktype not supported.")
1251     (defconstant eai_service -8 "SERVICE not supported for ai_socktype.")
1252     (defconstant eai_addrfamily -9 "Address family for NAME not supported.")
1253     (defconstant eai_memory -10 "Memory allocation failure.")
1254     (defconstant eai_system -11 "System error returned in errno.")
1255 dtc 1.1
1256    
1257 toy 1.28 #+(or)
1258 dtc 1.2 (defun unix-getaddrinfo (name service req pai)
1259     "Translate name of a service location and/or a service name to set of
1260     socket addresses."
1261     (int-syscall ("getaddrinfo" c-string c-string (* (struct addrinfo))
1262     (* (* struct addrinfo)))
1263     name service req pai))
1264 dtc 1.1
1265    
1266 toy 1.28 #+(or)
1267 dtc 1.2 (defun unix-freeaddrinfo (ai)
1268     "Free `addrinfo' structure AI including associated storage."
1269     (void-syscall ("freeaddrinfo" (* struct addrinfo))
1270     ai))
1271 dtc 1.1
1272    
1273 dtc 1.2 ;;; pty.h
1274 dtc 1.1
1275 rtoy 1.45 (defun unix-openpty (name termp winp)
1276 dtc 1.2 "Create pseudo tty master slave pair with NAME and set terminal
1277     attributes according to TERMP and WINP and return handles for both
1278     ends in AMASTER and ASLAVE."
1279 rtoy 1.45 (with-alien ((amaster int)
1280     (aslave int))
1281     (values
1282     (int-syscall ("openpty" (* int) (* int) c-string (* (struct termios))
1283     (* (struct winsize)))
1284     (addr amaster) (addr aslave) name termp winp)
1285     amaster aslave)))
1286 dtc 1.1
1287 toy 1.28 #+(or)
1288 dtc 1.2 (defun unix-forkpty (amaster name termp winp)
1289     "Create child process and establish the slave pseudo terminal as the
1290     child's controlling terminal."
1291     (int-syscall ("forkpty" (* int) c-string (* (struct termios))
1292     (* (struct winsize)))
1293     amaster name termp winp))
1294 dtc 1.1
1295 toy 1.17
1296 dtc 1.2 ;; POSIX Standard: 9.2.2 User Database Access <pwd.h>
1297 dtc 1.1
1298 toy 1.28 #+(or)
1299 dtc 1.2 (defun unix-setpwent ()
1300     "Rewind the password-file stream."
1301     (void-syscall ("setpwent")))
1302 dtc 1.1
1303 toy 1.28 #+(or)
1304 dtc 1.2 (defun unix-endpwent ()
1305     "Close the password-file stream."
1306     (void-syscall ("endpwent")))
1307 dtc 1.1
1308 toy 1.28 #+(or)
1309 dtc 1.2 (defun unix-getpwent ()
1310     "Read an entry from the password-file stream, opening it if necessary."
1311     (let ((result (alien-funcall (extern-alien "getpwent"
1312     (function (* (struct passwd)))))))
1313     (declare (type system-area-pointer result))
1314     (if (zerop (sap-int result))
1315     nil
1316 dtc 1.7 result)))
1317 dtc 1.1
1318 dtc 1.2 ;;; resourcebits.h
1319 dtc 1.1
1320 dtc 1.2 (def-alien-type nil
1321     (struct rlimit
1322     (rlim-cur long) ; current (soft) limit
1323     (rlim-max long))); maximum value for rlim-cur
1324 dtc 1.1
1325 dtc 1.2 (defconstant rusage_self 0 "The calling process.")
1326     (defconstant rusage_children -1 "Terminated child processes.")
1327     (defconstant rusage_both -2)
1328 dtc 1.1
1329 dtc 1.2 (def-alien-type nil
1330     (struct rusage
1331     (ru-utime (struct timeval)) ; user time used
1332     (ru-stime (struct timeval)) ; system time used.
1333     (ru-maxrss long) ; Maximum resident set size (in kilobytes)
1334     (ru-ixrss long) ; integral shared memory size
1335     (ru-idrss long) ; integral unshared data "
1336     (ru-isrss long) ; integral unshared stack "
1337     (ru-minflt long) ; page reclaims
1338     (ru-majflt long) ; page faults
1339     (ru-nswap long) ; swaps
1340     (ru-inblock long) ; block input operations
1341     (ru-oublock long) ; block output operations
1342     (ru-msgsnd long) ; messages sent
1343     (ru-msgrcv long) ; messages received
1344     (ru-nsignals long) ; signals received
1345     (ru-nvcsw long) ; voluntary context switches
1346     (ru-nivcsw long))) ; involuntary "
1347 dtc 1.1
1348 dtc 1.2 ;; Priority limits.
1349 dtc 1.1
1350 dtc 1.2 (defconstant prio-min -20 "Minimum priority a process can have")
1351     (defconstant prio-max 20 "Maximum priority a process can have")
1352 dtc 1.1
1353    
1354 dtc 1.2 ;;; The type of the WHICH argument to `getpriority' and `setpriority',
1355     ;;; indicating what flavor of entity the WHO argument specifies.
1356 dtc 1.1
1357 dtc 1.2 (defconstant priority-process 0 "WHO is a process ID")
1358     (defconstant priority-pgrp 1 "WHO is a process group ID")
1359     (defconstant priority-user 2 "WHO is a user ID")
1360 dtc 1.1
1361 dtc 1.2 ;;; sched.h
1362 dtc 1.1
1363 toy 1.28 #+(or)
1364 dtc 1.2 (defun unix-sched_setparam (pid param)
1365     "Rewind the password-file stream."
1366     (int-syscall ("sched_setparam" pid-t (struct psched-param))
1367     pid param))
1368 dtc 1.1
1369 toy 1.28 #+(or)
1370 dtc 1.2 (defun unix-sched_getparam (pid param)
1371     "Rewind the password-file stream."
1372     (int-syscall ("sched_getparam" pid-t (struct psched-param))
1373     pid param))
1374 dtc 1.1
1375    
1376 toy 1.28 #+(or)
1377 dtc 1.2 (defun unix-sched_setscheduler (pid policy param)
1378     "Set scheduling algorithm and/or parameters for a process."
1379     (int-syscall ("sched_setscheduler" pid-t int (struct psched-param))
1380     pid policy param))
1381 dtc 1.1
1382 toy 1.28 #+(or)
1383 dtc 1.2 (defun unix-sched_getscheduler (pid)
1384     "Retrieve scheduling algorithm for a particular purpose."
1385     (int-syscall ("sched_getscheduler" pid-t)
1386     pid))
1387 dtc 1.1
1388 dtc 1.8 (defun unix-sched-yield ()
1389 dtc 1.2 "Retrieve scheduling algorithm for a particular purpose."
1390     (int-syscall ("sched_yield")))
1391 dtc 1.1
1392 toy 1.28 #+(or)
1393 dtc 1.2 (defun unix-sched_get_priority_max (algorithm)
1394     "Get maximum priority value for a scheduler."
1395     (int-syscall ("sched_get_priority_max" int)
1396     algorithm))
1397 dtc 1.1
1398 toy 1.28 #+(or)
1399 dtc 1.2 (defun unix-sched_get_priority_min (algorithm)
1400     "Get minimum priority value for a scheduler."
1401     (int-syscall ("sched_get_priority_min" int)
1402     algorithm))
1403 dtc 1.1
1404    
1405    
1406 toy 1.28 #+(or)
1407 dtc 1.2 (defun unix-sched_rr_get_interval (pid t)
1408     "Get the SCHED_RR interval for the named process."
1409     (int-syscall ("sched_rr_get_interval" pid-t (* (struct timespec)))
1410     pid t))
1411 dtc 1.1
1412 dtc 1.2 ;;; schedbits.h
1413 dtc 1.1
1414 dtc 1.2 (defconstant scheduler-other 0)
1415     (defconstant scheduler-fifo 1)
1416     (defconstant scheduler-rr 2)
1417 dtc 1.1
1418    
1419 dtc 1.2 ;; Data structure to describe a process' schedulability.
1420 dtc 1.1
1421 dtc 1.2 (def-alien-type nil
1422     (struct sched_param
1423     (sched-priority int)))
1424 dtc 1.1
1425 dtc 1.2 ;; Cloning flags.
1426     (defconstant csignal #x000000ff "Signal mask to be sent at exit.")
1427     (defconstant clone_vm #x00000100 "Set if VM shared between processes.")
1428     (defconstant clone_fs #x00000200 "Set if fs info shared between processes")
1429     (defconstant clone_files #x00000400 "Set if open files shared between processe")
1430     (defconstant clone_sighand #x00000800 "Set if signal handlers shared.")
1431     (defconstant clone_pid #x00001000 "Set if pid shared.")
1432 dtc 1.1
1433    
1434 dtc 1.2 ;;; shadow.h
1435 dtc 1.1
1436 dtc 1.2 ;; Structure of the password file.
1437 dtc 1.1
1438 dtc 1.2 (def-alien-type nil
1439     (struct spwd
1440     (sp-namp c-string) ; Login name.
1441     (sp-pwdp c-string) ; Encrypted password.
1442     (sp-lstchg long) ; Date of last change.
1443     (sp-min long) ; Minimum number of days between changes.
1444     (sp-max long) ; Maximum number of days between changes.
1445     (sp-warn long) ; Number of days to warn user to change the password.
1446     (sp-inact long) ; Number of days the account may be inactive.
1447     (sp-expire long) ; Number of days since 1970-01-01 until account expires.
1448     (sp-flags long))) ; Reserved.
1449 dtc 1.1
1450 toy 1.28 #+(or)
1451 dtc 1.2 (defun unix-setspent ()
1452     "Open database for reading."
1453     (void-syscall ("setspent")))
1454 dtc 1.1
1455 toy 1.28 #+(or)
1456 dtc 1.2 (defun unix-endspent ()
1457     "Close database."
1458     (void-syscall ("endspent")))
1459 dtc 1.1
1460 toy 1.28 #+(or)
1461 dtc 1.2 (defun unix-getspent ()
1462     "Get next entry from database, perhaps after opening the file."
1463     (let ((result (alien-funcall (extern-alien "getspent"
1464     (function (* (struct spwd)))))))
1465     (declare (type system-area-pointer result))
1466     (if (zerop (sap-int result))
1467     nil
1468     result)))
1469 dtc 1.1
1470 toy 1.28 #+(or)
1471 dtc 1.2 (defun unix-getspnam (name)
1472     "Get shadow entry matching NAME."
1473     (let ((result (alien-funcall (extern-alien "getspnam"
1474     (function (* (struct spwd))
1475     c-string))
1476     name)))
1477     (declare (type system-area-pointer result))
1478     (if (zerop (sap-int result))
1479     nil
1480     result)))
1481 dtc 1.1
1482 toy 1.28 #+(or)
1483 dtc 1.2 (defun unix-sgetspent (string)
1484     "Read shadow entry from STRING."
1485     (let ((result (alien-funcall (extern-alien "sgetspent"
1486     (function (* (struct spwd))
1487     c-string))
1488     string)))
1489     (declare (type system-area-pointer result))
1490     (if (zerop (sap-int result))
1491     nil
1492     result)))
1493 dtc 1.1
1494 dtc 1.2 ;;
1495 dtc 1.1
1496 toy 1.28 #+(or)
1497 dtc 1.2 (defun unix-lckpwdf ()
1498     "Protect password file against multi writers."
1499     (void-syscall ("lckpwdf")))
1500 dtc 1.1
1501    
1502 toy 1.28 #+(or)
1503 dtc 1.2 (defun unix-ulckpwdf ()
1504     "Unlock password file."
1505     (void-syscall ("ulckpwdf")))
1506 dtc 1.1
1507 toy 1.18 ;;; bits/stat.h
1508 dtc 1.1
1509 dtc 1.2 (def-alien-type nil
1510     (struct stat
1511     (st-dev dev-t)
1512 cwang 1.31 #-(or alpha amd64) (st-pad1 unsigned-short)
1513 dtc 1.2 (st-ino ino-t)
1514 toy 1.18 #+alpha (st-pad1 unsigned-int)
1515 cwang 1.31 #-amd64 (st-mode mode-t)
1516 dtc 1.2 (st-nlink nlink-t)
1517 cwang 1.31 #+amd64 (st-mode mode-t)
1518 dtc 1.2 (st-uid uid-t)
1519     (st-gid gid-t)
1520     (st-rdev dev-t)
1521 pw 1.4 #-alpha (st-pad2 unsigned-short)
1522 dtc 1.2 (st-size off-t)
1523 pw 1.4 #-alpha (st-blksize unsigned-long)
1524 emarsden 1.21 #-alpha (st-blocks blkcnt-t)
1525 dtc 1.2 (st-atime time-t)
1526 pw 1.4 #-alpha (unused-1 unsigned-long)
1527 dtc 1.2 (st-mtime time-t)
1528 pw 1.4 #-alpha (unused-2 unsigned-long)
1529 dtc 1.2 (st-ctime time-t)
1530 toy 1.18 #+alpha (st-blocks int)
1531     #+alpha (st-pad2 unsigned-int)
1532 pw 1.4 #+alpha (st-blksize unsigned-int)
1533     #+alpha (st-flags unsigned-int)
1534     #+alpha (st-gen unsigned-int)
1535 toy 1.18 #+alpha (st-pad3 unsigned-int)
1536     #+alpha (unused-1 unsigned-long)
1537     #+alpha (unused-2 unsigned-long)
1538     (unused-3 unsigned-long)
1539     (unused-4 unsigned-long)
1540 pw 1.4 #-alpha (unused-5 unsigned-long)))
1541 dtc 1.2
1542     ;; Encoding of the file mode.
1543    
1544     (defconstant s-ifmt #o0170000 "These bits determine file type.")
1545    
1546     ;; File types.
1547    
1548     (defconstant s-ififo #o0010000 "FIFO")
1549     (defconstant s-ifchr #o0020000 "Character device")
1550     (defconstant s-ifdir #o0040000 "Directory")
1551     (defconstant s-ifblk #o0060000 "Block device")
1552     (defconstant s-ifreg #o0100000 "Regular file")
1553    
1554     ;; These don't actually exist on System V, but having them doesn't hurt.
1555    
1556     (defconstant s-iflnk #o0120000 "Symbolic link.")
1557     (defconstant s-ifsock #o0140000 "Socket.")
1558    
1559     ;; Protection bits.
1560 dtc 1.1
1561 dtc 1.2 (defconstant s-isuid #o0004000 "Set user ID on execution.")
1562     (defconstant s-isgid #o0002000 "Set group ID on execution.")
1563     (defconstant s-isvtx #o0001000 "Save swapped text after use (sticky).")
1564     (defconstant s-iread #o0000400 "Read by owner")
1565     (defconstant s-iwrite #o0000200 "Write by owner.")
1566     (defconstant s-iexec #o0000100 "Execute by owner.")
1567 dtc 1.1
1568 dtc 1.2 ;;; statfsbuf.h
1569 dtc 1.1
1570 dtc 1.2 (def-alien-type nil
1571     (struct statfs
1572     (f-type int)
1573     (f-bsize int)
1574 emarsden 1.21 (f-blocks fsblkcnt-t)
1575     (f-bfree fsblkcnt-t)
1576     (f-bavail fsblkcnt-t)
1577     (f-files fsfilcnt-t)
1578     (f-ffree fsfilcnt-t)
1579 dtc 1.2 (f-fsid fsid-t)
1580     (f-namelen int)
1581     (f-spare (array int 6))))
1582    
1583    
1584     ;;; termbits.h
1585    
1586     (def-alien-type cc-t unsigned-char)
1587     (def-alien-type speed-t unsigned-int)
1588     (def-alien-type tcflag-t unsigned-int)
1589 dtc 1.1
1590 dtc 1.2 (defconstant +NCCS+ 32
1591     "Size of control character vector.")
1592 dtc 1.1
1593 dtc 1.2 (def-alien-type nil
1594     (struct termios
1595     (c-iflag tcflag-t)
1596     (c-oflag tcflag-t)
1597     (c-cflag tcflag-t)
1598     (c-lflag tcflag-t)
1599     (c-line cc-t)
1600     (c-cc (array cc-t #.+NCCS+))
1601     (c-ispeed speed-t)
1602     (c-ospeed speed-t)))
1603    
1604     ;; c_cc characters
1605    
1606     (def-enum + 0 vintr vquit verase
1607     vkill veof vtime
1608     vmin vswtc vstart
1609     vstop vsusp veol
1610     vreprint vdiscard vwerase
1611     vlnext veol2)
1612     (defvar vdsusp vsusp)
1613 dtc 1.1
1614 dtc 1.2 (def-enum + 0 tciflush tcoflush tcioflush)
1615 dtc 1.1
1616 dtc 1.2 (def-enum + 0 tcsanow tcsadrain tcsaflush)
1617 dtc 1.1
1618 dtc 1.2 ;; c_iflag bits
1619     (def-enum ash 1 tty-ignbrk tty-brkint tty-ignpar tty-parmrk tty-inpck
1620     tty-istrip tty-inlcr tty-igncr tty-icrnl tty-iuclc
1621     tty-ixon tty-ixany tty-ixoff
1622     tty-imaxbel)
1623 dtc 1.1
1624 dtc 1.2 ;; c_oflag bits
1625     (def-enum ash 1 tty-opost tty-olcuc tty-onlcr tty-ocrnl tty-onocr
1626     tty-onlret tty-ofill tty-ofdel tty-nldly)
1627 dtc 1.1
1628 dtc 1.2 (defconstant tty-nl0 0)
1629     (defconstant tty-nl1 #o400)
1630 dtc 1.1
1631 dtc 1.2 (defconstant tty-crdly #o0003000)
1632     (defconstant tty-cr0 #o0000000)
1633     (defconstant tty-cr1 #o0001000)
1634     (defconstant tty-cr2 #o0002000)
1635     (defconstant tty-cr3 #o0003000)
1636     (defconstant tty-tabdly #o0014000)
1637     (defconstant tty-tab0 #o0000000)
1638     (defconstant tty-tab1 #o0004000)
1639     (defconstant tty-tab2 #o0010000)
1640     (defconstant tty-tab3 #o0014000)
1641     (defconstant tty-xtabs #o0014000)
1642     (defconstant tty-bsdly #o0020000)
1643     (defconstant tty-bs0 #o0000000)
1644     (defconstant tty-bs1 #o0020000)
1645     (defconstant tty-vtdly #o0040000)
1646     (defconstant tty-vt0 #o0000000)
1647     (defconstant tty-vt1 #o0040000)
1648     (defconstant tty-ffdly #o0100000)
1649     (defconstant tty-ff0 #o0000000)
1650     (defconstant tty-ff1 #o0100000)
1651    
1652     ;; c-cflag bit meaning
1653     (defconstant tty-cbaud #o0010017)
1654     (defconstant tty-b0 #o0000000) ;; hang up
1655     (defconstant tty-b50 #o0000001)
1656     (defconstant tty-b75 #o0000002)
1657     (defconstant tty-b110 #o0000003)
1658     (defconstant tty-b134 #o0000004)
1659     (defconstant tty-b150 #o0000005)
1660     (defconstant tty-b200 #o0000006)
1661     (defconstant tty-b300 #o0000007)
1662     (defconstant tty-b600 #o0000010)
1663     (defconstant tty-b1200 #o0000011)
1664     (defconstant tty-b1800 #o0000012)
1665     (defconstant tty-b2400 #o0000013)
1666     (defconstant tty-b4800 #o0000014)
1667     (defconstant tty-b9600 #o0000015)
1668     (defconstant tty-b19200 #o0000016)
1669     (defconstant tty-b38400 #o0000017)
1670     (defconstant tty-exta tty-b19200)
1671     (defconstant tty-extb tty-b38400)
1672     (defconstant tty-csize #o0000060)
1673     (defconstant tty-cs5 #o0000000)
1674     (defconstant tty-cs6 #o0000020)
1675     (defconstant tty-cs7 #o0000040)
1676     (defconstant tty-cs8 #o0000060)
1677     (defconstant tty-cstopb #o0000100)
1678     (defconstant tty-cread #o0000200)
1679     (defconstant tty-parenb #o0000400)
1680     (defconstant tty-parodd #o0001000)
1681     (defconstant tty-hupcl #o0002000)
1682     (defconstant tty-clocal #o0004000)
1683     (defconstant tty-cbaudex #o0010000)
1684     (defconstant tty-b57600 #o0010001)
1685     (defconstant tty-b115200 #o0010002)
1686     (defconstant tty-b230400 #o0010003)
1687     (defconstant tty-b460800 #o0010004)
1688     (defconstant tty-cibaud #o002003600000) ; input baud rate (not used)
1689     (defconstant tty-crtscts #o020000000000) ;flow control
1690 dtc 1.1
1691 dtc 1.2 ;; c_lflag bits
1692     (def-enum ash 1 tty-isig tty-icanon tty-xcase tty-echo tty-echoe
1693     tty-echok tty-echonl tty-noflsh
1694     tty-tostop tty-echoctl tty-echoprt
1695     tty-echoke tty-flusho
1696     tty-pendin tty-iexten)
1697 dtc 1.1
1698 dtc 1.2 ;;; tcflow() and TCXONC use these
1699     (def-enum + 0 tty-tcooff tty-tcoon tty-tcioff tty-tcion)
1700 dtc 1.1
1701 dtc 1.2 ;; tcflush() and TCFLSH use these */
1702     (def-enum + 0 tty-tciflush tty-tcoflush tty-tcioflush)
1703 dtc 1.1
1704 dtc 1.2 ;; tcsetattr uses these
1705     (def-enum + 0 tty-tcsanow tty-tcsadrain tty-tcsaflush)
1706 dtc 1.1
1707 dtc 1.2 ;;; termios.h
1708 dtc 1.1
1709 dtc 1.2 (defun unix-cfgetospeed (termios)
1710     "Get terminal output speed."
1711     (multiple-value-bind (speed errno)
1712     (int-syscall ("cfgetospeed" (* (struct termios))) termios)
1713     (if speed
1714     (values (svref terminal-speeds speed) 0)
1715     (values speed errno))))
1716 dtc 1.1
1717 dtc 1.2 (defun unix-cfsetospeed (termios speed)
1718     "Set terminal output speed."
1719     (let ((baud (or (position speed terminal-speeds)
1720     (error "Bogus baud rate ~S" speed))))
1721     (void-syscall ("cfsetospeed" (* (struct termios)) int) termios baud)))
1722 dtc 1.1
1723 dtc 1.2 (defun unix-cfgetispeed (termios)
1724     "Get terminal input speed."
1725     (multiple-value-bind (speed errno)
1726     (int-syscall ("cfgetispeed" (* (struct termios))) termios)
1727     (if speed
1728     (values (svref terminal-speeds speed) 0)
1729     (values speed errno))))
1730 dtc 1.1
1731 dtc 1.2 (defun unix-cfsetispeed (termios speed)
1732     "Set terminal input speed."
1733     (let ((baud (or (position speed terminal-speeds)
1734     (error "Bogus baud rate ~S" speed))))
1735     (void-syscall ("cfsetispeed" (* (struct termios)) int) termios baud)))
1736 dtc 1.1
1737 dtc 1.2 (defun unix-tcgetattr (fd termios)
1738     "Get terminal attributes."
1739     (declare (type unix-fd fd))
1740     (void-syscall ("tcgetattr" int (* (struct termios))) fd termios))
1741 dtc 1.1
1742 dtc 1.2 (defun unix-tcsetattr (fd opt termios)
1743     "Set terminal attributes."
1744     (declare (type unix-fd fd))
1745     (void-syscall ("tcsetattr" int int (* (struct termios))) fd opt termios))
1746 dtc 1.1
1747 dtc 1.2 (defun unix-tcsendbreak (fd duration)
1748     "Send break"
1749     (declare (type unix-fd fd))
1750     (void-syscall ("tcsendbreak" int int) fd duration))
1751 dtc 1.1
1752 dtc 1.2 (defun unix-tcdrain (fd)
1753     "Wait for output for finish"
1754     (declare (type unix-fd fd))
1755     (void-syscall ("tcdrain" int) fd))
1756 dtc 1.1
1757 dtc 1.2 (defun unix-tcflush (fd selector)
1758     "See tcflush(3)"
1759     (declare (type unix-fd fd))
1760     (void-syscall ("tcflush" int int) fd selector))
1761 dtc 1.1
1762 dtc 1.2 (defun unix-tcflow (fd action)
1763     "Flow control"
1764     (declare (type unix-fd fd))
1765     (void-syscall ("tcflow" int int) fd action))
1766 dtc 1.1
1767 dtc 1.2 ;;; timebits.h
1768 dtc 1.1
1769 dtc 1.2 ;; A time value that is accurate to the nearest
1770     ;; microsecond but also has a range of years.
1771     (def-alien-type nil
1772     (struct timeval
1773 toy 1.18 (tv-sec time-t) ; seconds
1774     (tv-usec time-t))) ; and microseconds
1775 dtc 1.1
1776 dtc 1.2 ;;; unistd.h
1777 dtc 1.1
1778 dtc 1.2 (defun sub-unix-execve (program arg-list env-list)
1779     (let ((argv nil)
1780     (argv-bytes 0)
1781     (envp nil)
1782     (envp-bytes 0)
1783     result error-code)
1784     (unwind-protect
1785     (progn
1786     ;; Blast the stuff into the proper format
1787     (multiple-value-setq
1788     (argv argv-bytes)
1789     (string-list-to-c-strvec arg-list))
1790     (multiple-value-setq
1791     (envp envp-bytes)
1792     (string-list-to-c-strvec env-list))
1793     ;;
1794     ;; Now do the system call
1795     (multiple-value-setq
1796     (result error-code)
1797     (int-syscall ("execve"
1798     (* char) system-area-pointer system-area-pointer)
1799     (vector-sap program) argv envp)))
1800     ;;
1801     ;; Deallocate memory
1802     (when argv
1803     (system:deallocate-system-memory argv argv-bytes))
1804     (when envp
1805     (system:deallocate-system-memory envp envp-bytes)))
1806     (values result error-code)))
1807 dtc 1.1
1808 dtc 1.2 ;;;; UNIX-EXECVE
1809 dtc 1.1
1810 dtc 1.2 (defun unix-execve (program &optional arg-list
1811     (environment *environment-list*))
1812     "Executes the Unix execve system call. If the system call suceeds, lisp
1813 dtc 1.1 will no longer be running in this process. If the system call fails this
1814     function returns two values: NIL and an error code. Arg-list should be a
1815     list of simple-strings which are passed as arguments to the exec'ed program.
1816     Environment should be an a-list mapping symbols to simple-strings which this
1817     function bashes together to form the environment for the exec'ed program."
1818     (check-type program simple-string)
1819     (let ((env-list (let ((envlist nil))
1820     (dolist (cons environment)
1821     (push (if (cdr cons)
1822     (concatenate 'simple-string
1823     (string (car cons)) "="
1824     (cdr cons))
1825     (car cons))
1826     envlist))
1827     envlist)))
1828     (sub-unix-execve program arg-list env-list)))
1829    
1830    
1831     (defmacro round-bytes-to-words (n)
1832     `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
1833    
1834 dtc 1.2 ;; Values for the second argument to access.
1835 dtc 1.1
1836 dtc 1.2 ;;; Unix-access accepts a path and a mode. It returns two values the
1837     ;;; first is T if the file is accessible and NIL otherwise. The second
1838     ;;; only has meaning in the second case and is the unix errno value.
1839 dtc 1.1
1840 dtc 1.2 (defun unix-access (path mode)
1841     "Given a file path (a string) and one of four constant modes,
1842     unix-access returns T if the file is accessible with that
1843     mode and NIL if not. It also returns an errno value with
1844     NIL which determines why the file was not accessible.
1845 dtc 1.1
1846 dtc 1.2 The access modes are:
1847     r_ok Read permission.
1848     w_ok Write permission.
1849     x_ok Execute permission.
1850     f_ok Presence of file."
1851     (declare (type unix-pathname path)
1852     (type (mod 8) mode))
1853     (void-syscall ("access" c-string int) path mode))
1854    
1855     (defconstant l_set 0 "set the file pointer")
1856     (defconstant l_incr 1 "increment the file pointer")
1857     (defconstant l_xtnd 2 "extend the file size")
1858    
1859     (defun unix-lseek (fd offset whence)
1860 emarsden 1.21 "UNIX-LSEEK accepts a file descriptor and moves the file pointer ahead
1861     a certain OFFSET for that file. WHENCE can be any of the following:
1862 dtc 1.2
1863     l_set Set the file pointer.
1864     l_incr Increment the file pointer.
1865     l_xtnd Extend the file size.
1866     "
1867     (declare (type unix-fd fd)
1868 emarsden 1.19 (type (signed-byte 64) offset)
1869 dtc 1.2 (type (integer 0 2) whence))
1870 emarsden 1.19 (let ((result (alien-funcall
1871 emarsden 1.21 (extern-alien "lseek64" (function off-t int off-t int))
1872 emarsden 1.19 fd offset whence)))
1873     (if (minusp result)
1874 pmai 1.32 (values nil (unix-errno))
1875 emarsden 1.19 (values result 0))))
1876 dtc 1.1
1877    
1878 emarsden 1.21 ;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read.
1879 dtc 1.2 ;;; It attempts to read len bytes from the device associated with fd
1880     ;;; and store them into the buffer. It returns the actual number of
1881     ;;; bytes read.
1882 dtc 1.1
1883 dtc 1.2 (defun unix-read (fd buf len)
1884 emarsden 1.21 "UNIX-READ attempts to read from the file described by fd into
1885 dtc 1.2 the buffer buf until it is full. Len is the length of the buffer.
1886     The number of bytes actually read is returned or NIL and an error
1887     number if an error occured."
1888     (declare (type unix-fd fd)
1889     (type (unsigned-byte 32) len))
1890 rtoy 1.33 #+gencgc
1891     ;; With gencgc, the collector tries to keep raw objects like strings
1892     ;; in separate pages that are not write-protected. However, this
1893     ;; isn't always true. Thus, BUF will sometimes be write-protected
1894     ;; and the kernel doesn't like writing to write-protected pages. So
1895     ;; go through and touch each page to give the segv handler a chance
1896     ;; to unprotect the pages. (This is taken from unix.lisp.)
1897     (without-gcing
1898     (let* ((page-size (get-page-size))
1899     (1-page-size (1- page-size))
1900     (sap (etypecase buf
1901     (system-area-pointer buf)
1902     (vector (vector-sap buf))))
1903     (end (sap+ sap len)))
1904     (declare (type (and fixnum unsigned-byte) page-size 1-page-size)
1905     (type system-area-pointer sap end)
1906     (optimize (speed 3) (safety 0)))
1907     ;; Touch the beginning of every page
1908     (do ((sap (int-sap (logand (sap-int sap)
1909     (logxor 1-page-size (ldb (byte 32 0) -1))))
1910     (sap+ sap page-size)))
1911     ((sap>= sap end))
1912     (declare (type system-area-pointer sap))
1913     (setf (sap-ref-8 sap 0) (sap-ref-8 sap 0)))))
1914 dtc 1.2 (int-syscall ("read" int (* char) int) fd buf len))
1915 dtc 1.1
1916    
1917 dtc 1.2 ;;; Unix-write accepts a file descriptor, a buffer, an offset, and the
1918     ;;; length to write. It attempts to write len bytes to the device
1919     ;;; associated with fd from the the buffer starting at offset. It returns
1920     ;;; the actual number of bytes written.
1921 dtc 1.1
1922 dtc 1.2 (defun unix-write (fd buf offset len)
1923     "Unix-write attempts to write a character buffer (buf) of length
1924     len to the file described by the file descriptor fd. NIL and an
1925     error is returned if the call is unsuccessful."
1926     (declare (type unix-fd fd)
1927     (type (unsigned-byte 32) offset len))
1928     (int-syscall ("write" int (* char) int)
1929     fd
1930     (with-alien ((ptr (* char) (etypecase buf
1931     ((simple-array * (*))
1932     (vector-sap buf))
1933     (system-area-pointer
1934     buf))))
1935     (addr (deref ptr offset)))
1936     len))
1937 dtc 1.1
1938 dtc 1.2 (defun unix-pipe ()
1939     "Unix-pipe sets up a unix-piping mechanism consisting of
1940     an input pipe and an output pipe. Unix-Pipe returns two
1941     values: if no error occurred the first value is the pipe
1942     to be read from and the second is can be written to. If
1943     an error occurred the first value is NIL and the second
1944     the unix error code."
1945     (with-alien ((fds (array int 2)))
1946     (syscall ("pipe" (* int))
1947     (values (deref fds 0) (deref fds 1))
1948     (cast fds (* int)))))
1949 dtc 1.1
1950    
1951 dtc 1.2 (defun unix-chown (path uid gid)
1952     "Given a file path, an integer user-id, and an integer group-id,
1953     unix-chown changes the owner of the file and the group of the
1954     file to those specified. Either the owner or the group may be
1955     left unchanged by specifying them as -1. Note: Permission will
1956     fail if the caller is not the superuser."
1957     (declare (type unix-pathname path)
1958     (type (or unix-uid (integer -1 -1)) uid)
1959     (type (or unix-gid (integer -1 -1)) gid))
1960     (void-syscall ("chown" c-string int int) path uid gid))
1961 dtc 1.1
1962 dtc 1.2 ;;; Unix-fchown is exactly the same as unix-chown except that the file
1963     ;;; is specified by a file-descriptor ("fd") instead of a pathname.
1964 dtc 1.1
1965 dtc 1.2 (defun unix-fchown (fd uid gid)
1966     "Unix-fchown is like unix-chown, except that it accepts an integer
1967     file descriptor instead of a file path name."
1968     (declare (type unix-fd fd)
1969     (type (or unix-uid (integer -1 -1)) uid)
1970     (type (or unix-gid (integer -1 -1)) gid))
1971     (void-syscall ("fchown" int int int) fd uid gid))
1972 dtc 1.1
1973 dtc 1.2 ;;; Unix-chdir accepts a directory name and makes that the
1974     ;;; current working directory.
1975 dtc 1.1
1976 dtc 1.2 (defun unix-chdir (path)
1977     "Given a file path string, unix-chdir changes the current working
1978     directory to the one specified."
1979     (declare (type unix-pathname path))
1980     (void-syscall ("chdir" c-string) path))
1981 dtc 1.1
1982 dtc 1.2 (defun unix-current-directory ()
1983     "Put the absolute pathname of the current working directory in BUF.
1984     If successful, return BUF. If not, put an error message in
1985     BUF and return NULL. BUF should be at least PATH_MAX bytes long."
1986 toy 1.18 ;; 5120 is some randomly selected maximum size for the buffer for getcwd.
1987     (with-alien ((buf (array c-call:char 5120)))
1988     (let ((result (alien-funcall
1989     (extern-alien "getcwd"
1990     (function (* c-call:char)
1991     (* c-call:char) c-call:int))
1992     (cast buf (* c-call:char))
1993     5120)))
1994    
1995     (values (not (zerop (sap-int (alien-sap result))))
1996     (cast buf c-call:c-string)))))
1997 dtc 1.1
1998    
1999 dtc 1.2 ;;; Unix-dup returns a duplicate copy of the existing file-descriptor
2000     ;;; passed as an argument.
2001 dtc 1.1
2002 dtc 1.2 (defun unix-dup (fd)
2003     "Unix-dup duplicates an existing file descriptor (given as the
2004     argument) and return it. If FD is not a valid file descriptor, NIL
2005     and an error number are returned."
2006     (declare (type unix-fd fd))
2007     (int-syscall ("dup" int) fd))
2008 dtc 1.1
2009 dtc 1.2 ;;; Unix-dup2 makes the second file-descriptor describe the same file
2010     ;;; as the first. If the second file-descriptor points to an open
2011     ;;; file, it is first closed. In any case, the second should have a
2012     ;;; value which is a valid file-descriptor.
2013 dtc 1.1
2014 dtc 1.2 (defun unix-dup2 (fd1 fd2)
2015     "Unix-dup2 duplicates an existing file descriptor just as unix-dup
2016     does only the new value of the duplicate descriptor may be requested
2017     through the second argument. If a file already exists with the
2018     requested descriptor number, it will be closed and the number
2019     assigned to the duplicate."
2020     (declare (type unix-fd fd1 fd2))
2021     (void-syscall ("dup2" int int) fd1 fd2))
2022 dtc 1.1
2023 dtc 1.2 ;;; Unix-exit terminates a program.
2024 dtc 1.1
2025 dtc 1.2 (defun unix-exit (&optional (code 0))
2026     "Unix-exit terminates the current process with an optional
2027     error code. If successful, the call doesn't return. If
2028     unsuccessful, the call returns NIL and an error number."
2029     (declare (type (signed-byte 32) code))
2030     (void-syscall ("exit" int) code))
2031 dtc 1.1
2032 toy 1.28 #+(or)
2033 dtc 1.2 (defun unix-pathconf (path name)
2034     "Get file-specific configuration information about PATH."
2035     (int-syscall ("pathconf" c-string int) path name))
2036 dtc 1.1
2037 toy 1.28 #+(or)
2038 dtc 1.2 (defun unix-sysconf (name)
2039     "Get the value of the system variable NAME."
2040     (int-syscall ("sysconf" c-string) name))
2041 dtc 1.1
2042 toy 1.28 #+(or)
2043 dtc 1.2 (defun unix-confstr (name)
2044     "Get the value of the string-valued system variable NAME."
2045     (with-alien ((buf (array char 1024)))
2046     (values (not (zerop (alien-funcall (extern-alien "confstr"
2047     (function int
2048     c-string
2049     size-t))
2050     name buf 1024)))
2051     (cast buf c-string))))
2052    
2053    
2054     (def-alien-routine ("getpid" unix-getpid) int
2055     "Unix-getpid returns the process-id of the current process.")
2056    
2057     (def-alien-routine ("getppid" unix-getppid) int
2058     "Unix-getppid returns the process-id of the parent of the current process.")
2059    
2060     ;;; Unix-getpgrp returns the group-id associated with the
2061 dtc 1.6 ;;; current process.
2062 dtc 1.1
2063 dtc 1.6 (defun unix-getpgrp ()
2064     "Unix-getpgrp returns the group-id of the calling process."
2065     (int-syscall ("getpgrp")))
2066    
2067     ;;; Unix-setpgid sets the group-id of the process specified by
2068 dtc 1.2 ;;; "pid" to the value of "pgrp". The process must either have
2069     ;;; the same effective user-id or be a super-user process.
2070 dtc 1.1
2071 dtc 1.6 ;;; setpgrp(int int)[freebsd] is identical to setpgid and is retained
2072     ;;; for backward compatibility. setpgrp(void)[solaris] is being phased
2073     ;;; out in favor of setsid().
2074    
2075 dtc 1.2 (defun unix-setpgrp (pid pgrp)
2076     "Unix-setpgrp sets the process group on the process pid to
2077 dtc 1.6 pgrp. NIL and an error number are returned upon failure."
2078     (void-syscall ("setpgid" int int) pid pgrp))
2079    
2080     (defun unix-setpgid (pid pgrp)
2081     "Unix-setpgid sets the process group of the process pid to
2082     pgrp. If pgid is equal to pid, the process becomes a process
2083     group leader. NIL and an error number are returned upon failure."
2084     (void-syscall ("setpgid" int int) pid pgrp))
2085 dtc 1.1
2086 toy 1.28 #+(or)
2087 dtc 1.2 (defun unix-setsid ()
2088     "Create a new session with the calling process as its leader.
2089     The process group IDs of the session and the calling process
2090     are set to the process ID of the calling process, which is returned."
2091     (void-syscall ( "setsid")))
2092 dtc 1.1
2093 toy 1.28 #+(or)
2094 dtc 1.2 (defun unix-getsid ()
2095     "Return the session ID of the given process."
2096     (int-syscall ( "getsid")))
2097    
2098     (def-alien-routine ("getuid" unix-getuid) int
2099     "Unix-getuid returns the real user-id associated with the
2100     current process.")
2101 dtc 1.1
2102 toy 1.28 #+(or)
2103 dtc 1.2 (def-alien-routine ("geteuid" unix-getuid) int
2104     "Get the effective user ID of the calling process.")
2105    
2106     (def-alien-routine ("getgid" unix-getgid) int
2107     "Unix-getgid returns the real group-id of the current process.")
2108    
2109     (def-alien-routine ("getegid" unix-getegid) int
2110     "Unix-getegid returns the effective group-id of the current process.")
2111    
2112     ;/* If SIZE is zero, return the number of supplementary groups
2113     ; the calling process is in. Otherwise, fill in the group IDs
2114     ; of its supplementary groups in LIST and return the number written. */
2115     ;extern int getgroups __P ((int __size, __gid_t __list[]));
2116 dtc 1.1
2117 toy 1.28 #+(or)
2118 dtc 1.2 (defun unix-group-member (gid)
2119     "Return nonzero iff the calling process is in group GID."
2120     (int-syscall ( "group-member" gid-t) gid))
2121    
2122 dtc 1.1
2123 dtc 1.2 (defun unix-setuid (uid)
2124     "Set the user ID of the calling process to UID.
2125     If the calling process is the super-user, set the real
2126     and effective user IDs, and the saved set-user-ID to UID;
2127     if not, the effective user ID is set to UID."
2128 emarsden 1.29 (int-syscall ("setuid" uid-t) uid))
2129 dtc 1.2
2130     ;;; Unix-setreuid sets the real and effective user-id's of the current
2131     ;;; process to the arguments "ruid" and "euid", respectively. Usage is
2132     ;;; restricted for anyone but the super-user. Setting either "ruid" or
2133     ;;; "euid" to -1 makes the system use the current id instead.
2134    
2135     (defun unix-setreuid (ruid euid)
2136     "Unix-setreuid sets the real and effective user-id's of the current
2137     process to the specified ones. NIL and an error number is returned
2138     if the call fails."
2139     (void-syscall ("setreuid" int int) ruid euid))
2140 dtc 1.1
2141 dtc 1.2 (defun unix-setgid (gid)
2142     "Set the group ID of the calling process to GID.
2143     If the calling process is the super-user, set the real
2144     and effective group IDs, and the saved set-group-ID to GID;
2145     if not, the effective group ID is set to GID."
2146 emarsden 1.29 (int-syscall ("setgid" gid-t) gid))
2147 dtc 1.2
2148    
2149     ;;; Unix-setregid sets the real and effective group-id's of the current
2150     ;;; process to the arguments "rgid" and "egid", respectively. Usage is
2151     ;;; restricted for anyone but the super-user. Setting either "rgid" or
2152     ;;; "egid" to -1 makes the system use the current id instead.
2153    
2154     (defun unix-setregid (rgid egid)
2155     "Unix-setregid sets the real and effective group-id's of the current
2156     process process to the specified ones. NIL and an error number is
2157     returned if the call fails."
2158     (void-syscall ("setregid" int int) rgid egid))
2159    
2160     (defun unix-fork ()
2161     "Executes the unix fork system call. Returns 0 in the child and the pid
2162     of the child in the parent if it works, or NIL and an error number if it
2163     doesn't work."
2164     (int-syscall ("fork")))
2165    
2166     (def-alien-routine ("ttyname" unix-ttyname) c-string
2167     (fd int))
2168    
2169     (def-alien-routine ("isatty" unix-isatty) boolean
2170     "Accepts a Unix file descriptor and returns T if the device
2171     associated with it is a terminal."
2172     (fd int))
2173    
2174     ;;; Unix-link creates a hard link from name2 to name1.
2175    
2176     (defun unix-link (name1 name2)
2177     "Unix-link creates a hard link from the file with name1 to the
2178     file with name2."
2179     (declare (type unix-pathname name1 name2))
2180     (void-syscall ("link" c-string c-string) name1 name2))
2181    
2182     (defun unix-symlink (name1 name2)
2183     "Unix-symlink creates a symbolic link named name2 to the file
2184     named name1. NIL and an error number is returned if the call
2185     is unsuccessful."
2186     (declare (type unix-pathname name1 name2))
2187     (void-syscall ("symlink" c-string c-string) name1 name2))
2188    
2189     (defun unix-readlink (path)
2190     "Unix-readlink invokes the readlink system call on the file name
2191     specified by the simple string path. It returns up to two values:
2192     the contents of the symbolic link if the call is successful, or
2193     NIL and the Unix error number."
2194     (declare (type unix-pathname path))
2195     (with-alien ((buf (array char 1024)))
2196     (syscall ("readlink" c-string (* char) int)
2197     (let ((string (make-string result)))
2198     (kernel:copy-from-system-area
2199     (alien-sap buf) 0
2200     string (* vm:vector-data-offset vm:word-bits)
2201     (* result vm:byte-bits))
2202     string)
2203     path (cast buf (* char)) 1024)))
2204    
2205     ;;; Unix-unlink accepts a name and deletes the directory entry for that
2206     ;;; name and the file if this is the last link.
2207    
2208     (defun unix-unlink (name)
2209     "Unix-unlink removes the directory entry for the named file.
2210     NIL and an error code is returned if the call fails."
2211     (declare (type unix-pathname name))
2212     (void-syscall ("unlink" c-string) name))
2213    
2214     ;;; Unix-rmdir accepts a name and removes the associated directory.
2215    
2216     (defun unix-rmdir (name)
2217     "Unix-rmdir attempts to remove the directory name. NIL and
2218     an error number is returned if an error occured."
2219     (declare (type unix-pathname name))
2220     (void-syscall ("rmdir" c-string) name))
2221    
2222     (defun tcgetpgrp (fd)
2223     "Get the tty-process-group for the unix file-descriptor FD."
2224     (alien:with-alien ((alien-pgrp c-call:int))
2225     (multiple-value-bind (ok err)
2226     (unix-ioctl fd
2227     tiocgpgrp
2228     (alien:alien-sap (alien:addr alien-pgrp)))
2229     (if ok
2230     (values alien-pgrp nil)
2231     (values nil err)))))
2232    
2233     (defun tty-process-group (&optional fd)
2234     "Get the tty-process-group for the unix file-descriptor FD. If not supplied,
2235     FD defaults to /dev/tty."
2236     (if fd
2237     (tcgetpgrp fd)
2238     (multiple-value-bind (tty-fd errno)
2239     (unix-open "/dev/tty" o_rdwr 0)
2240     (cond (tty-fd
2241     (multiple-value-prog1
2242     (tcgetpgrp tty-fd)
2243     (unix-close tty-fd)))
2244     (t
2245     (values nil errno))))))
2246