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