?  search:
summary | log | graphiclog1 | graphiclog2 | refs | edit | fork

80725e930f29443301d1be42e4a675802ac180b5
[iolib.git] / src / syscalls / ffi-functions-unix.lisp
blob80725e930f29443301d1be42e4a675802ac180b5
1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; --- *UNIX foreign function definitions.
4 ;;;
5
6 (in-package :iolib.syscalls)
7
8 (eval-when (:compile-toplevel)
9 (declaim (optimize (speed 3) (safety 1) (debug 1))))
10
11 ;; FIXME: move this into an ASDF operation
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13 (define-foreign-library libfixposix
14 (t (:default "libfixposix")))
15 (use-foreign-library libfixposix))
16
17 \f
18
19 ;;;-------------------------------------------------------------------------
20 ;;; ERRNO-related functions
21 ;;;-------------------------------------------------------------------------
22
23 (defcfun (errno "lfp_errno") :int)
24
25 (defun (setf errno) (value)
26 (foreign-funcall "lfp_set_errno" :int value :int))
27
28 (defsyscall (%strerror "lfp_strerror")
29 :int
30 (errnum :int)
31 (buf :pointer)
32 (buflen size-t))
33
34 (defentrypoint strerror (&optional (err (errno)))
35 "Look up the error message string for ERRNO (reentrant)."
36 (let ((errno
37 (if (keywordp err)
38 (foreign-enum-value 'errno-values err)
39 err)))
40 (with-foreign-pointer-as-string ((buf bufsiz) 1024)
41 (%strerror errno buf bufsiz))))
42
43 (defmethod print-object ((e syscall-error) s)
44 (with-slots (syscall code identifier message handle handle2) e
45 (print-unreadable-object (e s :type nil :identity nil)
46 (cond
47 (message
48 (format s "~A" message))
49 (t
50 (format s "Syscall ~S signalled error ~A(~S) ~S"
51 syscall identifier (or code "[No code]")
52 (or (strerror code) "[Can't get error string.]"))
53 (when handle (format s " FD=~A" handle))
54 (when handle2 (format s " FD2=~A" handle2)))))))
55 \f
56
57 ;;;-------------------------------------------------------------------------
58 ;;; Memory manipulation
59 ;;;-------------------------------------------------------------------------
60
61 (defcfun (memset "memset") :pointer
62 "Fill the first COUNT bytes of BUFFER with the constant VALUE."
63 (buffer :pointer)
64 (value :int)
65 (count size-t))
66
67 (defentrypoint bzero (buffer count)
68 "Fill the first COUNT bytes of BUFFER with zeros."
69 (memset buffer 0 count))
70
71 (defcfun (memcpy "memcpy") :pointer
72 "Copy COUNT octets from SRC to DEST.
73 The two memory areas must not overlap."
74 (dest :pointer)
75 (src :pointer)
76 (count size-t))
77
78 (defcfun (memmove "memmove") :pointer
79 "Copy COUNT octets from SRC to DEST.
80 The two memory areas may overlap."
81 (dest :pointer)
82 (src :pointer)
83 (count size-t))
84 \f
85
86 ;;;-------------------------------------------------------------------------
87 ;;; Files
88 ;;;-------------------------------------------------------------------------
89
90 (defsyscall (%open "lfp_open")
91 (:int :restart t)
92 (path sstring)
93 (flags :uint64)
94 (mode mode-t))
95
96 (defentrypoint open (path flags &optional (mode #o666))
97 "Open a file descriptor for PATH using FLAGS and permissions MODE(#o666 by default)."
98 (%open path flags mode))
99
100 (defsyscall (creat "lfp_creat")
101 (:int :restart t)
102 "Create file PATH with permissions MODE and return the new FD."
103 (path sstring)
104 (mode mode-t))
105
106 (defsyscall (%pipe "pipe") :int
107 (fds :pointer))
108
109 (defentrypoint pipe ()
110 "Create pipe, returns two values with the new FDs."
111 (with-foreign-object (fds :int 2)
112 (%pipe fds)
113 (values (mem-aref fds :int 0)
114 (mem-aref fds :int 1))))
115
116 (defsyscall (mkfifo "mkfifo") :int
117 "Create a FIFO (named pipe) with name PATH and permissions MODE."
118 (path sstring)
119 (mode mode-t))
120
121 (defsyscall (umask "umask") mode-t
122 "Sets the umask to NEW-MODE and returns the old one."
123 (new-mode mode-t))
124
125 (defsyscall (lseek "lfp_lseek")
126 (off-t :handle fd)
127 "Reposition the offset of the open file associated with the file descriptor FD
128 to the argument OFFSET according to the directive WHENCE."
129 (fd :int)
130 (offset off-t)
131 (whence :int))
132
133 (defsyscall (access "access") :int
134 "Check whether the file PATH can be accessed using mode MODE."
135 (path sstring)
136 (mode :int))
137
138 (defsyscall (truncate "lfp_truncate")
139 (:int :restart t)
140 "Truncate the file PATH to a size of precisely LENGTH octets."
141 (path sstring)
142 (length off-t))
143
144 (defsyscall (ftruncate "lfp_ftruncate")
145 (:int :restart t :handle fd)
146 "Truncate the file referenced by FD to a size of precisely LENGTH octets."
147 (fd :int)
148 (length off-t))
149
150 (defsyscall (rename "rename") :int
151 "Rename file named by OLDPATH to NEWPATH."
152 (oldpath sstring)
153 (newpath sstring))
154
155 (defsyscall (link "link") :int
156 "Create a hard link from file OLDPATH to NEWPATH."
157 (oldpath sstring)
158 (newpath sstring))
159
160 (defsyscall (symlink "symlink") :int
161 "Create a symbolic link from file OLDPATH to NEWPATH."
162 (oldpath sstring)
163 (newpath sstring))
164
165 (defsyscall (%readlink "readlink") ssize-t
166 (path sstring)
167 (buf :pointer)
168 (bufsize size-t))
169
170 (defentrypoint readlink (path)
171 "Read the file name pointed by the symbolic link PATH."
172 (with-foreign-pointer (buf +cstring-path-max+ bufsize)
173 (let ((count (%readlink path buf bufsize)))
174 (cstring-to-sstring buf count))))
175
176 (defsyscall (%realpath "realpath") sstring
177 (path sstring)
178 (resolved-path :pointer))
179
180 (defentrypoint realpath (path)
181 "Read the file name pointed by the symbolic link PATH."
182 (with-foreign-pointer (buf +cstring-path-max+)
183 (%realpath path buf)))
184
185 (defsyscall (unlink "unlink") :int
186 "Delete the file PATH from the file system."
187 (path sstring))
188
189 (defsyscall (chown "chown")
190 (:int :restart t)
191 "Change ownership of file PATH to uid OWNER and gid GROUP(dereferences symlinks)."
192 (path sstring)
193 (owner uid-t)
194 (group uid-t))
195
196 (defsyscall (fchown "fchown")
197 (:int :restart t :handle fd)
198 "Change ownership of an open file referenced by FD to uid OWNER and gid GROUP."
199 (fd :int)
200 (owner uid-t)
201 (group uid-t))
202
203 (defsyscall (lchown "lchown")
204 (:int :restart t)
205 "Change ownership of a file PATH to uid OWNER and gid GROUP(does not dereference symlinks)."
206 (path sstring)
207 (owner uid-t)
208 (group uid-t))
209
210 (defsyscall (chmod "chmod")
211 (:int :restart t)
212 "Change permissions of file PATH to mode MODE."
213 (path sstring)
214 (mode mode-t))
215
216 (defsyscall (fchmod "fchmod")
217 (:int :restart t :handle fd)
218 "Change permissions of open file referenced by FD to mode MODE."
219 (fd :int)
220 (mode mode-t))
221 \f
222
223 ;;;-------------------------------------------------------------------------
224 ;;; I/O
225 ;;;-------------------------------------------------------------------------
226
227 (defsyscall (read "read")
228 (ssize-t :restart t :handle fd)
229 "Read at most COUNT bytes from FD into the foreign area BUF."
230 (fd :int)
231 (buf :pointer)
232 (count size-t))
233
234 (defsyscall (write "write")
235 (ssize-t :restart t :handle fd)
236 "Write at most COUNT bytes to FD from the foreign area BUF."
237 (fd :int)
238 (buf :pointer)
239 (count size-t))
240
241 (defsyscall (readv "readv")
242 (ssize-t :restart t :handle fd)
243 "Read from FD into the first IOVCNT buffers of the IOV array."
244 (fd :int)
245 (iov :pointer)
246 (iovcnt :int))
247
248 (defsyscall (writev "writev")
249 (ssize-t :restart t :handle fd)
250 "Writes to FD the first IOVCNT buffers of the IOV array."
251 (fd :int)
252 (iov :pointer)
253 (iovcnt :int))
254
255 (defsyscall (pread "lfp_pread")
256 (ssize-t :restart t :handle fd)
257 "Read at most COUNT bytes from FD at offset OFFSET into the foreign area BUF."
258 (fd :int)
259 (buf :pointer)
260 (count size-t)
261 (offset off-t))
262
263 (defsyscall (pwrite "lfp_pwrite")
264 (ssize-t :restart t :handle fd)
265 "Write at most COUNT bytes to FD at offset OFFSET from the foreign area BUF."
266 (fd :int)
267 (buf :pointer)
268 (count size-t)
269 (offset off-t))
270
271 (defsyscall (sendfile "lfp_sendfile")
272 (ssize-t :restart t :handle infd :handle2 outfd)
273 (infd :int)
274 (outfd :int)
275 (offset off-t)
276 (nbytes size-t))
277 \f
278
279 ;;;-------------------------------------------------------------------------
280 ;;; Stat()
281 ;;;-------------------------------------------------------------------------
282
283 (define-c-struct-wrapper stat ())
284
285 (defsyscall (%stat "lfp_stat")
286 :int
287 (file-name sstring)
288 (buf :pointer))
289
290 (defsyscall (%fstat "lfp_fstat")
291 (:int :handle fd)
292 (fd :int)
293 (buf :pointer))
294
295 (defsyscall (%lstat "lfp_lstat")
296 :int
297 (file-name sstring)
298 (buf :pointer))
299
300 ;;; If necessary for performance reasons, we can add an optional
301 ;;; argument to this function and use that to reuse a wrapper object.
302 (defentrypoint funcall-stat (fn arg)
303 (with-foreign-object (buf 'stat)
304 (funcall fn arg buf)
305 (make-instance 'stat :pointer buf)))
306
307 (defentrypoint stat (path)
308 "Get information about file PATH(dereferences symlinks)."
309 (funcall-stat #'%stat path))
310
311 (defentrypoint fstat (fd)
312 "Get information about file descriptor FD."
313 (funcall-stat #'%fstat fd))
314
315 (defentrypoint lstat (path)
316 "Get information about file PATH(does not dereference symlinks)."
317 (funcall-stat #'%lstat path))
318
319 (defsyscall (sync "sync") :void
320 "Schedule all file system buffers to be written to disk.")
321
322 (defsyscall (fsync "fsync")
323 (:int :restart t)
324 "Schedule a file's buffers to be written to disk."
325 (fd :int))
326
327 (defsyscall (%mkstemp "lfp_mkstemp") :int
328 (template :pointer))
329
330 (defentrypoint mkstemp (&optional (template ""))
331 "Generate a unique temporary filename from TEMPLATE.
332 Return two values: the file descriptor and the path of the temporary file."
333 (let ((template (concatenate 'string template "XXXXXX")))
334 (with-sstring-to-cstring (ptr template)
335 (values (%mkstemp ptr) (cstring-to-sstring ptr)))))
336 \f
337
338 ;;;-------------------------------------------------------------------------
339 ;;; Directories
340 ;;;-------------------------------------------------------------------------
341
342 (defsyscall (mkdir "mkdir") :int
343 "Create directory PATH with permissions MODE."
344 (path sstring)
345 (mode mode-t))
346
347 (defsyscall (rmdir "rmdir") :int
348 "Delete directory PATH."
349 (path sstring))
350
351 (defsyscall (chdir "chdir") :int
352 "Change the current working directory to PATH."
353 (path sstring))
354
355 (defsyscall (fchdir "fchdir")
356 (:int :restart t :handle fd)
357 "Change the current working directory to the directory referenced by FD."
358 (fd :int))
359
360 (defsyscall (%getcwd "getcwd") :pointer
361 (buf :pointer)
362 (size size-t))
363
364 (defentrypoint getcwd ()
365 "Return the current working directory as a string."
366 (with-cstring-to-sstring (buf +cstring-path-max+ bufsize)
367 (%getcwd buf bufsize)))
368
369 (defsyscall (%mkdtemp "mkdtemp") sstring
370 (template sstring))
371
372 (defentrypoint mkdtemp (&optional (template ""))
373 "Generate a unique temporary filename from TEMPLATE."
374 (let ((template (concatenate 'string template "XXXXXX")))
375 (%mkdtemp template)))
376 \f
377
378 ;;;-------------------------------------------------------------------------
379 ;;; File Descriptors
380 ;;;-------------------------------------------------------------------------
381
382 (defsyscall (close "close")
383 (:int :handle fd)
384 "Close open file descriptor FD."
385 (fd :int))
386
387 (defsyscall (dup "dup")
388 (:int :handle fd)
389 "Duplicate file descriptor FD."
390 (fd :int))
391
392 (defsyscall (dup2 "dup2")
393 (:int :restart t :handle oldfd :handle2 newfd)
394 "Make NEWFD be the copy of OLDFD, closing NEWFD first if necessary."
395 (oldfd :int)
396 (newfd :int))
397
398 (defsyscall (%fcntl/noarg "fcntl")
399 (:int :handle fd)
400 (fd :int)
401 (cmd :int))
402
403 ;;; FIXME: Linux/glibc says ARG's type is long, POSIX says it's int.
404 ;;; Is this an issue?
405 (defsyscall (%fcntl/int "fcntl")
406 (:int :handle fd)
407 (fd :int)
408 (cmd :int)
409 (arg :int))
410
411 (defsyscall (%fcntl/pointer "fcntl")
412 (:int :handle fd)
413 (fd :int)
414 (cmd :int)
415 (arg :pointer))
416
417 (defentrypoint fcntl (fd cmd &optional (arg nil argp))
418 (cond
419 ((not argp) (%fcntl/noarg fd cmd))
420 ((integerp arg) (%fcntl/int fd cmd arg))
421 ((pointerp arg) (%fcntl/pointer fd cmd arg))
422 (t (error 'type-error :datum arg
423 :expected-type '(or null integer foreign-pointer)))))
424
425 (defsyscall (%ioctl/noarg "ioctl")
426 (:int :handle fd)
427 "Send request REQUEST to file referenced by FD."
428 (fd :int)
429 (request :unsigned-int))
430
431 (defsyscall (%ioctl/pointer "ioctl")
432 (:int :handle fd)
433 "Send request REQUEST to file referenced by FD using argument ARG."
434 (fd :int)
435 (request :unsigned-int)
436 (arg :pointer))
437
438 (defentrypoint ioctl (fd request &optional (arg nil argp))
439 "Control an I/O device."
440 (cond
441 ((not argp) (%ioctl/noarg fd request))
442 ((pointerp arg) (%ioctl/pointer fd request arg))
443 (t (error 'type-error :datum arg
444 :expected-type '(or null foreign-pointer)))))
445
446 (defsyscall (fd-cloexec-p "lfp_is_fd_cloexec") bool-designator
447 (fd :int))
448
449 (defsyscall (%set-fd-cloexec "lfp_set_fd_cloexec") :int
450 (fd :int)
451 (enabled bool-designator))
452
453 (defentrypoint (setf fd-cloexec-p) (enabled fd)
454 (%set-fd-cloexec fd enabled))
455
456 (defsyscall (fd-nonblock-p "lfp_is_fd_nonblock") bool-designator
457 (fd :int))
458
459 (defsyscall (%set-fd-nonblock "lfp_set_fd_nonblock") :int
460 (fd :int)
461 (enabled bool-designator))
462
463 (defentrypoint (setf fd-nonblock-p) (enabled fd)
464 (%set-fd-nonblock fd enabled))
465
466 (defsyscall (fd-open-p "lfp_is_fd_open") bool-designator
467 (fd :int))
468 \f
469
470 ;;;-------------------------------------------------------------------------
471 ;;; TTYs
472 ;;;-------------------------------------------------------------------------
473
474 (defsyscall (openpt "lfp_openpt") :int
475 (flags :uint64))
476
477 (defsyscall (grantpt "grantpt")
478 (:int :handle fd)
479 (fd :int))
480
481 (defsyscall (unlockpt "unlockpt")
482 (:int :handle fd)
483 (fd :int))
484
485 (defsyscall (%ptsname "lfp_ptsname")
486 (:pointer :handle fd)
487 (fd :int))
488
489 (defentrypoint ptsname (fd)
490 (let ((str (%ptsname fd)))
491 (unwind-protect
492 (nth-value 0 (foreign-string-to-lisp str))
493 (foreign-free str))))
494 \f
495
496 ;;;-------------------------------------------------------------------------
497 ;;; I/O polling
498 ;;;-------------------------------------------------------------------------
499
500 (defsyscall (select "lfp_select") :int
501 "Scan for I/O activity on multiple file descriptors."
502 (nfds :int)
503 (readfds :pointer)
504 (writefds :pointer)
505 (exceptfds :pointer)
506 (timeout :pointer))
507
508 (defentrypoint copy-fd-set (from to)
509 (memcpy to from (sizeof 'fd-set))
510 to)
511
512 (defcfun (fd-clr "lfp_fd_clr") :void
513 (fd :int)
514 (fd-set :pointer))
515
516 (defcfun (fd-isset "lfp_fd_isset") bool
517 (fd :int)
518 (fd-set :pointer))
519
520 (defcfun (fd-set "lfp_fd_set") :void
521 (fd :int)
522 (fd-set :pointer))
523
524 (defcfun (fd-zero "lfp_fd_zero") :void
525 (fd-set :pointer))
526
527 ;;; FIXME: Until a way to autodetect platform features is implemented
528 (eval-when (:compile-toplevel :load-toplevel :execute)
529 (unless (boundp 'pollrdhup)
530 (defconstant pollrdhup 0)))
531
532 (defsyscall (poll "poll") :int
533 "Scan for I/O activity on multiple file descriptors."
534 (fds :pointer)
535 (nfds nfds-t)
536 (timeout :int))
537
538 #+linux
539 (progn
540 (defsyscall (epoll-create "epoll_create") :int
541 "Open an epoll file descriptor."
542 (size :int))
543
544 (defsyscall (epoll-ctl "epoll_ctl")
545 (:int :handle epfd :handle2 fd)
546 "Control interface for an epoll descriptor."
547 (epfd :int)
548 (op :int)
549 (fd :int)
550 (event :pointer))
551
552 (defsyscall (epoll-wait "epoll_wait")
553 (:int :handle epfd)
554 "Wait for an I/O event on an epoll file descriptor."
555 (epfd :int)
556 (events :pointer)
557 (maxevents :int)
558 (timeout :int)))
559
560 #+bsd
561 (progn
562 (defsyscall (kqueue "kqueue") :int
563 "Open a kernel event queue.")
564
565 (defsyscall (kevent "kevent")
566 (:int :handle fd)
567 "Control interface for a kernel event queue."
568 (fd :int)
569 (changelist :pointer) ; const struct kevent *
570 (nchanges :int)
571 (eventlist :pointer) ; struct kevent *
572 (nevents :int)
573 (timeout :pointer)) ; const struct timespec *
574
575 (defentrypoint ev-set (%kev %ident %filter %flags %fflags %data %udata)
576 (with-foreign-slots ((ident filter flags fflags data udata) %kev kevent)
577 (setf ident %ident filter %filter flags %flags
578 fflags %fflags data %data udata %udata))))
579 \f
580
581 ;;;-------------------------------------------------------------------------
582 ;;; Socket message readers
583 ;;;-------------------------------------------------------------------------
584
585 (defcfun (cmsg.firsthdr "lfp_cmsg_firsthdr") :pointer
586 (msgh :pointer))
587
588 (defcfun (cmsg.nxthdr "lfp_cmsg_nxthdr") :pointer
589 (msgh :pointer)
590 (cmsg :pointer))
591
592 (defcfun (cmsg.space "lfp_cmsg_space") size-t
593 (length size-t))
594
595 (defcfun (cmsg.len "lfp_cmsg_len") size-t
596 (length size-t))
597
598 (defcfun (cmsg.data "lfp_cmsg_data") :pointer
599 (cmsg :pointer))
600 \f
601
602 ;;;-------------------------------------------------------------------------
603 ;;; Directory walking
604 ;;;-------------------------------------------------------------------------
605
606 (defsyscall (opendir "opendir") :pointer
607 "Open directory PATH for listing of its contents."
608 (path sstring))
609
610 (defsyscall (closedir "closedir") :int
611 "Close directory DIR when done listing its contents."
612 (dirp :pointer))
613
614 (defsyscall (%readdir "lfp_readdir") :int
615 (dirp :pointer)
616 (entry :pointer)
617 (result :pointer))
618
619 (defentrypoint readdir (dir)
620 "Reads an item from the listing of directory DIR (reentrant)."
621 (with-foreign-objects ((entry 'dirent) (result :pointer))
622 (%readdir dir entry result)
623 (if (null-pointer-p (mem-ref result :pointer))
624 nil
625 (with-foreign-slots ((name type fileno) entry dirent)
626 (values (cstring-to-sstring name) type fileno)))))
627
628 (defsyscall (rewinddir "rewinddir") :void
629 "Rewind directory DIR."
630 (dirp :pointer))
631
632 (defsyscall (seekdir "seekdir") :void
633 "Seek into directory DIR to position POS(as returned by TELLDIR)."
634 (dirp :pointer)
635 (pos :long))
636
637 ;;; FIXME: According to POSIX docs "no errors are defined" for
638 ;;; telldir() but Linux manpages specify a possible EBADF.
639 (defsyscall (telldir "telldir") off-t
640 "Return the current location in directory DIR."
641 (dirp :pointer))
642 \f
643
644 ;;;-------------------------------------------------------------------------
645 ;;; Memory mapping
646 ;;;-------------------------------------------------------------------------
647
648 (defsyscall (mmap "lfp_mmap")
649 (:pointer :handle fd)
650 "Map file referenced by FD at offset OFFSET into address space of the
651 calling process at address ADDR and length LENGTH.
652 PROT describes the desired memory protection of the mapping.
653 FLAGS determines whether updates to the mapping are visible to other
654 processes mapping the same region."
655 (addr :pointer)
656 (length size-t)
657 (prot :int)
658 (flags :int)
659 (fd :int)
660 (offset off-t))
661
662 (defsyscall (munmap "munmap") :int
663 "Unmap pages of memory starting at address ADDR with length LENGTH."
664 (addr :pointer)
665 (length size-t))
666 \f
667
668 ;;;-------------------------------------------------------------------------
669 ;;; Process creation and info
670 ;;;-------------------------------------------------------------------------
671
672 (defsyscall (fork "fork") pid-t)
673
674 (defsyscall (execv "execv") :int
675 (path sstring)
676 (argv :pointer))
677
678 (defsyscall (%waitpid "waitpid") pid-t
679 (pid pid-t)
680 (status :pointer)
681 (options :int))
682
683 (defentrypoint waitpid (pid options)
684 (with-foreign-pointer (status (sizeof :int))
685 (let ((ret (%waitpid pid status options)))
686 (values ret (mem-ref status :int)))))
687
688 (defsyscall (getpid "getpid") pid-t
689 "Returns the process id of the current process")
690
691 (defsyscall (getppid "getppid") pid-t
692 "Returns the process id of the current process's parent")
693
694 #+linux
695 (defentrypoint gettid ()
696 (foreign-funcall "syscall" :int sys-gettid :int))
697
698 (defsyscall (getuid "getuid") uid-t
699 "Get real user id of the current process.")
700
701 (defsyscall (setuid "setuid") :int
702 "Set real user id of the current process to UID."
703 (uid uid-t))
704
705 (defsyscall (geteuid "geteuid") uid-t
706 "Get effective user id of the current process.")
707
708 (defsyscall (seteuid "seteuid") :int
709 "Set effective user id of the current process to UID."
710 (uid uid-t))
711
712 (defsyscall (getgid "getgid") gid-t
713 "Get real group id of the current process.")
714
715 (defsyscall (setgid "setgid") :int
716 "Set real group id of the current process to GID."
717 (gid gid-t))
718
719 (defsyscall (getegid "getegid") gid-t
720 "Get effective group id of the current process.")
721
722 (defsyscall (setegid "setegid") :int
723 "Set effective group id of the current process to GID."
724 (gid gid-t))
725
726 (defsyscall (setreuid "setreuid") :int
727 "Set real and effective user id of the current process to RUID and EUID."
728 (ruid uid-t)
729 (euid uid-t))
730
731 (defsyscall (setregid "setregid") :int
732 "Set real and effective group id of the current process to RGID and EGID."
733 (rgid gid-t)
734 (egid gid-t))
735
736 (defsyscall (getpgid "getpgid") pid-t
737 "Get process group id of process PID."
738 (pid pid-t))
739
740 (defsyscall (setpgid "setpgid") :int
741 "Set process group id of process PID to value PGID."
742 (pid pid-t)
743 (pgid pid-t))
744
745 (defsyscall (getpgrp "getpgrp") pid-t
746 "Get process group id of the current process.")
747
748 (defsyscall (setpgrp "setpgrp") pid-t
749 "Set process group id of the current process.")
750
751 (defsyscall (setsid "setsid") pid-t
752 "Create session and set process group id of the current process.")
753
754 (defsyscall (%getrlimit "lfp_getrlimit")
755 :int
756 (resource :int)
757 (rlimit :pointer))
758
759 (defentrypoint getrlimit (resource)
760 "Return soft and hard limit of system resource RESOURCE."
761 (with-foreign-object (rl 'rlimit)
762 (with-foreign-slots ((cur max) rl rlimit)
763 (%getrlimit resource rl)
764 (values cur max))))
765
766 (defsyscall (%setrlimit "lfp_setrlimit")
767 :int
768 (resource :int)
769 (rlimit :pointer))
770
771 (defentrypoint setrlimit (resource soft-limit hard-limit)
772 "Set SOFT-LIMIT and HARD-LIMIT of system resource RESOURCE."
773 (with-foreign-object (rl 'rlimit)
774 (with-foreign-slots ((cur max) rl rlimit)
775 (setf cur soft-limit
776 max hard-limit)
777 (%setrlimit resource rl))))
778
779 (defsyscall (%getrusage "getrusage") :int
780 (who :int)
781 (usage :pointer))
782
783 ;;; TODO: it might be more convenient to return a wrapper object here
784 ;;; instead like we do in STAT.
785 (defentrypoint getrusage (who)
786 "Return resource usage measures of WHO."
787 (with-foreign-object (ru 'rusage)
788 (%getrusage who ru)
789 (with-foreign-slots ((maxrss ixrss idrss isrss minflt majflt nswap inblock
790 oublock msgsnd msgrcv nsignals nvcsw nivcsw)
791 ru rusage)
792 (values (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
793 'timeval 'sec)
794 (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
795 'timeval 'usec)
796 (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
797 'timeval 'sec)
798 (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
799 'timeval 'usec)
800 maxrss ixrss idrss isrss minflt majflt
801 nswap inblock oublock msgsnd
802 msgrcv nsignals nvcsw nivcsw))))
803
804 (defsyscall (getpriority "getpriority") :int
805 "Get the scheduling priority of a process, process group, or user,
806 as indicated by WHICH and WHO."
807 (which :int)
808 (who :int))
809
810 (defsyscall (setpriority "setpriority") :int
811 "Set the scheduling priority of a process, process group, or user,
812 as indicated by WHICH and WHO to VALUE."
813 (which :int)
814 (who :int)
815 (value :int))
816
817 (defentrypoint nice (&optional (increment 0))
818 "Get or set process priority."
819 ;; FIXME: race condition. might need WITHOUT-INTERRUPTS on some impl.s
820 (setf (errno) 0)
821 (let ((retval (foreign-funcall "nice" :int increment :int))
822 (errno (errno)))
823 (if (and (= retval -1) (/= errno 0))
824 (signal-syscall-error errno "nice")
825 retval)))
826
827 (defsyscall (exit "_exit") :void
828 "terminate the calling process"
829 (status :int))
830
831 \f
832
833 ;;;-------------------------------------------------------------------------
834 ;;; Signals
835 ;;;-------------------------------------------------------------------------
836
837 (defsyscall (kill "kill") :int
838 "Send signal SIG to process PID."
839 (pid pid-t)
840 (signum signal))
841
842 (defsyscall (sigaction "sigaction") :int
843 (signum :int)
844 (act :pointer)
845 (oldact :pointer))
846
847 (defentrypoint wifexited (status)
848 (plusp (foreign-funcall "lfp_wifexited" :int status :int)))
849
850 (defentrypoint wexitstatus (status)
851 (foreign-funcall "lfp_wexitstatus" :int status :int))
852
853 (defentrypoint wifsignaled (status)
854 (plusp (foreign-funcall "lfp_wifsignaled" :int status :int)))
855
856 (defentrypoint wtermsig (status)
857 (foreign-funcall "lfp_wtermsig" :int status :int))
858
859 (defentrypoint wtermsig* (status)
860 (foreign-enum-keyword 'signal (wtermsig status)))
861
862 (defentrypoint wcoredump (status)
863 (plusp (foreign-funcall "lfp_wcoredump" :int status :int)))
864
865 (defentrypoint wifstopped (status)
866 (plusp (foreign-funcall "lfp_wifstopped" :int status :int)))
867
868 (defentrypoint wstopsig (status)
869 (foreign-funcall "lfp_wstopsig" :int status :int))
870
871 (defentrypoint wifcontinued (status)
872 (plusp (foreign-funcall "lfp_wifcontinued" :int status :int)))
873 \f
874
875 ;;;-------------------------------------------------------------------------
876 ;;; Time
877 ;;;-------------------------------------------------------------------------
878
879 (defsyscall (usleep "usleep") :int
880 "Suspend execution for USECONDS microseconds."
881 (useconds useconds-t))
882
883 (defsyscall (%clock-getres "lfp_clock_getres") :int
884 "Returns the resolution of the clock CLOCKID."
885 (clockid clockid-t)
886 (res :pointer))
887
888 (defentrypoint clock-getres (clock-id)
889 (with-foreign-object (ts 'timespec)
890 (with-foreign-slots ((sec nsec) ts timespec)
891 (%clock-getres clock-id ts)
892 (values sec nsec))))
893
894 (defsyscall (%clock-gettime "lfp_clock_gettime") :int
895 (clockid clockid-t)
896 (tp :pointer))
897
898 (defentrypoint clock-gettime (clock-id)
899 "Returns the time of the clock CLOCKID."
900 (with-foreign-object (ts 'timespec)
901 (with-foreign-slots ((sec nsec) ts timespec)
902 (%clock-gettime clock-id ts)
903 (values sec nsec))))
904
905 (defsyscall (%clock-settime "lfp_clock_settime") :int
906 (clockid clockid-t)
907 (tp :pointer))
908
909 (defentrypoint clock-settime (clock-id)
910 "Sets the time of the clock CLOCKID."
911 (with-foreign-object (ts 'timespec)
912 (with-foreign-slots ((sec nsec) ts timespec)
913 (%clock-settime clock-id ts)
914 (values sec nsec))))
915
916 ;; FIXME: replace it with clock_gettime(CLOCK_MONOTONIC, ...)
917 (defentrypoint get-monotonic-time ()
918 "Gets current time in seconds from a system's monotonic clock."
919 (multiple-value-bind (seconds nanoseconds)
920 (clock-gettime clock-monotonic)
921 (+ seconds (/ nanoseconds 1d9))))
922 \f
923
924 ;;;-------------------------------------------------------------------------
925 ;;; Environment
926 ;;;-------------------------------------------------------------------------
927
928 (defsyscall (os-environ "lfp_get_environ") :pointer
929 "Return a pointer to the current process environment.")
930
931 (defmacro %obsolete-*environ* ()
932 (iolib.base::signal-obsolete '*environ* "use function OS-ENVIRON instead"
933 "symbol macro" :WARN)
934 `(os-environ))
935
936 (define-symbol-macro *environ* (%obsolete-*environ*))
937
938 (defentrypoint getenv (name)
939 "Returns the value of environment variable NAME."
940 (when (and (pointerp name) (null-pointer-p name))
941 (setf (errno) einval)
942 (signal-syscall-error einval "getenv"))
943 (foreign-funcall "getenv" :string name :string))
944
945 (defsyscall (setenv "setenv") :int
946 "Changes the value of environment variable NAME to VALUE.
947 The environment variable is overwritten only if overwrite is not NIL."
948 (name :string)
949 (value :string)
950 (overwrite bool-designator))
951
952 (defsyscall (unsetenv "unsetenv") :int
953 "Removes the binding of environment variable NAME."
954 (name :string))
955
956 ;; FIXME: move into libfixposix
957 (defentrypoint clearenv ()
958 "Remove all name-value pairs from the environment set the
959 OS environment to NULL."
960 (let ((envptr (os-environ)))
961 (unless (null-pointer-p envptr)
962 (loop :for i :from 0 :by 1
963 :for string := (mem-aref envptr :string i)
964 :for name := (subseq string 0 (position #\= string))
965 :while name :do (unsetenv name))
966 (setf (mem-ref envptr :pointer) (null-pointer)))
967 (values)))
968 \f
969
970 ;;;-------------------------------------------------------------------------
971 ;;; Hostname info
972 ;;;-------------------------------------------------------------------------
973
974 (defsyscall (%gethostname "gethostname") :int
975 (name :pointer)
976 (namelen size-t))
977
978 (defentrypoint gethostname ()
979 "Return the host name of the current machine."
980 (with-foreign-pointer-as-string ((cstr size) 256)
981 (%gethostname cstr size)))
982
983 (defsyscall (%getdomainname "getdomainname") :int
984 (name :pointer)
985 (namelen size-t))
986
987 (defentrypoint getdomainname ()
988 "Return the domain name of the current machine."
989 (with-foreign-pointer-as-string ((cstr size) 256)
990 (%getdomainname cstr size)))
991
992 (defsyscall (%uname "uname") :int
993 (buf :pointer))
994
995 (defentrypoint uname ()
996 "Get name and information about current kernel."
997 (with-foreign-object (buf 'utsname)
998 (bzero buf (sizeof 'utsname))
999 (%uname buf)
1000 (macrolet ((utsname-slot (name)
1001 `(foreign-string-to-lisp
1002 (foreign-slot-pointer buf 'utsname ',name))))
1003 (values (utsname-slot sysname)
1004 (utsname-slot nodename)
1005 (utsname-slot release)
1006 (utsname-slot version)
1007 (utsname-slot machine)))))
1008 \f
1009
1010 ;;;-------------------------------------------------------------------------
1011 ;;; User info
1012 ;;;-------------------------------------------------------------------------
1013
1014 (defsyscall (%getpwuid-r "getpwuid_r")
1015 (:int
1016 :error-predicate plusp
1017 :error-location :return)
1018 (uid uid-t)
1019 (pwd :pointer)
1020 (buffer :pointer)
1021 (bufsize size-t)
1022 (result :pointer))
1023
1024 (defsyscall (%getpwnam-r "getpwnam_r")
1025 (:int
1026 :error-predicate plusp
1027 :error-location :return)
1028 (name :string)
1029 (pwd :pointer)
1030 (buffer :pointer)
1031 (bufsize size-t)
1032 (result :pointer))
1033
1034 (defun funcall-getpw (fn arg)
1035 (with-foreign-objects ((pw 'passwd) (pwp :pointer))
1036 (with-foreign-pointer (buf +cstring-path-max+ bufsize)
1037 (with-foreign-slots ((name passwd uid gid gecos dir shell) pw passwd)
1038 (funcall fn arg pw buf bufsize pwp)
1039 (if (null-pointer-p (mem-ref pwp :pointer))
1040 nil
1041 (values name passwd uid gid gecos dir shell))))))
1042
1043 (defentrypoint getpwuid (uid)
1044 "Gets the passwd info of a user, by user id (reentrant)."
1045 (funcall-getpw #'%getpwuid-r uid))
1046
1047 (defentrypoint getpwnam (name)
1048 "Gets the passwd info of a user, by username (reentrant)."
1049 (funcall-getpw #'%getpwnam-r name))
1050 \f
1051
1052 ;;;-------------------------------------------------------------------------
1053 ;;; Group info
1054 ;;;-------------------------------------------------------------------------
1055
1056 (defsyscall (%getgrgid-r "getgrgid_r")
1057 (:int
1058 :error-predicate plusp
1059 :error-location :return)
1060 (uid uid-t)
1061 (grp :pointer)
1062 (buffer :pointer)
1063 (bufsize size-t)
1064 (result :pointer))
1065
1066 (defsyscall (%getgrnam-r "getgrnam_r")
1067 (:int
1068 :error-predicate plusp
1069 :error-location :return)
1070 (name :string)
1071 (grp :pointer)
1072 (buffer :pointer)
1073 (bufsize size-t)
1074 (result :pointer))
1075
1076 ;; FIXME: return group members too
1077 (defun funcall-getgr (fn arg)
1078 (with-foreign-objects ((gr 'group) (grp :pointer))
1079 (with-foreign-pointer (buf +cstring-path-max+ bufsize)
1080 (with-foreign-slots ((name passwd gid) gr group)
1081 (funcall fn arg gr buf bufsize grp)
1082 (if (null-pointer-p (mem-ref grp :pointer))
1083 nil
1084 (values name passwd gid))))))
1085
1086 (defentrypoint getgrgid (gid)
1087 "Gets a group info, by group id (reentrant)."
1088 (funcall-getgr #'%getgrgid-r gid))
1089
1090 (defentrypoint getgrnam (name)
1091 "Gets a group info, by group name (reentrant)."
1092 (funcall-getgr #'%getgrnam-r name))
1093 \f
1094
1095 ;;;-------------------------------------------------------------------------
1096 ;;; Syslog
1097 ;;;-------------------------------------------------------------------------
1098
1099 (defsyscall (openlog "lfp_openlog") :void
1100 "Opens a connection to the system logger for a program."
1101 (ident :string)
1102 (option :int)
1103 (facility :int))
1104
1105 (defsyscall (%syslog "lfp_syslog") :void
1106 "Generates a log message, which will be distributed by syslogd."
1107 (priority :int)
1108 (format :string)
1109 (message :string))
1110
1111 (defentrypoint syslog (priority format &rest args)
1112 "Generates a log message, which will be distributed by syslogd.
1113 Using a FORMAT string and ARGS for lisp-side message formating."
1114 (with-foreign-string (c-string (apply #'format nil format args))
1115 (%syslog priority "%s" c-string)))
1116
1117 (defsyscall (closelog "lfp_closelog") :void
1118 "Closes the descriptor being used to write to the system logger (optional).")
1119
1120 (defsyscall (setlogmask "lfp_setlogmask") :int
1121 "Set the log mask level."
1122 (mask :int))
1123
1124 (defsyscall (log-mask "lfp_log_mask") :int
1125 "Log mask corresponding to PRIORITY."
1126 (priority :int))
1127
1128 (defsyscall (log-upto "lfp_log_upto") :int
1129 "Log mask upto and including PRIORITY."
1130 (priority :int))
1131
1132 (defmacro with-syslog ((identity &key (options log-ndelay) (facility log-daemon))
1133 &body body)
1134 `(unwind-protect
1135 (progn
1136 (openlog ,identity ,options ,facility)
1137 ,@body)
1138 (closelog)))
Common Lisp I/O library