<commit_before>;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- Wrapper over lfp_spawn(3)
;;;

(in-package :iolib.os)

(defun tty-read-fn (fd buf nbytes)
  (handler-case
      (isys:read fd buf nbytes)
    (isys:eio () 0)))

(defun tty-write-fn (fd buf nbytes)
  (handler-case
      (isys:write fd buf nbytes)
    (isys:eio ()
      (error 'isys:epipe
             :handle fd
             :syscall "write"))))

(defclass tty-stream (iolib.streams:dual-channel-gray-stream)
  ()
  (:default-initargs :read-fn  #'tty-read-fn
                     :write-fn #'tty-write-fn))

(defclass process ()
  ((pid    :initarg :pid :reader process-pid)
   (status :initform :running)
   (closed :initform nil)
   (stdin  :reader process-stdin)
   (stdout :reader process-stdout)
   (stderr :reader process-stderr)
   (pty    :reader process-pty)))

(defmethod initialize-instance :after ((process process) &key
                                       stdin stdout stderr tty external-format)
  (with-slots ((in stdin) (out stdout) (err stderr) pty)
      process
    (when stdin
      (setf in  (make-instance 'tty-stream :fd stdin
                               :external-format external-format)))
    (when stdout
      (setf out (make-instance 'tty-stream :fd stdout
                               :external-format external-format)))
    (when stderr
      (setf err (make-instance 'tty-stream :fd stderr
                               :external-format external-format)))
    (when tty
      (setf pty (make-instance 'tty-stream :fd tty
                               :external-format external-format)))))

(defmethod close ((process process) &key abort)
  (if (slot-value process 'closed)
      nil
      (macrolet ((close-process-stream (slot)
                   `(when (slot-boundp process ',slot)
                      (close (slot-value process ',slot) :abort abort)
                      (slot-makunbound process ',slot))))
        (close-process-stream stdin)
        (close-process-stream stdout)
        (close-process-stream stderr)
        (close-process-stream pty)
        (process-status process :wait (not abort))
        (setf (slot-value process 'closed) t)
        t)))

(defmethod print-object ((o process) s)
  (print-unreadable-object (o s :type t :identity nil)
    (format s "~S ~S ~S ~S"
            :pid (process-pid o)
            :status (process-status o))))

(defun exit-status (status)
  (cond
    ((isys:wifexited status)
     (isys:wexitstatus status))
    ((isys:wifsignaled status)
     (values (isys:wtermsig* status)
             (isys:wcoredump status)))))

(defgeneric process-status (process &key wait)
  (:method ((process process) &key wait)
    (if (integerp (slot-value process 'status))
        (exit-status (slot-value process 'status))
        (multiple-value-bind (pid status)
            (isys:waitpid (process-pid process)
                          (if wait 0 isys:wnohang))
          (cond
            ((zerop pid)
             :running)
            (t
             (setf (slot-value process 'status) status)
             (exit-status status)))))))

(defgeneric process-activep (process)
  (:method ((process process))
    (eql :running (process-status process))))

(defgeneric process-kill (process &optional signum)
  (:method ((process process) &optional (signum :sigterm))
    (isys:kill (process-pid process) signum)
    process))



(defmacro with-lfp-spawn-arguments ((attributes file-actions pid) &body body)
  (with-gensyms (spawnattr-initialized-p file-actions-initialized-p)
    `(with-foreign-objects ((,attributes 'lfp-spawnattr-t)
                            (,file-actions 'lfp-spawn-file-actions-t)
                            (,pid 'pid-t))
       (let ((,spawnattr-initialized-p nil)
             (,file-actions-initialized-p nil))
         (unwind-protect
              (progn
                (setf ,spawnattr-initialized-p
                      (lfp-spawnattr-init ,attributes))
                (setf ,file-actions-initialized-p
                      (lfp-spawn-file-actions-init ,file-actions))
                ,@body)
           (when ,spawnattr-initialized-p
             (lfp-spawnattr-destroy ,attributes))
           (when ,file-actions-initialized-p
             (lfp-spawn-file-actions-destroy ,file-actions)))))))

(defun allocate-argv (argv program arglist)
  ;; copy program name
  (setf (mem-aref argv :pointer 0)
        (foreign-string-alloc program))
  ;; copy program arguments
  (loop :for i :from 1
        :for arg :in arglist :do
        (setf (mem-aref argv :pointer i)
              (foreign-string-alloc arg))))

(defun find-program (program)
  (cond
    ((eql :shell program)
     (list "/bin/sh" "-c"))
    (t
     (file-path-namestring program))))

(defmacro with-argv (((arg0 argv) program arguments) &body body)
  (with-gensyms (argc)
    `(let* ((,program (ensure-list (find-program ,program)))
            (arguments (append (cdr ,program) arguments))
            (,argc (+ 2 (length ,arguments))))
       (with-foreign-object (,argv :pointer ,argc)
         (isys:bzero ,argv (* ,argc (isys:sizeof :pointer)))
         (unwind-protect
              (progn
                (allocate-argv ,argv (car ,program) ,arguments)
                (let ((,arg0 (mem-ref ,argv :pointer)))
                  ,@body))
           (delocate-null-ended-list ,argv))))))

(defun redirect-one-stream (file-actions fd stream
                            &optional flags (mode #o644) close-old-fd)
  (flet ((dup-from-path (path)
           (lfp-spawn-file-actions-addopen file-actions fd path flags mode))
         (dup-from-fd (oldfd)
           (lfp-spawn-file-actions-adddup2 file-actions oldfd fd)
           (when close-old-fd
             (lfp-spawn-file-actions-addclose file-actions oldfd))))
    (etypecase stream
      ((eql t) nil)
      ((or string file-path pathname)
       (dup-from-path (file-path-namestring stream)))
      ((eql :null)
       (dup-from-path "/dev/null"))
      (unsigned-byte
       (dup-from-fd stream))
      (iolib.streams:dual-channel-fd-mixin<commit_msg>Fix missing unquoting in WITH-ARGV<commit_after>;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- Wrapper over lfp_spawn(3)
;;;

(in-package :iolib.os)

(defun tty-read-fn (fd buf nbytes)
  (handler-case
      (isys:read fd buf nbytes)
    (isys:eio () 0)))

(defun tty-write-fn (fd buf nbytes)
  (handler-case
      (isys:write fd buf nbytes)
    (isys:eio ()
      (error 'isys:epipe
             :handle fd
             :syscall "write"))))

(defclass tty-stream (iolib.streams:dual-channel-gray-stream)
  ()
  (:default-initargs :read-fn  #'tty-read-fn
                     :write-fn #'tty-write-fn))

(defclass process ()
  ((pid    :initarg :pid :reader process-pid)
   (status :initform :running)
   (closed :initform nil)
   (stdin  :reader process-stdin)
   (stdout :reader process-stdout)
   (stderr :reader process-stderr)
   (pty    :reader process-pty)))

(defmethod initialize-instance :after ((process process) &key
                                       stdin stdout stderr tty external-format)
  (with-slots ((in stdin) (out stdout) (err stderr) pty)
      process
    (when stdin
      (setf in  (make-instance 'tty-stream :fd stdin
                               :external-format external-format)))
    (when stdout
      (setf out (make-instance 'tty-stream :fd stdout
                               :external-format external-format)))
    (when stderr
      (setf err (make-instance 'tty-stream :fd stderr
                               :external-format external-format)))
    (when tty
      (setf pty (make-instance 'tty-stream :fd tty
                               :external-format external-format)))))

(defmethod close ((process process) &key abort)
  (if (slot-value process 'closed)
      nil
      (macrolet ((close-process-stream (slot)
                   `(when (slot-boundp process ',slot)
                      (close (slot-value process ',slot) :abort abort)
                      (slot-makunbound process ',slot))))
        (close-process-stream stdin)
        (close-process-stream stdout)
        (close-process-stream stderr)
        (close-process-stream pty)
        (process-status process :wait (not abort))
        (setf (slot-value process 'closed) t)
        t)))

(defmethod print-object ((o process) s)
  (print-unreadable-object (o s :type t :identity nil)
    (format s "~S ~S ~S ~S"
            :pid (process-pid o)
            :status (process-status o))))

(defun exit-status (status)
  (cond
    ((isys:wifexited status)
     (isys:wexitstatus status))
    ((isys:wifsignaled status)
     (values (isys:wtermsig* status)
             (isys:wcoredump status)))))

(defgeneric process-status (process &key wait)
  (:method ((process process) &key wait)
    (if (integerp (slot-value process 'status))
        (exit-status (slot-value process 'status))
        (multiple-value-bind (pid status)
            (isys:waitpid (process-pid process)
                          (if wait 0 isys:wnohang))
          (cond
            ((zerop pid)
             :running)
            (t
             (setf (slot-value process 'status) status)
             (exit-status status)))))))

(defgeneric process-activep (process)
  (:method ((process process))
    (eql :running (process-status process))))

(defgeneric process-kill (process &optional signum)
  (:method ((process process) &optional (signum :sigterm))
    (isys:kill (process-pid process) signum)
    process))



(defmacro with-lfp-spawn-arguments ((attributes file-actions pid) &body body)
  (with-gensyms (spawnattr-initialized-p file-actions-initialized-p)
    `(with-foreign-objects ((,attributes 'lfp-spawnattr-t)
                            (,file-actions 'lfp-spawn-file-actions-t)
                            (,pid 'pid-t))
       (let ((,spawnattr-initialized-p nil)
             (,file-actions-initialized-p nil))
         (unwind-protect
              (progn
                (setf ,spawnattr-initialized-p
                      (lfp-spawnattr-init ,attributes))
                (setf ,file-actions-initialized-p
                      (lfp-spawn-file-actions-init ,file-actions))
                ,@body)
           (when ,spawnattr-initialized-p
             (lfp-spawnattr-destroy ,attributes))
           (when ,file-actions-initialized-p
             (lfp-spawn-file-actions-destroy ,file-actions)))))))

(defun allocate-argv (argv program arglist)
  ;; copy program name
  (setf (mem-aref argv :pointer 0)
        (foreign-string-alloc program))
  ;; copy program arguments
  (loop :for i :from 1
        :for arg :in arglist :do
        (setf (mem-aref argv :pointer i)
              (foreign-string-alloc arg))))

(defun find-program (program)
  (cond
    ((eql :shell program)
     (list "/bin/sh" "-c"))
    (t
     (file-path-namestring program))))

(defmacro with-argv (((arg0 argv) program arguments) &body body)
  (with-gensyms (argc)
    `(let* ((,program (ensure-list (find-program ,program)))
            (,arguments (append (cdr ,program) ,arguments))
            (,argc (+ 2 (length ,arguments))))
       (with-foreign-object (,argv :pointer ,argc)
         (isys:bzero ,argv (* ,argc (isys:sizeof :pointer)))
         (unwind-protect
              (progn
                (allocate-argv ,argv (car ,program) ,arguments)
                (let ((,arg0 (mem-ref ,argv :pointer)))
                  ,@body))
           (delocate-null-ended-list ,argv))))))

(defun redirect-one-stream (file-actions fd stream
                            &optional flags (mode #o644) close-old-fd)
  (flet ((dup-from-path (path)
           (lfp-spawn-file-actions-addopen file-actions fd path flags mode))
         (dup-from-fd (oldfd)
           (lfp-spawn-file-actions-adddup2 file-actions oldfd fd)
           (when close-old-fd
             (lfp-spawn-file-actions-addclose file-actions oldfd))))
    (etypecase stream
      ((eql t) nil)
      ((or string file-path pathname)
       (dup-from-path (file-path-namestring stream)))
      ((eql :null)
       (dup-from-path "/dev/null"))
      (unsigned-byte
       (dup-from-fd stream))
      (iolib.streams:dual-channel-fd-mixin
{'fraction_non_alphanumeric': 0.13639727041026062, 'fraction_numerical': 0.0019731974019567542, 'mean_word_length': 2.1062308478038814, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6696217', 'n_tokens_mistral': 3862, 'n_tokens_neox': 3786, 'n_words': 945}