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