1 (cl:in-package
:sb-posix
)
3 (defmacro define-protocol-class
4 (name alien-type superclasses slots
&rest options
)
5 (let ((to-protocol (intern (format nil
"ALIEN-TO-~A" name
)))
6 (to-alien (intern (format nil
"~A-TO-ALIEN" name
))))
8 (export ',name
:sb-posix
)
9 (defclass ,name
,superclasses
10 ,(loop for slotd in slots
11 collect
(ldiff slotd
(member :array-length slotd
)))
13 (declaim (inline ,to-alien
,to-protocol
))
14 (declaim (inline ,to-protocol
,to-alien
))
15 (defun ,to-protocol
(alien &optional instance
)
16 (declare (type (sb-alien:alien
(* ,alien-type
)) alien
)
17 (type (or null
,name
) instance
))
19 (setf instance
(make-instance ',name
)))
20 ,@(loop for slotd in slots
21 ;; FIXME: slotds in source are more complicated in general
23 ;; FIXME: baroque construction of intricate fragility
24 for array-length
= (getf (cdr slotd
) :array-length
)
27 (let ((array (make-array ,array-length
)))
28 (setf (slot-value instance
',(car slotd
))
30 (dotimes (i ,array-length
)
33 (sb-alien:slot alien
',(car slotd
))
36 collect
`(setf (slot-value instance
',(car slotd
))
37 (sb-alien:slot alien
',(car slotd
))))
39 (defun ,to-alien
(instance &optional alien
)
40 (declare (type (or null
(sb-alien:alien
(* ,alien-type
))) alien
)
41 (type ,name instance
))
43 (setf alien
(sb-alien:make-alien
,alien-type
)))
44 ,@(loop for slotd in slots
45 for array-length
= (getf (cdr slotd
) :array-length
)
48 (let ((array (slot-value instance
',(car slotd
))))
49 (dotimes (i ,array-length
)
51 (sb-alien:slot alien
',(car slotd
))
55 collect
`(setf (sb-alien:slot alien
',(car slotd
))
56 (slot-value instance
',(car slotd
)))))
57 (find-class ',name
))))
59 (define-condition sb-posix
:syscall-error
(error)
60 ((errno :initarg
:errno
:reader sb-posix
:syscall-errno
))
61 (:report
(lambda (c s
)
62 (let ((errno (sb-posix:syscall-errno c
)))
63 (format s
"System call error ~A (~A)"
64 errno
(sb-int:strerror errno
))))))
66 (defun syscall-error ()
67 (error 'sb-posix
:syscall-error
:errno
(get-errno)))
69 (defun unsupported-error (lisp-name c-name
)
70 (error "~S is unsupported by SBCL on this platform due to lack of ~A()."
73 (defun unsupported-warning (lisp-name c-name
)
74 (warn "~S is unsupported by SBCL on this platform due to lack of ~A()."
77 (declaim (inline never-fails
))
78 (defun never-fails (&rest args
)
79 (declare (ignore args
))
82 ;;; Some systems may need C-level wrappers, which can live in the
83 ;;; runtime (so that save-lisp-and-die can produce standalone
84 ;;; executables). See REAL-C-NAME in macros.lisp for the use of this
86 (eval-when (:compile-toplevel
:load-toplevel
)
87 (setf *c-functions-in-runtime
*
88 '`(#+netbsd
,@("stat" "lstat" "fstat" "readdir" "opendir"))))
92 (defmacro define-call
* (name &rest arguments
)
93 #-win32
`(define-call ,name
,@arguments
)
94 #+win32
`(define-call ,(if (consp name
)
95 `(,(concatenate 'string
"_" (car name
))
97 (concatenate 'string
"_" name
))
100 (define-call* "access" int minusp
(pathname filename
) (mode int
))
101 (define-call* "chdir" int minusp
(pathname filename
))
102 (define-call* "chmod" int minusp
(pathname filename
) (mode mode-t
))
103 (define-call* "close" int minusp
(fd file-descriptor
))
104 (define-call* "creat" int minusp
(pathname filename
) (mode mode-t
))
105 (define-call* "dup" int minusp
(oldfd file-descriptor
))
106 (define-call* "dup2" int minusp
(oldfd file-descriptor
)
107 (newfd file-descriptor
))
108 (define-call* ("lseek" :options
:largefile
)
109 off-t minusp
(fd file-descriptor
) (offset off-t
)
111 (define-call* "mkdir" int minusp
(pathname filename
) (mode mode-t
))
114 (define-call-internally open-with-mode
,x int minusp
115 (pathname filename
) (flags int
) (mode mode-t
))
116 (define-call-internally open-without-mode
,x int minusp
117 (pathname filename
) (flags int
))
118 (define-entry-point ,x
119 (pathname flags
&optional
(mode nil mode-supplied
))
121 (open-with-mode pathname flags mode
)
122 (open-without-mode pathname flags
))))))
123 (def #-win32
"open" #+win32
"_open"))
124 (define-call "rename" int minusp
(oldpath filename
) (newpath filename
))
125 (define-call* "rmdir" int minusp
(pathname filename
))
126 (define-call* "unlink" int minusp
(pathname filename
))
127 (define-call #-netbsd
"opendir" #+netbsd
"_opendir"
128 (* t
) null-alien
(pathname filename
))
129 (define-call (#-netbsd
"readdir" #+netbsd
"_readdir" :options
:largefile
)
131 ;; readdir() has the worst error convention in the world. It's just
132 ;; too painful to support. (return is NULL _and_ errno "unchanged"
133 ;; is not an error, it's EOF).
136 (define-call "closedir" int minusp
(dir (* t
)))
137 ;; need to do this here because we can't do it in the DEFPACKAGE
138 (define-call* "umask" mode-t never-fails
(mode mode-t
))
139 (define-call* "getpid" pid-t never-fails
)
143 (define-call "chown" int minusp
(pathname filename
)
144 (owner uid-t
) (group gid-t
))
145 (define-call "chroot" int minusp
(pathname filename
))
146 (define-call "fchdir" int minusp
(fd file-descriptor
))
147 (define-call "fchmod" int minusp
(fd file-descriptor
) (mode mode-t
))
148 (define-call "fchown" int minusp
(fd file-descriptor
)
149 (owner uid-t
) (group gid-t
))
150 (define-call "fdatasync" int minusp
(fd file-descriptor
))
151 (define-call ("ftruncate" :options
:largefile
)
152 int minusp
(fd file-descriptor
) (length off-t
))
153 (define-call "fsync" int minusp
(fd file-descriptor
))
154 (define-call "lchown" int minusp
(pathname filename
)
155 (owner uid-t
) (group gid-t
))
156 (define-call "link" int minusp
(oldpath filename
) (newpath filename
))
157 (define-call "lockf" int minusp
(fd file-descriptor
) (cmd int
) (len off-t
))
158 (define-call "mkfifo" int minusp
(pathname filename
) (mode mode-t
))
159 (define-call "symlink" int minusp
(oldpath filename
) (newpath filename
))
160 (define-call "sync" void never-fails
)
161 (define-call ("truncate" :options
:largefile
)
162 int minusp
(pathname filename
) (length off-t
))
164 (macrolet ((def-mk*temp
(lisp-name c-name result-type errorp dirp values
)
165 (declare (ignore dirp
))
166 (if (sb-sys:find-foreign-symbol-address c-name
)
168 (defun ,lisp-name
(template)
169 (let* ((external-format sb-alien
::*default-c-string-external-format
*)
170 (arg (sb-ext:string-to-octets
172 :external-format external-format
)))
173 (sb-sys:with-pinned-objects
(arg)
174 ;; accommodate for the call-by-reference
175 ;; nature of mks/dtemp's template strings.
176 (let ((result (alien-funcall (extern-alien ,c-name
177 (function ,result-type system-area-pointer
))
178 (sb-alien::vector-sap arg
))))
179 (when (,errorp result
)
181 ;; FIXME: We'd rather return pathnames, but other
182 ;; SB-POSIX functions like this return strings...
183 (let ((pathname (sb-ext:octets-to-string
184 arg
:external-format external-format
)))
186 '(values result pathname
)
188 (export ',lisp-name
))
190 (defun ,lisp-name
(template)
191 (declare (ignore template
))
192 (unsupported-error ',lisp-name
,c-name
))
193 (define-compiler-macro ,lisp-name
(&whole form template
)
194 (declare (ignore template
))
195 (unsupported-warning ',lisp-name
,c-name
)
197 (export ',lisp-name
)))))
198 (def-mk*temp mktemp
"mktemp" (* char
) null-alien nil nil
)
199 ;; FIXME: Windows does have _mktemp, which has a slightly different
201 (def-mk*temp mkstemp
"mkstemp" int minusp nil t
)
202 ;; FIXME: What about Windows?
203 (def-mk*temp mkdtemp
"mkdtemp" (* char
) null-alien t nil
))
204 (define-call-internally ioctl-without-arg
"ioctl" int minusp
205 (fd file-descriptor
) (cmd int
))
206 (define-call-internally ioctl-with-int-arg
"ioctl" int minusp
207 (fd file-descriptor
) (cmd int
) (arg int
))
208 (define-call-internally ioctl-with-pointer-arg
"ioctl" int minusp
209 (fd file-descriptor
) (cmd int
)
210 (arg alien-pointer-to-anything-or-nil
))
211 (define-entry-point "ioctl" (fd cmd
&optional
(arg nil argp
))
214 ((alien int
) (ioctl-with-int-arg fd cmd arg
))
215 ((or (alien (* t
)) null
) (ioctl-with-pointer-arg fd cmd arg
)))
216 (ioctl-without-arg fd cmd
)))
217 (define-call-internally fcntl-without-arg
"fcntl" int minusp
218 (fd file-descriptor
) (cmd int
))
219 (define-call-internally fcntl-with-int-arg
"fcntl" int minusp
220 (fd file-descriptor
) (cmd int
) (arg int
))
221 (define-call-internally fcntl-with-pointer-arg
"fcntl" int minusp
222 (fd file-descriptor
) (cmd int
)
223 (arg alien-pointer-to-anything-or-nil
))
224 (define-protocol-class flock alien-flock
()
225 ((type :initarg
:type
:accessor flock-type
226 :documentation
"Type of lock; F_RDLCK, F_WRLCK, F_UNLCK.")
227 (whence :initarg
:whence
:accessor flock-whence
228 :documentation
"Flag for starting offset.")
229 (start :initarg
:start
:accessor flock-start
230 :documentation
"Relative offset in bytes.")
231 (len :initarg
:len
:accessor flock-len
232 :documentation
"Size; if 0 then until EOF.")
233 ;; Note: PID isn't initable, and is read-only. But other stuff in
234 ;; SB-POSIX right now loses when a protocol-class slot is unbound,
235 ;; so we initialize it to 0.
236 (pid :initform
0 :reader flock-pid
238 "Process ID of the process holding the lock; returned with F_GETLK."))
239 (:documentation
"Class representing locks used in fcntl(2)."))
240 (define-entry-point "fcntl" (fd cmd
&optional
(arg nil argp
))
243 ((alien int
) (fcntl-with-int-arg fd cmd arg
))
244 ((or (alien (* t
)) null
) (fcntl-with-pointer-arg fd cmd arg
))
245 (flock (with-alien-flock a-flock
()
246 (flock-to-alien arg a-flock
)
247 (let ((r (fcntl-with-pointer-arg fd cmd a-flock
)))
248 (alien-to-flock a-flock arg
)
250 (fcntl-without-arg fd cmd
)))
253 (define-call "geteuid" uid-t never-fails
) ; "always successful", it says
254 (define-call "getresuid" uid-t never-fails
)
255 (define-call "getuid" uid-t never-fails
)
256 (define-call "seteuid" int minusp
(uid uid-t
))
257 (define-call "setfsuid" int minusp
(uid uid-t
))
258 (define-call "setreuid" int minusp
(ruid uid-t
) (euid uid-t
))
259 (define-call "setresuid" int minusp
(ruid uid-t
) (euid uid-t
) (suid uid-t
))
260 (define-call "setuid" int minusp
(uid uid-t
))
261 (define-call "getegid" gid-t never-fails
)
262 (define-call "getgid" gid-t never-fails
)
263 (define-call "getresgid" gid-t never-fails
)
264 (define-call "setegid" int minusp
(gid gid-t
))
265 (define-call "setfsgid" int minusp
(gid gid-t
))
266 (define-call "setgid" int minusp
(gid gid-t
))
267 (define-call "setregid" int minusp
(rgid gid-t
) (egid gid-t
))
268 (define-call "setresgid" int minusp
(rgid gid-t
) (egid gid-t
) (sgid gid-t
))
270 ;; processes, signals
271 (define-call "alarm" int never-fails
(seconds unsigned
))
275 #+mach-exception-handler
277 ;; FIXME this is a lie, of course this can fail, but there's no
278 ;; error handling here yet!
279 (define-call "setup_mach_exceptions" void never-fails
)
280 (define-call ("posix_fork" :c-name
"fork") pid-t minusp
)
282 (let ((pid (posix-fork)))
284 (setup-mach-exceptions))
286 (export 'fork
:sb-posix
))
288 #-mach-exception-handler
289 (define-call "fork" pid-t minusp
)
291 (define-call "getpgid" pid-t minusp
(pid pid-t
))
292 (define-call "getppid" pid-t never-fails
)
293 (define-call "getpgrp" pid-t never-fails
)
294 (define-call "getsid" pid-t minusp
(pid pid-t
))
295 (define-call "kill" int minusp
(pid pid-t
) (signal int
))
296 (define-call "killpg" int minusp
(pgrp int
) (signal int
))
297 (define-call "pause" int minusp
)
298 (define-call "setpgid" int minusp
(pid pid-t
) (pgid pid-t
))
299 (define-call "setpgrp" int minusp
)
300 (define-call "setsid" pid-t minusp
))
302 (defmacro with-growing-c-string
((buffer size
) &body body
)
303 (sb-int:with-unique-names
(c-string-block)
304 `(block ,c-string-block
306 (flet ((,buffer
(&optional
(size-incl-null))
308 (setf (sb-sys:sap-ref-8
(sb-alien:alien-sap
,buffer
) size-incl-null
)
310 (return-from ,c-string-block
311 (sb-alien::c-string-to-string
312 (sb-alien:alien-sap
,buffer
)
313 (sb-impl::default-external-format
)
315 (loop for
,size
= 128 then
(* 2 ,size
)
318 (setf ,buffer
(make-alien c-string
,size
))
321 (free-alien ,buffer
)))))))))
325 (export 'readlink
:sb-posix
)
326 (defun readlink (pathspec)
327 "Returns the resolved target of a symbolic link as a string."
328 (flet ((%readlink
(path buf length
)
330 (extern-alien "readlink" (function int c-string
(* t
) int
))
332 (with-growing-c-string (buf size
)
333 (let ((count (%readlink
(filename pathspec
) buf size
)))
334 (cond ((minusp count
)
340 (export 'getcwd
:sb-posix
)
342 "Returns the process's current working directory as a string."
343 (flet ((%getcwd
(buffer size
)
345 (extern-alien #-win32
"getcwd"
346 #+win32
"_getcwd" (function c-string
(* t
) int
))
348 (with-growing-c-string (buf size
)
349 (let ((result (%getcwd buf size
)))
352 ((/= (get-errno) sb-posix
:erange
)
353 (syscall-error))))))))
357 (export 'wait
:sb-posix
)
358 (declaim (inline wait
))
359 (defun wait (&optional statusptr
)
360 (declare (type (or null
(simple-array (signed-byte 32) (1))) statusptr
))
361 (let* ((ptr (or statusptr
(make-array 1 :element-type
'(signed-byte 32))))
362 (pid (sb-sys:with-pinned-objects
(ptr)
364 (extern-alien "wait" (function pid-t
(* int
)))
365 (sb-sys:vector-sap ptr
)))))
368 (values pid
(aref ptr
0))))))
372 (export 'waitpid
:sb-posix
)
373 (declaim (inline waitpid
))
374 (defun waitpid (pid options
&optional statusptr
)
375 (declare (type (sb-alien:alien pid-t
) pid
)
376 (type (sb-alien:alien int
) options
)
377 (type (or null
(simple-array (signed-byte 32) (1))) statusptr
))
378 (let* ((ptr (or statusptr
(make-array 1 :element-type
'(signed-byte 32))))
379 (pid (sb-sys:with-pinned-objects
(ptr)
381 (extern-alien "waitpid" (function pid-t
383 pid
(sb-sys:vector-sap ptr
) options
))))
386 (values pid
(aref ptr
0)))))
388 (define-call "wifexited" boolean never-fails
(status int
))
389 (define-call "wexitstatus" int never-fails
(status int
))
390 (define-call "wifsignaled" boolean never-fails
(status int
))
391 (define-call "wtermsig" int never-fails
(status int
))
392 (define-call "wifstopped" boolean never-fails
(status int
))
393 (define-call "wstopsig" int never-fails
(status int
))
394 #+nil
; see alien/waitpid-macros.c
395 (define-call "wifcontinued" boolean never-fails
(status int
)))
400 (define-call ("mmap" :options
:largefile
) sb-sys
:system-area-pointer
402 (= (sb-sys:sap-int res
) #.
(1- (expt 2 sb-vm
::n-machine-word-bits
))))
403 (addr sap-or-nil
) (length unsigned
) (prot unsigned
)
404 (flags unsigned
) (fd file-descriptor
) (offset off-t
))
406 (define-call "munmap" int minusp
407 (start sb-sys
:system-area-pointer
) (length unsigned
))
409 (define-call "msync" int minusp
410 (addr sb-sys
:system-area-pointer
) (length unsigned
) (flags int
)))
412 ;;; mlockall, munlockall
413 (define-call "mlockall" int minusp
(flags int
))
414 (define-call "munlockall" int minusp
)
417 (define-call "getpagesize" int minusp
)
419 ;;; KLUDGE: This could be taken from GetSystemInfo
420 (export (defun getpagesize () 4096))
423 ;; The docstrings are copied from the descriptions in SUSv3,
426 (define-protocol-class passwd alien-passwd
()
427 ((name :initarg
:name
:accessor passwd-name
428 :documentation
"User's login name.")
429 ;; Note: SUSv3 doesn't require this member.
430 (passwd :initarg
:passwd
:accessor passwd-passwd
431 :documentation
"The account's encrypted password.")
432 (uid :initarg
:uid
:accessor passwd-uid
433 :documentation
"Numerical user ID.")
434 (gid :initarg
:gid
:accessor passwd-gid
435 :documentation
"Numerical group ID.")
436 ;; Note: SUSv3 doesn't require this member.
437 (gecos :initarg
:gecos
:accessor passwd-gecos
438 :documentation
"User's name or comment field.")
439 (dir :initarg
:dir
:accessor passwd-dir
440 :documentation
"Initial working directory.")
441 (shell :initarg
:shell
:accessor passwd-shell
442 :documentation
"Program to use as shell."))
443 (:documentation
"Instances of this class represent entries in
444 the system's user database."))
448 (define-protocol-class group alien-group
()
449 ((name :initarg
:name
:accessor group-name
)
450 (passwd :initarg
:passwd
:accessor group-passwd
)
451 (gid :initarg
:gid
:accessor group-gid
)))
453 (defmacro define-obj-call
(name arg type conv
)
455 ;; FIXME: this isn't the documented way of doing this, surely?
456 (let ((lisp-name (intern (string-upcase name
) :sb-posix
)))
458 (export ',lisp-name
:sb-posix
)
459 (declaim (inline ,lisp-name
))
460 (defun ,lisp-name
(,arg
)
461 (let ((r (alien-funcall (extern-alien ,name
,type
) ,arg
)))
466 (define-obj-call "getpwnam" login-name
(function (* alien-passwd
) c-string
) alien-to-passwd
)
467 (define-obj-call "getpwuid" uid
(function (* alien-passwd
) uid-t
) alien-to-passwd
)
468 (define-obj-call "getgrnam" login-name
(function (* alien-group
) c-string
) alien-to-group
)
469 (define-obj-call "getgrgid" gid
(function (* alien-group
) gid-t
) alien-to-group
)
473 (define-protocol-class timeval alien-timeval
()
474 ((sec :initarg
:tv-sec
:accessor timeval-sec
475 :documentation
"Seconds.")
476 (usec :initarg
:tv-usec
:accessor timeval-usec
477 :documentation
"Microseconds."))
478 (:documentation
"Instances of this class represent time values."))
480 (define-protocol-class stat alien-stat
()
481 ((mode :initarg
:mode
:reader stat-mode
482 :documentation
"Mode of file.")
483 (ino :initarg
:ino
:reader stat-ino
484 :documentation
"File serial number.")
485 (dev :initarg
:dev
:reader stat-dev
486 :documentation
"Device ID of device containing file.")
487 (nlink :initarg
:nlink
:reader stat-nlink
488 :documentation
"Number of hard links to the file.")
489 (uid :initarg
:uid
:reader stat-uid
490 :documentation
"User ID of file.")
491 (gid :initarg
:gid
:reader stat-gid
492 :documentation
"Group ID of file.")
493 (size :initarg
:size
:reader stat-size
494 :documentation
"For regular files, the file size in
495 bytes. For symbolic links, the length
496 in bytes of the filename contained in
498 (atime :initarg
:atime
:reader stat-atime
499 :documentation
"Time of last access.")
500 (mtime :initarg
:mtime
:reader stat-mtime
501 :documentation
"Time of last data modification.")
502 (ctime :initarg
:ctime
:reader stat-ctime
503 :documentation
"Time of last status change"))
504 (:documentation
"Instances of this class represent Posix file
507 (defmacro define-stat-call
(name arg designator-fun type
)
508 ;; FIXME: this isn't the documented way of doing this, surely?
509 (let ((lisp-name (lisp-for-c-symbol name
)))
511 (export ',lisp-name
:sb-posix
)
512 (declaim (inline ,lisp-name
))
513 (defun ,lisp-name
(,arg
&optional stat
)
514 (declare (type (or null stat
) stat
))
515 (with-alien-stat a-stat
()
516 (let ((r (alien-funcall
517 (extern-alien ,(real-c-name (list name
:options
:largefile
)) ,type
)
518 (,designator-fun
,arg
)
522 (alien-to-stat a-stat stat
)))))))
524 (define-stat-call #-win32
"stat" #+win32
"_stat"
526 (function int c-string
(* alien-stat
)))
529 (define-stat-call "lstat"
531 (function int c-string
(* alien-stat
)))
532 ;;; No symbolic links on Windows, so use stat
535 (declaim (inline lstat
))
536 (export (defun lstat (filename &optional stat
)
537 (if stat
(stat filename stat
) (stat filename
)))))
539 (define-stat-call #-win32
"fstat" #+win32
"_fstat"
541 (function int int
(* alien-stat
)))
545 (define-call "s_isreg" boolean never-fails
(mode mode-t
))
546 (define-call "s_isdir" boolean never-fails
(mode mode-t
))
547 (define-call "s_ischr" boolean never-fails
(mode mode-t
))
548 (define-call "s_isblk" boolean never-fails
(mode mode-t
))
549 (define-call "s_isfifo" boolean never-fails
(mode mode-t
))
550 (define-call "s_islnk" boolean never-fails
(mode mode-t
))
551 (define-call "s_issock" boolean never-fails
(mode mode-t
))
555 (export 'pipe
:sb-posix
)
556 (declaim (inline pipe
))
557 (defun pipe (&optional filedes2
)
558 (declare (type (or null
(simple-array (signed-byte 32) (2))) filedes2
))
560 (setq filedes2
(make-array 2 :element-type
'(signed-byte 32))))
561 (let ((r (sb-sys:with-pinned-objects
(filedes2)
563 ;; FIXME: (* INT)? (ARRAY INT 2) would be better
564 (extern-alien "pipe" (function int
(* int
)))
565 (sb-sys:vector-sap filedes2
)))))
568 (values (aref filedes2
0) (aref filedes2
1))))
571 (define-protocol-class termios alien-termios
()
572 ((iflag :initarg
:iflag
:accessor sb-posix
:termios-iflag
573 :documentation
"Input modes.")
574 (oflag :initarg
:oflag
:accessor sb-posix
:termios-oflag
575 :documentation
"Output modes.")
576 (cflag :initarg
:cflag
:accessor sb-posix
:termios-cflag
577 :documentation
"Control modes.")
578 (lflag :initarg
:lflag
:accessor sb-posix
:termios-lflag
579 :documentation
"Local modes.")
580 (cc :initarg
:cc
:accessor sb-posix
:termios-cc
:array-length nccs
581 :documentation
"Control characters"))
582 (:documentation
"Instances of this class represent I/O
583 characteristics of the terminal."))
587 (export 'tcsetattr
:sb-posix
)
588 (declaim (inline tcsetattr
))
589 (defun tcsetattr (fd actions termios
)
590 (declare (type termios termios
))
591 (with-alien-termios a-termios
()
592 (termios-to-alien termios a-termios
)
593 (let ((fd (file-descriptor fd
)))
594 (let* ((r (alien-funcall
597 (function int int int
(* alien-termios
)))
598 fd actions a-termios
)))
602 (export 'tcgetattr
:sb-posix
)
603 (declaim (inline tcgetattr
))
604 (defun tcgetattr (fd &optional termios
)
605 (declare (type (or null termios
) termios
))
606 (with-alien-termios a-termios
()
607 (let ((r (alien-funcall
608 (extern-alien "tcgetattr"
609 (function int int
(* alien-termios
)))
614 (setf termios
(alien-to-termios a-termios termios
))))
616 (export 'cfsetispeed
:sb-posix
)
617 (declaim (inline cfsetispeed
))
618 (defun cfsetispeed (speed &optional termios
)
619 (declare (type (or null termios
) termios
))
620 (with-alien-termios a-termios
()
621 (let ((r (alien-funcall
622 (extern-alien "cfsetispeed"
623 (function int
(* alien-termios
) speed-t
))
628 (setf termios
(alien-to-termios a-termios termios
))))
630 (export 'cfsetospeed
:sb-posix
)
631 (declaim (inline cfsetospeed
))
632 (defun cfsetospeed (speed &optional termios
)
633 (declare (type (or null termios
) termios
))
634 (with-alien-termios a-termios
()
635 (let ((r (alien-funcall
636 (extern-alien "cfsetospeed"
637 (function int
(* alien-termios
) speed-t
))
642 (setf termios
(alien-to-termios a-termios termios
))))
644 (export 'cfgetispeed
:sb-posix
)
645 (declaim (inline cfgetispeed
))
646 (defun cfgetispeed (termios)
647 (declare (type termios termios
))
648 (with-alien-termios a-termios
()
649 (termios-to-alien termios a-termios
)
650 (alien-funcall (extern-alien "cfgetispeed"
651 (function speed-t
(* alien-termios
)))
653 (export 'cfgetospeed
:sb-posix
)
654 (declaim (inline cfgetospeed
))
655 (defun cfgetospeed (termios)
656 (declare (type termios termios
))
657 (with-alien-termios a-termios
()
658 (termios-to-alien termios a-termios
)
659 (alien-funcall (extern-alien "cfgetospeed"
660 (function speed-t
(* alien-termios
)))
666 (export 'time
:sb-posix
)
668 (let ((result (alien-funcall (extern-alien "time"
669 (function time-t
(* time-t
)))
674 (export 'utime
:sb-posix
)
675 (defun utime (filename &optional access-time modification-time
)
676 (let ((fun (extern-alien "utime" (function int c-string
678 (name (filename filename
)))
679 (if (not (and access-time modification-time
))
680 (alien-funcall fun name nil
)
681 (with-alien ((utimbuf (struct alien-utimbuf
)))
682 (setf (slot utimbuf
'actime
) (or access-time
0)
683 (slot utimbuf
'modtime
) (or modification-time
0))
684 (let ((result (alien-funcall fun name
(alien-sap utimbuf
))))
688 (export 'utimes
:sb-posix
)
689 (defun utimes (filename &optional access-time modification-time
)
690 (flet ((seconds-and-useconds (time)
691 (multiple-value-bind (integer fractional
)
693 (values integer
(cl:truncate
(* fractional
1000000)))))
694 (maybe-syscall-error (value)
698 (let ((fun (extern-alien "utimes" (function int c-string
699 (* (array alien-timeval
2)))))
700 (name (filename filename
)))
701 (if (not (and access-time modification-time
))
702 (maybe-syscall-error (alien-funcall fun name nil
))
703 (with-alien ((buf (array alien-timeval
2)))
704 (let ((actime (deref buf
0))
705 (modtime (deref buf
1)))
706 (setf (values (slot actime
'sec
)
708 (seconds-and-useconds (or access-time
0))
709 (values (slot modtime
'sec
)
710 (slot modtime
'usec
))
711 (seconds-and-useconds (or modification-time
0)))
712 (maybe-syscall-error (alien-funcall fun name
713 (alien-sap buf
))))))))))
718 (export 'getenv
:sb-posix
)
720 (let ((r (alien-funcall
721 (extern-alien "getenv" (function (* char
) c-string
))
723 (declare (type (alien (* char
)) r
))
724 (unless (null-alien r
)
726 (define-call "putenv" int minusp
(string c-string
))
731 (export 'openlog
:sb-posix
)
732 (export 'syslog
:sb-posix
)
733 (export 'closelog
:sb-posix
)
734 (defun openlog (ident options
&optional
(facility log-user
))
735 (alien-funcall (extern-alien
736 "openlog" (function void c-string int int
))
737 ident options facility
))
738 (defun syslog (priority format
&rest args
)
739 "Send a message to the syslog facility, with severity level
740 PRIORITY. The message will be formatted as by CL:FORMAT (rather
741 than C's printf) with format string FORMAT and arguments ARGS."
742 (flet ((syslog1 (priority message
)
743 (alien-funcall (extern-alien
744 "syslog" (function void int c-string c-string
))
745 priority
"%s" message
)))
746 (syslog1 priority
(apply #'format nil format args
))))
747 (define-call "closelog" void never-fails
))