#xyzzy でプロセス関連の API

gistfile1.cl

#|
テスト

(progn
  (call-process "dir" :show :hide)
  (call-process "date" :show :hide)
  (get-child-processes))
;=> (#S(process-entry exe-file "dir.exe" process-id 1188 parent-process-id 4660
                      module-id 0 default-heap-id 0 threads 1
                      pri-class-base 8 usage 0 flags 0)
     #S(process-entry exe-file "date.exe" process-id 5576 parent-process-id 4660
                      module-id 0 default-heap-id 0 threads 1
                      pri-class-base 8 usage 0 flags 0))

(progn
  (call-process "ruby -e 'exit 23'" :show :hide)
  (let* ((p (car (search-child-processes "ruby" :regexp t)))
         (h (open-process (process-entry-process-id p))))
    (sleep-for 3)
    (unwind-protect
        (get-exit-code-process h)
      (terminate-process h 0)
      (close-process h))))
;=> 23
|#

(require "api.l")

(c:define-c-struct PROCESSENTRY32
  (winapi::DWORD     dwSize)
  (winapi::DWORD     cntUsage)
  (winapi::DWORD     th32ProcessID)
  ((winapi::ULONG *) th32DefaultHeapID)
  (winapi::DWORD     th32ModuleID)
  (winapi::DWORD     cntThreads)
  (winapi::DWORD     th32ParentProcessID)
  (winapi::LONG      pcPriClassBase)
  (winapi::DWORD     dwFlags)
  (c:char            szExeFile 1024)
  )

(c:define-dll-entry
  winapi::HANDLE
  CreateToolhelp32Snapshot (winapi::DWORD ; dwFlags
                            winapi::DWORD ; th32ProcessID
                            )
  "kernel32")

(c:define-dll-entry
  winapi::BOOL
  Process32First (winapi::HANDLE     ; hSnapshot
                  (PROCESSENTRY32 *) ; lppe
                  )
  "kernel32")

(c:define-dll-entry
  winapi::BOOL
  Process32Next (winapi::HANDLE     ; hSnapshot
                 (PROCESSENTRY32 *) ; lppe
                 )
  "kernel32")

(c:define-dll-entry
  winapi::DWORD
  GetWindowThreadProcessId (winapi::HWND      ; hWnd
                            (winapi::DWORD *) ; lpdwProcessId
                            )
  "user32")

(c:define-dll-entry
  winapi::BOOL
  GetExitCodeProcess (winapi::HANDLE
                      (winapi::DWORD *))
  "kernel32")

(c:define-dll-entry
  winapi::HANDLE
  OpenProcess (winapi::DWORD
               winapi::BOOL
               winapi::DWORD)
  "kernel32")

(c:define-dll-entry
  winapi::DWORD
  GetCurrentProcessId ()
  "kernel32")

(c:define-dll-entry
  winapi::BOOL
  TerminateProcess (winapi::HANDLE
                    winapi::UINT)
  "kernel32")

(defstruct process-entry
  exe-file
  process-id parent-process-id
  module-id default-heap-id threads
  pri-class-base usage flags)

(defun walk-process-snapshot (fn)
  (let ((handle (CreateToolhelp32Snapshot 2 0)))
    (unwind-protect
        (let ((proc (make-PROCESSENTRY32))
              (r 0))
          (setf (PROCESSENTRY32-dwSize proc)  (c:c-struct-size-of PROCESSENTRY32))
          (setf r (Process32First handle proc))
          (while (not (zerop r))
            (funcall fn proc)
            (setf r (Process32Next handle proc))))
      (winapi::CloseHandle handle))))

(defun filter-process-snapshot (&optional predicate)
  (let ((r nil))
    (unless predicate
      (setf predicate #'identity))
    (walk-process-snapshot #'(lambda (proc)
                               (when (funcall predicate proc)
                                 (push (convert-to-process-entry-struct proc) r))))
    (nreverse r)))

(defun convert-to-process-entry-struct (proc)
  (when proc
    (make-process-entry
     :usage             (PROCESSENTRY32-cntUsage proc)
     :process-id        (PROCESSENTRY32-th32ProcessID proc)
     :default-heap-id   (PROCESSENTRY32-th32DefaultHeapID proc)
     :module-id         (PROCESSENTRY32-th32ModuleID proc)
     :threads           (PROCESSENTRY32-cntThreads proc)
     :parent-process-id (PROCESSENTRY32-th32ParentProcessID proc)
     :pri-class-base    (PROCESSENTRY32-pcPriClassBase proc)
     :flags             (PROCESSENTRY32-dwFlags proc)
     :exe-file          (exe-file proc))))

(defun exe-file (proc)
  (si:unpack-string
   (si:make-chunk nil 256 proc
                  (c:c-struct-offset-of PROCESSENTRY32 szExeFile))
   0 256))

(defun get-window-thread-process-id (hwnd)
  (let ((r (make-DWORD)))
    (GetWindowThreadProcessId hwnd r)
    (unpack-DWORD r)))

(defun get-all-processes ()
  (filter-process-snapshot))

(defun get-child-processes ()
  (filter-process-snapshot #'child-process-p))

(defun search-processes (query &key regexp)
  (filter-process-snapshot
   #'(lambda (proc)
       (exe-file-match-p proc query :regexp regexp))))

(defun search-child-processes (query &key regexp)
  (filter-process-snapshot
   #'(lambda (proc)
       (and (child-process-p proc)
            (exe-file-match-p proc query :regexp regexp)))))

(defun child-process-p (proc)
  (let ((self (get-current-process-id)))
    (= self (PROCESSENTRY32-th32ParentProcessID proc))))

(defun exe-file-match-p (proc query &key regexp)
  (let ((exe-file (exe-file proc))
        (predicate (if regexp #'string-matchp #'string-equal)))
    (when exe-file
      (funcall predicate query exe-file))))

(defun open-process (pid)
  (OpenProcess 2035711 0 pid))

(defun close-process (handle)
  (winapi::CloseHandle handle))

(defun terminate-process (handle exitcode)
  (winapi::TerminateProcess handle exitcode))

(defun get-exit-code-process (handle)
  (let ((r (make-DWORD)))
    (GetExitCodeProcess handle r)
    (unpack-DWORD r)))

(defun get-current-process-id ()
  (GetCurrentProcessId))

(defun make-DWORD ()
  (let ((r (si:make-chunk nil 4)))
    (setf (si:unpack-uint32 r 0) 0)
    r))

(defun unpack-DWORD (chunk)
  (si:unpack-uint32 chunk 0))