;;;; unix-poll access for clircd

(in-package #:cffi-unix)

(defun wrapper-function (internal-function args &key test filter)
  (loop
     for interrupted = nil
     for result = (apply internal-function args)
     do (cond ((eq errno :EINTR)
	       (setq interrupted t))
	      ((and test
		    (funcall test result))
	       (if errno
		   (error (make-unix-error errno))
		   (return-from wrapper-function nil))))
     while interrupted
     initially (setf errno 0)
     finally (return (if filter
			 (funcall filter result)
			 result))))

(defmacro defforeign (names return-type docstring &rest argspecs)
  "Defines a cfunction and wraps it using defwrapper."
  (declare (ignore docstring)) ;;FIXME defcfun has no docstrings
  (let* ((foreign-name
	  (cond ((stringp names)
		 names)
		((and (listp names)
		      (stringp (car names)))
		 (car names))
		(t (error "Invalid foreign name ~S" names))))
	 (wrapped-name
	  (cond ((stringp names)
		 (read-from-string (substitute #\- #\_ foreign-name)))
		((and (listp names)
		      (symbolp (cadr names)))
		 (cadr names))
		(t (error "Invalid foreign name ~S" names))))
         (internal-name (cffi-grovel:symbolicate "%" wrapped-name))
         (arg-names (mapcar #'first argspecs))
	 (canonical-type (when (cffi::find-type return-type)
			   (cffi::canonicalize
			    (cffi::find-type return-type))))
	 (test nil)
	 (filter nil))
    (case return-type
      ((:pointer)
       (setq test 'null-pointer-p))
      ((:string)
       (setq test '(lambda (s) (not (stringp s)))))
      ((:int :ssize)
       (setq test 'minusp))
      (t
       (cond ((eq canonical-type :pointer)
	      (setq test 'null-pointer-p
		    filter (cffi-grovel:make-from-pointer-function-name
			    return-type))))))    
    `(progn
       (declaim (inline ,internal-name))
       (defcfun (,foreign-name ,internal-name) ,return-type
         ,@argspecs)
       (defun ,wrapped-name (,@arg-names)
	 (wrapper-function #',internal-name (list ,@arg-names)
			   :test ,(when test `#',test)
			   :filter ,(when filter `#',filter))))))


;;; GNU LIBC has a weird incompatible strerror_r:
;;;        char *strerror_r(int errnum, char *buf, size_t n);
;;; we sneak around and grab the standardish one which they also define
;;; but under a different name.
;;;
;;; ...Except that older GNU LIBC's don't Have that nice
;;; __xpg_strerror_r function, so we have to support both.
;;; :glibc-broken-strerror-r gets pushed onto *features* when we have
;;; no __xpg_strerror_r and are using the quirky GNU calling
;;; convention.
(eval-when (:compile-toplevel :execute)
  (cond ((not (foreign-function-exists-p "strerror_r"))
         ;; Fine and well, but some systems don't have ANY strerror_r
         (push :no-strerror-r *features*))
        ((and (eq :gnu (libc-implementation))
              (not (foreign-function-exists-p "__xpg_strerror_r")))
         (push :glibc-broken-strerror-r *features*))))

#+no-strerror-r
(defforeign ("strerror" %strerror) :pointer
  (errnum :int))

#-no-strerror-r
(defforeign (#.(choose-foreign-function "__xpg_strerror_r"
					"strerror_r")
               %strerror-r)
    #-glibc-broken-strerror-r :int
    #+glibc-broken-strerror-r :pointer
    "Thread-safe error string access."
    (errnum errno-values)
    (buf :pointer)
    (size :size))

#+no-strerror-r
(defun strerror (errnum)
  "Return the string for UNIX error errnum."
  (foreign-string-to-lisp
   (%strerror errnum)))

#-no-strerror-r
(defun strerror (errnum)
  "Return the string for UNIX error errnum."
  
  #-glibc-broken-strerror-r
  (with-foreign-pointer (buf 1024 size)
    (%strerror-r errnum buf size)
    (foreign-string-to-lisp buf))
  
  #+glibc-broken-strerror-r
  (with-foreign-pointer (buf 1024 size)
    (foreign-string-to-lisp
     (%strerror-r errnum buf size))))

(define-condition unix-error (error)
  ((number :reader unix-error-number
           :initarg :number
           :type integer)))

(defvar *error-symbols* nil)
(defmacro defunix-error (symbol)
  (check-type symbol keyword)
  (let ((cond-name
         (cffi-grovel:symbolicate '#:unix-error-
                                  (read-from-string  
                                   (string-downcase 
                                    (subseq (symbol-name symbol) 1))))))
    `(progn
       (define-condition ,cond-name (unix-error) ())
       (push (cons ',symbol ',cond-name) *error-symbols*))))

(defmacro defunix-errors (symbols)
  `(progn
     ,@(loop for symbol in symbols
          collect `(defunix-error ,symbol))))

;; FIXME this should be in cffi
(defun foreign-enum-keywords (type)
  (loop for key being each hash-key in  
       (cffi::keyword-values (cffi::parse-type type))
     collect key))

;(defunix-errors #.(foreign-enum-keywords 'errno-values))
(defunix-errors #.(loop for key being each hash-key in
                       (cffi::keyword-values
                        (cffi::parse-type 'errno-values))
                     collect key))

(defun make-unix-error (err)
  (let* ((error-keyword
          (etypecase err
            (keyword err)
            (integer (ignore-errors
		       (cffi:foreign-enum-keyword 'errno-values err)))))
         (error-num
	  (etypecase err
	    (keyword (cffi:foreign-enum-value 'errno-values error-keyword))
	    (integer err))))
    (let ((condition-class (cdr (assoc error-keyword *error-symbols*))))
      (if condition-class (make-condition condition-class :number error-num)
          (make-condition 'unix-error :number error-num)))))

(defmethod print-object ((unix-error unix-error) stream)
  (print-unreadable-object (unix-error stream :type t :identity nil)
    (let ((num (unix-error-number unix-error)))
      (format stream "~d ~s ~a"
              num
              (or (ignore-errors
		    (cffi:foreign-enum-keyword 'errno-values num))
		  (format nil "~D" num))
              (or (ignore-errors (strerror num))
		  "[Can't get error string.]")))))

(declaim (inline %gettimeofday))
(defcfun ("gettimeofday" %gettimeofday) :int
  (tp  :pointer)
  (tzp :pointer))

(defun gettimeofday ()
  "Return the time in seconds and microseconds."
  (with-foreign-object (tv 'timeval)
    (with-foreign-slots ((tv-sec tv-usec) tv timeval)
      (%gettimeofday tv (null-pointer))
      (values tv-sec tv-usec))))

(defforeign "read" :ssize
    "Read at most count bytes from fd into the foreign area buf."
  (fd :int)
  (buf :pointer)
  (count :size))

(defforeign "write" :ssize
    "Write at most count bytes to fd from the foreign area buf."
  (fd :int)
  (buf :pointer)
  (count :size))

(defforeign "socket" :int
    "Create a BSD socket."
  (domain address-family)    ; af-*
  (type socket-protocol)      ; sock-*
  (protocol :int)) ; zero

(defforeign "getsockopt" :int
  "Retrieve socket configuration."
  (fd :int)
  (level :int)
  (optname socket-options)
  (optval :pointer)
  (optlen :int))

(defforeign "setsockopt" :int
  "Configure a socket."
  (fd :int)
  (level :int)
  (optname socket-options)
  (optval :pointer)
  (optlen :int))

(defforeign "bind" :int
    "Bind a socket to a particular local address."
  (fd :int)
  (addr :pointer)
  (addrlen :int))

(defforeign "listen" :int
    "Mark a bound socket as listening for incoming connections."
  (s :int)
  (backlog :int))

(defforeign "accept" :int
    "Accept an incoming connection, returning the file descriptor."
  (s :int)
  (addr :pointer)                       ; sockaddr-foo
  (addrlen :pointer))

(defforeign "connect" :int
  "Create an outgoing connection on a given socket."
  (s :int)
  (addr :pointer) ; sockaddr-foo
  (addrlen :socklen))

(defforeign "close" :int
    "Close an open file descriptor."
  (fd :int))

(defforeign "poll" :int
    "Scan for I/O activity."
  (ufds :pointer)
  (nfds :unsigned-int)
  (timeout :int))

(defforeign ("getcwd" %getcwd) :pointer
  "Returns the current working directory as a string."
  (buf :pointer)
  (size :size))

(defun getcwd ()
  "Returns the current working directory as a string."
  (with-foreign-pointer (buf path-max size)
    (%getcwd buf size)
    (foreign-string-to-lisp buf)))

(defforeign "umask" :mode
  "Sets the umask and returns the old one"
  (new-mode :mode))

(defforeign "chdir" :int
  "Changes the current working directory"
  (path :string))

(defforeign "symlink" :int
  "Creates a symbolic link"
  (name1 :string)
  (name2 :string))

(defforeign "getpid" :pid
  "Returns the process id of the current process")

(defforeign "getenv" :string
  "Returns the value of an environment variable"
  (name :string))

(defforeign "setenv" :int
  "Changes the value of an environment variable"
  (name :string)
  (value :string))

(defforeign "unsetenv" :void
  "Removes the binding of an environment variable"
  (name :string))

(defforeign "getpwuid" password-entry
  "Gets the password-entry of a user, by user id"
  (uid :uid))

(defforeign "getpwnam" password-entry
  "Gets the password-entry of a user, by username"
  (login :string))

(defforeign "getgrgid" group-entry
  "Gets a group-entry, by group id"
  (gid :gid))

(defforeign "getgrnam" group-entry
  "Gets a group-entry, by group name"
  (name :string))

(defforeign "opendir" :pointer
  "Opens a directory for listing of its contents"
  (filename :string))

(defforeign "closedir" :int
  "Closes a directory when done listing its contents"
  (dir :pointer))

(defforeign "readdir" directory-entry
  "Reads an item from the listing of a directory"
  (dir :pointer))

(defforeign "rewinddir" :void
  "Rewinds a directory"
  (dir :pointer))

;; fixme
#-clisp
(defforeign ("stat" %stat) :int
  "Get directory information about a file."
  (path :string)
  (buf :pointer))

;; fixme
#-clisp
(defforeign ("lstat" %lstat) :int
  "Get directory information about a file or symlink."
  (path :string)
  (buf :pointer))

;; fixme
#-clisp
(defforeign ("fstat" %fstat) :int
  "Get directory information about a file descriptor."
  (fd :int)
  (buf :pointer))

;; fixme
#-clisp
(defun stat (path &optional (follow-symlink t))
  (with-foreign-pointer (result (foreign-type-size 'stat))
    (cond ((integerp path)
	   (%fstat path result))
	  (follow-symlink
	   (%stat path result))
	  (t
	   (%lstat path result)))
    (make-stat-from-pointer result)))