syscalls/ffi-functions-unix.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- *UNIX foreign function definitions.
   4 ;;;
   5
   6 (in-package :iolib.syscalls)
   7
   8 ;;; Needed for clock_gettime() and friends.
   9 (eval-when (:compile-toplevel :load-toplevel :execute)
  10   (define-foreign-library librt
  11     (:linux "librt.so"))
  12   (use-foreign-library librt))
  13 \f
  14
  15 ;;;-------------------------------------------------------------------------
  16 ;;; ERRNO-related functions
  17 ;;;-------------------------------------------------------------------------
  18
  19 (defentrypoint (setf %sys-errno) (value)
  20   "Set errno value."
  21   (%%sys-set-errno value))
  22
  23 (defsyscall (%%sys-strerror-r (#+linux "__xpg_strerror_r" "strerror_r"))
  24     :int
  25   (errnum :int)
  26   (buf    :string)
  27   (buflen size-t))
  28
  29 (defentrypoint %sys-strerror (&optional (err (%sys-errno)))
  30   "Look up the error message string for ERRNO (reentrant)."
  31   (let ((errno
  32          (if (keywordp err)
  33              (foreign-enum-value 'errno-values err)
  34              err)))
  35     (with-foreign-pointer-as-string ((buf bufsiz) 1024)
  36       (%%sys-strerror-r errno buf bufsiz))))
  37
  38 (defmethod print-object ((e posix-error) stream)
  39   (print-unreadable-object (e stream :type nil :identity nil)
  40     (let ((code (code-of e))
  41           (identifier (identifier-of e)))
  42       (format stream "System-Error ~A(~S) ~S"
  43               identifier (or code "[No code]")
  44               (or (%sys-strerror code) "[Can't get error string.]")))))
  45 \f
  46
  47 ;;;-------------------------------------------------------------------------
  48 ;;; Memory manipulation
  49 ;;;-------------------------------------------------------------------------
  50
  51 (defcfun* (%sys-memset "memset") :pointer
  52   "Fill the first COUNT bytes of BUFFER with the constant VALUE."
  53   (buffer :pointer)
  54   (value  :int)
  55   (count  size-t))
  56
  57 (defentrypoint %sys-bzero (buffer count)
  58   "Fill the first COUNT bytes of BUFFER with zeros."
  59   (%sys-memset buffer 0 count))
  60
  61 (defcfun* (%sys-memcpy "memcpy") :pointer
  62   "Copy COUNT octets from SRC to DEST.
  63 The two memory areas must not overlap."
  64   (dest :pointer)
  65   (src  :pointer)
  66   (count size-t))
  67
  68 (defcfun* (%sys-memmove "memmove") :pointer
  69   "Copy COUNT octets from SRC to DEST.
  70 The two memory areas may overlap."
  71   (dest :pointer)
  72   (src  :pointer)
  73   (count size-t))
  74 \f
  75
  76 ;;;-------------------------------------------------------------------------
  77 ;;; I/O
  78 ;;;-------------------------------------------------------------------------
  79
  80 (defsyscall (%sys-read "read")
  81     (ssize-t :restart t)
  82   "Read at most COUNT bytes from FD into the foreign area BUF."
  83   (fd    :int)
  84   (buf   :pointer)
  85   (count size-t))
  86
  87 (defsyscall (%sys-write "write")
  88     (ssize-t :restart t)
  89   "Write at most COUNT bytes to FD from the foreign area BUF."
  90   (fd    :int)
  91   (buf   :pointer)
  92   (count size-t))
  93
  94 (defsyscall (%sys-pread (#+linux "pread64" "pread"))
  95     (ssize-t :restart t)
  96   "Read at most COUNT bytes from FD at offset OFFSET into the foreign area BUF."
  97   (fd     :int)
  98   (buf    :pointer)
  99   (count  size-t)
 100   (offset off-t))
 101
 102 (defsyscall (%sys-pwrite (#+linux "pwrite64" "pwrite"))
 103     (ssize-t :restart t)
 104   "Write at most COUNT bytes to FD at offset OFFSET from the foreign area BUF."
 105   (fd     :int)
 106   (buf    :pointer)
 107   (count  size-t)
 108   (offset off-t))
 109 \f
 110
 111 ;;;-------------------------------------------------------------------------
 112 ;;; Files
 113 ;;;-------------------------------------------------------------------------
 114
 115 (defsyscall (%%sys-open "open")
 116     (:int :restart t)
 117   (path  filename-designator)
 118   (flags :int)
 119   (mode  mode-t))
 120
 121 (defvar *default-open-mode* #o666)
 122
 123 (defentrypoint %sys-open (path flags &optional (mode *default-open-mode*))
 124   "Open a file descriptor for PATH using FLAGS and permissions MODE
 125 \(default value is *DEFAULT-OPEN-MODE* - #o666)."
 126   (%%sys-open path flags mode))
 127
 128 (defsyscall (%sys-creat "creat")
 129     (:int :restart t)
 130   "Create file PATH with permissions MODE and return the new FD."
 131   (path filename-designator)
 132   (mode mode-t))
 133
 134 (defsyscall (%%sys-pipe "pipe") :int
 135   (filedes :pointer))
 136
 137 (defentrypoint %sys-pipe ()
 138   "Create pipe, returns two values with the new FDs."
 139   (with-foreign-object (filedes :int 2)
 140     (%%sys-pipe filedes)
 141     (values (mem-aref filedes :int 0)
 142             (mem-aref filedes :int 1))))
 143
 144 (defsyscall (%sys-mkfifo "mkfifo") :int
 145   "Create a FIFO (named pipe) with name PATH and permissions MODE."
 146   (path filename-designator)
 147   (mode mode-t))
 148
 149 (defsyscall (%sys-umask "umask") mode-t
 150   "Sets the umask to NEW-MODE and returns the old one."
 151   (new-mode mode-t))
 152
 153 (defsyscall (%sys-lseek (#+linux "lseek64" "lseek"))
 154     off-t
 155   "Reposition the offset of the open file associated with the file descriptor FD
 156 to the argument OFFSET according to the directive WHENCE."
 157   (fd     :int)
 158   (offset off-t)
 159   (whence :int))
 160
 161 (defsyscall (%sys-access "access") :int
 162   "Check whether the file PATH can be accessed using mode MODE."
 163   (path filename-designator)
 164   (mode :int))
 165
 166 (defsyscall (%sys-truncate (#+linux "truncate64" "truncate"))
 167     (:int :restart t)
 168   "Truncate the file PATH to a size of precisely LENGTH octets."
 169   (path   filename-designator)
 170   (length off-t))
 171
 172 (defsyscall (%sys-ftruncate (#+linux "ftruncate64" "ftruncate"))
 173     (:int :restart t)
 174   "Truncate the file referenced by FD to a size of precisely LENGTH octets."
 175   (fd     :int)
 176   (length off-t))
 177
 178 (defsyscall (%sys-rename "rename") :int
 179   "Rename file named by OLDPATH to NEWPATH."
 180   (oldpath filename-designator)
 181   (newpath filename-designator))
 182
 183 (defsyscall (%sys-link "link") :int
 184   "Create a hard link from file OLDPATH to NEWPATH."
 185   (oldpath filename-designator)
 186   (newpath filename-designator))
 187
 188 (defsyscall (%sys-symlink "symlink") :int
 189   "Create a symbolic link from file OLDPATH to NEWPATH."
 190   (oldpath filename-designator)
 191   (newpath filename-designator))
 192
 193 (defsyscall (%%sys-readlink "readlink") ssize-t
 194   (path    filename-designator)
 195   (buf     :pointer)
 196   (bufsize size-t))
 197
 198 (defentrypoint %sys-readlink (path)
 199   "Read the file name pointed by the symbolic link PATH."
 200   (with-foreign-pointer (buf 4096 bufsize)
 201     (let ((count (%%sys-readlink path buf bufsize)))
 202       (values (foreign-string-to-lisp buf :count count)))))
 203
 204 (defsyscall (%sys-unlink "unlink") :int
 205   "Delete the file PATH from the file system."
 206   (path filename-designator))
 207
 208 (defsyscall (%sys-chown "chown")
 209     (:int :restart t)
 210   "Change ownership of file PATH to uid OWNER and gid GROUP(dereferences symlinks)."
 211   (path  filename-designator)
 212   (owner uid-t)
 213   (group uid-t))
 214
 215 (defsyscall (%sys-fchown "fchown")
 216     (:int :restart t)
 217   "Change ownership of an open file referenced by FD to uid OWNER and gid GROUP."
 218   (fd    :int)
 219   (owner uid-t)
 220   (group uid-t))
 221
 222 (defsyscall (%sys-lchown "lchown")
 223     (:int :restart t)
 224   "Change ownership of a file PATH to uid OWNER and gid GROUP(does not dereference symlinks)."
 225   (path  filename-designator)
 226   (owner uid-t)
 227   (group uid-t))
 228
 229 (defsyscall (%sys-chmod "chmod")
 230     (:int :restart t)
 231   "Change permissions of file PATH to mode MODE."
 232   (path filename-designator)
 233   (mode mode-t))
 234
 235 (defsyscall (%sys-fchmod "fchmod")
 236     (:int :restart t)
 237   "Change permissions of open file referenced by FD to mode MODE."
 238   (fd   :int)
 239   (mode mode-t))
 240
 241 ;;; STAT()
 242
 243 (define-c-struct-wrapper stat ())
 244
 245 #+linux
 246 (defconstant +stat-version+ 3)
 247
 248 (defsyscall (%%sys-stat (#+linux "__xstat64" "stat"))
 249     :int
 250   #+linux
 251   (version   :int)
 252   (file-name filename-designator)
 253   (buf       :pointer))
 254
 255 (defsyscall (%%sys-fstat (#+linux "__fxstat64" "fstat"))
 256     :int
 257   #+linux
 258   (version   :int)
 259   (filedes :int)
 260   (buf     :pointer))
 261
 262 (defsyscall (%%sys-lstat (#+linux "__lxstat64" "lstat"))
 263     :int
 264   #+linux
 265   (version   :int)
 266   (file-name filename-designator)
 267   (buf       :pointer))
 268
 269 ;;; If necessary for performance reasons, we can add an optional
 270 ;;; argument to this function and use that to reuse a wrapper object.
 271 (defentrypoint funcall-stat (fn arg)
 272   (with-foreign-object (buf 'stat)
 273     (funcall fn #+linux +stat-version+ arg buf)
 274     (make-instance 'stat :pointer buf)))
 275
 276 (defentrypoint %sys-stat (path)
 277   "Get information about file PATH(dereferences symlinks)."
 278   (funcall-stat #'%%sys-stat path))
 279
 280 (defentrypoint %sys-fstat (fd)
 281   "Get information about file descriptor FD."
 282   (funcall-stat #'%%sys-fstat fd))
 283
 284 (defentrypoint %sys-lstat (path)
 285   "Get information about file PATH(does not dereference symlinks)."
 286   (funcall-stat #'%%sys-lstat path))
 287
 288 (defsyscall (%sys-sync "sync") :void
 289   "Schedule all file system buffers to be written to disk.")
 290
 291 (defsyscall (%sys-fsync "fsync")
 292     (:int :restart t)
 293   "Schedule a file's buffers to be written to disk."
 294   (fildes :int))
 295
 296 (defsyscall (%%sys-mkstemp "mkstemp") :int
 297   (template filename-designator))
 298
 299 (defentrypoint %sys-mkstemp (&optional (template ""))
 300   "Generate a unique temporary filename from TEMPLATE."
 301   (let ((template (concatenate 'string template "XXXXXX")))
 302     (with-foreign-string (ptr (filename template))
 303       (values (%%sys-mkstemp ptr) (foreign-string-to-lisp ptr)))))
 304 \f
 305
 306 ;;;-------------------------------------------------------------------------
 307 ;;; Directories
 308 ;;;-------------------------------------------------------------------------
 309
 310 (defsyscall (%sys-mkdir "mkdir") :int
 311   "Create directory PATH with permissions MODE."
 312   (path filename-designator)
 313   (mode mode-t))
 314
 315 (defsyscall (%sys-rmdir "rmdir") :int
 316   "Delete directory PATH."
 317   (path filename-designator))
 318
 319 (defsyscall (%sys-chdir "chdir") :int
 320   "Change the current working directory to PATH."
 321   (path filename-designator))
 322
 323 (defsyscall (%sys-fchdir "fchdir")
 324     (:int :restart t)
 325   "Change the current working directory to the directory referenced by FD."
 326   (fildes :int))
 327
 328 (defsyscall (%%sys-getcwd "getcwd") :string
 329   (buf :pointer)
 330   (size size-t))
 331
 332 (defentrypoint %sys-getcwd ()
 333   "Return the current working directory as a string."
 334   (with-foreign-pointer (buf path-max size)
 335     (%%sys-getcwd buf size)))
 336
 337 (defsyscall (%%sys-mkdtemp "mkdtemp") :int
 338   (template filename-designator))
 339
 340 (defentrypoint %sys-mkdtemp (&optional (template ""))
 341   "Generate a unique temporary filename from TEMPLATE."
 342   (let ((template (concatenate 'string template "XXXXXX")))
 343     (with-foreign-string (ptr (filename template))
 344       (values (%%sys-mkdtemp ptr) (foreign-string-to-lisp ptr)))))
 345 \f
 346
 347 ;;;-------------------------------------------------------------------------
 348 ;;; File Descriptors
 349 ;;;-------------------------------------------------------------------------
 350
 351 (defsyscall (%sys-close "close") :int
 352   "Close open file descriptor FD."
 353   (fd :int))
 354
 355 (defsyscall (%sys-dup "dup") :int
 356   "Duplicate file descriptor FD."
 357   (fd :int))
 358
 359 (defsyscall (%sys-dup2 "dup2")
 360     (:int :restart t)
 361   "Make NEWFD be the copy of OLDFD, closing NEWFD first if necessary."
 362   (oldfd :int)
 363   (newfd :int))
 364
 365 (defsyscall (%sys-ioctl/2 "ioctl")
 366     (:int :restart t)
 367   "Send request REQUEST to file referenced by FD."
 368   (fd      :int)
 369   (request :int))
 370
 371 (defsyscall (%sys-ioctl/3 "ioctl")
 372     (:int :restart t)
 373   "Send request REQUEST to file referenced by FD using argument ARG."
 374  (fd      :int)
 375  (request :int)
 376  (arg     :pointer))
 377
 378 (defentrypoint %sys-fd-open-p (fd)
 379   (handler-case
 380       (progn (%sys-fstat fd) t)
 381     (ebadf () nil)))
 382 \f
 383
 384 ;;;-------------------------------------------------------------------------
 385 ;;; File descriptor polling
 386 ;;;-------------------------------------------------------------------------
 387
 388 (defsyscall (%sys-select "select") :int
 389   "Scan for I/O activity on multiple file descriptors."
 390   (nfds      :int)
 391   (readfds   :pointer)
 392   (writefds  :pointer)
 393   (exceptfds :pointer)
 394   (timeout   :pointer))
 395
 396 (defentrypoint %sys-fd-zero (fd-set)
 397   (%sys-bzero fd-set size-of-fd-set)
 398   (values fd-set))
 399
 400 (defentrypoint %sys-copy-fd-set (from to)
 401   (%sys-memcpy to from size-of-fd-set)
 402   (values to))
 403
 404 (deftype select-file-descriptor ()
 405   `(mod #.fd-setsize))
 406
 407 (defentrypoint %sys-fd-isset (fd fd-set)
 408   (multiple-value-bind (byte-off bit-off) (floor fd 8)
 409     (let ((oldval (mem-aref fd-set :uint8 byte-off)))
 410       (logbitp bit-off oldval))))
 411
 412 (defentrypoint %sys-fd-clr (fd fd-set)
 413   (multiple-value-bind (byte-off bit-off) (floor fd 8)
 414     (let ((oldval (mem-aref fd-set :uint8 byte-off)))
 415       (setf (mem-aref fd-set :uint8 byte-off)
 416             (logandc2 oldval (ash 1 bit-off)))))
 417   (values fd-set))
 418
 419 (defentrypoint %sys-fd-set (fd fd-set)
 420   (multiple-value-bind (byte-off bit-off) (floor fd 8)
 421     (let ((oldval (mem-aref fd-set :uint8 byte-off)))
 422       (setf (mem-aref fd-set :uint8 byte-off)
 423             (logior oldval (ash 1 bit-off)))))
 424   (values fd-set))
 425
 426 ;;; FIXME: Until a way to autodetect platform features is implemented
 427 (eval-when (:compile-toplevel :load-toplevel :execute)
 428   (unless (boundp 'pollrdhup)
 429     (defconstant pollrdhup 0)))
 430
 431 (defsyscall (%sys-poll "poll") :int
 432   "Scan for I/O activity on multiple file descriptors."
 433   (fds     :pointer)
 434   (nfds    nfds-t)
 435   (timeout :int))
 436
 437 #+linux
 438 (progn
 439   (defsyscall (%sys-epoll-create "epoll_create") :int
 440     "Open an epoll file descriptor."
 441     (size :int))
 442
 443   (defsyscall (%sys-epoll-ctl "epoll_ctl") :int
 444     "Control interface for an epoll descriptor."
 445     (epfd  :int)
 446     (op    :int)
 447     (fd    :int)
 448     (event :pointer))
 449
 450   (defsyscall (%sys-epoll-wait "epoll_wait") :int
 451     "Wait for an I/O event on an epoll file descriptor."
 452     (epfd      :int)
 453     (events    :pointer)
 454     (maxevents :int)
 455     (timeout   :int)))
 456
 457 #+bsd
 458 (progn
 459   (defsyscall (%sys-kqueue "kqueue") :int
 460     "Open a kernel event queue.")
 461
 462   (defsyscall (%sys-kevent "kevent") :int
 463     "Control interface for a kernel event queue."
 464     (kq         :int)
 465     (changelist :pointer)               ; const struct kevent *
 466     (nchanges   :int)
 467     (eventlist  :pointer)               ; struct kevent *
 468     (nevents    :int)
 469     (timeout    :pointer))              ; const struct timespec *
 470
 471   (defentrypoint %sys-ev-set (%kev %ident %filter %flags %fflags %data %udata)
 472     (with-foreign-slots ((ident filter flags fflags data udata) %kev kevent)
 473       (setf ident %ident filter %filter flags %flags
 474             fflags %fflags data %data udata %udata))))
 475 \f
 476
 477 ;;;-------------------------------------------------------------------------
 478 ;;; Directory walking
 479 ;;;-------------------------------------------------------------------------
 480
 481 (defsyscall (%sys-opendir "opendir") :pointer
 482   "Open directory PATH for listing of its contents."
 483   (path filename-designator))
 484
 485 (defsyscall (%sys-closedir "closedir") :int
 486   "Close directory DIR when done listing its contents."
 487   (dir :pointer))
 488
 489 (defsyscall (%%sys-readdir-r (#+linux "readdir64_r" "readdir_r"))
 490     (:int
 491      :error-predicate plusp
 492      :error-location :return)
 493   (dirp   :pointer)
 494   (entry  :pointer)
 495   (result :pointer))
 496
 497 (defentrypoint %sys-readdir (dir)
 498   "Reads an item from the listing of directory DIR (reentrant)."
 499   (with-foreign-objects ((entry 'dirent) (result :pointer))
 500     (%%sys-readdir-r dir entry result)
 501     (if (null-pointer-p (mem-ref result :pointer))
 502         nil
 503         (with-foreign-slots ((name type fileno) entry dirent)
 504           (values (foreign-string-to-lisp name) type fileno)))))
 505
 506 (defsyscall (%sys-rewinddir "rewinddir") :void
 507   "Rewind directory DIR."
 508   (dir :pointer))
 509
 510 (defsyscall (%sys-seekdir "seekdir") :void
 511   "Seek into directory DIR to position POS(as returned by TELLDIR)."
 512   (dir :pointer)
 513   (pos :long))
 514
 515 ;;; FIXME: According to POSIX docs "no errors are defined" for
 516 ;;; telldir() but Linux manpages specify a possible EBADF.
 517 (defsyscall (%sys-telldir "telldir") off-t
 518   "Return the current location in directory DIR."
 519   (dir :pointer))
 520 \f
 521
 522 ;;;-------------------------------------------------------------------------
 523 ;;; Memory mapping
 524 ;;;-------------------------------------------------------------------------
 525
 526 (defsyscall (%sys-mmap (#+linux "mmap64" "mmap"))
 527     :pointer
 528   "Map file referenced by FD at offset OFFSET into address space of the
 529 calling process at address ADDR and length LENGTH.
 530 PROT describes the desired memory protection of the mapping.
 531 FLAGS determines whether updates to the mapping are visible to other
 532 processes mapping the same region."
 533   (addr   :pointer)
 534   (length size-t)
 535   (prot   :int)
 536   (flags  :int)
 537   (fd     :int)
 538   (offset off-t))
 539
 540 (defsyscall (%sys-munmap "munmap") :int
 541   "Unmap pages of memory starting at address ADDR with length LENGTH."
 542   (addr   :pointer)
 543   (length size-t))
 544 \f
 545
 546 ;;;-------------------------------------------------------------------------
 547 ;;; Process creation and info
 548 ;;;-------------------------------------------------------------------------
 549
 550 (defsyscall (%sys-fork "fork") pid-t
 551   "Create a child process.")
 552
 553 (defsyscall (%sys-getpid "getpid") pid-t
 554   "Returns the process id of the current process")
 555
 556 (defsyscall (%sys-getppid "getppid") pid-t
 557   "Returns the process id of the current process's parent")
 558
 559 (defsyscall (%sys-getuid "getuid") uid-t
 560   "Get real user id of the current process.")
 561
 562 (defsyscall (%sys-setuid "setuid") :int
 563   "Set real user id of the current process to UID."
 564   (uid uid-t))
 565
 566 (defsyscall (%sys-geteuid "geteuid") uid-t
 567   "Get effective user id of the current process.")
 568
 569 (defsyscall (%sys-seteuid "seteuid") :int
 570   "Set effective user id of the current process to UID."
 571   (uid uid-t))
 572
 573 (defsyscall (%sys-getgid "getgid") gid-t
 574   "Get real group id of the current process.")
 575
 576 (defsyscall (%sys-setgid "setgid") :int
 577   "Set real group id of the current process to GID."
 578   (gid gid-t))
 579
 580 (defsyscall (%sys-getegid "getegid") gid-t
 581   "Get effective group id of the current process.")
 582
 583 (defsyscall (%sys-setegid "setegid") :int
 584   "Set effective group id of the current process to GID."
 585   (gid gid-t))
 586
 587 (defsyscall (%sys-setreuid "setreuid") :int
 588   "Set real and effective user id of the current process to RUID and EUID."
 589   (ruid uid-t)
 590   (euid uid-t))
 591
 592 (defsyscall (%sys-setregid "setregid") :int
 593   "Set real and effective group id of the current process to RGID and EGID."
 594   (rgid gid-t)
 595   (egid gid-t))
 596
 597 (defsyscall (%sys-getpgid "getpgid") pid-t
 598   "Get process group id of process PID."
 599   (pid pid-t))
 600
 601 (defsyscall (%sys-setpgid "setpgid") :int
 602   "Set process group id of process PID to value PGID."
 603   (pid  pid-t)
 604   (pgid pid-t))
 605
 606 (defsyscall (%sys-getpgrp "getpgrp") pid-t
 607   "Get process group id of the current process.")
 608
 609 (defsyscall (%sys-setpgrp "setpgrp") pid-t
 610   "Set process group id of the current process.")
 611
 612 (defsyscall (%sys-setsid "setsid") pid-t
 613   "Create session and set process group id of the current process.")
 614
 615 (defsyscall (%%sys-getrlimit (#+linux "getrlimit64" "getrlimit"))
 616     :int
 617   (resource :int)
 618   (rlimit   :pointer))
 619
 620 (defentrypoint %sys-getrlimit (resource)
 621   "Return soft and hard limit of system resource RESOURCE."
 622   (with-foreign-object (rl 'rlimit)
 623     (with-foreign-slots ((cur max) rl rlimit)
 624       (%%sys-getrlimit resource rl)
 625       (values cur max))))
 626
 627 (defsyscall (%%sys-setrlimit (#+linux "setrlimit64" "setrlimit"))
 628     :int
 629   (resource :int)
 630   (rlimit   :pointer))
 631
 632 (defentrypoint %sys-setrlimit (resource soft-limit hard-limit)
 633   "Set SOFT-LIMIT and HARD-LIMIT of system resource RESOURCE."
 634   (with-foreign-object (rl 'rlimit)
 635     (with-foreign-slots ((cur max) rl rlimit)
 636       (setf cur soft-limit
 637             max hard-limit)
 638       (%%sys-setrlimit resource rl))))
 639
 640 (defsyscall (%%sys-getrusage "getrusage") :int
 641   (who   :int)
 642   (usage :pointer))
 643
 644 ;;; TODO: it might be more convenient to return a wrapper object here
 645 ;;; instead like we do in STAT.
 646 (defentrypoint %sys-getrusage (who)
 647   "Return resource usage measures of WHO."
 648   (with-foreign-object (ru 'rusage)
 649     (%%sys-getrusage who ru)
 650     (with-foreign-slots ((maxrss ixrss idrss isrss minflt majflt nswap inblock
 651                           oublock msgsnd msgrcv nsignals nvcsw nivcsw)
 652                          ru rusage)
 653       (values (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
 654                                   'timeval 'sec)
 655               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
 656                                   'timeval 'usec)
 657               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
 658                                   'timeval 'sec)
 659               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
 660                                   'timeval 'usec)
 661               maxrss ixrss idrss isrss minflt majflt
 662               nswap inblock oublock msgsnd
 663               msgrcv nsignals nvcsw nivcsw))))
 664
 665 (defsyscall (%sys-getpriority "getpriority") :int
 666   "Get the scheduling priority of a process, process group, or user,
 667 as indicated by WHICH and WHO."
 668   (which :int)
 669   (who   :int))
 670
 671 (defsyscall (%sys-setpriority "setpriority") :int
 672   "Set the scheduling priority of a process, process group, or user,
 673 as indicated by WHICH and WHO to VALUE."
 674   (which :int)
 675   (who   :int)
 676   (value :int))
 677
 678 (defentrypoint %sys-nice (&optional (increment 0))
 679   "Get or set process priority."
 680   ;; FIXME: race condition. might need WITHOUT-INTERRUPTS on some impl.s
 681   (setf (%sys-errno) 0)
 682   (let ((r (foreign-funcall "nice" :int increment :int)))
 683     (if (and (= r -1) (/= (%sys-errno) 0))
 684         (signal-posix-error r)
 685         r)))
 686 \f
 687
 688 ;;;-------------------------------------------------------------------------
 689 ;;; Time
 690 ;;;-------------------------------------------------------------------------
 691
 692 (defsyscall (%sys-usleep "usleep")
 693     (:int :restart t)
 694   "Suspend execution for USECONDS microseconds."
 695   (useconds useconds-t))
 696
 697 (defsyscall (%%sys-time "time") time-t
 698   (tloc :pointer))
 699
 700 (defentrypoint %sys-time ()
 701   "Get time in seconds."
 702   (%%sys-time (null-pointer)))
 703
 704 (defsyscall (%%sys-gettimeofday "gettimeofday") :int
 705   (tp  :pointer)
 706   (tzp :pointer))
 707
 708 (defentrypoint %sys-gettimeofday ()
 709   "Return the time in seconds and microseconds."
 710   (with-foreign-object (tv 'timeval)
 711     (with-foreign-slots ((sec usec) tv timeval)
 712       (%%sys-gettimeofday tv (null-pointer))
 713       (values sec usec))))
 714
 715 #-darwin
 716 (progn
 717   (defsyscall (%%sys-clock-getres "clock_getres") :int
 718     "Returns the resolution of the clock CLOCKID."
 719     (clockid clockid-t)
 720     (res     :pointer))
 721
 722   (defentrypoint %sys-clock-getres (clock-id)
 723     (with-foreign-object (ts 'timespec)
 724       (with-foreign-slots ((sec nsec) ts timespec)
 725         (%%sys-clock-getres clock-id ts)
 726         (values sec nsec))))
 727
 728   (defsyscall (%%sys-clock-gettime "clock_gettime") :int
 729     (clockid clockid-t)
 730     (tp      :pointer))
 731
 732   (defentrypoint %sys-clock-gettime (clock-id)
 733     "Returns the time of the clock CLOCKID."
 734     (with-foreign-object (ts 'timespec)
 735       (with-foreign-slots ((sec nsec) ts timespec)
 736         (%%sys-clock-gettime clock-id ts)
 737         (values sec nsec))))
 738
 739   (defsyscall (%%sys-clock-settime "clock_settime") :int
 740     (clockid clockid-t)
 741     (tp      :pointer))
 742
 743   (defentrypoint %sys-clock-settime (clock-id)
 744     "Sets the time of the clock CLOCKID."
 745     (with-foreign-object (ts 'timespec)
 746       (with-foreign-slots ((sec nsec) ts timespec)
 747         (%%sys-clock-settime clock-id ts)
 748         (values sec nsec)))))
 749
 750 ;;; FIXME: or we can implement this through the MACH functions.
 751 #+darwin
 752 (progn
 753   (defctype kern-return-t :int)
 754   (defctype clock-res-t :int)
 755   (defctype clock-id-t :int)
 756   (defctype port-t :unsigned-int)         ; not sure
 757   (defctype clock-serv-t port)
 758
 759   (defconstant kern-success 0)
 760
 761   (defconstant system-clock 0)
 762   (defconstant calendar-clock 1)
 763   (defconstant realtime-clock 0)
 764
 765   (defsyscall (%sys-mach-host-self "mach_host_self") port-t)
 766
 767   (defsyscall (%%sys-host-get-clock-service "host_get_clock_service") kern-return-t
 768     (host       port-t)
 769     (id         clock-id-t)
 770     (clock-name :pointer))
 771
 772   (defentrypoint %sys-host-get-clock-service (id &optional (host (%sys-mach-host-self)))
 773     (with-foreign-object (clock 'clock-serv-t)
 774       (%%sys-host-get-clock-service host id clock)
 775       (mem-ref clock :int)))
 776
 777   (defsyscall (%clock-get-time "clock_get_time") kern-return-t
 778     (clock-serv clock-serv-t)
 779     (cur-time   timespec))
 780
 781   (defentrypoint clock-get-time (clock-service)
 782     (with-foreign-object (time 'timespec)
 783       (%clock-get-time clock-service time)
 784       (with-foreign-slots ((tv-sec tv-nsec) time timespec)
 785         (values tv-sec tv-nsec)))))
 786
 787 (defentrypoint %sys-get-monotonic-time ()
 788   "Gets current time in seconds from a system's monotonic clock."
 789   (multiple-value-bind (seconds nanoseconds)
 790       #-darwin (%sys-clock-gettime clock-monotonic)
 791       #+darwin (%sys-clock-get-time (%sys-host-get-clock-service system-clock))
 792     (+ seconds (/ nanoseconds 1d9))))
 793 \f
 794
 795 ;;;-------------------------------------------------------------------------
 796 ;;; Environement
 797 ;;;-------------------------------------------------------------------------
 798
 799 (defcvar ("environ" :read-only t) (:pointer :string))
 800
 801 (defsyscall (%sys-getenv "getenv") :string
 802   "Returns the value of environment variable NAME."
 803   (name :string))
 804
 805 (defsyscall (%sys-setenv "setenv") :int
 806   "Changes the value of environment variable NAME to VALUE.
 807 The environment variable is overwritten only if overwrite it non-NIL."
 808   (name      :string)
 809   (value     :string)
 810   (overwrite bool-designator))
 811
 812 (defsyscall (%sys-unsetenv "unsetenv") :int
 813   "Removes the binding of environment variable NAME."
 814   (name :string))
 815 \f
 816
 817 ;;;-------------------------------------------------------------------------
 818 ;;; Hostname info
 819 ;;;-------------------------------------------------------------------------
 820
 821 (defsyscall (%%sys-gethostname "gethostname") :int
 822   (name    :pointer)
 823   (namelen size-t))
 824
 825 (defentrypoint %sys-gethostname ()
 826   "Return the host name of the current machine."
 827   (with-foreign-pointer-as-string ((cstr size) 256)
 828     (%%sys-gethostname cstr size)))
 829
 830 (defsyscall (%%sys-getdomainname "getdomainname") :int
 831   (name    :pointer)
 832   (namelen size-t))
 833
 834 (defentrypoint %sys-getdomainname ()
 835   "Return the domain name of the current machine."
 836   (with-foreign-pointer-as-string ((cstr size) 256)
 837     (%%sys-getdomainname cstr size)))
 838
 839 (defsyscall (%%sys-uname "uname") :int
 840   (buf :pointer))
 841
 842 (defentrypoint %sys-uname ()
 843   "Get name and information about current kernel."
 844   (with-foreign-object (buf 'utsname)
 845     (%sys-bzero buf size-of-utsname)
 846     (%%sys-uname buf)
 847     (macrolet ((utsname-slot (name)
 848                  `(foreign-string-to-lisp
 849                    (foreign-slot-pointer buf 'utsname ',name))))
 850       (values (utsname-slot sysname)
 851               (utsname-slot nodename)
 852               (utsname-slot release)
 853               (utsname-slot version)
 854               (utsname-slot machine)))))
 855 \f
 856
 857 ;;;-------------------------------------------------------------------------
 858 ;;; User info
 859 ;;;-------------------------------------------------------------------------
 860
 861 (defsyscall (%%sys-getpwuid-r "getpwuid_r")
 862     (:int
 863      :error-predicate plusp
 864      :error-location :return)
 865   (uid     uid-t)
 866   (pwd     :pointer)
 867   (buffer  :pointer)
 868   (bufsize size-t)
 869   (result  :pointer))
 870
 871 (defsyscall (%%sys-getpwnam-r "getpwnam_r")
 872     (:int
 873      :error-predicate plusp
 874      :error-location :return)
 875   (name    :string)
 876   (pwd     :pointer)
 877   (buffer  :pointer)
 878   (bufsize size-t)
 879   (result  :pointer))
 880
 881 (defun funcall-getpw (fn arg)
 882   (with-foreign-objects ((pw 'passwd-entry) (pwp :pointer))
 883     (with-foreign-pointer (buf 4096 bufsize)
 884       (with-foreign-slots ((name passwd uid gid gecos dir shell) pw passwd-entry)
 885         (funcall fn arg pw buf bufsize pwp)
 886         (if (null-pointer-p (mem-ref pwp :pointer))
 887             nil
 888             (values name passwd uid gid gecos dir shell))))))
 889
 890 (defentrypoint %sys-getpwuid (uid)
 891   "Gets the password-entry of a user, by user id (reentrant)."
 892   (funcall-getpw #'%%sys-getpwuid-r uid))
 893
 894 (defentrypoint %sys-getpwnam (name)
 895   "Gets the password-entry of a user, by username (reentrant)."
 896   (funcall-getpw #'%%sys-getpwnam-r name))
 897 \f
 898
 899 ;;;-------------------------------------------------------------------------
 900 ;;; Group info
 901 ;;;-------------------------------------------------------------------------
 902
 903 (defsyscall (%%sys-getgrgid-r "getgrgid_r")
 904     (:int
 905      :error-predicate plusp
 906      :error-location :return)
 907   (uid     uid-t)
 908   (grp     :pointer)
 909   (buffer  :pointer)
 910   (bufsize size-t)
 911   (result  :pointer))
 912
 913 (defsyscall (%%sys-getgrnam-r "getgrnam_r")
 914     (:int
 915      :error-predicate plusp
 916      :error-location :return)
 917   (name    :string)
 918   (grp     :pointer)
 919   (buffer  :pointer)
 920   (bufsize size-t)
 921   (result  :pointer))
 922
 923 (defun funcall-getgr (fn arg)
 924   (with-foreign-objects ((gr 'group-entry) (grp :pointer))
 925     (with-foreign-pointer (buf 4096 bufsize)
 926       (with-foreign-slots ((name passwd gid) gr group-entry)
 927         (funcall fn arg gr buf bufsize grp)
 928         (if (null-pointer-p (mem-ref grp :pointer))
 929             nil
 930             (values name passwd gid))))))
 931
 932 (defentrypoint %sys-getgrgid (gid)
 933   "Gets a group-entry, by group id (reentrant)."
 934   (funcall-getgr #'%%sys-getgrgid-r gid))
 935
 936 (defentrypoint %sys-getgrnam (name)
 937   "Gets a group-entry, by group name (reentrant)."
 938   (funcall-getgr #'%%sys-getgrnam-r name))