1 ! Copyright (C) 2021 Doug Coleman.
2 ! See https://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
9 : with-open-process ( access 1/0 processid quot -- )
10 [ OpenProcess dup win32-error=0/f ] dip
11 '[ _ <win32-handle> &dispose @ ] with-destructors ; inline
13 : with-open-process-all-access ( processid quot -- )
14 [ PROCESS_ALL_ACCESS FALSE ] 2dip with-open-process ; inline
16 : with-create-toolhelp32-snapshot ( flags processId quot: ( alien -- alien ) -- )
17 [ CreateToolhelp32Snapshot dup win32-error=0/f ] dip
19 _ [ <win32-handle> &dispose drop ] keep @
20 ] with-destructors ; inline
22 : with-create-toolhelp32-snapshot-processes ( quot: ( alien -- processes ) -- )
23 [ TH32CS_SNAPPROCESS 0 ] dip with-create-toolhelp32-snapshot ; inline
25 : with-create-toolhelp32-snapshot-modules ( processId quot: ( alien -- processes ) -- )
26 [ TH32CS_SNAPMODULE ] 2dip with-create-toolhelp32-snapshot ; inline
28 : with-create-toolhelp32-snapshot-threads ( processId quot: ( alien -- processes ) -- )
29 [ TH32CS_SNAPTHREAD ] 2dip with-create-toolhelp32-snapshot ; inline
31 : with-create-toolhelp32-snapshot-heaplists ( quot: ( alien -- heaplists ) -- )
32 [ TH32CS_SNAPHEAPLIST GetCurrentProcessId ] dip with-create-toolhelp32-snapshot ; inline
34 : check-snapshot ( n -- continue? )
35 ${ ERROR_NO_MORE_FILES } win32-error=0/f-allowed 1 = ;
37 : get-process-list ( -- processes )
39 PROCESSENTRY32 <struct> [ dup byte-length >>dwSize Process32FirstW check-snapshot ] 2keep rot [
42 PROCESSENTRY32 <struct> [
43 dup byte-length >>dwSize Process32NextW
52 ] with-create-toolhelp32-snapshot-processes ;
54 : get-process-modules ( dwPid -- processes )
56 MODULEENTRY32W <struct> [
57 dup byte-length >>dwSize Module32FirstW check-snapshot ] 2keep rot [
60 MODULEENTRY32W <struct> [
61 dup byte-length >>dwSize
62 Module32NextW check-snapshot
70 ] with-create-toolhelp32-snapshot-modules ;
72 : get-process-threads ( dwPid -- processes )
74 THREADENTRY32 <struct> [
75 dup byte-length >>dwSize Thread32First check-snapshot ] 2keep rot [
78 THREADENTRY32 <struct> [
79 dup byte-length >>dwSize
80 Thread32Next check-snapshot
88 ] with-create-toolhelp32-snapshot-threads ;
90 : get-heap-entries ( heapId -- heap-entries )
92 HEAPENTRY32 <struct> dup byte-length >>dwSize GetCurrentProcessId
93 ] dip [ Heap32First check-snapshot ] 3keep 2drop dup clone rot
96 [ Heap32Next check-snapshot ] keep swap
97 ] [ dup clone ] produce swap prefix nip
102 : get-heap-lists ( -- heaplists )
104 HEAPLIST32 <struct> [ dup byte-length >>dwSize Heap32ListFirst check-snapshot ] 2keep rot [
105 ! dup th32HeapID>> get-heap-entries describe
109 [ dup byte-length >>dwSize Heap32ListNext check-snapshot ] 2keep rot
116 ] with-create-toolhelp32-snapshot-heaplists ;
118 : get-process-image-name ( processId -- string )
120 [ uchar <c-array> ] [ DWORD <ref> ] bi
121 [ QueryFullProcessImageNameA win32-error=0/f ] 2keep
124 : get-my-process-image-name ( -- string )
125 GetCurrentProcess get-process-image-name ;