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 #+linux (load-foreign-library "librt.so")
  10 \f
  11
  12 ;;;-------------------------------------------------------------------------
  13 ;;; ERRNO-related functions
  14 ;;;-------------------------------------------------------------------------
  15
  16 (defentrypoint (setf %sys-errno) (value)
  17   (%%sys-set-errno value))
  18
  19 (defentrypoint %sys-strerror (&optional (err (%sys-errno)))
  20   "Look up the error message string for ERRNO. (reentrant)"
  21   (let ((errno
  22          (if (keywordp err)
  23              (foreign-enum-value 'errno-values err)
  24              err)))
  25     (with-foreign-pointer-as-string ((buf bufsiz) 1024)
  26       (%sys-strerror-r errno buf bufsiz))))
  27
  28 (defmethod print-object ((posix-error posix-error) stream)
  29   (print-unreadable-object (posix-error stream :type nil :identity nil)
  30     (let ((code (code-of posix-error))
  31           (identifier (identifier-of posix-error)))
  32       (format stream "POSIX Error ~A code: ~S ~S"
  33               identifier (or code "[No code]")
  34               (or (%sys-strerror code) "[Can't get error string.]")))))
  35 \f
  36
  37 ;;;-------------------------------------------------------------------------
  38 ;;; Memory manipulation
  39 ;;;-------------------------------------------------------------------------
  40
  41 (defcfun* ("memset" %sys-memset) :pointer
  42   (buffer :pointer)
  43   (value  :int)
  44   (length size-t))
  45
  46 (defentrypoint %sys-bzero (buffer length)
  47   (%sys-memset buffer 0 length))
  48
  49 (defcfun* ("memcpy" %sys-memcpy) :pointer
  50   (dest   :pointer)
  51   (src    :pointer)
  52   (length size-t))
  53
  54 (defcfun* ("memmove" %sys-memmove) :pointer
  55   (dest   :pointer)
  56   (src    :pointer)
  57   (length size-t))
  58 \f
  59
  60 ;;;-------------------------------------------------------------------------
  61 ;;; I/O
  62 ;;;-------------------------------------------------------------------------
  63
  64 (defsyscall* ("read" %sys-read) ssize-t
  65   "Read at most COUNT bytes from FD into the foreign area BUF."
  66   (fd    :int)
  67   (buf   :pointer)
  68   (count size-t))
  69
  70 (defsyscall* ("write" %sys-write) ssize-t
  71   "Write at most COUNT bytes to FD from the foreign area BUF."
  72   (fd    :int)
  73   (buf   :pointer)
  74   (count size-t))
  75 \f
  76
  77 ;;;-------------------------------------------------------------------------
  78 ;;; Files
  79 ;;;-------------------------------------------------------------------------
  80
  81 (defsyscall* ("open" %%sys-open) :int
  82   (pathname filename-designator)
  83   (flags    :int)
  84   (mode     mode-t))
  85
  86 (defvar *default-open-mode* #o666)
  87
  88 (defentrypoint %sys-open (pathname flags &optional (mode *default-open-mode*))
  89   (%%sys-open pathname flags mode))
  90
  91 (defsyscall* ("creat" %sys-creat) :int
  92   (pathname filename-designator)
  93   (mode     mode-t))
  94
  95 (defsyscall ("pipe" %%sys-pipe) :int
  96   (filedes :pointer))
  97
  98 (defentrypoint %sys-pipe ()
  99   "Create pipe, returns two values with the new FDs."
 100   (with-foreign-object (filedes :int 2)
 101     (%%sys-pipe filedes)
 102     (values (mem-aref filedes :int 0)
 103             (mem-aref filedes :int 1))))
 104
 105 (defsyscall ("mkfifo" %sys-mkfifo) :int
 106   "Create a FIFO (named pipe)."
 107   (path filename-designator)
 108   (mode mode-t))
 109
 110 (defsyscall "umask" mode-t
 111   "Sets the umask and returns the old one"
 112   (new-mode mode-t))
 113
 114 (defsyscall ("access" %sys-access) :int
 115   (path  filename-designator)
 116   (amode :int))
 117
 118 (defsyscall ("rename" %sys-rename) :int
 119   "Rename a file."
 120   (old filename-designator)
 121   (new filename-designator))
 122
 123 (defsyscall ("link" %sys-link) :int
 124   (path1 filename-designator)
 125   (path2 filename-designator))
 126
 127 (defsyscall ("symlink" %sys-symlink) :int
 128   "Creates a symbolic link"
 129   (name1 filename-designator)
 130   (name2 filename-designator))
 131
 132 (defsyscall ("readlink" %%sys-readlink) ssize-t
 133   (path    filename-designator)
 134   (buf     :pointer)
 135   (bufsize size-t))
 136
 137 (defentrypoint %sys-readlink (path)
 138   "Read value of a symbolic link."
 139   (with-foreign-pointer (buf 4096 bufsize)
 140     (let ((count (%%sys-readlink path buf bufsize)))
 141       (values (foreign-string-to-lisp buf :count count)))))
 142
 143 (defsyscall ("unlink" %sys-unlink) :int
 144   (path filename-designator))
 145
 146 (defsyscall* ("chown" %sys-chown) :int
 147   "Change ownership of a file."
 148   (path  filename-designator)
 149   (owner uid-t)
 150   (group uid-t))
 151
 152 (defsyscall* ("fchown" %sys-fchown) :int
 153   "Change ownership of an open file."
 154   (fd    :int)
 155   (owner uid-t)
 156   (group uid-t))
 157
 158 (defsyscall* ("lchown" %sys-lchown) :int
 159   "Change ownership of a file or symlink."
 160   (path  filename-designator)
 161   (owner uid-t)
 162   (group uid-t))
 163
 164 (defsyscall* ("chmod" %sys-chmod) :int
 165   (path filename-designator)
 166   (mode mode-t))
 167
 168 (defsyscall* ("fchmod" %sys-fchmod) :int
 169   (fd   :int)
 170   (mode mode-t))
 171
 172 ;;; STAT()
 173
 174 (define-c-struct-wrapper stat ())
 175
 176 (defconstant +stat-version-linux+ 3)
 177
 178 ;;; If necessary for performance reasons, we can add an optional
 179 ;;; argument to this function and use that to reuse a wrapper object.
 180 (defentrypoint funcall-stat (fn arg)
 181   (with-foreign-object (buf 'stat)
 182     (funcall fn arg buf)
 183     (make-instance 'stat :pointer buf)))
 184
 185 (defentrypoint %sys-stat (path)
 186   "Get information about a file."
 187   (funcall-stat #'%%sys-stat path))
 188
 189 (defentrypoint %sys-fstat (fd)
 190   "Get information about a file descriptor"
 191   (funcall-stat #'%%sys-fstat fd))
 192
 193 (defentrypoint %sys-lstat (path)
 194   "Get information about a file or symlink."
 195   (funcall-stat #'%%sys-lstat path))
 196
 197 (defsyscall ("sync" %sys-sync) :void
 198   "Schedule all file system buffers to be written to disk.")
 199
 200 (defsyscall* ("fsync" %sys-fsync) :int
 201   (fildes :int))
 202
 203 (defsyscall ("mkstemp" %%sys-mkstemp) :int
 204   (template filename-designator))
 205
 206 (defentrypoint %sys-mkstemp (&optional (template ""))
 207   (let ((template (concatenate 'string template "XXXXXX")))
 208     (with-foreign-string (ptr (filename template))
 209       (values (%%sys-mkstemp ptr) (foreign-string-to-lisp ptr)))))
 210 \f
 211
 212 ;;;-------------------------------------------------------------------------
 213 ;;; Directories
 214 ;;;-------------------------------------------------------------------------
 215
 216 (defsyscall "mkdir" :int
 217   "Create a directory."
 218   (path filename-designator)
 219   (mode mode-t))
 220
 221 (defsyscall ("rmdir" %sys-rmdir) :int
 222   (path filename-designator))
 223
 224 (defsyscall ("chdir" %sys-chdir) :int
 225   "Changes the current working directory"
 226   (path filename-designator))
 227
 228 (defsyscall* ("fchdir" %sys-fchdir) :int
 229   (fildes :int))
 230
 231 (defsyscall ("getcwd" %%sys-getcwd) :string
 232   (buf :pointer)
 233   (size size-t))
 234
 235 (defentrypoint %sys-getcwd ()
 236   "Returns the current working directory as a string."
 237   (with-foreign-pointer (buf path-max size)
 238     (%%sys-getcwd buf size)))
 239
 240 (defsyscall ("mkdtemp" %%sys-mkdtemp) :int
 241   (template filename-designator))
 242
 243 (defentrypoint %sys-mkdtemp (&optional (template ""))
 244   (let ((template (concatenate 'string template "XXXXXX")))
 245     (with-foreign-string (ptr (filename template))
 246       (values (%%sys-mkdtemp ptr) (foreign-string-to-lisp ptr)))))
 247 \f
 248
 249 ;;;-------------------------------------------------------------------------
 250 ;;; File Descriptors
 251 ;;;-------------------------------------------------------------------------
 252
 253 (defsyscall ("close" %sys-close) :int
 254   "Close an open file descriptor."
 255   (fd :int))
 256
 257 (defsyscall ("dup" %sys-dup) :int
 258   (fildes :int))
 259
 260 (defsyscall* ("dup2" %sys-dup2) :int
 261   (fildes1 :int)
 262   (fildes2 :int))
 263
 264 (defsyscall* ("ioctl" %sys-ioctl/2) :int
 265   (fd      :int)
 266   (request :int))
 267
 268 (defsyscall* ("ioctl" %sys-ioctl/3) :int
 269  (fd      :int)
 270  (request :int)
 271  (arg     :pointer))
 272
 273 (defentrypoint %sys-fd-open-p (fd)
 274   (not (minusp (%sys-fstat fd))))
 275 \f
 276
 277 ;;;-------------------------------------------------------------------------
 278 ;;; File descriptor polling
 279 ;;;-------------------------------------------------------------------------
 280
 281 ;;; FIXME: Until a way to autodetect platform features is implemented
 282 #+(or darwin freebsd)
 283 (defconstant pollrdhup 0)
 284
 285 (defsyscall ("poll" %sys-poll) :int
 286   "Scan for I/O activity on multiple file descriptors."
 287   (fds     :pointer)
 288   (nfds    nfds-t)
 289   (timeout :int))
 290 \f
 291
 292 ;;;-------------------------------------------------------------------------
 293 ;;; Memory mapping
 294 ;;;-------------------------------------------------------------------------
 295
 296 (defsyscall ("munmap" %sys-munmap) :int
 297   "Unmap pages of memory."
 298   (addr :pointer)
 299   (len  size-t))
 300 \f
 301
 302 ;;;-------------------------------------------------------------------------
 303 ;;; Process creation and info
 304 ;;;-------------------------------------------------------------------------
 305
 306 (defsyscall ("fork" %sys-fork) pid-t
 307   "Create a child process.")
 308
 309 (defsyscall ("getpid" %sys-getpid) pid-t
 310   "Returns the process id of the current process")
 311
 312 (defsyscall ("getppid" %sys-getppid) pid-t
 313   "Returns the process id of the current process's parent")
 314
 315 (defsyscall ("getuid" %sys-getuid) uid-t
 316   "Get real user id of the current process.")
 317
 318 (defsyscall ("setuid" %sys-setuid) :int
 319   "Set real user id of the current process."
 320   (uid uid-t))
 321
 322 (defsyscall ("geteuid" %sys-geteuid) uid-t
 323   "Get effective user id of the current process.")
 324
 325 (defsyscall ("seteuid" %sys-seteuid) :int
 326   "Set effective user id of the current process."
 327   (uid uid-t))
 328
 329 (defsyscall ("getgid" %sys-getgid) gid-t
 330   "Get real group id of the current process.")
 331
 332 (defsyscall ("setgid" %sys-setgid) :int
 333   "Set real group id of the current process."
 334   (gid gid-t))
 335
 336 (defsyscall ("getegid" %sys-getegid) gid-t
 337   "Get effective group id of the current process.")
 338
 339 (defsyscall ("setegid" %sys-setegid) :int
 340   "Set effective group id of the current process."
 341   (gid gid-t))
 342
 343 (defsyscall ("setreuid" %sys-setreuid) :int
 344   "Set real and effective user id of the current process."
 345   (ruid uid-t)
 346   (euid uid-t))
 347
 348 (defsyscall ("setregid" %sys-setregid) :int
 349   "Set real and effective group id of the current process."
 350   (rgid gid-t)
 351   (egid gid-t))
 352
 353 (defsyscall ("getpgid" %sys-getpgid) pid-t
 354   "Get process group id of a process."
 355   (pid pid-t))
 356
 357 (defsyscall ("setpgid" %sys-setpgid) :int
 358   "Set process group id of a process."
 359   (pid  pid-t)
 360   (pgid pid-t))
 361
 362 (defsyscall ("getpgrp" %sys-getpgrp) pid-t
 363   "Get process group id of the current process.")
 364
 365 (defsyscall ("setpgrp" %sys-setpgrp) pid-t
 366   "Set process group id of the current process.")
 367
 368 (defsyscall ("setsid" %sys-setsid) pid-t
 369   "Create session and set process group id of the current process.")
 370
 371 (defentrypoint %sys-getrlimit (resource)
 372   (with-foreign-object (rl 'rlimit)
 373     (with-foreign-slots ((cur max) rl rlimit)
 374       (%%sys-getrlimit resource rl)
 375       (values cur max))))
 376
 377 (defentrypoint %sys-setrlimit (resource soft-limit hard-limit)
 378   (with-foreign-object (rl 'rlimit)
 379     (with-foreign-slots ((cur max) rl rlimit)
 380       (setf cur soft-limit
 381             max hard-limit)
 382       (%%sys-setrlimit resource rl))))
 383
 384 (defsyscall ("getrusage" %%sys-getrusage) :int
 385   (who   :int)
 386   (usage :pointer))
 387
 388 ;;; TODO: it might be more convenient to return a wrapper object here
 389 ;;; instead like we do in STAT.
 390 (defentrypoint %sys-getrusage (who)
 391   (with-foreign-object (ru 'rusage)
 392     (%%sys-getrusage who ru)
 393     (with-foreign-slots ((maxrss ixrss idrss isrss minflt majflt nswap inblock
 394                           oublock msgsnd msgrcv nsignals nvcsw nivcsw)
 395                          ru rusage)
 396       (values (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
 397                                   'timeval 'sec)
 398               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
 399                                   'timeval 'usec)
 400               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
 401                                   'timeval 'sec)
 402               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
 403                                   'timeval 'usec)
 404               maxrss ixrss idrss isrss minflt majflt
 405               nswap inblock oublock msgsnd
 406               msgrcv nsignals nvcsw nivcsw))))
 407
 408 (defsyscall ("getpriority" %sys-getpriority) :int
 409   (which :int)
 410   (who   :int))
 411
 412 (defsyscall ("setpriority" %sys-setpriority) :int
 413   (which :int)
 414   (who   :int)
 415   (value :int))
 416
 417 (defentrypoint %sys-nice (&optional (increment 0))
 418   "Get or set process priority."
 419   ;; FIXME: race condition. might need WITHOUT-INTERRUPTS on some impl.s
 420   (setf (%sys-errno) 0)
 421   (let ((r (foreign-funcall "nice" :int increment :int)))
 422     (if (and (= r -1) (/= (%sys-errno) 0))
 423         (signal-posix-error r)
 424         r)))
 425 \f
 426
 427 ;;;-------------------------------------------------------------------------
 428 ;;; Time
 429 ;;;-------------------------------------------------------------------------
 430
 431 (defsyscall* ("usleep" %sys-usleep) :int
 432   (useconds useconds-t))
 433
 434 (defsyscall ("time" %%sys-time) time-t
 435   (tloc :pointer))
 436
 437 (defentrypoint %sys-time ()
 438   (%%sys-time (null-pointer)))
 439
 440 (defsyscall ("gettimeofday" %%sys-gettimeofday) :int
 441   (tp  :pointer)
 442   (tzp :pointer))
 443
 444 (defentrypoint %sys-gettimeofday ()
 445   "Return the time in seconds and microseconds."
 446   (with-foreign-object (tv 'timeval)
 447     (with-foreign-slots ((sec usec) tv timeval)
 448       (%%sys-gettimeofday tv (null-pointer))
 449       (values sec usec))))
 450
 451 ;;; FIXME: or we can implement this through the MACH functions.
 452 #+darwin
 453 (progn
 454   (defctype kern-return-t :int)
 455   (defctype clock-res-t :int)
 456   (defctype clock-id-t :int)
 457   (defctype port-t :unsigned-int)         ; not sure
 458   (defctype clock-serv-t port)
 459
 460   (defconstant kern-success 0)
 461
 462   (defconstant system-clock 0)
 463   (defconstant calendar-clock 1)
 464   (defconstant realtime-clock 0)
 465
 466   (defsyscall ("mach_host_self" %sys-mach-host-self) port-t)
 467
 468   (defsyscall ("host_get_clock_service" %%sys-host-get-clock-service) kern-return-t
 469     (host port-t)
 470     (id clock-id-t)
 471     (clock-name (:pointer clock-serv-t)))
 472
 473   (defentrypoint %sys-host-get-clock-service (id &optional (host (%sys-mach-host-self)))
 474     (with-foreign-object (clock 'clock-serv-t)
 475       (%%sys-host-get-clock-service host id clock)
 476       (mem-ref clock :int)))
 477
 478   (defsyscall ("clock_get_time" %clock-get-time) kern-return-t
 479     (clock-serv clock-serv-t)
 480     (cur-time timespec))
 481
 482   (defentrypoint clock-get-time (clock-service)
 483     (with-foreign-object (time 'timespec)
 484       (%clock-get-time clock-service time)
 485       (with-foreign-slots ((tv-sec tv-nsec) time timespec)
 486         (values tv-sec tv-nsec)))))
 487
 488 #-darwin
 489 (progn
 490   (defsyscall ("clock_getres" %%sys-clock-getres) :int
 491     "Returns the resolution of the clock CLOCKID."
 492     (clockid clockid-t)
 493     (res     :pointer))
 494
 495   (defentrypoint %sys-clock-getres (clock-id)
 496     (with-foreign-object (ts 'timespec)
 497       (with-foreign-slots ((sec nsec) ts timespec)
 498         (%%sys-clock-getres clock-id ts)
 499         (values sec nsec))))
 500
 501   (defsyscall ("clock_gettime" %%sys-clock-gettime) :int
 502     (clockid clockid-t)
 503     (tp      :pointer))
 504
 505   (defentrypoint %sys-clock-gettime (clock-id)
 506     "Returns the time of the clock CLOCKID."
 507     (with-foreign-object (ts 'timespec)
 508       (with-foreign-slots ((sec nsec) ts timespec)
 509         (%%sys-clock-gettime clock-id ts)
 510         (values sec nsec))))
 511
 512   (defsyscall ("clock_settime" %%sys-clock-settime) :int
 513     (clockid clockid-t)
 514     (tp      :pointer))
 515
 516   (defentrypoint %sys-clock-settime (clock-id)
 517     "Sets the time of the clock CLOCKID."
 518     (with-foreign-object (ts 'timespec)
 519       (with-foreign-slots ((sec nsec) ts timespec)
 520         (%%sys-clock-settime clock-id ts)
 521         (values sec nsec)))))
 522
 523 (defentrypoint %sys-get-monotonic-time ()
 524   "Gets current time in seconds from a system's monotonic clock."
 525   (multiple-value-bind (seconds nanoseconds)
 526       #-darwin (%sys-clock-gettime clock-monotonic)
 527       #+darwin (%sys-clock-get-time (%sys-host-get-clock-service system-clock))
 528     (+ seconds (/ nanoseconds 1d9))))
 529 \f
 530
 531 ;;;-------------------------------------------------------------------------
 532 ;;; Environement
 533 ;;;-------------------------------------------------------------------------
 534
 535 (defcvar ("environ" :read-only t) (:pointer :string))
 536
 537 (defsyscall ("getenv" %sys-getenv) :string
 538   "Returns the value of an environment variable"
 539   (name :string))
 540
 541 (defsyscall ("setenv" %sys-setenv) :int
 542   "Changes the value of an environment variable"
 543   (name      :string)
 544   (value     :string)
 545   (overwrite bool-designator))
 546
 547 (defsyscall ("unsetenv" %sys-unsetenv) :int
 548   "Removes the binding of an environment variable"
 549   (name :string))
 550 \f
 551
 552 ;;;-------------------------------------------------------------------------
 553 ;;; Local info
 554 ;;;-------------------------------------------------------------------------
 555
 556 (defsyscall ("gethostname" %%sys-gethostname) :int
 557   (name    :pointer)
 558   (namelen size-t))
 559
 560 (defentrypoint %sys-gethostname ()
 561   (with-foreign-pointer-as-string ((cstr size) 256)
 562     (%%sys-gethostname cstr size)))
 563
 564 (defsyscall ("getdomainname" %%sys-getdomainname) :int
 565   (name    :pointer)
 566   (namelen size-t))
 567
 568 (defentrypoint %sys-getdomainname ()
 569   (with-foreign-pointer-as-string ((cstr size) 256)
 570     (%%sys-getdomainname cstr size)))