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 #-darwin
 567 (defsyscall (%sys-fdopendir "fdopendir") :pointer
 568   "Open directory denoted by descriptor FD for listing of its contents."
 569   (fd :int))
 570
 571 #-darwin
 572 (defsyscall (%sys-dirfd "dirfd") :int
 573   "Returns the file descriptor associated with the directory DIRP."
 574   (dirp :pointer))
 575
 576 (defsyscall (%sys-closedir "closedir") :int
 577   "Close directory DIR when done listing its contents."
 578   (dirp :pointer))
 579
 580 (defsyscall (%%sys-readdir-r (#+linux "readdir64_r" "readdir_r"))
 581     (:int
 582      :error-predicate plusp
 583      :error-location :return)
 584   (dirp   :pointer)
 585   (entry  :pointer)
 586   (result :pointer))
 587
 588 (defentrypoint %sys-readdir (dir)
 589   "Reads an item from the listing of directory DIR (reentrant)."
 590   (with-foreign-objects ((entry 'dirent) (result :pointer))
 591     (%%sys-readdir-r dir entry result)
 592     (if (null-pointer-p (mem-ref result :pointer))
 593         nil
 594         (with-foreign-slots ((name type fileno) entry dirent)
 595           (values (cstring-to-sstring name) type fileno)))))
 596
 597 (defsyscall (%sys-rewinddir "rewinddir") :void
 598   "Rewind directory DIR."
 599   (dirp :pointer))
 600
 601 (defsyscall (%sys-seekdir "seekdir") :void
 602   "Seek into directory DIR to position POS(as returned by TELLDIR)."
 603   (dirp :pointer)
 604   (pos  :long))
 605
 606 ;;; FIXME: According to POSIX docs "no errors are defined" for
 607 ;;; telldir() but Linux manpages specify a possible EBADF.
 608 (defsyscall (%sys-telldir "telldir") off-t
 609   "Return the current location in directory DIR."
 610   (dirp :pointer))
 611 \f
 612
 613 ;;;-------------------------------------------------------------------------
 614 ;;; Memory mapping
 615 ;;;-------------------------------------------------------------------------
 616
 617 (defsyscall (%sys-mmap (#+linux "mmap64" "mmap"))
 618     (:pointer :handle fd)
 619   "Map file referenced by FD at offset OFFSET into address space of the
 620 calling process at address ADDR and length LENGTH.
 621 PROT describes the desired memory protection of the mapping.
 622 FLAGS determines whether updates to the mapping are visible to other
 623 processes mapping the same region."
 624   (addr   :pointer)
 625   (length size-t)
 626   (prot   :int)
 627   (flags  :int)
 628   (fd     :int)
 629   (offset off-t))
 630
 631 (defsyscall (%sys-munmap "munmap") :int
 632   "Unmap pages of memory starting at address ADDR with length LENGTH."
 633   (addr   :pointer)
 634   (length size-t))
 635 \f
 636
 637 ;;;-------------------------------------------------------------------------
 638 ;;; Process creation and info
 639 ;;;-------------------------------------------------------------------------
 640
 641 (defsyscall (%sys-fork "fork") pid-t
 642   "Create a child process.")
 643
 644 (defsyscall (%sys-execv "execv") :int
 645   (path :string)
 646   (argv :pointer))
 647
 648 (defsyscall (%sys-execvp "execvp") :int
 649   (file :string)
 650   (argv :pointer))
 651
 652 (defsyscall (%sys-waitpid "waitpid") pid-t
 653   (pid     pid-t)
 654   (status  :pointer)
 655   (options :int))
 656
 657 (defsyscall (%sys-getpid "getpid") pid-t
 658   "Returns the process id of the current process")
 659
 660 (defsyscall (%sys-getppid "getppid") pid-t
 661   "Returns the process id of the current process's parent")
 662
 663 #+linux
 664 (defentrypoint %sys-gettid ()
 665   (foreign-funcall "syscall" :int sys-gettid :int))
 666
 667 (defsyscall (%sys-getuid "getuid") uid-t
 668   "Get real user id of the current process.")
 669
 670 (defsyscall (%sys-setuid "setuid") :int
 671   "Set real user id of the current process to UID."
 672   (uid uid-t))
 673
 674 (defsyscall (%sys-geteuid "geteuid") uid-t
 675   "Get effective user id of the current process.")
 676
 677 (defsyscall (%sys-seteuid "seteuid") :int
 678   "Set effective user id of the current process to UID."
 679   (uid uid-t))
 680
 681 (defsyscall (%sys-getgid "getgid") gid-t
 682   "Get real group id of the current process.")
 683
 684 (defsyscall (%sys-setgid "setgid") :int
 685   "Set real group id of the current process to GID."
 686   (gid gid-t))
 687
 688 (defsyscall (%sys-getegid "getegid") gid-t
 689   "Get effective group id of the current process.")
 690
 691 (defsyscall (%sys-setegid "setegid") :int
 692   "Set effective group id of the current process to GID."
 693   (gid gid-t))
 694
 695 (defsyscall (%sys-setreuid "setreuid") :int
 696   "Set real and effective user id of the current process to RUID and EUID."
 697   (ruid uid-t)
 698   (euid uid-t))
 699
 700 (defsyscall (%sys-setregid "setregid") :int
 701   "Set real and effective group id of the current process to RGID and EGID."
 702   (rgid gid-t)
 703   (egid gid-t))
 704
 705 (defsyscall (%sys-getpgid "getpgid") pid-t
 706   "Get process group id of process PID."
 707   (pid pid-t))
 708
 709 (defsyscall (%sys-setpgid "setpgid") :int
 710   "Set process group id of process PID to value PGID."
 711   (pid  pid-t)
 712   (pgid pid-t))
 713
 714 (defsyscall (%sys-getpgrp "getpgrp") pid-t
 715   "Get process group id of the current process.")
 716
 717 (defsyscall (%sys-setpgrp "setpgrp") pid-t
 718   "Set process group id of the current process.")
 719
 720 (defsyscall (%sys-setsid "setsid") pid-t
 721   "Create session and set process group id of the current process.")
 722
 723 (defsyscall (%%sys-getrlimit (#+linux "getrlimit64" "getrlimit"))
 724     :int
 725   (resource :int)
 726   (rlimit   :pointer))
 727
 728 (defentrypoint %sys-getrlimit (resource)
 729   "Return soft and hard limit of system resource RESOURCE."
 730   (with-foreign-object (rl 'rlimit)
 731     (with-foreign-slots ((cur max) rl rlimit)
 732       (%%sys-getrlimit resource rl)
 733       (values cur max))))
 734
 735 (defsyscall (%%sys-setrlimit (#+linux "setrlimit64" "setrlimit"))
 736     :int
 737   (resource :int)
 738   (rlimit   :pointer))
 739
 740 (defentrypoint %sys-setrlimit (resource soft-limit hard-limit)
 741   "Set SOFT-LIMIT and HARD-LIMIT of system resource RESOURCE."
 742   (with-foreign-object (rl 'rlimit)
 743     (with-foreign-slots ((cur max) rl rlimit)
 744       (setf cur soft-limit
 745             max hard-limit)
 746       (%%sys-setrlimit resource rl))))
 747
 748 (defsyscall (%%sys-getrusage "getrusage") :int
 749   (who   :int)
 750   (usage :pointer))
 751
 752 ;;; TODO: it might be more convenient to return a wrapper object here
 753 ;;; instead like we do in STAT.
 754 (defentrypoint %sys-getrusage (who)
 755   "Return resource usage measures of WHO."
 756   (with-foreign-object (ru 'rusage)
 757     (%%sys-getrusage who ru)
 758     (with-foreign-slots ((maxrss ixrss idrss isrss minflt majflt nswap inblock
 759                           oublock msgsnd msgrcv nsignals nvcsw nivcsw)
 760                          ru rusage)
 761       (values (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
 762                                   'timeval 'sec)
 763               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
 764                                   'timeval 'usec)
 765               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
 766                                   'timeval 'sec)
 767               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
 768                                   'timeval 'usec)
 769               maxrss ixrss idrss isrss minflt majflt
 770               nswap inblock oublock msgsnd
 771               msgrcv nsignals nvcsw nivcsw))))
 772
 773 (defsyscall (%sys-getpriority "getpriority") :int
 774   "Get the scheduling priority of a process, process group, or user,
 775 as indicated by WHICH and WHO."
 776   (which :int)
 777   (who   :int))
 778
 779 (defsyscall (%sys-setpriority "setpriority") :int
 780   "Set the scheduling priority of a process, process group, or user,
 781 as indicated by WHICH and WHO to VALUE."
 782   (which :int)
 783   (who   :int)
 784   (value :int))
 785
 786 (defentrypoint %sys-nice (&optional (increment 0))
 787   "Get or set process priority."
 788   ;; FIXME: race condition. might need WITHOUT-INTERRUPTS on some impl.s
 789   (setf (%sys-errno) 0)
 790   (let ((retval (foreign-funcall "nice" :int increment :int))
 791         (errno (%sys-errno)))
 792     (if (and (= retval -1) (/= errno 0))
 793         (signal-syscall-error errno)
 794         retval)))
 795 \f
 796
 797 ;;;-------------------------------------------------------------------------
 798 ;;; Signals
 799 ;;;-------------------------------------------------------------------------
 800
 801 (defsyscall (%sys-kill "kill") :int
 802   "Send signal SIG to process PID."
 803   (pid    pid-t)
 804   (signum :int))
 805
 806 (defsyscall (%sys-sigaction "sigaction") :int
 807   (signum :int)
 808   (act    :pointer)
 809   (oldact :pointer))
 810 \f
 811
 812 ;;;-------------------------------------------------------------------------
 813 ;;; Time
 814 ;;;-------------------------------------------------------------------------
 815
 816 (defsyscall (%sys-usleep "usleep") :int
 817   "Suspend execution for USECONDS microseconds."
 818   (useconds useconds-t))
 819
 820 (defsyscall (%%sys-time "time") time-t
 821   (tloc :pointer))
 822
 823 (defentrypoint %sys-time ()
 824   "Get time in seconds."
 825   (%%sys-time (null-pointer)))
 826
 827 (defsyscall (%%sys-gettimeofday "gettimeofday") :int
 828   (tp  :pointer)
 829   (tzp :pointer))
 830
 831 (defentrypoint %sys-gettimeofday ()
 832   "Return the time in seconds and microseconds."
 833   (with-foreign-object (tv 'timeval)
 834     (with-foreign-slots ((sec usec) tv timeval)
 835       (%%sys-gettimeofday tv (null-pointer))
 836       (values sec usec))))
 837
 838 #-darwin
 839 (progn
 840   (defsyscall (%%sys-clock-getres "clock_getres") :int
 841     "Returns the resolution of the clock CLOCKID."
 842     (clockid clockid-t)
 843     (res     :pointer))
 844
 845   (defentrypoint %sys-clock-getres (clock-id)
 846     (with-foreign-object (ts 'timespec)
 847       (with-foreign-slots ((sec nsec) ts timespec)
 848         (%%sys-clock-getres clock-id ts)
 849         (values sec nsec))))
 850
 851   (defsyscall (%%sys-clock-gettime "clock_gettime") :int
 852     (clockid clockid-t)
 853     (tp      :pointer))
 854
 855   (defentrypoint %sys-clock-gettime (clock-id)
 856     "Returns the time of the clock CLOCKID."
 857     (with-foreign-object (ts 'timespec)
 858       (with-foreign-slots ((sec nsec) ts timespec)
 859         (%%sys-clock-gettime clock-id ts)
 860         (values sec nsec))))
 861
 862   (defsyscall (%%sys-clock-settime "clock_settime") :int
 863     (clockid clockid-t)
 864     (tp      :pointer))
 865
 866   (defentrypoint %sys-clock-settime (clock-id)
 867     "Sets the time of the clock CLOCKID."
 868     (with-foreign-object (ts 'timespec)
 869       (with-foreign-slots ((sec nsec) ts timespec)
 870         (%%sys-clock-settime clock-id ts)
 871         (values sec nsec)))))
 872
 873 ;;; FIXME: or we can implement this through the MACH functions.
 874 #+darwin
 875 (progn
 876   (defctype kern-return-t :int)
 877   (defctype clock-res-t :int)
 878   (defctype clock-id-t :int)
 879   (defctype port-t :unsigned-int)         ; not sure
 880   (defctype clock-serv-t port-t)
 881
 882   (defconstant kern-success 0)
 883
 884   (defconstant system-clock 0)
 885   (defconstant calendar-clock 1)
 886   (defconstant realtime-clock 0)
 887
 888   (defsyscall (%sys-mach-host-self "mach_host_self") port-t)
 889
 890   (defsyscall (%%sys-host-get-clock-service "host_get_clock_service") kern-return-t
 891     (host       port-t)
 892     (id         clock-id-t)
 893     (clock-name :pointer))
 894
 895   (defentrypoint %sys-host-get-clock-service (id &optional (host (%sys-mach-host-self)))
 896     (with-foreign-object (clock 'clock-serv-t)
 897       (%%sys-host-get-clock-service host id clock)
 898       (mem-ref clock :int)))
 899
 900   (defsyscall (%%sys-clock-get-time "clock_get_time") kern-return-t
 901     (clock-serv clock-serv-t)
 902     (cur-time   timespec))
 903
 904   (defentrypoint %sys-clock-get-time (clock-service)
 905     (with-foreign-object (time 'timespec)
 906       (%%sys-clock-get-time clock-service time)
 907       (with-foreign-slots ((sec nsec) time timespec)
 908         (values sec nsec)))))
 909
 910 (defentrypoint %sys-get-monotonic-time ()
 911   "Gets current time in seconds from a system's monotonic clock."
 912   (multiple-value-bind (seconds nanoseconds)
 913       #-darwin (%sys-clock-gettime clock-monotonic)
 914       #+darwin (%sys-clock-get-time (%sys-host-get-clock-service system-clock))
 915     (+ seconds (/ nanoseconds 1d9))))
 916 \f
 917
 918 ;;;-------------------------------------------------------------------------
 919 ;;; Environement
 920 ;;;-------------------------------------------------------------------------
 921
 922 (defcvar ("environ" :read-only t) (:pointer :string))
 923
 924 (defentrypoint %sys-getenv (name)
 925   "Returns the value of environment variable NAME."
 926   (when (and (pointerp name) (null-pointer-p name))
 927     (setf (%sys-errno) einval)
 928     (signal-syscall-error))
 929   (foreign-funcall "getenv" :string name :string))
 930
 931 (defsyscall (%sys-setenv "setenv") :int
 932   "Changes the value of environment variable NAME to VALUE.
 933 The environment variable is overwritten only if overwrite is not NIL."
 934   (name      :string)
 935   (value     :string)
 936   (overwrite bool-designator))
 937
 938 (defsyscall (%sys-unsetenv "unsetenv") :int
 939   "Removes the binding of environment variable NAME."
 940   (name :string))
 941
 942 (defentrypoint %sys-clearenv ()
 943   "Remove all name-value pairs from the environment and set the external
 944 variable *environ* to NULL."
 945   (let ((envptr isys:*environ*))
 946     (unless (null-pointer-p envptr)
 947       (loop :for i :from 0 :by 1
 948             :for string := (mem-aref envptr :string i)
 949             :for name := (subseq string 0 (position #\= string))
 950             :while name :do (isys:%sys-unsetenv name))
 951       (setf (mem-ref envptr :pointer) (null-pointer)))
 952     (values)))
 953 \f
 954
 955 ;;;-------------------------------------------------------------------------
 956 ;;; Hostname info
 957 ;;;-------------------------------------------------------------------------
 958
 959 (defsyscall (%%sys-gethostname "gethostname") :int
 960   (name    :pointer)
 961   (namelen size-t))
 962
 963 (defentrypoint %sys-gethostname ()
 964   "Return the host name of the current machine."
 965   (with-foreign-pointer-as-string ((cstr size) 256)
 966     (%%sys-gethostname cstr size)))
 967
 968 (defsyscall (%%sys-getdomainname "getdomainname") :int
 969   (name    :pointer)
 970   (namelen size-t))
 971
 972 (defentrypoint %sys-getdomainname ()
 973   "Return the domain name of the current machine."
 974   (with-foreign-pointer-as-string ((cstr size) 256)
 975     (%%sys-getdomainname cstr size)))
 976
 977 (defsyscall (%%sys-uname "uname") :int
 978   (buf :pointer))
 979
 980 (defentrypoint %sys-uname ()
 981   "Get name and information about current kernel."
 982   (with-foreign-object (buf 'utsname)
 983     (%sys-bzero buf size-of-utsname)
 984     (%%sys-uname buf)
 985     (macrolet ((utsname-slot (name)
 986                  `(foreign-string-to-lisp
 987                    (foreign-slot-pointer buf 'utsname ',name))))
 988       (values (utsname-slot sysname)
 989               (utsname-slot nodename)
 990               (utsname-slot release)
 991               (utsname-slot version)
 992               (utsname-slot machine)))))
 993 \f
 994
 995 ;;;-------------------------------------------------------------------------
 996 ;;; User info
 997 ;;;-------------------------------------------------------------------------
 998
 999 (defsyscall (%%sys-getpwuid-r "getpwuid_r")
1000     (:int
1001      :error-predicate plusp
1002      :error-location :return)
1003   (uid     uid-t)
1004   (pwd     :pointer)
1005   (buffer  :pointer)
1006   (bufsize size-t)
1007   (result  :pointer))
1008
1009 (defsyscall (%%sys-getpwnam-r "getpwnam_r")
1010     (:int
1011      :error-predicate plusp
1012      :error-location :return)
1013   (name    :string)
1014   (pwd     :pointer)
1015   (buffer  :pointer)
1016   (bufsize size-t)
1017   (result  :pointer))
1018
1019 (defun funcall-getpw (fn arg)
1020   (with-foreign-objects ((pw 'passwd-entry) (pwp :pointer))
1021     (with-foreign-pointer (buf +cstring-path-max+ bufsize)
1022       (with-foreign-slots ((name passwd uid gid gecos dir shell) pw passwd-entry)
1023         (funcall fn arg pw buf bufsize pwp)
1024         (if (null-pointer-p (mem-ref pwp :pointer))
1025             nil
1026             (values name passwd uid gid gecos dir shell))))))
1027
1028 (defentrypoint %sys-getpwuid (uid)
1029   "Gets the password-entry of a user, by user id (reentrant)."
1030   (funcall-getpw #'%%sys-getpwuid-r uid))
1031
1032 (defentrypoint %sys-getpwnam (name)
1033   "Gets the password-entry of a user, by username (reentrant)."
1034   (funcall-getpw #'%%sys-getpwnam-r name))
1035 \f
1036
1037 ;;;-------------------------------------------------------------------------
1038 ;;; Group info
1039 ;;;-------------------------------------------------------------------------
1040
1041 (defsyscall (%%sys-getgrgid-r "getgrgid_r")
1042     (:int
1043      :error-predicate plusp
1044      :error-location :return)
1045   (uid     uid-t)
1046   (grp     :pointer)
1047   (buffer  :pointer)
1048   (bufsize size-t)
1049   (result  :pointer))
1050
1051 (defsyscall (%%sys-getgrnam-r "getgrnam_r")
1052     (:int
1053      :error-predicate plusp
1054      :error-location :return)
1055   (name    :string)
1056   (grp     :pointer)
1057   (buffer  :pointer)
1058   (bufsize size-t)
1059   (result  :pointer))
1060
1061 ;; FIXME: return group members too
1062 (defun funcall-getgr (fn arg)
1063   (with-foreign-objects ((gr 'group-entry) (grp :pointer))
1064     (with-foreign-pointer (buf +cstring-path-max+ bufsize)
1065       (with-foreign-slots ((name passwd gid) gr group-entry)
1066         (funcall fn arg gr buf bufsize grp)
1067         (if (null-pointer-p (mem-ref grp :pointer))
1068             nil
1069             (values name passwd gid))))))
1070
1071 (defentrypoint %sys-getgrgid (gid)
1072   "Gets a group-entry, by group id (reentrant)."
1073   (funcall-getgr #'%%sys-getgrgid-r gid))
1074
1075 (defentrypoint %sys-getgrnam (name)
1076   "Gets a group-entry, by group name (reentrant)."
1077   (funcall-getgr #'%%sys-getgrnam-r name))