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