/[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.37 - (hide annotations)
Sat Apr 7 15:05:52 2007 UTC (7 years ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2007-05, snapshot-2007-07, snapshot-2007-06
Changes since 1.36: +15 -5 lines
Use unix-mmap from unix.lisp because mmap can return "negative" values,
which means we can't use syscall.

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