basis/windows/processes/processes.factor

   1 ! Copyright (C) 2021 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.data arrays
   4 classes.struct destructors endian kernel literals sequences
   5 strings windows windows.errors windows.handles windows.kernel32
   6 windows.types ;
   7 IN: windows.processes
   8
   9 : with-open-process ( access 1/0 processid quot --  )
  10     [ OpenProcess dup win32-error=0/f ] dip
  11     '[ _ <win32-handle> &dispose @ ] with-destructors ; inline
  12
  13 : with-open-process-all-access ( processid quot -- )
  14     [ PROCESS_ALL_ACCESS FALSE ] 2dip with-open-process ; inline
  15
  16 : with-create-toolhelp32-snapshot ( flags processId quot: ( alien -- alien ) -- )
  17     [ CreateToolhelp32Snapshot dup win32-error=0/f ] dip
  18     '[
  19         _ [ <win32-handle> &dispose drop ] keep @
  20     ] with-destructors ; inline
  21
  22 : with-create-toolhelp32-snapshot-processes ( quot: ( alien -- processes ) -- )
  23     [ TH32CS_SNAPPROCESS 0 ] dip with-create-toolhelp32-snapshot ; inline
  24
  25 : with-create-toolhelp32-snapshot-modules ( processId quot: ( alien -- processes ) -- )
  26     [ TH32CS_SNAPMODULE ] 2dip with-create-toolhelp32-snapshot ; inline
  27
  28 : with-create-toolhelp32-snapshot-threads ( processId quot: ( alien -- processes ) -- )
  29     [ TH32CS_SNAPTHREAD ] 2dip with-create-toolhelp32-snapshot ; inline
  30
  31 : with-create-toolhelp32-snapshot-heaplists ( quot: ( alien -- heaplists ) -- )
  32     [ TH32CS_SNAPHEAPLIST GetCurrentProcessId ] dip with-create-toolhelp32-snapshot ; inline
  33
  34 : check-snapshot ( n -- continue? )
  35     ${ ERROR_NO_MORE_FILES } win32-error=0/f-allowed 1 = ;
  36
  37 : get-process-list ( -- processes )
  38     [
  39         PROCESSENTRY32 <struct> [ dup byte-length >>dwSize Process32FirstW check-snapshot ] 2keep rot [
  40             [
  41                 [
  42                     PROCESSENTRY32 <struct> [
  43                         dup byte-length >>dwSize Process32NextW
  44                         check-snapshot
  45                     ] 2keep rot
  46                 ] [
  47                 ] produce
  48             ] dip prefix 2nip
  49         ] [
  50             1array nip
  51         ] if
  52     ] with-create-toolhelp32-snapshot-processes ;
  53
  54 : get-process-modules ( dwPid -- processes )
  55     [
  56         MODULEENTRY32W <struct> [
  57             dup byte-length >>dwSize Module32FirstW check-snapshot ] 2keep rot [
  58             [
  59                 [
  60                     MODULEENTRY32W <struct> [
  61                         dup byte-length >>dwSize
  62                         Module32NextW check-snapshot
  63                     ] 2keep rot
  64                 ] [
  65                 ] produce
  66             ] dip prefix 2nip
  67         ] [
  68             1array nip
  69         ] if
  70     ] with-create-toolhelp32-snapshot-modules ;
  71
  72 : get-process-threads ( dwPid -- processes )
  73     [
  74         THREADENTRY32 <struct> [
  75             dup byte-length >>dwSize Thread32First check-snapshot ] 2keep rot [
  76             [
  77                 [
  78                     THREADENTRY32 <struct> [
  79                         dup byte-length >>dwSize
  80                         Thread32Next check-snapshot
  81                     ] 2keep rot
  82                 ] [
  83                 ] produce
  84             ] dip prefix 2nip
  85         ] [
  86             1array nip
  87         ] if
  88     ] with-create-toolhelp32-snapshot-threads ;
  89
  90 : get-heap-entries ( heapId -- heap-entries )
  91     [
  92         HEAPENTRY32 <struct> dup byte-length >>dwSize GetCurrentProcessId
  93     ] dip [ Heap32First check-snapshot ] 3keep 2drop dup clone rot
  94     [
  95         [
  96             [ Heap32Next check-snapshot ] keep swap
  97         ] [ dup clone ] produce swap prefix nip
  98     ] [
  99         1array nip
 100     ] if ;
 101
 102 : get-heap-lists ( -- heaplists )
 103     [
 104         HEAPLIST32 <struct> [ dup byte-length >>dwSize Heap32ListFirst check-snapshot ] 2keep rot [
 105             ! dup th32HeapID>> get-heap-entries describe
 106             [
 107                 [
 108                     HEAPLIST32 <struct>
 109                     [ dup byte-length >>dwSize Heap32ListNext check-snapshot ] 2keep rot
 110                 ] [
 111                 ] produce
 112             ] dip prefix 2nip
 113         ] [
 114             2drop { }
 115         ] if
 116     ] with-create-toolhelp32-snapshot-heaplists ;
 117
 118 : get-process-image-name ( processId -- string )
 119     0 MAX_UNICODE_PATH
 120     [ uchar <c-array> ] [ DWORD <ref> ] bi
 121     [ QueryFullProcessImageNameA win32-error=0/f ] 2keep
 122     le> head >string ;
 123
 124 : get-my-process-image-name ( -- string )
 125     GetCurrentProcess get-process-image-name ;