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 ;; KLUDGE: Splice out :ARRAY-LENGTH options (they're
12 ;; for the conversion functions, not for DEFCLASS).
13 for array-length-option
= (member :array-length slotd
)
14 collect
(append (ldiff slotd array-length-option
)
15 (cddr array-length-option
)))
17 (declaim (inline ,to-alien
,to-protocol
))
18 (declaim (inline ,to-protocol
,to-alien
))
19 (defun ,to-protocol
(alien &optional instance
)
20 (declare (type (sb-alien:alien
(* ,alien-type
)) alien
)
21 (type (or null
,name
) instance
))
23 (setf instance
(make-instance ',name
)))
24 ,@(loop for slotd in slots
25 ;; FIXME: slotds in source are more complicated in general
27 ;; FIXME: baroque construction of intricate fragility
28 for array-length
= (getf (cdr slotd
) :array-length
)
31 (let ((array (make-array ,array-length
)))
32 (setf (slot-value instance
',(car slotd
))
34 (dotimes (i ,array-length
)
37 (sb-alien:slot alien
',(car slotd
))
40 collect
`(setf (slot-value instance
',(car slotd
))
41 (sb-alien:slot alien
',(car slotd
))))
43 (defun ,to-alien
(instance &optional alien
)
44 (declare (type (or null
(sb-alien:alien
(* ,alien-type
))) alien
)
45 (type ,name instance
))
47 (setf alien
(sb-alien:make-alien
,alien-type
)))
48 ,@(loop for slotd in slots
49 for array-length
= (getf (cdr slotd
) :array-length
)
52 (let ((array (slot-value instance
',(car slotd
))))
53 (dotimes (i ,array-length
)
55 (sb-alien:slot alien
',(car slotd
))
59 collect
`(setf (sb-alien:slot alien
',(car slotd
))
60 (slot-value instance
',(car slotd
)))))
61 (find-class ',name
))))
63 (define-condition sb-posix
:syscall-error
(error)
64 ((errno :initarg
:errno
:reader sb-posix
:syscall-errno
)
65 (name :initarg
:name
:initform nil
:reader sb-posix
:syscall-name
))
66 (:report
(lambda (c s
)
67 (let ((errno (sb-posix:syscall-errno c
))
68 (name (sb-posix:syscall-name c
)))
70 (format s
"Error in ~S: ~A (~A)"
72 (sb-int:strerror errno
)
74 (format s
"Error in syscall: ~A (~A)"
75 (sb-int:strerror errno
)
78 (declaim (ftype (function (&optional symbol
) nil
) syscall-error
))
79 (defun syscall-error (&optional name
)
80 (error 'sb-posix
:syscall-error
84 (defun unsupported-error (lisp-name c-name
)
85 (error "~S is unsupported by SBCL on this platform due to lack of ~A()."
88 (defun unsupported-warning (lisp-name c-name
)
89 (warn "~S is unsupported by SBCL on this platform due to lack of ~A()."
92 (declaim (inline never-fails
))
93 (defun never-fails (&rest args
)
94 (declare (ignore args
))
97 ;;; Some systems may need C-level wrappers, which can live in the
98 ;;; runtime (so that save-lisp-and-die can produce standalone
99 ;;; executables). See REAL-C-NAME in macros.lisp for the use of this
101 (eval-when (:compile-toplevel
:load-toplevel
)
102 (setf *c-functions-in-runtime
*
103 #+netbsd
'("stat" "lstat" "fstat" "readdir" "opendir")
107 ;;; filesystem access
108 (defmacro define-call
* (name &rest arguments
)
109 #-win32
`(define-call ,name
,@arguments
)
110 #+win32
`(define-call ,(if (consp name
)
111 `(,(concatenate 'string
"_" (car name
))
113 (concatenate 'string
"_" name
))
116 (define-call* "access" int minusp
(pathname filename
) (mode int
))
117 (define-call* "chdir" int minusp
(pathname filename
))
118 (define-call* "chmod" int minusp
(pathname filename
) (mode mode-t
))
119 (define-call* "close" int minusp
(fd file-descriptor
))
120 (define-call* "creat" int minusp
(pathname filename
) (mode mode-t
))
121 (define-call* "dup" int minusp
(oldfd file-descriptor
))
122 (define-call* "dup2" int minusp
(oldfd file-descriptor
)
123 (newfd file-descriptor
))
124 (define-call* ("lseek" :options
:largefile
)
125 off-t minusp
(fd file-descriptor
) (offset off-t
)
127 (define-call* "mkdir" int minusp
(pathname filename
) (mode mode-t
))
130 (define-call-internally open-with-mode
,x int minusp
131 (pathname filename
) (flags int
) (mode mode-t
))
132 (define-call-internally open-without-mode
,x int minusp
133 (pathname filename
) (flags int
))
134 (define-entry-point ,x
135 (pathname flags
&optional
(mode nil mode-supplied
))
137 (open-with-mode pathname flags mode
)
138 (open-without-mode pathname flags
))))))
139 (def #-win32
"open" #+win32
"_open"))
140 (define-call* "read" int minusp
141 (fd file-descriptor
) (buf (* t
)) (count int
))
142 (define-call "rename" int minusp
(oldpath filename
) (newpath filename
))
143 (define-call* "rmdir" int minusp
(pathname filename
))
144 (define-call* "unlink" int minusp
(pathname filename
))
145 (define-call #-netbsd
"opendir" #+netbsd
"_opendir"
146 (* t
) null-alien
(pathname filename
))
147 (define-call* "write" int minusp
148 (fd file-descriptor
) (buf (* t
)) (count int
))
150 (define-call ("readdir" :c-name
"readdir$INODE64" :options
:largefile
)
152 ;; readdir() has the worst error convention in the world. It's just
153 ;; too painful to support. (return is NULL _and_ errno "unchanged"
154 ;; is not an error, it's EOF).
158 (define-call (#-netbsd
"readdir" #+netbsd
"_readdir" :options
:largefile
)
160 ;; readdir() has the worst error convention in the world. It's just
161 ;; too painful to support. (return is NULL _and_ errno "unchanged"
162 ;; is not an error, it's EOF).
165 (define-call "closedir" int minusp
(dir (* t
)))
166 ;; need to do this here because we can't do it in the DEFPACKAGE
167 (define-call* "umask" mode-t never-fails
(mode mode-t
))
168 (define-call* "getpid" pid-t never-fails
)
172 (define-call "chown" int minusp
(pathname filename
)
173 (owner uid-t
) (group gid-t
))
174 (define-call "chroot" int minusp
(pathname filename
))
175 (define-call "fchdir" int minusp
(fd file-descriptor
))
176 (define-call "fchmod" int minusp
(fd file-descriptor
) (mode mode-t
))
177 (define-call "fchown" int minusp
(fd file-descriptor
)
178 (owner uid-t
) (group gid-t
))
179 (define-call "fdatasync" int minusp
(fd file-descriptor
))
180 (define-call ("ftruncate" :options
:largefile
)
181 int minusp
(fd file-descriptor
) (length off-t
))
182 (define-call "fsync" int minusp
(fd file-descriptor
))
183 (define-call "lchown" int minusp
(pathname filename
)
184 (owner uid-t
) (group gid-t
))
185 (define-call "link" int minusp
(oldpath filename
) (newpath filename
))
186 (define-call "lockf" int minusp
(fd file-descriptor
) (cmd int
) (len off-t
))
187 (define-call "mkfifo" int minusp
(pathname filename
) (mode mode-t
))
188 (define-call "symlink" int minusp
(oldpath filename
) (newpath filename
))
189 (define-call "sync" void never-fails
)
190 (define-call ("truncate" :options
:largefile
)
191 int minusp
(pathname filename
) (length off-t
))
193 (macrolet ((def-mk*temp
(lisp-name c-name result-type errorp dirp values
)
194 (declare (ignore dirp
))
195 (if (sb-sys:find-foreign-symbol-address c-name
)
197 (defun ,lisp-name
(template)
198 (let* ((external-format sb-alien
::*default-c-string-external-format
*)
199 (arg (sb-ext:string-to-octets
201 :external-format external-format
203 (sb-sys:with-pinned-objects
(arg)
204 ;; accommodate for the call-by-reference
205 ;; nature of mks/dtemp's template strings.
206 (let ((result (alien-funcall (extern-alien ,c-name
207 (function ,result-type system-area-pointer
))
208 (sb-alien::vector-sap arg
))))
209 (when (,errorp result
)
210 (syscall-error ',lisp-name
))
211 ;; FIXME: We'd rather return pathnames, but other
212 ;; SB-POSIX functions like this return strings...
213 (let ((pathname (sb-ext:octets-to-string
214 arg
:external-format external-format
215 :end
(1- (length arg
)))))
217 '(values result pathname
)
219 (export ',lisp-name
))
221 (defun ,lisp-name
(template)
222 (declare (ignore template
))
223 (unsupported-error ',lisp-name
,c-name
))
224 (define-compiler-macro ,lisp-name
(&whole form template
)
225 (declare (ignore template
))
226 (unsupported-warning ',lisp-name
,c-name
)
228 (export ',lisp-name
)))))
229 ;; FIXME: The man page for it says "Never use mktemp()"
230 (def-mk*temp mktemp
"mktemp" (* char
) null-alien nil nil
)
231 ;; FIXME: Windows does have _mktemp, which has a slightly different
233 (def-mk*temp mkstemp
"mkstemp" int minusp nil t
)
234 ;; FIXME: What about Windows?
235 (def-mk*temp mkdtemp
"mkdtemp" (* char
) null-alien t nil
))
236 (define-call-internally ioctl-without-arg
"ioctl" int minusp
237 (fd file-descriptor
) (cmd int
))
238 (define-call-internally ioctl-with-int-arg
"ioctl" int minusp
239 (fd file-descriptor
) (cmd int
) (arg int
))
240 (define-call-internally ioctl-with-pointer-arg
"ioctl" int minusp
241 (fd file-descriptor
) (cmd int
)
242 (arg alien-pointer-to-anything-or-nil
))
243 (define-entry-point "ioctl" (fd cmd
&optional
(arg nil argp
))
246 ((alien int
) (ioctl-with-int-arg fd cmd arg
))
247 ((or (alien (* t
)) null
) (ioctl-with-pointer-arg fd cmd arg
)))
248 (ioctl-without-arg fd cmd
)))
249 (define-call-internally fcntl-without-arg
"fcntl" int minusp
250 (fd file-descriptor
) (cmd int
))
251 (define-call-internally fcntl-with-int-arg
"fcntl" int minusp
252 (fd file-descriptor
) (cmd int
) (arg int
))
253 (define-call-internally fcntl-with-pointer-arg
"fcntl" int minusp
254 (fd file-descriptor
) (cmd int
)
255 (arg alien-pointer-to-anything-or-nil
))
256 (define-protocol-class flock alien-flock
()
257 ((type :initarg
:type
:accessor flock-type
258 :documentation
"Type of lock; F_RDLCK, F_WRLCK, F_UNLCK.")
259 (whence :initarg
:whence
:accessor flock-whence
260 :documentation
"Flag for starting offset.")
261 (start :initarg
:start
:accessor flock-start
262 :documentation
"Relative offset in bytes.")
263 (len :initarg
:len
:accessor flock-len
264 :documentation
"Size; if 0 then until EOF.")
265 ;; Note: PID isn't initable, and is read-only. But other stuff in
266 ;; SB-POSIX right now loses when a protocol-class slot is unbound,
267 ;; so we initialize it to 0.
268 (pid :initform
0 :reader flock-pid
270 "Process ID of the process holding the lock; returned with F_GETLK."))
271 (:documentation
"Class representing locks used in fcntl(2)."))
272 (define-entry-point "fcntl" (fd cmd
&optional
(arg nil argp
))
275 ((alien int
) (fcntl-with-int-arg fd cmd arg
))
276 ((or (alien (* t
)) null
) (fcntl-with-pointer-arg fd cmd arg
))
277 (flock (with-alien-flock a-flock
()
278 (flock-to-alien arg a-flock
)
279 (let ((r (fcntl-with-pointer-arg fd cmd a-flock
)))
280 (alien-to-flock a-flock arg
)
282 (fcntl-without-arg fd cmd
)))
285 (define-call "geteuid" uid-t never-fails
) ; "always successful", it says
287 (define-call "getresuid" uid-t never-fails
)
288 (define-call "getuid" uid-t never-fails
)
289 (define-call "seteuid" int minusp
(uid uid-t
))
291 (define-call "setfsuid" int minusp
(uid uid-t
))
292 (define-call "setreuid" int minusp
(ruid uid-t
) (euid uid-t
))
294 (define-call "setresuid" int minusp
(ruid uid-t
) (euid uid-t
) (suid uid-t
))
295 (define-call "setuid" int minusp
(uid uid-t
))
296 (define-call "getegid" gid-t never-fails
)
297 (define-call "getgid" gid-t never-fails
)
299 (define-call "getresgid" gid-t never-fails
)
300 (define-call "setegid" int minusp
(gid gid-t
))
302 (define-call "setfsgid" int minusp
(gid gid-t
))
303 (define-call "setgid" int minusp
(gid gid-t
))
304 (define-call "setregid" int minusp
(rgid gid-t
) (egid gid-t
))
306 (define-call "setresgid" int minusp
(rgid gid-t
) (egid gid-t
) (sgid gid-t
))
308 ;; processes, signals
309 (define-call "alarm" int never-fails
(seconds unsigned
))
311 ;; exit and abort, not much point inlining these
312 (define-simple-call abort void
)
313 (define-simple-call exit void
(status int
))
314 (define-simple-call _exit void
(status int
))
316 ;; FIXME this is a lie, of course this can fail, but there's no
317 ;; error handling here yet!
318 #+mach-exception-handler
319 (define-call "setup_mach_exceptions" void never-fails
)
320 (define-call ("posix_fork" :c-name
"fork") pid-t minusp
)
322 "Forks the current process, returning 0 in the new process and the PID of
323 the child process in the parent. Forking while multiple threads are running is
326 (sb-thread::with-all-threads-lock
327 (when (cdr sb-thread
::*all-threads
*)
329 (let ((pid (posix-fork)))
330 #+mach-exception-handler
332 (setup-mach-exceptions))
333 (return-from fork pid
)))
335 (error "Cannot fork with multiple threads running.")))
336 (export 'fork
:sb-posix
)
338 (define-call "getpgid" pid-t minusp
(pid pid-t
))
339 (define-call "getppid" pid-t never-fails
)
340 (define-call "getpgrp" pid-t never-fails
)
341 (define-call "getsid" pid-t minusp
(pid pid-t
))
342 (define-call "kill" int minusp
(pid pid-t
) (signal int
))
343 (define-call "killpg" int minusp
(pgrp int
) (signal int
))
344 (define-call "pause" int minusp
)
345 (define-call "setpgid" int minusp
(pid pid-t
) (pgid pid-t
))
346 (define-call "setpgrp" int minusp
)
347 (define-call "setsid" pid-t minusp
))
349 (defmacro with-growing-c-string
((buffer size
) &body body
)
350 (sb-int:with-unique-names
(c-string-block)
351 `(block ,c-string-block
353 (flet ((,buffer
(&optional
(size-incl-null))
355 (setf (sb-sys:sap-ref-8
(sb-alien:alien-sap
,buffer
) size-incl-null
)
357 (return-from ,c-string-block
358 (sb-alien::c-string-to-string
359 (sb-alien:alien-sap
,buffer
)
360 (sb-impl::default-external-format
)
362 (loop for
,size
= 128 then
(* 2 ,size
)
365 (setf ,buffer
(make-alien c-string
,size
))
368 (free-alien ,buffer
)))))))))
372 (export 'readlink
:sb-posix
)
373 (defun readlink (pathspec)
374 "Returns the resolved target of a symbolic link as a string."
375 (flet ((%readlink
(path buf length
)
377 (extern-alien "readlink" (function int
(c-string :not-null t
) (* t
) int
))
379 (with-growing-c-string (buf size
)
380 (let ((count (%readlink
(filename pathspec
) buf size
)))
381 (cond ((minusp count
)
382 (syscall-error 'readlink
))
387 (export 'getcwd
:sb-posix
)
389 "Returns the process's current working directory as a string."
390 (flet ((%getcwd
(buffer size
)
392 (extern-alien #-win32
"getcwd"
393 #+win32
"_getcwd" (function c-string
(* t
) int
))
395 (with-growing-c-string (buf size
)
396 (let ((result (%getcwd buf size
)))
399 ((/= (get-errno) sb-posix
:erange
)
400 (syscall-error 'getcwd
))))))))
404 (export 'wait
:sb-posix
)
405 (declaim (inline wait
))
406 (defun wait (&optional statusptr
)
407 (declare (type (or null
(simple-array (signed-byte 32) (1))) statusptr
))
408 (let* ((ptr (or statusptr
(make-array 1 :element-type
'(signed-byte 32))))
409 (pid (sb-sys:with-pinned-objects
(ptr)
411 (extern-alien "wait" (function pid-t
(* int
)))
412 (sb-sys:vector-sap ptr
)))))
414 (syscall-error 'wait
)
415 (values pid
(aref ptr
0))))))
419 (export 'waitpid
:sb-posix
)
420 (declaim (inline waitpid
))
421 (defun waitpid (pid options
&optional statusptr
)
422 (declare (type (sb-alien:alien pid-t
) pid
)
423 (type (sb-alien:alien int
) options
)
424 (type (or null
(simple-array (signed-byte 32) (1))) statusptr
))
425 (let* ((ptr (or statusptr
(make-array 1 :element-type
'(signed-byte 32))))
426 (pid (sb-sys:with-pinned-objects
(ptr)
428 (extern-alien "waitpid" (function pid-t
430 pid
(sb-sys:vector-sap ptr
) options
))))
432 (syscall-error 'waitpid
)
433 (values pid
(aref ptr
0)))))
435 (define-call "wifexited" boolean never-fails
(status int
))
436 (define-call "wexitstatus" int never-fails
(status int
))
437 (define-call "wifsignaled" boolean never-fails
(status int
))
438 (define-call "wtermsig" int never-fails
(status int
))
439 (define-call "wifstopped" boolean never-fails
(status int
))
440 (define-call "wstopsig" int never-fails
(status int
))
441 #+nil
; see alien/waitpid-macros.c
442 (define-call "wifcontinued" boolean never-fails
(status int
)))
447 (define-call ("mmap" :options
:largefile
) sb-sys
:system-area-pointer
449 (= (sb-sys:sap-int res
) #.
(1- (expt 2 sb-vm
::n-machine-word-bits
))))
450 (addr sap-or-nil
) (length size-t
) (prot unsigned
)
451 (flags unsigned
) (fd file-descriptor
) (offset off-t
))
453 (define-call "munmap" int minusp
454 (start sb-sys
:system-area-pointer
) (length unsigned
))
457 (define-call "msync" int minusp
458 (addr sb-sys
:system-area-pointer
) (length unsigned
) (flags int
)))
461 ;; No attempt is made to offer a full mmap-like interface on Windows.
462 ;; It would be possible to do so (and has been done by AK on his
463 ;; branch), but the use case is unclear to me. However, the following
464 ;; definitions are needed to keep existing code in sb-simple-streams
466 (defconstant PROT-READ
#x02
)
467 (defconstant PROT-WRITE
#x04
)
468 (defconstant PROT-EXEC
#x10
)
469 (defconstant PROT-NONE
0)
470 (defconstant MAP-SHARED
0)
471 (defconstant MAP-PRIVATE
1)
472 (defconstant MS-ASYNC nil
)
473 (defconstant MS-SYNC nil
)
474 (export ;export on the fly like define-call
475 (defun msync (address length flags
)
476 (declare (ignore flags
))
477 (when (zerop (sb-win32:flush-view-of-file address length
))
478 (sb-win32::win32-error
"FlushViewOfFile")))))
480 ;;; mlockall, munlockall
481 (define-call "mlockall" int minusp
(flags int
))
482 (define-call "munlockall" int minusp
)
485 (define-call "getpagesize" int minusp
)
487 ;;; KLUDGE: This could be taken from GetSystemInfo
488 (export (defun getpagesize () 4096))
491 ;; The docstrings are copied from the descriptions in SUSv3,
494 (define-protocol-class passwd alien-passwd
()
495 ((name :initarg
:name
:accessor passwd-name
496 :documentation
"User's login name.")
497 ;; Note: SUSv3 doesn't require this member.
498 (passwd :initarg
:passwd
:accessor passwd-passwd
499 :documentation
"The account's encrypted password.")
500 (uid :initarg
:uid
:accessor passwd-uid
501 :documentation
"Numerical user ID.")
502 (gid :initarg
:gid
:accessor passwd-gid
503 :documentation
"Numerical group ID.")
504 ;; Note: SUSv3 doesn't require this member.
505 (gecos :initarg
:gecos
:accessor passwd-gecos
506 :documentation
"User's name or comment field.")
507 (dir :initarg
:dir
:accessor passwd-dir
508 :documentation
"Initial working directory.")
509 (shell :initarg
:shell
:accessor passwd-shell
510 :documentation
"Program to use as shell."))
512 "Instances of this class represent entries in the system's user database."))
516 (define-protocol-class group alien-group
()
517 ((name :initarg
:name
:accessor group-name
)
518 (passwd :initarg
:passwd
:accessor group-passwd
)
519 (gid :initarg
:gid
:accessor group-gid
)))
521 (defmacro define-obj-call
(name arg type conv
)
523 ;; FIXME: this isn't the documented way of doing this, surely?
524 (let ((lisp-name (intern (string-upcase name
) :sb-posix
)))
526 (export ',lisp-name
:sb-posix
)
527 (declaim (inline ,lisp-name
))
528 (defun ,lisp-name
(,arg
)
529 (let ((r (alien-funcall (extern-alien ,name
,type
) ,arg
)))
534 (define-obj-call "getpwnam" login-name
(function (* alien-passwd
) (c-string :not-null t
))
536 (define-obj-call "getpwuid" uid
(function (* alien-passwd
) uid-t
)
538 (define-obj-call "getgrnam" login-name
(function (* alien-group
) (c-string :not-null t
))
540 (define-obj-call "getgrgid" gid
(function (* alien-group
) gid-t
)
545 (define-protocol-class timeval alien-timeval
()
546 ((sec :initarg
:tv-sec
:accessor timeval-sec
547 :documentation
"Seconds.")
548 (usec :initarg
:tv-usec
:accessor timeval-usec
549 :documentation
"Microseconds."))
550 (:documentation
"Instances of this class represent time values."))
552 (define-protocol-class stat alien-stat
()
553 ((mode :initarg
:mode
:reader stat-mode
554 :documentation
"Mode of file.")
555 (ino :initarg
:ino
:reader stat-ino
556 :documentation
"File serial number.")
557 (dev :initarg
:dev
:reader stat-dev
558 :documentation
"Device ID of device containing file.")
559 (nlink :initarg
:nlink
:reader stat-nlink
560 :documentation
"Number of hard links to the file.")
561 (uid :initarg
:uid
:reader stat-uid
562 :documentation
"User ID of file.")
563 (gid :initarg
:gid
:reader stat-gid
564 :documentation
"Group ID of file.")
565 (size :initarg
:size
:reader stat-size
566 :documentation
"For regular files, the file size in
567 bytes. For symbolic links, the length
568 in bytes of the filename contained in
570 (rdev :initarg
:rdev
:reader stat-rdev
571 :documentation
"For devices the device number.")
572 (atime :initarg
:atime
:reader stat-atime
573 :documentation
"Time of last access.")
574 (mtime :initarg
:mtime
:reader stat-mtime
575 :documentation
"Time of last data modification.")
576 (ctime :initarg
:ctime
:reader stat-ctime
577 :documentation
"Time of last status change."))
578 (:documentation
"Instances of this class represent POSIX file metadata."))
580 (defmacro define-stat-call
(name arg designator-fun type
)
581 ;; FIXME: this isn't the documented way of doing this, surely?
582 (let ((lisp-name (lisp-for-c-symbol name
))
583 (real-name #+inode64
(format nil
"~A$INODE64" name
)
586 (export ',lisp-name
:sb-posix
)
587 (declaim (inline ,lisp-name
))
588 (defun ,lisp-name
(,arg
&optional stat
)
589 (declare (type (or null stat
) stat
))
590 (with-alien-stat a-stat
()
591 (let ((r (alien-funcall
592 (extern-alien ,(real-c-name (list real-name
:options
:largefile
)) ,type
)
593 (,designator-fun
,arg
)
596 (syscall-error ',lisp-name
))
597 (alien-to-stat a-stat stat
)))))))
599 (define-stat-call #-win32
"stat" #+win32
"_stat"
601 (function int
(c-string :not-null t
) (* alien-stat
)))
604 (define-stat-call "lstat"
606 (function int
(c-string :not-null t
) (* alien-stat
)))
607 ;;; No symbolic links on Windows, so use stat
610 (declaim (inline lstat
))
611 (export (defun lstat (filename &optional stat
)
612 (if stat
(stat filename stat
) (stat filename
)))))
614 (define-stat-call #-win32
"fstat" #+win32
"_fstat"
616 (function int int
(* alien-stat
)))
620 (define-call "s_isreg" boolean never-fails
(mode mode-t
))
621 (define-call "s_isdir" boolean never-fails
(mode mode-t
))
622 (define-call "s_ischr" boolean never-fails
(mode mode-t
))
623 (define-call "s_isblk" boolean never-fails
(mode mode-t
))
624 (define-call "s_isfifo" boolean never-fails
(mode mode-t
))
625 (define-call "s_islnk" boolean never-fails
(mode mode-t
))
626 (define-call "s_issock" boolean never-fails
(mode mode-t
))
630 (export 'pipe
:sb-posix
)
631 (declaim (inline pipe
))
632 (defun pipe (&optional filedes2
)
633 (declare (type (or null
(simple-array (signed-byte 32) (2))) filedes2
))
635 (setq filedes2
(make-array 2 :element-type
'(signed-byte 32))))
636 (let ((r (sb-sys:with-pinned-objects
(filedes2)
638 ;; FIXME: (* INT)? (ARRAY INT 2) would be better
639 (extern-alien "pipe" (function int
(* int
)))
640 (sb-sys:vector-sap filedes2
)))))
642 (syscall-error 'pipe
)))
643 (values (aref filedes2
0) (aref filedes2
1))))
646 (define-protocol-class termios alien-termios
()
647 ((iflag :initarg
:iflag
:accessor sb-posix
:termios-iflag
648 :documentation
"Input modes.")
649 (oflag :initarg
:oflag
:accessor sb-posix
:termios-oflag
650 :documentation
"Output modes.")
651 (cflag :initarg
:cflag
:accessor sb-posix
:termios-cflag
652 :documentation
"Control modes.")
653 (lflag :initarg
:lflag
:accessor sb-posix
:termios-lflag
654 :documentation
"Local modes.")
655 (cc :initarg
:cc
:accessor sb-posix
:termios-cc
:array-length nccs
656 :documentation
"Control characters."))
658 "Instances of this class represent I/O characteristics of the terminal."))
662 (export 'tcsetattr
:sb-posix
)
663 (declaim (inline tcsetattr
))
664 (defun tcsetattr (fd actions termios
)
665 (declare (type termios termios
))
666 (with-alien-termios a-termios
()
667 (termios-to-alien termios a-termios
)
668 (let ((fd (file-descriptor fd
)))
669 (let* ((r (alien-funcall
672 (function int int int
(* alien-termios
)))
673 fd actions a-termios
)))
675 (syscall-error 'tcsetattr
)))
677 (export 'tcgetattr
:sb-posix
)
678 (declaim (inline tcgetattr
))
679 (defun tcgetattr (fd &optional termios
)
680 (declare (type (or null termios
) termios
))
681 (with-alien-termios a-termios
()
682 (let ((r (alien-funcall
683 (extern-alien "tcgetattr"
684 (function int int
(* alien-termios
)))
688 (syscall-error 'tcgetattr
))
689 (setf termios
(alien-to-termios a-termios termios
))))
691 (define-call "tcdrain" int minusp
(fd file-descriptor
))
692 (define-call "tcflow" int minusp
(fd file-descriptor
) (action int
))
693 (define-call "tcflush" int minusp
(fd file-descriptor
) (queue-selector int
))
694 (define-call "tcgetsid" pid-t minusp
(fd file-descriptor
))
695 (define-call "tcsendbreak" int minusp
(fd file-descriptor
) (duration int
))
696 (export 'cfsetispeed
:sb-posix
)
697 (declaim (inline cfsetispeed
))
698 (defun cfsetispeed (speed &optional termios
)
699 (declare (type (or null termios
) termios
))
700 (with-alien-termios a-termios
()
701 (let ((r (alien-funcall
702 (extern-alien "cfsetispeed"
703 (function int
(* alien-termios
) speed-t
))
707 (syscall-error 'cfsetispeed
))
708 (setf termios
(alien-to-termios a-termios termios
))))
710 (export 'cfsetospeed
:sb-posix
)
711 (declaim (inline cfsetospeed
))
712 (defun cfsetospeed (speed &optional termios
)
713 (declare (type (or null termios
) termios
))
714 (with-alien-termios a-termios
()
715 (let ((r (alien-funcall
716 (extern-alien "cfsetospeed"
717 (function int
(* alien-termios
) speed-t
))
721 (syscall-error 'cfsetospeed
))
722 (setf termios
(alien-to-termios a-termios termios
))))
724 (export 'cfgetispeed
:sb-posix
)
725 (declaim (inline cfgetispeed
))
726 (defun cfgetispeed (termios)
727 (declare (type termios termios
))
728 (with-alien-termios a-termios
()
729 (termios-to-alien termios a-termios
)
730 (alien-funcall (extern-alien "cfgetispeed"
731 (function speed-t
(* alien-termios
)))
733 (export 'cfgetospeed
:sb-posix
)
734 (declaim (inline cfgetospeed
))
735 (defun cfgetospeed (termios)
736 (declare (type termios termios
))
737 (with-alien-termios a-termios
()
738 (termios-to-alien termios a-termios
)
739 (alien-funcall (extern-alien "cfgetospeed"
740 (function speed-t
(* alien-termios
)))
746 (export 'time
:sb-posix
)
748 (let ((result (alien-funcall (extern-alien "time"
749 (function time-t
(* time-t
)))
752 (syscall-error 'time
)
754 (export 'utime
:sb-posix
)
755 (defun utime (filename &optional access-time modification-time
)
756 (let ((fun (extern-alien #-netbsd
"utime" #+netbsd
"_utime"
757 (function int
(c-string :not-null t
)
759 (name (filename filename
)))
760 (if (not (and access-time modification-time
))
761 (alien-funcall fun name nil
)
762 (with-alien ((utimbuf (struct alien-utimbuf
)))
763 (setf (slot utimbuf
'actime
) (or access-time
0)
764 (slot utimbuf
'modtime
) (or modification-time
0))
765 (let ((result (alien-funcall fun name
(alien-sap utimbuf
))))
767 (syscall-error 'utime
)
769 (export 'utimes
:sb-posix
)
770 (defun utimes (filename &optional access-time modification-time
)
771 (flet ((seconds-and-useconds (time)
772 (multiple-value-bind (integer fractional
)
774 (values integer
(cl:truncate
(* fractional
1000000)))))
775 (maybe-syscall-error (value)
777 (syscall-error 'utimes
)
779 (let ((fun (extern-alien "sb_utimes" (function int
(c-string :not-null t
)
780 (* (array alien-timeval
2)))))
781 (name (filename filename
)))
782 (if (not (and access-time modification-time
))
783 (maybe-syscall-error (alien-funcall fun name nil
))
784 (with-alien ((buf (array alien-timeval
2)))
785 (let ((actime (deref buf
0))
786 (modtime (deref buf
1)))
787 (setf (values (slot actime
'sec
)
789 (seconds-and-useconds (or access-time
0))
790 (values (slot modtime
'sec
)
791 (slot modtime
'usec
))
792 (seconds-and-useconds (or modification-time
0)))
793 (maybe-syscall-error (alien-funcall fun name
794 (alien-sap buf
))))))))))
799 (eval-when (:compile-toplevel
:load-toplevel
)
800 ;; Do this at compile-time as Win32 code below refers to it as
802 (export 'getenv
:sb-posix
))
804 (let ((r (alien-funcall
805 (extern-alien "getenv" (function (* char
) (c-string :not-null t
)))
807 (declare (type (alien (* char
)) r
))
808 (unless (null-alien r
)
812 (define-call "setenv" int minusp
813 (name (c-string :not-null t
))
814 (value (c-string :not-null t
))
816 (define-call "unsetenv" int minusp
(name (c-string :not-null t
)))
817 (export 'putenv
:sb-posix
)
818 (defun putenv (string)
819 (declare (string string
))
820 ;; We don't want to call actual putenv: the string passed to putenv ends
821 ;; up in environ, and we any string we allocate GC might move.
823 ;; This makes our wrapper nonconformant if you squit hard enough, but
824 ;; users who care about that should really be calling putenv() directly in
825 ;; order to be able to manage memory sanely.
826 (let ((p (position #\
= string
))
830 (unsetenv (subseq string
0 p
))
831 (setenv (subseq string
0 p
) (subseq string
(1+ p
)) 1))
832 (error "Invalid argument to putenv: ~S" string
)))))
835 ;; Windows doesn't define a POSIX setenv, but happily their _putenv is sane.
836 (define-call* "putenv" int minusp
(string (c-string :not-null t
)))
837 (export 'setenv
:sb-posix
)
838 (defun setenv (name value overwrite
)
839 (declare (string name value
))
840 (if (and (zerop overwrite
) (sb-posix:getenv name
))
842 (putenv (concatenate 'string name
"=" value
))))
843 (export 'unsetenv
:sb-posix
)
844 (defun unsetenv (name)
845 (declare (string name
))
846 (putenv (concatenate 'string name
"="))))
851 (export 'openlog
:sb-posix
)
852 (export 'syslog
:sb-posix
)
853 (export 'closelog
:sb-posix
)
854 (defun openlog (ident options
&optional
(facility log-user
))
855 (alien-funcall (extern-alien
856 "openlog" (function void
(c-string :not-null t
) int int
))
857 ident options facility
))
858 (defun syslog (priority format
&rest args
)
859 "Send a message to the syslog facility, with severity level
860 PRIORITY. The message will be formatted as by CL:FORMAT (rather
861 than C's printf) with format string FORMAT and arguments ARGS."
862 (flet ((syslog1 (priority message
)
863 (alien-funcall (extern-alien
864 "syslog" (function void int
865 (c-string :not-null t
)
866 (c-string :not-null t
)))
867 priority
"%s" message
)))
868 (syslog1 priority
(apply #'format nil format args
))))
869 (define-call "closelog" void never-fails
))