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
))))))
69 (do-symbols (symbol (find-package "SB-POSIX"))
70 (when (get symbol
'errno
)
71 (let ((errno (symbol-value symbol
)))
72 (setf errno-max
(max errno errno-max
))
74 (eval `(define-condition ,symbol
(syscall-error) ())))
76 (let ((table (make-array (1+ errno-max
))))
77 (mapc #'(lambda (cons) (setf (elt table
(car cons
)) (cdr cons
))) list
)
80 (defun syscall-error ()
81 (let ((errno (get-errno)))
82 (error (elt *errno-table
* errno
) :errno errno
)))
84 ;; Note that we inherit from SIMPLE-FILE-ERROR first, to get its
85 ;; error reporting, rather than SYSCALL-ERROR's.
86 (define-condition file-syscall-error
87 (sb-impl::simple-file-error syscall-error
)
90 (defvar *file-errno-table
*
91 (let ((array (copy-seq *errno-table
*)))
93 (lambda (condition-class-name)
94 (if (symbolp condition-class-name
)
95 (let ((file-condition-name
97 (format nil
"FILE-~A" condition-class-name
))))
98 ;; Should condition class names like FILE-ENOENT
99 ;; and FILE-ENOTDIR be exported? I want to say
100 ;; "no", since we already export ENOENT, ENOTDIR
101 ;; et al, and so the user can write handlers
104 ;; (handler-bind ((sb-posix:enoent ...)
105 ;; (sb-posix:enotdir ...)
109 ;; which will do the right thing for all our
110 ;; FILE-SYSCALL-ERRORs, without exposing this
111 ;; implementation detail. (Recall that some
112 ;; FILE-ERRORs don't strictly have to do with
113 ;; the file system, e.g., supplying a wild
114 ;; pathname to some functions.) But if the
115 ;; prevailing opinion is otherwise, uncomment
117 #|
(export file-condition-name
) |
#
118 (eval `(define-condition ,file-condition-name
119 (,condition-class-name file-syscall-error
)
121 condition-class-name
))
125 ;; Note: do we have to declare SIMPLE-FILE-PERROR notinline in
127 (sb-ext:without-package-locks
128 (defun sb-impl::simple-file-perror
(note-format pathname errno
)
129 (error (elt *file-errno-table
* errno
)
132 :format-control
"~@<~?: ~2I~_~A~:>"
134 (list note-format
(list pathname
) (sb-int:strerror errno
)))))
136 ;; Note: it might prove convenient to develop a parallel set of
137 ;; condition classes for STREAM-ERRORs, too.
138 (declaim (inline never-fails
))
139 (defun never-fails (&rest args
)
140 (declare (ignore args
))
143 ;;; Some systems may need C-level wrappers, which can live in the
144 ;;; runtime (so that save-lisp-and-die can produce standalone
145 ;;; executables). See REAL-C-NAME in macros.lisp for the use of this
147 (eval-when (:compile-toplevel
:load-toplevel
)
148 (setf *c-functions-in-runtime
*
149 '`(#+netbsd
,@("stat" "lstat" "fstat" "readdir" "opendir"))))
152 ;;; filesystem access
153 (defmacro define-call
* (name &rest arguments
)
154 #-win32
`(define-call ,name
,@arguments
)
155 #+win32
`(define-call ,(if (consp name
)
156 `(,(concatenate 'string
"_" (car name
))
158 (concatenate 'string
"_" name
))
161 (define-call* "access" int minusp
(pathname filename
) (mode int
))
162 (define-call* "chdir" int minusp
(pathname filename
))
163 (define-call* "chmod" int minusp
(pathname filename
) (mode mode-t
))
164 (define-call* "close" int minusp
(fd file-descriptor
))
165 (define-call* "creat" int minusp
(pathname filename
) (mode mode-t
))
166 (define-call* "dup" int minusp
(oldfd file-descriptor
))
167 (define-call* "dup2" int minusp
(oldfd file-descriptor
)
168 (newfd file-descriptor
))
169 (define-call* ("lseek" :options
:largefile
)
170 off-t minusp
(fd file-descriptor
) (offset off-t
)
172 (define-call* "mkdir" int minusp
(pathname filename
) (mode mode-t
))
175 (define-call-internally open-with-mode
,x int minusp
176 (pathname filename
) (flags int
) (mode mode-t
))
177 (define-call-internally open-without-mode
,x int minusp
178 (pathname filename
) (flags int
))
179 (define-entry-point ,x
180 (pathname flags
&optional
(mode nil mode-supplied
))
182 (open-with-mode pathname flags mode
)
183 (open-without-mode pathname flags
))))))
184 (def #-win32
"open" #+win32
"_open"))
185 (define-call "rename" int minusp
(oldpath filename
) (newpath filename
))
186 (define-call* "rmdir" int minusp
(pathname filename
))
187 (define-call* "unlink" int minusp
(pathname filename
))
188 (define-call #-netbsd
"opendir" #+netbsd
"_opendir"
189 (* t
) null-alien
(pathname filename
))
190 (define-call (#-netbsd
"readdir" #+netbsd
"_readdir" :options
:largefile
)
192 ;; readdir() has the worst error convention in the world. It's just
193 ;; too painful to support. (return is NULL _and_ errno "unchanged"
194 ;; is not an error, it's EOF).
197 (define-call "closedir" int minusp
(dir (* t
)))
198 ;; need to do this here because we can't do it in the DEFPACKAGE
199 (define-call* "umask" mode-t never-fails
(mode mode-t
))
200 (define-call* "getpid" pid-t never-fails
)
204 (define-call "chown" int minusp
(pathname filename
)
205 (owner uid-t
) (group gid-t
))
206 (define-call "chroot" int minusp
(pathname filename
))
207 (define-call "fchdir" int minusp
(fd file-descriptor
))
208 (define-call "fchmod" int minusp
(fd file-descriptor
) (mode mode-t
))
209 (define-call "fchown" int minusp
(fd file-descriptor
)
210 (owner uid-t
) (group gid-t
))
211 (define-call "fdatasync" int minusp
(fd file-descriptor
))
212 (define-call ("ftruncate" :options
:largefile
)
213 int minusp
(fd file-descriptor
) (length off-t
))
214 (define-call "fsync" int minusp
(fd file-descriptor
))
215 (define-call "lchown" int minusp
(pathname filename
)
216 (owner uid-t
) (group gid-t
))
217 (define-call "link" int minusp
(oldpath filename
) (newpath filename
))
218 (define-call "lockf" int minusp
(fd file-descriptor
) (cmd int
) (len off-t
))
219 (define-call "mkfifo" int minusp
(pathname filename
) (mode mode-t
))
220 (define-call "symlink" int minusp
(oldpath filename
) (newpath filename
))
221 (define-call "sync" void never-fails
)
222 (define-call ("truncate" :options
:largefile
)
223 int minusp
(pathname filename
) (length off-t
))
224 ;; FIXME: Windows does have _mktemp, which has a slightlty different
226 (defun mkstemp (template)
227 ;; we are emulating sb-alien's charset conversion for strings
228 ;; here, to accommodate for the call-by-reference nature of
229 ;; mkstemp's template strings.
230 (let ((arg (sb-ext:string-to-octets
232 :external-format sb-alien
::*default-c-string-external-format
*)))
233 (sb-sys:with-pinned-objects
(arg)
234 (let ((result (alien-funcall (extern-alien "mkstemp"
235 (function int c-string
))
236 (sap-alien (sb-alien::vector-sap arg
)
238 (when (minusp result
)
241 (sb-ext:octets-to-string
243 :external-format sb-alien
::*default-c-string-external-format
*))))))
244 (define-call-internally ioctl-without-arg
"ioctl" int minusp
245 (fd file-descriptor
) (cmd int
))
246 (define-call-internally ioctl-with-int-arg
"ioctl" int minusp
247 (fd file-descriptor
) (cmd int
) (arg int
))
248 (define-call-internally ioctl-with-pointer-arg
"ioctl" int minusp
249 (fd file-descriptor
) (cmd int
)
250 (arg alien-pointer-to-anything-or-nil
))
251 (define-entry-point "ioctl" (fd cmd
&optional
(arg nil argp
))
254 ((alien int
) (ioctl-with-int-arg fd cmd arg
))
255 ((or (alien (* t
)) null
) (ioctl-with-pointer-arg fd cmd arg
)))
256 (ioctl-without-arg fd cmd
)))
257 (define-call-internally fcntl-without-arg
"fcntl" int minusp
258 (fd file-descriptor
) (cmd int
))
259 (define-call-internally fcntl-with-int-arg
"fcntl" int minusp
260 (fd file-descriptor
) (cmd int
) (arg int
))
261 (define-call-internally fcntl-with-pointer-arg
"fcntl" int minusp
262 (fd file-descriptor
) (cmd int
)
263 (arg alien-pointer-to-anything-or-nil
))
264 (define-entry-point "fcntl" (fd cmd
&optional
(arg nil argp
))
267 ((alien int
) (fcntl-with-int-arg fd cmd arg
))
268 ((or (alien (* t
)) null
) (fcntl-with-pointer-arg fd cmd arg
)))
269 (fcntl-without-arg fd cmd
)))
272 (define-call "geteuid" uid-t never-fails
) ; "always successful", it says
273 (define-call "getresuid" uid-t never-fails
)
274 (define-call "getuid" uid-t never-fails
)
275 (define-call "seteuid" int minusp
(uid uid-t
))
276 (define-call "setfsuid" int minusp
(uid uid-t
))
277 (define-call "setreuid" int minusp
(ruid uid-t
) (euid uid-t
))
278 (define-call "setresuid" int minusp
(ruid uid-t
) (euid uid-t
) (suid uid-t
))
279 (define-call "setuid" int minusp
(uid uid-t
))
280 (define-call "getegid" gid-t never-fails
)
281 (define-call "getgid" gid-t never-fails
)
282 (define-call "getresgid" gid-t never-fails
)
283 (define-call "setegid" int minusp
(gid gid-t
))
284 (define-call "setfsgid" int minusp
(gid gid-t
))
285 (define-call "setgid" int minusp
(gid gid-t
))
286 (define-call "setregid" int minusp
(rgid gid-t
) (egid gid-t
))
287 (define-call "setresgid" int minusp
(rgid gid-t
) (egid gid-t
) (sgid gid-t
))
289 ;; processes, signals
290 (define-call "alarm" int never-fails
(seconds unsigned
))
294 #+mach-exception-handler
296 ;; FIXME this is a lie, of course this can fail, but there's no
297 ;; error handling here yet!
298 (define-call "setup_mach_exceptions" void never-fails
)
299 (define-call ("posix_fork" :c-name
"fork") pid-t minusp
)
301 (let ((pid (posix-fork)))
303 (setup-mach-exceptions))
305 (export 'fork
:sb-posix
))
307 #-mach-exception-handler
308 (define-call "fork" pid-t minusp
)
310 (define-call "getpgid" pid-t minusp
(pid pid-t
))
311 (define-call "getppid" pid-t never-fails
)
312 (define-call "getpgrp" pid-t never-fails
)
313 (define-call "getsid" pid-t minusp
(pid pid-t
))
314 (define-call "kill" int minusp
(pid pid-t
) (signal int
))
315 (define-call "killpg" int minusp
(pgrp int
) (signal int
))
316 (define-call "pause" int minusp
)
317 (define-call "setpgid" int minusp
(pid pid-t
) (pgid pid-t
))
318 (define-call "setpgrp" int minusp
))
320 (defmacro with-growing-c-string
((buffer size
) &body body
)
321 (sb-int:with-unique-names
(c-string-block)
322 `(block ,c-string-block
324 (flet ((,buffer
(&optional
(size-incl-null))
326 (setf (sb-sys:sap-ref-8
(sb-alien:alien-sap
,buffer
) size-incl-null
)
328 (return-from ,c-string-block
329 (sb-alien::c-string-to-string
330 (sb-alien:alien-sap
,buffer
)
331 (sb-impl::default-external-format
)
333 (loop for
,size
= 128 then
(* 2 ,size
)
336 (setf ,buffer
(make-alien c-string
,size
))
339 (free-alien ,buffer
)))))))))
343 (export 'readlink
:sb-posix
)
344 (defun readlink (pathspec)
345 "Returns the resolved target of a symbolic link as a string."
346 (flet ((%readlink
(path buf length
)
348 (extern-alien "readlink" (function int c-string
(* t
) int
))
350 (with-growing-c-string (buf size
)
351 (let ((count (%readlink
(filename pathspec
) buf size
)))
352 (cond ((minusp count
)
358 (export 'getcwd
:sb-posix
)
360 "Returns the process's current working directory as a string."
361 (flet ((%getcwd
(buffer size
)
363 (extern-alien #-win32
"getcwd"
364 #+win32
"_getcwd" (function c-string
(* t
) int
))
366 (with-growing-c-string (buf size
)
367 (let ((result (%getcwd buf size
)))
370 ((/= (get-errno) sb-posix
:erange
)
371 (syscall-error))))))))
375 (export 'wait
:sb-posix
)
376 (declaim (inline wait
))
377 (defun wait (&optional statusptr
)
378 (declare (type (or null
(simple-array (signed-byte 32) (1))) statusptr
))
379 (let* ((ptr (or statusptr
(make-array 1 :element-type
'(signed-byte 32))))
380 (pid (sb-sys:with-pinned-objects
(ptr)
382 (extern-alien "wait" (function pid-t
(* int
)))
383 (sb-sys:vector-sap ptr
)))))
386 (values pid
(aref ptr
0))))))
390 (export 'waitpid
:sb-posix
)
391 (declaim (inline waitpid
))
392 (defun waitpid (pid options
&optional statusptr
)
393 (declare (type (sb-alien:alien pid-t
) pid
)
394 (type (sb-alien:alien int
) options
)
395 (type (or null
(simple-array (signed-byte 32) (1))) statusptr
))
396 (let* ((ptr (or statusptr
(make-array 1 :element-type
'(signed-byte 32))))
397 (pid (sb-sys:with-pinned-objects
(ptr)
399 (extern-alien "waitpid" (function pid-t
401 pid
(sb-sys:vector-sap ptr
) options
))))
404 (values pid
(aref ptr
0)))))
406 (define-call "wifexited" boolean never-fails
(status int
))
407 (define-call "wexitstatus" int never-fails
(status int
))
408 (define-call "wifsignaled" boolean never-fails
(status int
))
409 (define-call "wtermsig" int never-fails
(status int
))
410 (define-call "wifstopped" boolean never-fails
(status int
))
411 (define-call "wstopsig" int never-fails
(status int
))
412 #+nil
; see alien/waitpid-macros.c
413 (define-call "wifcontinued" boolean never-fails
(status int
)))
418 (define-call ("mmap" :options
:largefile
) sb-sys
:system-area-pointer
420 (= (sb-sys:sap-int res
) #.
(1- (expt 2 sb-vm
::n-machine-word-bits
))))
421 (addr sap-or-nil
) (length unsigned
) (prot unsigned
)
422 (flags unsigned
) (fd file-descriptor
) (offset off-t
))
424 (define-call "munmap" int minusp
425 (start sb-sys
:system-area-pointer
) (length unsigned
))
427 (define-call "msync" int minusp
428 (addr sb-sys
:system-area-pointer
) (length unsigned
) (flags int
)))
431 (define-call "getpagesize" int minusp
)
433 ;;; KLUDGE: This could be taken from GetSystemInfo
434 (export (defun getpagesize () 4096))
437 ;; The docstrings are copied from the descriptions in SUSv3,
440 (define-protocol-class passwd alien-passwd
()
441 ((name :initarg
:name
:accessor passwd-name
442 :documentation
"User's login name.")
443 ;; Note: SUSv3 doesn't require this member.
444 (passwd :initarg
:passwd
:accessor passwd-passwd
445 :documentation
"The account's encrypted password.")
446 (uid :initarg
:uid
:accessor passwd-uid
447 :documentation
"Numerical user ID.")
448 (gid :initarg
:gid
:accessor passwd-gid
449 :documentation
"Numerical group ID.")
450 ;; Note: SUSv3 doesn't require this member.
451 (gecos :initarg
:gecos
:accessor passwd-gecos
452 :documentation
"User's name or comment field.")
453 (dir :initarg
:dir
:accessor passwd-dir
454 :documentation
"Initial working directory.")
455 (shell :initarg
:shell
:accessor passwd-shell
456 :documentation
"Program to use as shell."))
457 (:documentation
"Instances of this class represent entries in
458 the system's user database."))
460 (defmacro define-pw-call
(name arg type
)
462 ;; FIXME: this isn't the documented way of doing this, surely?
463 (let ((lisp-name (intern (string-upcase name
) :sb-posix
)))
465 (export ',lisp-name
:sb-posix
)
466 (declaim (inline ,lisp-name
))
467 (defun ,lisp-name
(,arg
)
468 (let ((r (alien-funcall (extern-alien ,name
,type
) ,arg
)))
471 (alien-to-passwd r
)))))))
473 (define-pw-call "getpwnam" login-name
(function (* alien-passwd
) c-string
))
474 (define-pw-call "getpwuid" uid
(function (* alien-passwd
) uid-t
))
478 (define-protocol-class group alien-group
()
479 ((name :initarg
:name
:accessor group-name
)
480 (passwd :initarg
:passwd
:accessor group-passwd
)
481 (gid :initarg
:gid
:accessor group-gid
)))
483 (defmacro define-gr-call
(name arg type
)
485 ;; FIXME: this isn't the documented way of doing this, surely?
486 (let ((lisp-name (intern (string-upcase name
) :sb-posix
)))
488 (export ',lisp-name
:sb-posix
)
489 (declaim (inline ,lisp-name
))
490 (defun ,lisp-name
(,arg
)
491 (let ((r (alien-funcall (extern-alien ,name
,type
) ,arg
)))
494 (alien-to-group r
)))))))
496 (define-gr-call "getgrnam" login-name
(function (* alien-group
) c-string
))
497 (define-gr-call "getgrgid" gid
(function (* alien-group
) gid-t
))
501 (define-protocol-class timeval alien-timeval
()
502 ((sec :initarg
:tv-sec
:accessor timeval-sec
503 :documentation
"Seconds.")
504 (usec :initarg
:tv-usec
:accessor timeval-usec
505 :documentation
"Microseconds."))
506 (:documentation
"Instances of this class represent time values."))
508 (define-protocol-class stat alien-stat
()
509 ((mode :initarg
:mode
:reader stat-mode
510 :documentation
"Mode of file.")
511 (ino :initarg
:ino
:reader stat-ino
512 :documentation
"File serial number.")
513 (dev :initarg
:dev
:reader stat-dev
514 :documentation
"Device ID of device containing file.")
515 (nlink :initarg
:nlink
:reader stat-nlink
516 :documentation
"Number of hard links to the file.")
517 (uid :initarg
:uid
:reader stat-uid
518 :documentation
"User ID of file.")
519 (gid :initarg
:gid
:reader stat-gid
520 :documentation
"Group ID of file.")
521 (size :initarg
:size
:reader stat-size
522 :documentation
"For regular files, the file size in
523 bytes. For symbolic links, the length
524 in bytes of the filename contained in
526 (atime :initarg
:atime
:reader stat-atime
527 :documentation
"Time of last access.")
528 (mtime :initarg
:mtime
:reader stat-mtime
529 :documentation
"Time of last data modification.")
530 (ctime :initarg
:ctime
:reader stat-ctime
531 :documentation
"Time of last status change"))
532 (:documentation
"Instances of this class represent Posix file
535 (defmacro define-stat-call
(name arg designator-fun type
)
536 ;; FIXME: this isn't the documented way of doing this, surely?
537 (let ((lisp-name (lisp-for-c-symbol name
)))
539 (export ',lisp-name
:sb-posix
)
540 (declaim (inline ,lisp-name
))
541 (defun ,lisp-name
(,arg
&optional stat
)
542 (declare (type (or null stat
) stat
))
543 (with-alien-stat a-stat
()
544 (let ((r (alien-funcall
545 (extern-alien ,(real-c-name (list name
:options
:largefile
)) ,type
)
546 (,designator-fun
,arg
)
550 (alien-to-stat a-stat stat
)))))))
552 (define-stat-call #-win32
"stat" #+win32
"_stat"
554 (function int c-string
(* alien-stat
)))
557 (define-stat-call "lstat"
559 (function int c-string
(* alien-stat
)))
560 ;;; No symbolic links on Windows, so use stat
563 (declaim (inline lstat
))
564 (export (defun lstat (filename &optional stat
)
565 (if stat
(stat filename stat
) (stat filename
)))))
567 (define-stat-call #-win32
"fstat" #+win32
"_fstat"
569 (function int int
(* alien-stat
)))
573 (define-call "s_isreg" boolean never-fails
(mode mode-t
))
574 (define-call "s_isdir" boolean never-fails
(mode mode-t
))
575 (define-call "s_ischr" boolean never-fails
(mode mode-t
))
576 (define-call "s_isblk" boolean never-fails
(mode mode-t
))
577 (define-call "s_isfifo" boolean never-fails
(mode mode-t
))
578 (define-call "s_islnk" boolean never-fails
(mode mode-t
))
579 (define-call "s_issock" boolean never-fails
(mode mode-t
))
583 (export 'pipe
:sb-posix
)
584 (declaim (inline pipe
))
585 (defun pipe (&optional filedes2
)
586 (declare (type (or null
(simple-array (signed-byte 32) (2))) filedes2
))
588 (setq filedes2
(make-array 2 :element-type
'(signed-byte 32))))
589 (let ((r (sb-sys:with-pinned-objects
(filedes2)
591 ;; FIXME: (* INT)? (ARRAY INT 2) would be better
592 (extern-alien "pipe" (function int
(* int
)))
593 (sb-sys:vector-sap filedes2
)))))
596 (values (aref filedes2
0) (aref filedes2
1))))
599 (define-protocol-class termios alien-termios
()
600 ((iflag :initarg
:iflag
:accessor sb-posix
:termios-iflag
601 :documentation
"Input modes.")
602 (oflag :initarg
:oflag
:accessor sb-posix
:termios-oflag
603 :documentation
"Output modes.")
604 (cflag :initarg
:cflag
:accessor sb-posix
:termios-cflag
605 :documentation
"Control modes.")
606 (lflag :initarg
:lflag
:accessor sb-posix
:termios-lflag
607 :documentation
"Local modes.")
608 (cc :initarg
:cc
:accessor sb-posix
:termios-cc
:array-length nccs
609 :documentation
"Control characters"))
610 (:documentation
"Instances of this class represent I/O
611 characteristics of the terminal."))
615 (export 'tcsetattr
:sb-posix
)
616 (declaim (inline tcsetattr
))
617 (defun tcsetattr (fd actions termios
)
618 (declare (type termios termios
))
619 (with-alien-termios a-termios
()
620 (termios-to-alien termios a-termios
)
621 (let ((fd (file-descriptor fd
)))
622 (let* ((r (alien-funcall
625 (function int int int
(* alien-termios
)))
626 fd actions a-termios
)))
630 (export 'tcgetattr
:sb-posix
)
631 (declaim (inline tcgetattr
))
632 (defun tcgetattr (fd &optional termios
)
633 (declare (type (or null termios
) termios
))
634 (with-alien-termios a-termios
()
635 (let ((r (alien-funcall
636 (extern-alien "tcgetattr"
637 (function int int
(* alien-termios
)))
642 (setf termios
(alien-to-termios a-termios termios
))))
644 (export 'cfsetispeed
:sb-posix
)
645 (declaim (inline cfsetispeed
))
646 (defun cfsetispeed (speed &optional termios
)
647 (declare (type (or null termios
) termios
))
648 (with-alien-termios a-termios
()
649 (let ((r (alien-funcall
650 (extern-alien "cfsetispeed"
651 (function int
(* alien-termios
) speed-t
))
656 (setf termios
(alien-to-termios a-termios termios
))))
658 (export 'cfsetospeed
:sb-posix
)
659 (declaim (inline cfsetospeed
))
660 (defun cfsetospeed (speed &optional termios
)
661 (declare (type (or null termios
) termios
))
662 (with-alien-termios a-termios
()
663 (let ((r (alien-funcall
664 (extern-alien "cfsetospeed"
665 (function int
(* alien-termios
) speed-t
))
670 (setf termios
(alien-to-termios a-termios termios
))))
672 (export 'cfgetispeed
:sb-posix
)
673 (declaim (inline cfgetispeed
))
674 (defun cfgetispeed (termios)
675 (declare (type termios termios
))
676 (with-alien-termios a-termios
()
677 (termios-to-alien termios a-termios
)
678 (alien-funcall (extern-alien "cfgetispeed"
679 (function speed-t
(* alien-termios
)))
681 (export 'cfgetospeed
:sb-posix
)
682 (declaim (inline cfgetospeed
))
683 (defun cfgetospeed (termios)
684 (declare (type termios termios
))
685 (with-alien-termios a-termios
()
686 (termios-to-alien termios a-termios
)
687 (alien-funcall (extern-alien "cfgetospeed"
688 (function speed-t
(* alien-termios
)))
694 (export 'time
:sb-posix
)
696 (let ((result (alien-funcall (extern-alien "time"
697 (function time-t
(* time-t
)))
702 (export 'utime
:sb-posix
)
703 (defun utime (filename &optional access-time modification-time
)
704 (let ((fun (extern-alien "utime" (function int c-string
706 (name (filename filename
)))
707 (if (not (and access-time modification-time
))
708 (alien-funcall fun name nil
)
709 (with-alien ((utimbuf (struct alien-utimbuf
)))
710 (setf (slot utimbuf
'actime
) (or access-time
0)
711 (slot utimbuf
'modtime
) (or modification-time
0))
712 (let ((result (alien-funcall fun name
(alien-sap utimbuf
))))
716 (export 'utimes
:sb-posix
)
717 (defun utimes (filename &optional access-time modification-time
)
718 (flet ((seconds-and-useconds (time)
719 (multiple-value-bind (integer fractional
)
721 (values integer
(cl:truncate
(* fractional
1000000)))))
722 (maybe-syscall-error (value)
726 (let ((fun (extern-alien "utimes" (function int c-string
727 (* (array alien-timeval
2)))))
728 (name (filename filename
)))
729 (if (not (and access-time modification-time
))
730 (maybe-syscall-error (alien-funcall fun name nil
))
731 (with-alien ((buf (array alien-timeval
2)))
732 (let ((actime (deref buf
0))
733 (modtime (deref buf
1)))
734 (setf (values (slot actime
'sec
)
736 (seconds-and-useconds (or access-time
0))
737 (values (slot modtime
'sec
)
738 (slot modtime
'usec
))
739 (seconds-and-useconds (or modification-time
0)))
740 (maybe-syscall-error (alien-funcall fun name
741 (alien-sap buf
))))))))))
746 (export 'getenv
:sb-posix
)
748 (let ((r (alien-funcall
749 (extern-alien "getenv" (function (* char
) c-string
))
751 (declare (type (alien (* char
)) r
))
752 (unless (null-alien r
)
754 (define-call "putenv" int minusp
(string c-string
))
759 (export 'openlog
:sb-posix
)
760 (export 'syslog
:sb-posix
)
761 (export 'closelog
:sb-posix
)
762 (defun openlog (ident options
&optional
(facility log-user
))
763 (alien-funcall (extern-alien
764 "openlog" (function void c-string int int
))
765 ident options facility
))
766 (defun syslog (priority format
&rest args
)
767 "Send a message to the syslog facility, with severity level
768 PRIORITY. The message will be formatted as by CL:FORMAT (rather
769 than C's printf) with format string FORMAT and arguments ARGS."
770 (flet ((syslog1 (priority message
)
771 (alien-funcall (extern-alien
772 "syslog" (function void int c-string c-string
))
773 priority
"%s" message
)))
774 (syslog1 priority
(apply #'format nil format args
))))
775 (define-call "closelog" void never-fails
))