async-process/src/async-process.lisp at master · petebu/async-process · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
(defpackage :async-process
  (:use :cl)
  (:export
   :delete-process
   :process-send-input
   :process-receive-output
   :process-alive-p
   :create-process))
(in-package :async-process)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun system (cmd)
    (ignore-errors (string-right-trim '(#\Newline) (uiop:run-program cmd :output :string))))
  (defun muslp ()
    (ignore-errors
      (not (zerop (length (uiop:run-program
                           "ldd /bin/ls |grep musl"
                           :ignore-error-status t
                           :output :string)))))))

(pushnew (asdf:system-relative-pathname
          :async-process
          (format nil "../static/~A/"
                  (cond
                    ;; Windows
                    ((uiop/os:featurep '(:and :windows :x86-64))
                     "x86_64/windows")
                    ((uiop/os:featurep :windows)
                     "x86/windows")
                    ;; macOS (Darwin)
                    ((uiop/os:featurep :os-macosx)
                     (format nil "~A/darwin"
                             (uiop:run-program '("uname" "-m") :output '(:string :stripped t))))
                    ;; Linux / Generic Unix
                    ((uiop/os:featurep :unix)
                     (format nil "~A/~A"
                             (uiop:run-program '("uname" "-m") :output '(:string :stripped t))
                             (let ((os (uiop:run-program '("uname") :output '(:string :stripped t))))
                               (cond ((and (equal os "Linux")
                                           (ignore-errors (funcall (read-from-string "muslp"))))
                                      "Linux-musl")
                                     (t os))))))))
         cffi:*foreign-library-directories*
         :test #'uiop:pathname-equal)

(cffi:define-foreign-library async-process
  (:darwin "libasyncprocess.dylib")
  (:unix "libasyncprocess.so")
  (:windows "libasyncprocess.dll"))

(cffi:use-foreign-library async-process)

(defclass process ()
  ((process :reader process-process :initarg :process)
   (encode :accessor process-encode :initarg :encode)))

(cffi:defcfun ("create_process" %create-process) :pointer
  (command :pointer)
  (nonblock :boolean)
  (path :string))

(cffi:defcfun ("delete_process" %delete-process) :void
  (process :pointer))

(cffi:defcfun ("process_pid" %process-pid) :int
  (process :pointer))

(cffi:defcfun ("process_send_input" %process-send-input) :void
  (process :pointer)
  (string :string))

(cffi:defcfun ("process_receive_output" %process-receive-output) :pointer
  (process :pointer))

(cffi:defcfun ("process_alive_p" %process-alive-p) :boolean
  (process :pointer))

(defun create-process (command &key nonblock (encode cffi:*default-foreign-encoding*) directory)
  (when (and directory (not (uiop:directory-exists-p directory)))
    (error "Directory ~S does not exist" directory))
  (let* ((command (uiop:ensure-list command))
         (length (length command)))
    (cffi:with-foreign-object (argv :string (1+ length))
      (loop :for i :from 0
            :for c :in command
            :do (setf (cffi:mem-aref argv :string i) c))
      (setf (cffi:mem-aref argv :string length) (cffi:null-pointer))
      (let ((p (%create-process argv nonblock (if directory
                                                  (namestring directory)
                                                  (cffi:null-pointer)))))
        (if (cffi:null-pointer-p p)
            (error "create-process failed: ~S" command)
            (make-instance 'process :process p :encode encode))))))

(defun delete-process (process)
  (%delete-process (process-process process)))

(defun process-pid (process)
  (%process-pid (process-process process)))

(defun process-send-input (process string)
  (let ((cffi:*default-foreign-encoding* (process-encode process)))
    (%process-send-input (process-process process) string)))

(defun pointer-to-string (pointer)
  (unless (cffi:null-pointer-p pointer)
    (let* ((bytes (loop :for i :from 0
                        :for code := (cffi:mem-aref pointer :unsigned-char i)
                        :until (zerop code)
                        :collect code))
           (octets (make-array (length bytes)
                               :element-type '(unsigned-byte 8)
                               :initial-contents bytes)))
      (handler-case (babel:octets-to-string octets)
        (error ()
          ;; Fallback when an error occurs with UTF-8 encoding
          (map 'string #'code-char octets))))))

(defun process-receive-output (process)
  (let ((cffi:*default-foreign-encoding* (process-encode process)))
    (pointer-to-string (%process-receive-output (process-process process)))))

(defun process-alive-p (process)
  (%process-alive-p (process-process process)))