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