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