/[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.33 - (show annotations)
Tue Aug 31 12:39:43 2004 UTC (9 years, 7 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2004-09
Changes since 1.32: +25 -2 lines
In UNIX-READ, go through and touch every page contained in BUF to make
sure the pages are not write-protected, because the kernel doesn't
like that.  Also update it to touch the beginning of every page.  Use
this idea in unix-glibc2.lisp.

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