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