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       (defclass ,name ,superclasses
   9         ,(loop for slotd in slots
  10                collect (ldiff slotd (member :array-length slotd)))
  11         ,@options)
  12       (declaim (inline ,to-alien ,to-protocol))
  13       (defun ,to-protocol (alien &optional instance)
  14         (declare (type (sb-alien:alien (* ,alien-type)) alien)
  15                  (type (or null ,name) instance))
  16         (unless instance
  17           (setf instance (make-instance ',name)))
  18         ,@(loop for slotd in slots
  19                 ;; FIXME: slotds in source are more complicated in general
  20                 ;;
  21                 ;; FIXME: baroque construction of intricate fragility
  22                 for array-length = (getf (cdr slotd) :array-length)
  23                 if array-length
  24                   collect `(progn
  25                              (let ((array (make-array ,array-length)))
  26                                (setf (slot-value instance ',(car slotd))
  27                                      array)
  28                                (dotimes (i ,array-length)
  29                                  (setf (aref array i)
  30                                        (sb-alien:deref
  31                                         (sb-alien:slot alien ',(car slotd))
  32                                         i)))))
  33                 else
  34                   collect `(setf (slot-value instance ',(car slotd))
  35                                  (sb-alien:slot alien ',(car slotd))))
  36         instance)
  37       (defun ,to-alien (instance &optional alien)
  38         (declare (type (or null (sb-alien:alien (* ,alien-type))) alien)
  39                  (type ,name instance))
  40         (unless alien
  41           (setf alien (sb-alien:make-alien ,alien-type)))
  42         ,@(loop for slotd in slots
  43                 for array-length = (getf (cdr slotd) :array-length)
  44                 if array-length
  45                   collect `(progn
  46                              (let ((array (slot-value instance ',(car slotd))))
  47                                (dotimes (i ,array-length)
  48                                  (setf (sb-alien:deref
  49                                         (sb-alien:slot alien ',(car slotd))
  50                                         i)
  51                                        (aref array i)))))
  52                 else
  53                   collect `(setf (sb-alien:slot alien ',(car slotd))
  54                                  (slot-value instance ',(car slotd)))))
  55       (find-class ',name))))
  56
  57 (define-condition sb-posix:syscall-error (error)
  58   ((errno :initarg :errno :reader sb-posix:syscall-errno))
  59   (:report (lambda (c s)
  60              (let ((errno (sb-posix:syscall-errno c)))
  61                (format s "System call error ~A (~A)"
  62                        errno (sb-int:strerror errno))))))
  63
  64 (defun syscall-error ()
  65   (error 'sb-posix:syscall-error :errno (get-errno)))
  66
  67 (declaim (inline never-fails))
  68 (defun never-fails (&rest args)
  69   (declare (ignore args))
  70   nil)
  71
  72 ;;; filesystem access
  73 (defmacro define-call* (name &rest arguments)
  74   #-win32 `(define-call ,name ,@arguments)
  75   #+win32 `(define-call ,(concatenate 'string "_" name) ,@arguments))
  76
  77 (define-call* "access" int minusp (pathname filename) (mode int))
  78 (define-call* "chdir" int minusp (pathname filename))
  79 (define-call* "chmod" int minusp (pathname filename) (mode mode-t))
  80 (define-call* "close" int minusp (fd file-descriptor))
  81 (define-call* "creat" int minusp (pathname filename) (mode mode-t))
  82 (define-call* "dup" int minusp (oldfd file-descriptor))
  83 (define-call* "dup2" int minusp (oldfd file-descriptor)
  84               (newfd file-descriptor))
  85 (define-call* "lseek" off-t minusp (fd file-descriptor) (offset off-t)
  86               (whence int))
  87 (define-call* "mkdir" int minusp (pathname filename) (mode mode-t))
  88 (macrolet ((def (x)
  89                `(progn
  90                  (define-call-internally open-with-mode ,x int minusp
  91                    (pathname filename) (flags int) (mode mode-t))
  92                  (define-call-internally open-without-mode ,x int minusp
  93                    (pathname filename) (flags int))
  94                  (define-entry-point ,x
  95                      (pathname flags &optional (mode nil mode-supplied))
  96                    (if mode-supplied
  97                        (open-with-mode pathname flags mode)
  98                        (open-without-mode pathname flags))))))
  99     (def #-win32 "open" #+win32 "_open"))
 100 (define-call "rename" int minusp (oldpath filename) (newpath filename))
 101 (define-call* "rmdir" int minusp (pathname filename))
 102 (define-call* "unlink" int minusp (pathname filename))
 103 (define-call "opendir" (* t) null-alien (pathname filename))
 104 (define-call "readdir" (* dirent)
 105   ;; readdir() has the worst error convention in the world.  It's just
 106   ;; too painful to support.  (return is NULL _and_ errno "unchanged"
 107   ;; is not an error, it's EOF).
 108   not
 109   (dir (* t)))
 110 (define-call "closedir" int minusp (dir (* t)))
 111 ;; need to do this here because we can't do it in the DEFPACKAGE
 112 (define-call* "umask" mode-t never-fails (mode mode-t))
 113 (define-call* "getpid" pid-t never-fails)
 114
 115 #-win32
 116 (progn
 117   (define-call "chown" int minusp (pathname filename)
 118                (owner uid-t) (group gid-t))
 119   (define-call "chroot" int minusp (pathname filename))
 120   (define-call "fchdir" int minusp (fd file-descriptor))
 121   (define-call "fchmod" int minusp (fd file-descriptor) (mode mode-t))
 122   (define-call "fchown" int minusp (fd file-descriptor)
 123              (owner uid-t)  (group gid-t))
 124   (define-call "fdatasync" int minusp (fd file-descriptor))
 125   (define-call "ftruncate" int minusp (fd file-descriptor) (length off-t))
 126   (define-call "fsync" int minusp (fd file-descriptor))
 127   (define-call "lchown" int minusp (pathname filename)
 128                (owner uid-t)  (group gid-t))
 129   (define-call "link" int minusp (oldpath filename) (newpath filename))
 130   (define-call "mkfifo" int minusp (pathname filename) (mode mode-t))
 131   (define-call "symlink" int minusp (oldpath filename) (newpath filename))
 132   (define-call "sync" void never-fails)
 133   (define-call "truncate" int minusp (pathname filename) (length off-t))
 134   ;; FIXME: Windows does have _mktemp, which has a slightlty different
 135   ;; interface
 136   (define-call "mkstemp" int minusp (template c-string))
 137   (define-call-internally ioctl-without-arg "ioctl" int minusp
 138                           (fd file-descriptor) (cmd int))
 139   (define-call-internally ioctl-with-int-arg "ioctl" int minusp
 140                           (fd file-descriptor) (cmd int) (arg int))
 141   (define-call-internally ioctl-with-pointer-arg "ioctl" int minusp
 142                           (fd file-descriptor) (cmd int)
 143                           (arg alien-pointer-to-anything-or-nil))
 144   (define-entry-point "ioctl" (fd cmd &optional (arg nil argp))
 145     (if argp
 146         (etypecase arg
 147           ((alien int) (ioctl-with-int-arg fd cmd arg))
 148           ((or (alien (* t)) null) (ioctl-with-pointer-arg fd cmd arg)))
 149         (ioctl-without-arg fd cmd)))
 150   (define-call-internally fcntl-without-arg "fcntl" int minusp
 151                           (fd file-descriptor) (cmd int))
 152   (define-call-internally fcntl-with-int-arg "fcntl" int minusp
 153                           (fd file-descriptor) (cmd int) (arg int))
 154   (define-call-internally fcntl-with-pointer-arg "fcntl" int minusp
 155                           (fd file-descriptor) (cmd int)
 156                           (arg alien-pointer-to-anything-or-nil))
 157   (define-entry-point "fcntl" (fd cmd &optional (arg nil argp))
 158     (if argp
 159         (etypecase arg
 160           ((alien int) (fcntl-with-int-arg fd cmd arg))
 161           ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg)))
 162         (fcntl-without-arg fd cmd)))
 163
 164   ;; uid, gid
 165   (define-call "geteuid" uid-t never-fails) ; "always successful", it says
 166   (define-call "getresuid" uid-t never-fails)
 167   (define-call "getuid" uid-t never-fails)
 168   (define-call "seteuid" int minusp (uid uid-t))
 169   (define-call "setfsuid" int minusp (uid uid-t))
 170   (define-call "setreuid" int minusp (ruid uid-t) (euid uid-t))
 171   (define-call "setresuid" int minusp (ruid uid-t) (euid uid-t) (suid uid-t))
 172   (define-call "setuid" int minusp (uid uid-t))
 173   (define-call "getegid" gid-t never-fails)
 174   (define-call "getgid" gid-t never-fails)
 175   (define-call "getresgid" gid-t never-fails)
 176   (define-call "setegid" int minusp (gid gid-t))
 177   (define-call "setfsgid" int minusp (gid gid-t))
 178   (define-call "setgid" int minusp (gid gid-t))
 179   (define-call "setregid" int minusp (rgid gid-t) (egid gid-t))
 180   (define-call "setresgid" int minusp (rgid gid-t) (egid gid-t) (sgid gid-t))
 181
 182   ;; processes, signals
 183   (define-call "alarm" int never-fails (seconds unsigned))
 184   (define-call "fork" pid-t minusp)
 185   (define-call "getpgid" pid-t minusp (pid pid-t))
 186   (define-call "getppid" pid-t never-fails)
 187   (define-call "getpgrp" pid-t never-fails)
 188   (define-call "getsid" pid-t minusp  (pid pid-t))
 189   (define-call "kill" int minusp (pid pid-t) (signal int))
 190   (define-call "killpg" int minusp (pgrp int) (signal int))
 191   (define-call "pause" int minusp)
 192   (define-call "setpgid" int minusp (pid pid-t) (pgid pid-t))
 193   (define-call "setpgrp" int minusp))
 194
 195 ;;(define-call "readlink" int minusp (path filename) (buf (* t)) (len int))
 196
 197 #-win32
 198 (progn
 199  (export 'wait :sb-posix)
 200  (declaim (inline wait))
 201  (defun wait (&optional statusptr)
 202    (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr))
 203    (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32))))
 204           (pid (alien-funcall
 205                 (extern-alien "wait" (function pid-t (* int)))
 206                 (sb-sys:vector-sap ptr))))
 207      (if (minusp pid)
 208          (syscall-error)
 209          (values pid (aref ptr 0))))))
 210
 211 #-win32
 212 (progn
 213  (export 'waitpid :sb-posix)
 214  (declaim (inline waitpid))
 215  (defun waitpid (pid options &optional statusptr)
 216    (declare (type (sb-alien:alien pid-t) pid)
 217             (type (sb-alien:alien int) options)
 218             (type (or null (simple-array (signed-byte 32) (1))) statusptr))
 219    (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32))))
 220           (pid (alien-funcall
 221                 (extern-alien "waitpid" (function pid-t
 222                                                   pid-t (* int) int))
 223                 pid (sb-sys:vector-sap ptr) options)))
 224      (if (minusp pid)
 225          (syscall-error)
 226          (values pid (aref ptr 0)))))
 227  ;; waitpid macros
 228  (define-call "wifexited" boolean never-fails (status int))
 229  (define-call "wexitstatus" int never-fails (status int))
 230  (define-call "wifsignaled" boolean never-fails (status int))
 231  (define-call "wtermsig" int never-fails (status int))
 232  (define-call "wifstopped" boolean never-fails (status int))
 233  (define-call "wstopsig" int never-fails (status int))
 234  #+nil ; see alien/waitpid-macros.c
 235  (define-call "wifcontinued" boolean never-fails (status int)))
 236
 237 ;;; mmap, msync
 238 #-win32
 239 (progn
 240  (define-call "mmap" sb-sys:system-area-pointer
 241    (lambda (res)
 242      (= (sb-sys:sap-int res) #.(1- (expt 2 sb-vm::n-machine-word-bits))))
 243    (addr sap-or-nil) (length unsigned) (prot unsigned)
 244    (flags unsigned) (fd file-descriptor) (offset off-t))
 245
 246  (define-call "munmap" int minusp
 247    (start sb-sys:system-area-pointer) (length unsigned))
 248
 249 (define-call "msync" int minusp
 250   (addr sb-sys:system-area-pointer) (length unsigned) (flags int)))
 251
 252 #-win32
 253 (define-call "getpagesize" int minusp)
 254 #+win32
 255 ;;; KLUDGE: This could be taken from GetSystemInfo
 256 (export (defun getpagesize () 4096))
 257
 258 ;;; passwd database
 259 #-win32
 260 (define-protocol-class passwd alien-passwd ()
 261   ((name :initarg :name :accessor passwd-name)
 262    (passwd :initarg :passwd :accessor passwd-passwd)
 263    (uid :initarg :uid :accessor passwd-uid)
 264    (gid :initarg :gid :accessor passwd-gid)
 265    (gecos :initarg :gecos :accessor passwd-gecos)
 266    (dir :initarg :dir :accessor passwd-dir)
 267    (shell :initarg :shell :accessor passwd-shell)))
 268
 269 (defmacro define-pw-call (name arg type)
 270   #-win32
 271   ;; FIXME: this isn't the documented way of doing this, surely?
 272   (let ((lisp-name (intern (string-upcase name) :sb-posix)))
 273     `(progn
 274       (export ',lisp-name :sb-posix)
 275       (declaim (inline ,lisp-name))
 276       (defun ,lisp-name (,arg)
 277         (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
 278           (if (null r)
 279               r
 280               (alien-to-passwd r)))))))
 281
 282 (define-pw-call "getpwnam" login-name (function (* alien-passwd) c-string))
 283 (define-pw-call "getpwuid" uid (function (* alien-passwd) uid-t))
 284
 285 (define-protocol-class stat alien-stat ()
 286   ((mode :initarg :mode :accessor stat-mode)
 287    (ino :initarg :ino :accessor stat-ino)
 288    (dev :initarg :dev :accessor stat-dev)
 289    (nlink :initarg :nlink :accessor stat-nlink)
 290    (uid :initarg :uid :accessor stat-uid)
 291    (gid :initarg :gid :accessor stat-gid)
 292    (size :initarg :size :accessor stat-size)
 293    (atime :initarg :atime :accessor stat-atime)
 294    (mtime :initarg :mtime :accessor stat-mtime)
 295    (ctime :initarg :ctime :accessor stat-ctime)))
 296
 297 (defmacro define-stat-call (name arg designator-fun type)
 298   ;; FIXME: this isn't the documented way of doing this, surely?
 299   (let ((lisp-name (lisp-for-c-symbol name)))
 300     `(progn
 301       (export ',lisp-name :sb-posix)
 302       (declaim (inline ,lisp-name))
 303       (defun ,lisp-name (,arg &optional stat)
 304         (declare (type (or null (sb-alien:alien (* alien-stat))) stat))
 305         (with-alien-stat a-stat ()
 306           (let ((r (alien-funcall
 307                     (extern-alien ,name ,type)
 308                     (,designator-fun ,arg)
 309                     a-stat)))
 310             (when (minusp r)
 311               (syscall-error))
 312             (alien-to-stat a-stat stat)))))))
 313
 314 (define-stat-call #-win32 "stat" #+win32 "_stat" pathname filename
 315                   (function int c-string (* alien-stat)))
 316
 317 #-win32
 318 (define-stat-call "lstat" pathname filename
 319                   (function int c-string (* alien-stat)))
 320 ;;; No symbolic links on Windows, so use stat
 321 #+win32
 322 (progn
 323   (declaim (inline lstat))
 324   (export (defun lstat (filename &optional stat)
 325             (if stat (stat filename stat) (stat filename)))))
 326
 327 (define-stat-call #-win32 "fstat" #+win32 "_fstat" fd file-descriptor
 328                   (function int int (* alien-stat)))
 329
 330
 331 ;;; mode flags
 332 (define-call "s_isreg" boolean never-fails (mode mode-t))
 333 (define-call "s_isdir" boolean never-fails (mode mode-t))
 334 (define-call "s_ischr" boolean never-fails (mode mode-t))
 335 (define-call "s_isblk" boolean never-fails (mode mode-t))
 336 (define-call "s_isfifo" boolean never-fails (mode mode-t))
 337 (define-call "s_islnk" boolean never-fails (mode mode-t))
 338 (define-call "s_issock" boolean never-fails (mode mode-t))
 339
 340 #-win32
 341 (progn
 342  (export 'pipe :sb-posix)
 343  (declaim (inline pipe))
 344  (defun pipe (&optional filedes2)
 345    (declare (type (or null (simple-array (signed-byte 32) (2))) filedes2))
 346    (unless filedes2
 347      (setq filedes2 (make-array 2 :element-type '(signed-byte 32))))
 348    (let ((r (alien-funcall
 349              ;; FIXME: (* INT)?  (ARRAY INT 2) would be better
 350              (extern-alien "pipe" (function int (* int)))
 351              (sb-sys:vector-sap filedes2))))
 352      (when (minusp r)
 353        (syscall-error)))
 354    (values (aref filedes2 0) (aref filedes2 1))))
 355
 356 #-win32
 357 (define-protocol-class termios alien-termios ()
 358   ((iflag :initarg :iflag :accessor sb-posix:termios-iflag)
 359    (oflag :initarg :oflag :accessor sb-posix:termios-oflag)
 360    (cflag :initarg :cflag :accessor sb-posix:termios-cflag)
 361    (lflag :initarg :lflag :accessor sb-posix:termios-lflag)
 362    (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs)))
 363
 364 #-win32
 365 (progn
 366  (export 'tcsetattr :sb-posix)
 367  (declaim (inline tcsetattr))
 368  (defun tcsetattr (fd actions termios)
 369    (with-alien-termios a-termios ()
 370      (termios-to-alien termios a-termios)
 371      (let ((fd (file-descriptor fd)))
 372        (let* ((r (alien-funcall
 373                   (extern-alien
 374                    "tcsetattr"
 375                    (function int int int (* alien-termios)))
 376                   fd actions a-termios)))
 377          (when (minusp r)
 378            (syscall-error)))
 379        (values))))
 380  (export 'tcgetattr :sb-posix)
 381  (declaim (inline tcgetattr))
 382  (defun tcgetattr (fd &optional termios)
 383    (with-alien-termios a-termios ()
 384      (let ((r (alien-funcall
 385                (extern-alien "tcgetattr"
 386                              (function int int (* alien-termios)))
 387                (file-descriptor fd)
 388                a-termios)))
 389        (when (minusp r)
 390          (syscall-error))
 391        (setf termios (alien-to-termios a-termios termios))))
 392    termios))
 393
 394 ;;; environment
 395
 396 (export 'getenv :sb-posix)
 397 (defun getenv (name)
 398   (let ((r (alien-funcall
 399             (extern-alien "getenv" (function (* char) c-string))
 400             name)))
 401     (declare (type (alien (* char)) r))
 402     (unless (null-alien r)
 403       (cast r c-string))))
 404 (define-call "putenv" int minusp (string c-string))