/[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.21 - (show annotations)
Sun Mar 2 15:48:31 2003 UTC (11 years, 1 month ago) by emarsden
Branch: MAIN
Changes since 1.20: +57 -33 lines
Additions to the Large File Support, necessary in order to for large
files to be visible via DIRECTORY and friends: added stat64, fstat64,
lstat64, statfs64, readdir64. This requires additional transitions to
64-bit wide data types, and additions to linux-stubs.S, given that some
of the 64-bit stat variants are not accessible via dlsym().

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