;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-

;;;
;;; --- *UNIX foreign function definitions.
;;;

(in-package :iolib.syscalls)

(eval-when (:compile-toplevel)
  (declaim (optimize (speed 3) (safety 1) (debug 1))))

;; FIXME: move this into an ASDF operation

(eval-when (:compile-toplevel :load-toplevel :execute)

  (define-foreign-library libfixposix
    (t (:default "libfixposix")))
  (use-foreign-library libfixposix))

;;;-------------------------------------------------------------------------

;;; ERRNO-related functions

;;;-------------------------------------------------------------------------

(defcfun (errno "lfp_errno") :int)

(defun (setf errno) (value)
  (foreign-funcall "lfp_set_errno" :int value :int))

(defsyscall (%strerror "lfp_strerror")

    :int
  (errnum :int)

  (buf    :pointer)

  (buflen size-t))

(defentrypoint strerror (&optional (err (errno)))

  "Look up the error message string for ERRNO (reentrant)."

  (let ((errno
         (if (keywordp err)
             (foreign-enum-value 'errno-values err)
             err)))
    (with-foreign-pointer-as-string ((buf bufsiz) 1024)

      (%strerror errno buf bufsiz))))

(defmethod print-object ((e syscall-error) s)

  (with-slots (syscall code identifier message handle handle2) e

    (print-unreadable-object (e s :type nil :identity nil)
      (cond
        (message
         (format s "~A" message))
        (t
         (format s "Syscall ~S signalled error ~A(~S) ~S"
                 syscall identifier (or code "[No code]")
                 (or (strerror code) "[Can't get error string.]"))
         (when handle (format s " FD=~A" handle))
         (when handle2 (format s " FD2=~A" handle2)))))))

;;;-------------------------------------------------------------------------

;;; Memory manipulation

;;;-------------------------------------------------------------------------

(defcfun (memset "memset") :pointer
  "Fill the first COUNT bytes of BUFFER with the constant VALUE."
  (buffer :pointer)
  (value  :int)
  (count  size-t))

(defentrypoint bzero (buffer count)

  "Fill the first COUNT bytes of BUFFER with zeros."
  (memset buffer 0 count))

(defcfun (memcpy "memcpy") :pointer
  "Copy COUNT octets from SRC to DEST.
The two memory areas must not overlap."
  (dest :pointer)
  (src  :pointer)

  (count size-t))

(defcfun (memmove "memmove") :pointer
  "Copy COUNT octets from SRC to DEST.
The two memory areas may overlap."
  (dest :pointer)
  (src  :pointer)

  (count size-t))


;;;-------------------------------------------------------------------------

;;; Files

;;;-------------------------------------------------------------------------

(defsyscall (%open "lfp_open")

    (:int :restart t)

  (path  sstring)

  (flags :uint64)

  (mode  mode-t))

(defentrypoint open (path flags &optional (mode #o666))
  "Open a file descriptor for PATH using FLAGS and permissions MODE(#o666 by default)."

  (%open path flags mode))

(defsyscall (creat "lfp_creat")

    (:int :restart t)

  "Create file PATH with permissions MODE and return the new FD."

  (path sstring)

  (mode mode-t))

(defsyscall (%pipe "pipe") :int

  (fds :pointer))

(defentrypoint pipe ()

  "Create pipe, returns two values with the new FDs."

  (with-foreign-object (fds :int 2)

    (%pipe fds)

    (values (mem-aref fds :int 0)
            (mem-aref fds :int 1))))

(defsyscall (mkfifo "mkfifo") :int

  "Create a FIFO (named pipe) with name PATH and permissions MODE."

  (path sstring)

  (mode mode-t))

(defsyscall (umask "umask") mode-t

  "Sets the umask to NEW-MODE and returns the old one."

  (new-mode mode-t))

(defsyscall (lseek "lfp_lseek")

    (off-t :handle fd)

  "Reposition the offset of the open file associated with the file descriptor FD
to the argument OFFSET according to the directive WHENCE."
  (fd     :int)

  (offset off-t)
  (whence :int))

(defsyscall (access "access") :int

  "Check whether the file PATH can be accessed using mode MODE."

  (path sstring)

  (mode :int))

(defsyscall (truncate "lfp_truncate")

    (:int :restart t)

  "Truncate the file PATH to a size of precisely LENGTH octets."

  (path   sstring)

  (length off-t))

(defsyscall (ftruncate "lfp_ftruncate")

    (:int :restart t :handle fd)

  "Truncate the file referenced by FD to a size of precisely LENGTH octets."

  (fd     :int)
  (length off-t))

(defsyscall (rename "rename") :int

  "Rename file named by OLDPATH to NEWPATH."

  (oldpath sstring)
  (newpath sstring))

(defsyscall (link "link") :int

  "Create a hard link from file OLDPATH to NEWPATH."

  (oldpath sstring)
  (newpath sstring))

(defsyscall (symlink "symlink") :int

  "Create a symbolic link from file OLDPATH to NEWPATH."

  (oldpath sstring)
  (newpath sstring))

(defsyscall (%readlink "readlink") ssize-t

  (path    sstring)

  (buf     :pointer)
  (bufsize size-t))

(defentrypoint readlink (path)

  "Read the file name pointed by the symbolic link PATH."

  (with-foreign-pointer (buf +cstring-path-max+ bufsize)

    (let ((count (%readlink path buf bufsize)))

      (cstring-to-sstring buf count))))

(defsyscall (%realpath "realpath") sstring

  (path          sstring)

  (resolved-path :pointer))

(defentrypoint realpath (path)

  "Read the file name pointed by the symbolic link PATH."
  (with-foreign-pointer (buf +cstring-path-max+)

    (%realpath path buf)))

(defsyscall (unlink "unlink") :int

  "Delete the file PATH from the file system."

  (path sstring))

(defsyscall (chown "chown")

    (:int :restart t)

  "Change ownership of file PATH to uid OWNER and gid GROUP(dereferences symlinks)."

  (path  sstring)

  (owner uid-t)
  (group uid-t))

(defsyscall (fchown "fchown")

    (:int :restart t :handle fd)

  "Change ownership of an open file referenced by FD to uid OWNER and gid GROUP."

  (fd    :int)
  (owner uid-t)
  (group uid-t))

(defsyscall (lchown "lchown")

    (:int :restart t)

  "Change ownership of a file PATH to uid OWNER and gid GROUP(does not dereference symlinks)."

  (path  sstring)

  (owner uid-t)
  (group uid-t))

(defsyscall (chmod "chmod")

    (:int :restart t)

  "Change permissions of file PATH to mode MODE."

  (path sstring)

  (mode mode-t))

(defsyscall (fchmod "fchmod")

    (:int :restart t :handle fd)

  "Change permissions of open file referenced by FD to mode MODE."

  (fd   :int)
  (mode mode-t))

;;;-------------------------------------------------------------------------
;;; I/O
;;;-------------------------------------------------------------------------

(defsyscall (read "read")
    (ssize-t :restart t :handle fd)
  "Read at most COUNT bytes from FD into the foreign area BUF."
  (fd    :int)
  (buf   :pointer)
  (count size-t))

(defsyscall (write "write")
    (ssize-t :restart t :handle fd)
  "Write at most COUNT bytes to FD from the foreign area BUF."
  (fd    :int)
  (buf   :pointer)
  (count size-t))

(defsyscall (readv "readv")
    (ssize-t :restart t :handle fd)
  "Read from FD into the first IOVCNT buffers of the IOV array."
  (fd     :int)
  (iov    :pointer)
  (iovcnt :int))

(defsyscall (writev "writev")
    (ssize-t :restart t :handle fd)
  "Writes to FD the first IOVCNT buffers of the IOV array."
  (fd     :int)
  (iov    :pointer)
  (iovcnt :int))

(defsyscall (pread "lfp_pread")
    (ssize-t :restart t :handle fd)
  "Read at most COUNT bytes from FD at offset OFFSET into the foreign area BUF."
  (fd     :int)
  (buf    :pointer)
  (count  size-t)
  (offset off-t))

(defsyscall (pwrite "lfp_pwrite")
    (ssize-t :restart t :handle fd)
  "Write at most COUNT bytes to FD at offset OFFSET from the foreign area BUF."
  (fd     :int)
  (buf    :pointer)
  (count  size-t)
  (offset off-t))

(defsyscall (sendfile "lfp_sendfile")
    (ssize-t :restart t :handle infd :handle2 outfd)
  (infd   :int)
  (outfd  :int)
  (offset off-t)
  (nbytes size-t))

;;;-------------------------------------------------------------------------
;;; Stat()
;;;-------------------------------------------------------------------------

(define-c-struct-wrapper stat ())

(defsyscall (%stat "lfp_stat")

    :int

  (file-name sstring)

  (buf       :pointer))

(defsyscall (%fstat "lfp_fstat")

    (:int :handle fd)
  (fd      :int)

  (buf     :pointer))

(defsyscall (%lstat "lfp_lstat")

    :int

  (file-name sstring)

  (buf       :pointer))

;;; If necessary for performance reasons, we can add an optional
;;; argument to this function and use that to reuse a wrapper object.
(defentrypoint funcall-stat (fn arg)
  (with-foreign-object (buf 'stat)

    (funcall fn arg buf)

    (make-instance 'stat :pointer buf)))

(defentrypoint stat (path)

  "Get information about file PATH(dereferences symlinks)."

  (funcall-stat #'%stat path))

(defentrypoint fstat (fd)

  "Get information about file descriptor FD."

  (funcall-stat #'%fstat fd))

(defentrypoint lstat (path)

  "Get information about file PATH(does not dereference symlinks)."

  (funcall-stat #'%lstat path))

(defsyscall (sync "sync") :void

  "Schedule all file system buffers to be written to disk.")

(defsyscall (fsync "fsync")

    (:int :restart t)

  "Schedule a file's buffers to be written to disk."

  (fd :int))

(defsyscall (%mkstemp "lfp_mkstemp") :int

  (template :pointer))

(defentrypoint mkstemp (&optional (template ""))

  "Generate a unique temporary filename from TEMPLATE.
Return two values: the file descriptor and the path of the temporary file."

  (let ((template (concatenate 'string template "XXXXXX")))
    (with-sstring-to-cstring (ptr template)

      (values (%mkstemp ptr) (cstring-to-sstring ptr)))))

;;;-------------------------------------------------------------------------

;;; Directories

;;;-------------------------------------------------------------------------

(defsyscall (mkdir "mkdir") :int

  "Create directory PATH with permissions MODE."

  (path sstring)

  (mode mode-t))

(defsyscall (rmdir "rmdir") :int

  "Delete directory PATH."

  (path sstring))

(defsyscall (chdir "chdir") :int

  "Change the current working directory to PATH."

  (path sstring))

(defsyscall (fchdir "fchdir")

    (:int :restart t :handle fd)

  "Change the current working directory to the directory referenced by FD."

  (fd :int))

(defsyscall (%getcwd "getcwd") :pointer

  (buf :pointer)
  (size size-t))

(defentrypoint getcwd ()

  "Return the current working directory as a string."

  (with-cstring-to-sstring (buf +cstring-path-max+ bufsize)

    (%getcwd buf bufsize)))

(defsyscall (%mkdtemp "mkdtemp") sstring

  (template sstring))

(defentrypoint mkdtemp (&optional (template ""))

  "Generate a unique temporary filename from TEMPLATE."

  (let ((template (concatenate 'string template "XXXXXX")))

    (%mkdtemp template)))

;;;-------------------------------------------------------------------------

;;; File Descriptors

;;;-------------------------------------------------------------------------

(defsyscall (close "close")

    (:int :handle fd)

  "Close open file descriptor FD."

  (fd :int))

(defsyscall (dup "dup")

    (:int :handle fd)

  "Duplicate file descriptor FD."
  (fd :int))

(defsyscall (dup2 "dup2")

    (:int :restart t :handle oldfd :handle2 newfd)

  "Make NEWFD be the copy of OLDFD, closing NEWFD first if necessary."
  (oldfd :int)
  (newfd :int))

(defsyscall (%fcntl/noarg "fcntl")

    (:int :handle fd)

  (fd  :int)
  (cmd :int))

;;; FIXME: Linux/glibc says ARG's type is long, POSIX says it's int.
;;; Is this an issue?

(defsyscall (%fcntl/int "fcntl")

    (:int :handle fd)

  (fd  :int)
  (cmd :int)
  (arg :int))

(defsyscall (%fcntl/pointer "fcntl")

    (:int :handle fd)

  (fd  :int)
  (cmd :int)
  (arg :pointer))

(defentrypoint fcntl (fd cmd &optional (arg nil argp))

  (cond

    ((not argp)     (%fcntl/noarg   fd cmd))
    ((integerp arg) (%fcntl/int     fd cmd arg))
    ((pointerp arg) (%fcntl/pointer fd cmd arg))

    (t (error 'type-error :datum arg

              :expected-type '(or null integer foreign-pointer)))))

(defsyscall (%ioctl/noarg "ioctl")

    (:int :handle fd)

  "Send request REQUEST to file referenced by FD."

  (fd      :int)

  (request :unsigned-int))

(defsyscall (%ioctl/pointer "ioctl")

    (:int :handle fd)

  "Send request REQUEST to file referenced by FD using argument ARG."

 (fd      :int)

 (request :unsigned-int)

 (arg     :pointer))

(defentrypoint ioctl (fd request &optional (arg nil argp))

  "Control an I/O device."
  (cond

    ((not argp)     (%ioctl/noarg   fd request))
    ((pointerp arg) (%ioctl/pointer fd request arg))

    (t (error 'type-error :datum arg
              :expected-type '(or null foreign-pointer)))))

(defsyscall (fd-cloexec-p "lfp_is_fd_cloexec") bool-designator
  (fd :int))

(defsyscall (%set-fd-cloexec "lfp_set_fd_cloexec") :int
  (fd      :int)
  (enabled bool-designator))

(defentrypoint (setf fd-cloexec-p) (enabled fd)
  (%set-fd-cloexec fd enabled))

(defsyscall (fd-nonblock-p "lfp_is_fd_nonblock") bool-designator
  (fd :int))

(defsyscall (%set-fd-nonblock "lfp_set_fd_nonblock") :int
  (fd      :int)
  (enabled bool-designator))

(defentrypoint (setf fd-nonblock-p) (enabled fd)
  (%set-fd-nonblock fd enabled))

(defsyscall (fd-open-p "lfp_is_fd_open") bool-designator
  (fd :int))

;;;-------------------------------------------------------------------------
;;; TTYs
;;;-------------------------------------------------------------------------

(defsyscall (openpt "lfp_openpt") :int
  (flags :uint64))

(defsyscall (grantpt "grantpt")

    (:int :handle fd)
  (fd :int))

(defsyscall (unlockpt "unlockpt")

    (:int :handle fd)
  (fd :int))

(defsyscall (%ptsname "lfp_ptsname")
    (:pointer :handle fd)

  (fd     :int)
  (buf    :pointer)
  (buflen size-t))

(defentrypoint ptsname (fd)

  (with-foreign-pointer (buf +cstring-path-max+ bufsize)
    (%ptsname fd buf bufsize)
    (nth-value 0 (foreign-string-to-lisp buf))))

;;;-------------------------------------------------------------------------

;;; I/O polling

;;;-------------------------------------------------------------------------

(defsyscall (select "lfp_select") :int

  "Scan for I/O activity on multiple file descriptors."
  (nfds      :int)
  (readfds   :pointer)
  (writefds  :pointer)
  (exceptfds :pointer)

  (timeout   :pointer))

(defentrypoint copy-fd-set (from to)

  (memcpy to from (sizeof 'fd-set))

  to)

(defcfun (fd-clr "lfp_fd_clr") :void
  (fd     :int)
  (fd-set :pointer))

(defcfun (fd-isset "lfp_fd_isset") bool
  (fd     :int)
  (fd-set :pointer))

(defcfun (fd-set "lfp_fd_set") :void
  (fd     :int)
  (fd-set :pointer))

(defcfun (fd-zero "lfp_fd_zero") :void
  (fd-set :pointer))

;;; FIXME: Until a way to autodetect platform features is implemented

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (boundp 'pollrdhup)
    (defconstant pollrdhup 0)))

(defsyscall (poll "poll") :int

  "Scan for I/O activity on multiple file descriptors."
  (fds     :pointer)
  (nfds    nfds-t)
  (timeout :int))

#+linux
(progn

  (defsyscall (epoll-create "epoll_create") :int

    "Open an epoll file descriptor."
    (size :int))

  (defsyscall (epoll-ctl "epoll_ctl")

      (:int :handle epfd :handle2 fd)

    "Control interface for an epoll descriptor."
    (epfd  :int)
    (op    :int)
    (fd    :int)
    (event :pointer))

  (defsyscall (epoll-wait "epoll_wait")

      (:int :handle epfd)

    "Wait for an I/O event on an epoll file descriptor."
    (epfd      :int)
    (events    :pointer)
    (maxevents :int)
    (timeout   :int)))

#+bsd
(progn

  (defsyscall (kqueue "kqueue") :int

    "Open a kernel event queue.")

  (defsyscall (kevent "kevent")

      (:int :handle fd)

    "Control interface for a kernel event queue."

    (fd         :int)

    (changelist :pointer)               ; const struct kevent *
    (nchanges   :int)
    (eventlist  :pointer)               ; struct kevent *
    (nevents    :int)
    (timeout    :pointer))              ; const struct timespec *