/[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 - (show annotations)
Sun May 25 13:57:00 2008 UTC (5 years, 10 months ago) by rtoy
Branch: unicode-utf16-branch
CVS Tags: unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09
Branch point for: unicode-utf16-extfmt-branch
Changes since 1.43.4.3: +3 -1 lines
run-program.lisp
o Add comment
o Forgot to terminate the C strings with nul.

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