src/syscalls/ffi-functions-unix.lisp

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