contrib/sb-posix/interface.lisp

   1 (cl:in-package :sb-posix)
   2
   3 (defmacro define-protocol-class
   4     (name alien-type superclasses slots &rest options)
   5   (let ((to-protocol (intern (format nil "ALIEN-TO-~A" name)))
   6         (to-alien (intern (format nil "~A-TO-ALIEN" name))))
   7     `(progn
   8       (export ',name :sb-posix)
   9       (defclass ,name ,superclasses
  10         ,(loop for slotd in slots
  11                collect (ldiff slotd (member :array-length slotd)))
  12         ,@options)
  13       (declaim (inline ,to-alien ,to-protocol))
  14       (declaim (inline ,to-protocol ,to-alien))
  15       (defun ,to-protocol (alien &optional instance)
  16         (declare (type (sb-alien:alien (* ,alien-type)) alien)
  17                  (type (or null ,name) instance))
  18         (unless instance
  19           (setf instance (make-instance ',name)))
  20         ,@(loop for slotd in slots
  21                 ;; FIXME: slotds in source are more complicated in general
  22                 ;;
  23                 ;; FIXME: baroque construction of intricate fragility
  24                 for array-length = (getf (cdr slotd) :array-length)
  25                 if array-length
  26                   collect `(progn
  27                              (let ((array (make-array ,array-length)))
  28                                (setf (slot-value instance ',(car slotd))
  29                                      array)
  30                                (dotimes (i ,array-length)
  31                                  (setf (aref array i)
  32                                        (sb-alien:deref
  33                                         (sb-alien:slot alien ',(car slotd))
  34                                         i)))))
  35                 else
  36                   collect `(setf (slot-value instance ',(car slotd))
  37                                  (sb-alien:slot alien ',(car slotd))))
  38         instance)
  39       (defun ,to-alien (instance &optional alien)
  40         (declare (type (or null (sb-alien:alien (* ,alien-type))) alien)
  41                  (type ,name instance))
  42         (unless alien
  43           (setf alien (sb-alien:make-alien ,alien-type)))
  44         ,@(loop for slotd in slots
  45                 for array-length = (getf (cdr slotd) :array-length)
  46                 if array-length
  47                   collect `(progn
  48                              (let ((array (slot-value instance ',(car slotd))))
  49                                (dotimes (i ,array-length)
  50                                  (setf (sb-alien:deref
  51                                         (sb-alien:slot alien ',(car slotd))
  52                                         i)
  53                                        (aref array i)))))
  54                 else
  55                   collect `(setf (sb-alien:slot alien ',(car slotd))
  56                                  (slot-value instance ',(car slotd)))))
  57       (find-class ',name))))
  58
  59 (define-condition sb-posix:syscall-error (error)
  60   ((errno :initarg :errno :reader sb-posix:syscall-errno))
  61   (:report (lambda (c s)
  62              (let ((errno (sb-posix:syscall-errno c)))
  63                (format s "System call error ~A (~A)"
  64                        errno (sb-int:strerror errno))))))
  65
  66 (defun syscall-error ()
  67   (error 'sb-posix:syscall-error :errno (get-errno)))
  68
  69 (declaim (inline never-fails))
  70 (defun never-fails (&rest args)
  71   (declare (ignore args))
  72   nil)
  73
  74 ;;; Some systems may need C-level wrappers, which can live in the
  75 ;;; runtime (so that save-lisp-and-die can produce standalone
  76 ;;; executables).  See REAL-C-NAME in macros.lisp for the use of this
  77 ;;; variable.
  78 (eval-when (:compile-toplevel :load-toplevel)
  79   (setf *c-functions-in-runtime*
  80         '`(#+netbsd ,@("stat" "lstat" "fstat" "readdir" "opendir"))))
  81
  82
  83 ;;; filesystem access
  84 (defmacro define-call* (name &rest arguments)
  85   #-win32 `(define-call ,name ,@arguments)
  86   #+win32 `(define-call ,(if (consp name)
  87                              `(,(concatenate 'string "_" (car name))
  88                                 ,@(cdr name))
  89                              (concatenate 'string "_" name))
  90                ,@arguments))
  91
  92 (define-call* "access" int minusp (pathname filename) (mode int))
  93 (define-call* "chdir" int minusp (pathname filename))
  94 (define-call* "chmod" int minusp (pathname filename) (mode mode-t))
  95 (define-call* "close" int minusp (fd file-descriptor))
  96 (define-call* "creat" int minusp (pathname filename) (mode mode-t))
  97 (define-call* "dup" int minusp (oldfd file-descriptor))
  98 (define-call* "dup2" int minusp (oldfd file-descriptor)
  99               (newfd file-descriptor))
 100 (define-call* ("lseek" :options :largefile)
 101     off-t minusp (fd file-descriptor) (offset off-t)
 102     (whence int))
 103 (define-call* "mkdir" int minusp (pathname filename) (mode mode-t))
 104 (macrolet ((def (x)
 105                `(progn
 106                  (define-call-internally open-with-mode ,x int minusp
 107                    (pathname filename) (flags int) (mode mode-t))
 108                  (define-call-internally open-without-mode ,x int minusp
 109                    (pathname filename) (flags int))
 110                  (define-entry-point ,x
 111                      (pathname flags &optional (mode nil mode-supplied))
 112                    (if mode-supplied
 113                        (open-with-mode pathname flags mode)
 114                        (open-without-mode pathname flags))))))
 115     (def #-win32 "open" #+win32 "_open"))
 116 (define-call "rename" int minusp (oldpath filename) (newpath filename))
 117 (define-call* "rmdir" int minusp (pathname filename))
 118 (define-call* "unlink" int minusp (pathname filename))
 119 (define-call #-netbsd "opendir" #+netbsd "_opendir"
 120     (* t) null-alien (pathname filename))
 121 (define-call (#-netbsd "readdir" #+netbsd "_readdir" :options :largefile)
 122   (* dirent)
 123   ;; readdir() has the worst error convention in the world.  It's just
 124   ;; too painful to support.  (return is NULL _and_ errno "unchanged"
 125   ;; is not an error, it's EOF).
 126   not
 127   (dir (* t)))
 128 (define-call "closedir" int minusp (dir (* t)))
 129 ;; need to do this here because we can't do it in the DEFPACKAGE
 130 (define-call* "umask" mode-t never-fails (mode mode-t))
 131 (define-call* "getpid" pid-t never-fails)
 132
 133 #-win32
 134 (progn
 135   (define-call "chown" int minusp (pathname filename)
 136                (owner uid-t) (group gid-t))
 137   (define-call "chroot" int minusp (pathname filename))
 138   (define-call "fchdir" int minusp (fd file-descriptor))
 139   (define-call "fchmod" int minusp (fd file-descriptor) (mode mode-t))
 140   (define-call "fchown" int minusp (fd file-descriptor)
 141                (owner uid-t)  (group gid-t))
 142   (define-call "fdatasync" int minusp (fd file-descriptor))
 143   (define-call ("ftruncate" :options :largefile)
 144       int minusp (fd file-descriptor) (length off-t))
 145   (define-call "fsync" int minusp (fd file-descriptor))
 146   (define-call "lchown" int minusp (pathname filename)
 147                (owner uid-t)  (group gid-t))
 148   (define-call "link" int minusp (oldpath filename) (newpath filename))
 149   (define-call "lockf" int minusp (fd file-descriptor) (cmd int) (len off-t))
 150   (define-call "mkfifo" int minusp (pathname filename) (mode mode-t))
 151   (define-call "symlink" int minusp (oldpath filename) (newpath filename))
 152   (define-call "sync" void never-fails)
 153   (define-call ("truncate" :options :largefile)
 154       int minusp (pathname filename) (length off-t))
 155   ;; FIXME: Windows does have _mktemp, which has a slightlty different
 156   ;; interface
 157   (defun mkstemp (template)
 158     ;; we are emulating sb-alien's charset conversion for strings
 159     ;; here, to accommodate for the call-by-reference nature of
 160     ;; mkstemp's template strings.
 161     (let ((arg (sb-ext:string-to-octets
 162                 (filename template)
 163                 :external-format sb-alien::*default-c-string-external-format*)))
 164       (sb-sys:with-pinned-objects (arg)
 165         (let ((result (alien-funcall (extern-alien "mkstemp"
 166                                                    (function int c-string))
 167                                      (sap-alien (sb-alien::vector-sap arg)
 168                                                 (* char)))))
 169           (when (minusp result)
 170             (syscall-error))
 171           (values result
 172                   (sb-ext:octets-to-string
 173                    arg
 174                    :external-format sb-alien::*default-c-string-external-format*))))))
 175   (define-call-internally ioctl-without-arg "ioctl" int minusp
 176                           (fd file-descriptor) (cmd int))
 177   (define-call-internally ioctl-with-int-arg "ioctl" int minusp
 178                           (fd file-descriptor) (cmd int) (arg int))
 179   (define-call-internally ioctl-with-pointer-arg "ioctl" int minusp
 180                           (fd file-descriptor) (cmd int)
 181                           (arg alien-pointer-to-anything-or-nil))
 182   (define-entry-point "ioctl" (fd cmd &optional (arg nil argp))
 183     (if argp
 184         (etypecase arg
 185           ((alien int) (ioctl-with-int-arg fd cmd arg))
 186           ((or (alien (* t)) null) (ioctl-with-pointer-arg fd cmd arg)))
 187         (ioctl-without-arg fd cmd)))
 188   (define-call-internally fcntl-without-arg "fcntl" int minusp
 189                           (fd file-descriptor) (cmd int))
 190   (define-call-internally fcntl-with-int-arg "fcntl" int minusp
 191                           (fd file-descriptor) (cmd int) (arg int))
 192   (define-call-internally fcntl-with-pointer-arg "fcntl" int minusp
 193                           (fd file-descriptor) (cmd int)
 194                           (arg alien-pointer-to-anything-or-nil))
 195   (define-entry-point "fcntl" (fd cmd &optional (arg nil argp))
 196     (if argp
 197         (etypecase arg
 198           ((alien int) (fcntl-with-int-arg fd cmd arg))
 199           ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg)))
 200         (fcntl-without-arg fd cmd)))
 201
 202   ;; uid, gid
 203   (define-call "geteuid" uid-t never-fails) ; "always successful", it says
 204   (define-call "getresuid" uid-t never-fails)
 205   (define-call "getuid" uid-t never-fails)
 206   (define-call "seteuid" int minusp (uid uid-t))
 207   (define-call "setfsuid" int minusp (uid uid-t))
 208   (define-call "setreuid" int minusp (ruid uid-t) (euid uid-t))
 209   (define-call "setresuid" int minusp (ruid uid-t) (euid uid-t) (suid uid-t))
 210   (define-call "setuid" int minusp (uid uid-t))
 211   (define-call "getegid" gid-t never-fails)
 212   (define-call "getgid" gid-t never-fails)
 213   (define-call "getresgid" gid-t never-fails)
 214   (define-call "setegid" int minusp (gid gid-t))
 215   (define-call "setfsgid" int minusp (gid gid-t))
 216   (define-call "setgid" int minusp (gid gid-t))
 217   (define-call "setregid" int minusp (rgid gid-t) (egid gid-t))
 218   (define-call "setresgid" int minusp (rgid gid-t) (egid gid-t) (sgid gid-t))
 219
 220   ;; processes, signals
 221   (define-call "alarm" int never-fails (seconds unsigned))
 222
 223
 224
 225   #+mach-exception-handler
 226   (progn
 227     ;; FIXME this is a lie, of course this can fail, but there's no
 228     ;; error handling here yet!
 229     (define-call "setup_mach_exceptions" void never-fails)
 230     (define-call ("posix_fork" :c-name "fork") pid-t minusp)
 231     (defun fork ()
 232       (let ((pid (posix-fork)))
 233         (when (= pid 0)
 234           (setup-mach-exceptions))
 235         pid))
 236     (export 'fork :sb-posix))
 237
 238   #-mach-exception-handler
 239   (define-call "fork" pid-t minusp)
 240
 241   (define-call "getpgid" pid-t minusp (pid pid-t))
 242   (define-call "getppid" pid-t never-fails)
 243   (define-call "getpgrp" pid-t never-fails)
 244   (define-call "getsid" pid-t minusp  (pid pid-t))
 245   (define-call "kill" int minusp (pid pid-t) (signal int))
 246   (define-call "killpg" int minusp (pgrp int) (signal int))
 247   (define-call "pause" int minusp)
 248   (define-call "setpgid" int minusp (pid pid-t) (pgid pid-t))
 249   (define-call "setpgrp" int minusp))
 250
 251 (defmacro with-growing-c-string ((buffer size) &body body)
 252   (sb-int:with-unique-names (c-string-block)
 253     `(block ,c-string-block
 254        (let (,buffer)
 255          (flet ((,buffer (&optional (size-incl-null))
 256                   (when size-incl-null
 257                     (setf (sb-sys:sap-ref-8 (sb-alien:alien-sap ,buffer) size-incl-null)
 258                           0))
 259                   (return-from ,c-string-block
 260                     (sb-alien::c-string-to-string
 261                      (sb-alien:alien-sap ,buffer)
 262                      (sb-impl::default-external-format)
 263                      'character))))
 264            (loop for ,size = 128 then (* 2 ,size)
 265                  do (unwind-protect
 266                          (progn
 267                            (setf ,buffer (make-alien c-string ,size))
 268                            ,@body)
 269                       (when ,buffer
 270                         (free-alien ,buffer)))))))))
 271
 272 #-win32
 273 (progn
 274   (export 'readlink :sb-posix)
 275   (defun readlink (pathspec)
 276     "Returns the resolved target of a symbolic link as a string."
 277     (flet ((%readlink (path buf length)
 278              (alien-funcall
 279               (extern-alien "readlink" (function int c-string (* t) int))
 280               path buf length)))
 281       (with-growing-c-string (buf size)
 282         (let ((count (%readlink (filename pathspec) buf size)))
 283           (cond ((minusp count)
 284                  (syscall-error))
 285                 ((< 0 count size)
 286                  (buf count))))))))
 287
 288 (progn
 289   (export 'getcwd :sb-posix)
 290   (defun getcwd ()
 291     "Returns the process's current working directory as a string."
 292     (flet ((%getcwd (buffer size)
 293              (alien-funcall
 294               (extern-alien #-win32 "getcwd"
 295                             #+win32 "_getcwd" (function c-string (* t) int))
 296               buffer size)))
 297       (with-growing-c-string (buf size)
 298         (let ((result (%getcwd buf size)))
 299           (cond (result
 300                  (buf))
 301                 ((/= (get-errno) sb-posix:erange)
 302                  (syscall-error))))))))
 303
 304 #-win32
 305 (progn
 306  (export 'wait :sb-posix)
 307  (declaim (inline wait))
 308  (defun wait (&optional statusptr)
 309    (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr))
 310    (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32))))
 311           (pid (sb-sys:with-pinned-objects (ptr)
 312                  (alien-funcall
 313                   (extern-alien "wait" (function pid-t (* int)))
 314                   (sb-sys:vector-sap ptr)))))
 315      (if (minusp pid)
 316          (syscall-error)
 317          (values pid (aref ptr 0))))))
 318
 319 #-win32
 320 (progn
 321  (export 'waitpid :sb-posix)
 322  (declaim (inline waitpid))
 323  (defun waitpid (pid options &optional statusptr)
 324    (declare (type (sb-alien:alien pid-t) pid)
 325             (type (sb-alien:alien int) options)
 326             (type (or null (simple-array (signed-byte 32) (1))) statusptr))
 327    (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32))))
 328           (pid (sb-sys:with-pinned-objects (ptr)
 329                  (alien-funcall
 330                   (extern-alien "waitpid" (function pid-t
 331                                                     pid-t (* int) int))
 332                   pid (sb-sys:vector-sap ptr) options))))
 333      (if (minusp pid)
 334          (syscall-error)
 335          (values pid (aref ptr 0)))))
 336  ;; waitpid macros
 337  (define-call "wifexited" boolean never-fails (status int))
 338  (define-call "wexitstatus" int never-fails (status int))
 339  (define-call "wifsignaled" boolean never-fails (status int))
 340  (define-call "wtermsig" int never-fails (status int))
 341  (define-call "wifstopped" boolean never-fails (status int))
 342  (define-call "wstopsig" int never-fails (status int))
 343  #+nil ; see alien/waitpid-macros.c
 344  (define-call "wifcontinued" boolean never-fails (status int)))
 345
 346 ;;; mmap, msync
 347 #-win32
 348 (progn
 349  (define-call ("mmap" :options :largefile) sb-sys:system-area-pointer
 350    (lambda (res)
 351      (= (sb-sys:sap-int res) #.(1- (expt 2 sb-vm::n-machine-word-bits))))
 352    (addr sap-or-nil) (length unsigned) (prot unsigned)
 353    (flags unsigned) (fd file-descriptor) (offset off-t))
 354
 355  (define-call "munmap" int minusp
 356    (start sb-sys:system-area-pointer) (length unsigned))
 357
 358 (define-call "msync" int minusp
 359   (addr sb-sys:system-area-pointer) (length unsigned) (flags int)))
 360
 361 #-win32
 362 (define-call "getpagesize" int minusp)
 363 #+win32
 364 ;;; KLUDGE: This could be taken from GetSystemInfo
 365 (export (defun getpagesize () 4096))
 366
 367 ;;; passwd database
 368 ;; The docstrings are copied from the descriptions in SUSv3,
 369 ;; where present.
 370 #-win32
 371 (define-protocol-class passwd alien-passwd ()
 372   ((name :initarg :name :accessor passwd-name
 373          :documentation "User's login name.")
 374    ;; Note: SUSv3 doesn't require this member.
 375    (passwd :initarg :passwd :accessor passwd-passwd
 376            :documentation "The account's encrypted password.")
 377    (uid :initarg :uid :accessor passwd-uid
 378         :documentation "Numerical user ID.")
 379    (gid :initarg :gid :accessor passwd-gid
 380         :documentation "Numerical group ID.")
 381    ;; Note: SUSv3 doesn't require this member.
 382    (gecos :initarg :gecos :accessor passwd-gecos
 383           :documentation "User's name or comment field.")
 384    (dir :initarg :dir :accessor passwd-dir
 385         :documentation "Initial working directory.")
 386    (shell :initarg :shell :accessor passwd-shell
 387           :documentation "Program to use as shell."))
 388   (:documentation "Instances of this class represent entries in
 389                    the system's user database."))
 390
 391 (defmacro define-pw-call (name arg type)
 392   #-win32
 393   ;; FIXME: this isn't the documented way of doing this, surely?
 394   (let ((lisp-name (intern (string-upcase name) :sb-posix)))
 395     `(progn
 396       (export ',lisp-name :sb-posix)
 397       (declaim (inline ,lisp-name))
 398       (defun ,lisp-name (,arg)
 399         (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
 400           (if (null r)
 401               r
 402               (alien-to-passwd r)))))))
 403
 404 (define-pw-call "getpwnam" login-name (function (* alien-passwd) c-string))
 405 (define-pw-call "getpwuid" uid (function (* alien-passwd) uid-t))
 406
 407 ;;; group database
 408 #-win32
 409 (define-protocol-class group alien-group ()
 410   ((name :initarg :name :accessor group-name)
 411    (passwd :initarg :passwd :accessor group-passwd)
 412    (gid :initarg :gid :accessor group-gid)))
 413
 414 (defmacro define-gr-call (name arg type)
 415   #-win32
 416   ;; FIXME: this isn't the documented way of doing this, surely?
 417   (let ((lisp-name (intern (string-upcase name) :sb-posix)))
 418     `(progn
 419       (export ',lisp-name :sb-posix)
 420       (declaim (inline ,lisp-name))
 421       (defun ,lisp-name (,arg)
 422         (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
 423           (if (null r)
 424               r
 425               (alien-to-group r)))))))
 426
 427 (define-gr-call "getgrnam" login-name (function (* alien-group) c-string))
 428 (define-gr-call "getgrgid" gid (function (* alien-group) gid-t))
 429
 430
 431 #-win32
 432 (define-protocol-class timeval alien-timeval ()
 433   ((sec :initarg :tv-sec :accessor timeval-sec
 434         :documentation "Seconds.")
 435    (usec :initarg :tv-usec :accessor timeval-usec
 436          :documentation "Microseconds."))
 437   (:documentation "Instances of this class represent time values."))
 438
 439 (define-protocol-class stat alien-stat ()
 440   ((mode :initarg :mode :reader stat-mode
 441          :documentation "Mode of file.")
 442    (ino :initarg :ino :reader stat-ino
 443         :documentation "File serial number.")
 444    (dev :initarg :dev :reader stat-dev
 445         :documentation "Device ID of device containing file.")
 446    (nlink :initarg :nlink :reader stat-nlink
 447           :documentation "Number of hard links to the file.")
 448    (uid :initarg :uid :reader stat-uid
 449         :documentation "User ID of file.")
 450    (gid :initarg :gid :reader stat-gid
 451         :documentation "Group ID of file.")
 452    (size :initarg :size :reader stat-size
 453          :documentation "For regular files, the file size in
 454                          bytes.  For symbolic links, the length
 455                          in bytes of the filename contained in
 456                          the symbolic link.")
 457    (atime :initarg :atime :reader stat-atime
 458           :documentation "Time of last access.")
 459    (mtime :initarg :mtime :reader stat-mtime
 460           :documentation "Time of last data modification.")
 461    (ctime :initarg :ctime :reader stat-ctime
 462           :documentation "Time of last status change"))
 463   (:documentation "Instances of this class represent Posix file
 464                    metadata."))
 465
 466 (defmacro define-stat-call (name arg designator-fun type)
 467   ;; FIXME: this isn't the documented way of doing this, surely?
 468   (let ((lisp-name (lisp-for-c-symbol name)))
 469     `(progn
 470       (export ',lisp-name :sb-posix)
 471       (declaim (inline ,lisp-name))
 472       (defun ,lisp-name (,arg &optional stat)
 473         (declare (type (or null stat) stat))
 474         (with-alien-stat a-stat ()
 475           (let ((r (alien-funcall
 476                     (extern-alien ,(real-c-name (list name :options :largefile)) ,type)
 477                     (,designator-fun ,arg)
 478                     a-stat)))
 479             (when (minusp r)
 480               (syscall-error))
 481             (alien-to-stat a-stat stat)))))))
 482
 483 (define-stat-call #-win32 "stat" #+win32 "_stat"
 484                   pathname filename
 485                   (function int c-string (* alien-stat)))
 486
 487 #-win32
 488 (define-stat-call "lstat"
 489                   pathname filename
 490                   (function int c-string (* alien-stat)))
 491 ;;; No symbolic links on Windows, so use stat
 492 #+win32
 493 (progn
 494   (declaim (inline lstat))
 495   (export (defun lstat (filename &optional stat)
 496             (if stat (stat filename stat) (stat filename)))))
 497
 498 (define-stat-call #-win32 "fstat" #+win32 "_fstat"
 499                   fd file-descriptor
 500                   (function int int (* alien-stat)))
 501
 502
 503 ;;; mode flags
 504 (define-call "s_isreg" boolean never-fails (mode mode-t))
 505 (define-call "s_isdir" boolean never-fails (mode mode-t))
 506 (define-call "s_ischr" boolean never-fails (mode mode-t))
 507 (define-call "s_isblk" boolean never-fails (mode mode-t))
 508 (define-call "s_isfifo" boolean never-fails (mode mode-t))
 509 (define-call "s_islnk" boolean never-fails (mode mode-t))
 510 (define-call "s_issock" boolean never-fails (mode mode-t))
 511
 512 #-win32
 513 (progn
 514  (export 'pipe :sb-posix)
 515  (declaim (inline pipe))
 516  (defun pipe (&optional filedes2)
 517    (declare (type (or null (simple-array (signed-byte 32) (2))) filedes2))
 518    (unless filedes2
 519      (setq filedes2 (make-array 2 :element-type '(signed-byte 32))))
 520    (let ((r (sb-sys:with-pinned-objects (filedes2)
 521               (alien-funcall
 522                ;; FIXME: (* INT)?  (ARRAY INT 2) would be better
 523                (extern-alien "pipe" (function int (* int)))
 524                (sb-sys:vector-sap filedes2)))))
 525      (when (minusp r)
 526        (syscall-error)))
 527    (values (aref filedes2 0) (aref filedes2 1))))
 528
 529 #-win32
 530 (define-protocol-class termios alien-termios ()
 531   ((iflag :initarg :iflag :accessor sb-posix:termios-iflag
 532           :documentation "Input modes.")
 533    (oflag :initarg :oflag :accessor sb-posix:termios-oflag
 534           :documentation "Output modes.")
 535    (cflag :initarg :cflag :accessor sb-posix:termios-cflag
 536           :documentation "Control modes.")
 537    (lflag :initarg :lflag :accessor sb-posix:termios-lflag
 538           :documentation "Local modes.")
 539    (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs
 540        :documentation "Control characters"))
 541   (:documentation "Instances of this class represent I/O
 542                    characteristics of the terminal."))
 543
 544 #-win32
 545 (progn
 546  (export 'tcsetattr :sb-posix)
 547  (declaim (inline tcsetattr))
 548  (defun tcsetattr (fd actions termios)
 549    (declare (type termios termios))
 550    (with-alien-termios a-termios ()
 551      (termios-to-alien termios a-termios)
 552      (let ((fd (file-descriptor fd)))
 553        (let* ((r (alien-funcall
 554                   (extern-alien
 555                    "tcsetattr"
 556                    (function int int int (* alien-termios)))
 557                   fd actions a-termios)))
 558          (when (minusp r)
 559            (syscall-error)))
 560        (values))))
 561  (export 'tcgetattr :sb-posix)
 562  (declaim (inline tcgetattr))
 563  (defun tcgetattr (fd &optional termios)
 564    (declare (type (or null termios) termios))
 565    (with-alien-termios a-termios ()
 566      (let ((r (alien-funcall
 567                (extern-alien "tcgetattr"
 568                              (function int int (* alien-termios)))
 569                (file-descriptor fd)
 570                a-termios)))
 571        (when (minusp r)
 572          (syscall-error))
 573        (setf termios (alien-to-termios a-termios termios))))
 574    termios)
 575  (export 'cfsetispeed :sb-posix)
 576  (declaim (inline cfsetispeed))
 577  (defun cfsetispeed (speed &optional termios)
 578    (declare (type (or null termios) termios))
 579    (with-alien-termios a-termios ()
 580      (let ((r (alien-funcall
 581                (extern-alien "cfsetispeed"
 582                              (function int (* alien-termios) speed-t))
 583                a-termios
 584                speed)))
 585        (when (minusp r)
 586          (syscall-error))
 587        (setf termios (alien-to-termios a-termios termios))))
 588    termios)
 589  (export 'cfsetospeed :sb-posix)
 590  (declaim (inline cfsetospeed))
 591  (defun cfsetospeed (speed &optional termios)
 592    (declare (type (or null termios) termios))
 593    (with-alien-termios a-termios ()
 594      (let ((r (alien-funcall
 595                (extern-alien "cfsetospeed"
 596                              (function int (* alien-termios) speed-t))
 597                a-termios
 598                speed)))
 599        (when (minusp r)
 600          (syscall-error))
 601        (setf termios (alien-to-termios a-termios termios))))
 602    termios)
 603  (export 'cfgetispeed :sb-posix)
 604  (declaim (inline cfgetispeed))
 605  (defun cfgetispeed (termios)
 606    (declare (type termios termios))
 607    (with-alien-termios a-termios ()
 608      (termios-to-alien termios a-termios)
 609      (alien-funcall (extern-alien "cfgetispeed"
 610                                   (function speed-t (* alien-termios)))
 611                     a-termios)))
 612  (export 'cfgetospeed :sb-posix)
 613  (declaim (inline cfgetospeed))
 614  (defun cfgetospeed (termios)
 615    (declare (type termios termios))
 616    (with-alien-termios a-termios ()
 617      (termios-to-alien termios a-termios)
 618      (alien-funcall (extern-alien "cfgetospeed"
 619                                  (function speed-t (* alien-termios)))
 620                     a-termios))))
 621
 622
 623 #-win32
 624 (progn
 625   (export 'time :sb-posix)
 626   (defun time ()
 627     (let ((result (alien-funcall (extern-alien "time"
 628                                                (function time-t (* time-t)))
 629                                  nil)))
 630       (if (minusp result)
 631           (syscall-error)
 632           result)))
 633   (export 'utime :sb-posix)
 634   (defun utime (filename &optional access-time modification-time)
 635     (let ((fun (extern-alien "utime" (function int c-string
 636                                                (* alien-utimbuf))))
 637           (name (filename filename)))
 638       (if (not (and access-time modification-time))
 639           (alien-funcall fun name nil)
 640           (with-alien ((utimbuf (struct alien-utimbuf)))
 641             (setf (slot utimbuf 'actime) (or access-time 0)
 642                   (slot utimbuf 'modtime) (or modification-time 0))
 643             (let ((result (alien-funcall fun name (alien-sap utimbuf))))
 644               (if (minusp result)
 645                   (syscall-error)
 646                   result))))))
 647   (export 'utimes :sb-posix)
 648   (defun utimes (filename &optional access-time modification-time)
 649     (flet ((seconds-and-useconds (time)
 650              (multiple-value-bind (integer fractional)
 651                  (cl:truncate time)
 652                (values integer (cl:truncate (* fractional 1000000)))))
 653            (maybe-syscall-error (value)
 654              (if (minusp value)
 655                  (syscall-error)
 656                  value)))
 657       (let ((fun (extern-alien "utimes" (function int c-string
 658                                                   (* (array alien-timeval 2)))))
 659             (name (filename filename)))
 660         (if (not (and access-time modification-time))
 661             (maybe-syscall-error (alien-funcall fun name nil))
 662             (with-alien ((buf (array alien-timeval 2)))
 663               (let ((actime (deref buf 0))
 664                     (modtime (deref buf 1)))
 665                 (setf (values (slot actime 'sec)
 666                               (slot actime 'usec))
 667                       (seconds-and-useconds (or access-time 0))
 668                       (values (slot modtime 'sec)
 669                               (slot modtime 'usec))
 670                       (seconds-and-useconds (or modification-time 0)))
 671                 (maybe-syscall-error (alien-funcall fun name
 672                                                     (alien-sap buf))))))))))
 673
 674
 675 ;;; environment
 676
 677 (export 'getenv :sb-posix)
 678 (defun getenv (name)
 679   (let ((r (alien-funcall
 680             (extern-alien "getenv" (function (* char) c-string))
 681             name)))
 682     (declare (type (alien (* char)) r))
 683     (unless (null-alien r)
 684       (cast r c-string))))
 685 (define-call "putenv" int minusp (string c-string))
 686
 687 ;;; syslog
 688 #-win32
 689 (progn
 690   (export 'openlog :sb-posix)
 691   (export 'syslog :sb-posix)
 692   (export 'closelog :sb-posix)
 693   (defun openlog (ident options &optional (facility log-user))
 694     (alien-funcall (extern-alien
 695                     "openlog" (function void c-string int int))
 696                    ident options facility))
 697   (defun syslog (priority format &rest args)
 698     "Send a message to the syslog facility, with severity level
 699 PRIORITY.  The message will be formatted as by CL:FORMAT (rather
 700 than C's printf) with format string FORMAT and arguments ARGS."
 701     (flet ((syslog1 (priority message)
 702              (alien-funcall (extern-alien
 703                              "syslog" (function void int c-string c-string))
 704                             priority "%s" message)))
 705       (syslog1 priority (apply #'format nil format args))))
 706   (define-call "closelog" void never-fails))