windows: Add some win32 snapshot apis.

diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor
index 8a057f94588c0e44f006f1ecc9d4b0e932920ab6..5edba766fce4c9dfe21ce2c674f1e5059bb0b377 100644 (file)
--- a/basis/windows/errors/errors.factor
+++ b/basis/windows/errors/errors.factor
@@ -686,6 +686,7 @@ CONSTANT: ERROR_INC_BACKUP                         4003
 CONSTANT: ERROR_FULL_BACKUP                        4004
 CONSTANT: ERROR_REC_NON_EXISTENT                   4005
 CONSTANT: ERROR_RPL_NOT_ALLOWED                    4006
+CONSTANT: PEERDIST_ERROR_CONTENTINFO_VERSION_UNSUPPORTED 4050
 CONSTANT: ERROR_NO_BROWSER_SERVERS_FOUND           6118
 
 CONSTANT: SUBLANG_NEUTRAL 0
@@ -732,6 +733,16 @@ ERROR: windows-error n string ;
 : win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
 : win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
 
+: win32-allow-errors ( n allowed -- n )
+    GetLastError 2dup swap member? [
+        2drop
+    ] [
+        throw-windows-error
+    ] if ;
+
+: win32-error=0/f-allowed ( n allowed-seq -- n )
+    over { 0 f } member? [ win32-allow-errors ] [ drop ] if ;
+
 : check-invalid-handle ( handle -- handle )
     dup INVALID_HANDLE_VALUE = [ win32-error ] when ;
 

diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor
index 2d6a200ea5177e71194a2fc4f737d51eafc3db7e..bf062d65f761997acb9d69b12bf6b11e1cdaa298 100644 (file)
--- a/basis/windows/kernel32/kernel32.factor
+++ b/basis/windows/kernel32/kernel32.factor
@@ -193,6 +193,7 @@ CONSTANT: PROCESS_CREATE_PROCESS 0x80
 CONSTANT: PROCESS_SET_QUOTA 0x100
 CONSTANT: PROCESS_SET_INFORMATION 0x200
 CONSTANT: PROCESS_QUERY_INFORMATION 0x400
+CONSTANT: PROCESS_ALL_ACCESS 0x001F0FFF
 
 CONSTANT: MEM_COMMIT 0x1000
 CONSTANT: MEM_RELEASE  0x8000
@@ -852,6 +853,31 @@ STRUCT: CONSOLE_SCREEN_BUFFER_INFO
 { srWindow SMALL_RECT }
 { dwMaximumWindowSize COORD } ;
 
+CONSTANT: HEAP_CREATE_ENABLE_EXECUTE 0x00040000
+CONSTANT: HEAP_GENERATE_EXCEPTIONS 0x00000004
+CONSTANT: HEAP_NO_SERIALIZE 0x00000001
+
+STRUCT: HEAPLIST32
+    { dwSize SIZE_T }
+    { th32ProcessID DWORD }
+    { th32HeapID ULONG_PTR }
+    { dwFlags DWORD } ;
+TYPEDEF: HEAPLIST32* PHEAPLIST32
+TYPEDEF: HEAPLIST32* LPHEAPLIST32
+
+STRUCT: HEAPENTRY32
+    { dwSize SIZE_T }
+    { hHandle HANDLE }
+    { dwAddress ULONG_PTR }
+    { dwBlockSize SIZE_T }
+    { dwFlags DWORD }
+    { dwLockCount DWORD }
+    { dwResvd DWORD }
+    { th32ProcessID DWORD }
+    { th32HeapID ULONG_PTR } ;
+TYPEDEF: HEAPENTRY32* PHEAPENTRY32
+TYPEDEF: HEAPENTRY32* LPHEAPENTRY32
+
 STRUCT: PROCESSENTRY32
     { dwSize DWORD }
     { cntUsage DWORD }
@@ -863,10 +889,50 @@ STRUCT: PROCESSENTRY32
     { pcPriClassBase LONG }
     { dwFlags DWORD }
     { szExeFile TCHAR[MAX_PATH] } ;
-
 TYPEDEF: PROCESSENTRY32* PPROCESSENTRY32
 TYPEDEF: PROCESSENTRY32* LPPROCESSENTRY32
 
+CONSTANT: MAX_MODULE_NAME32 255
+CONSTANT: MAX_MODULE_NAME32_SIZE 256
+! STRUCT: MODULEENTRY32
+!     { dwSize DWORD }
+!     { th32ModuleID DWORD }
+!     { th32ProcessID DWORD }
+!     { GlblcntUsage DWORD }
+!     { ProccntUsage DWORD }
+!     { modBaseAddr BYTE* }
+!     { modBaseSize DWORD }
+!     { hModule HMODULE }
+!     { szModule char[MAX_MODULE_NAME32_SIZE] }
+!     { szExePath char[MAX_PATH] } ;
+! TYPEDEF: MODULEENTRY32* PMODULEENTRY32
+! TYPEDEF: MODULEENTRY32* LPMODULEENTRY32
+
+STRUCT: MODULEENTRY32W
+    { dwSize DWORD }
+    { th32ModuleID DWORD }
+    { th32ProcessID DWORD }
+    { GlblcntUsage DWORD }
+    { ProccntUsage DWORD }
+    { modBaseAddr BYTE* }
+    { modBaseSize DWORD }
+    { hModule HMODULE }
+    { szModule WCHAR[MAX_MODULE_NAME32_SIZE] }
+    { szExePath WCHAR[MAX_PATH] } ;
+TYPEDEF: MODULEENTRY32W* PMODULEENTRY32W
+TYPEDEF: MODULEENTRY32W* LPMODULEENTRY32W
+
+STRUCT: THREADENTRY32
+    { dwSize DWORD }
+    { cntUsage DWORD }
+    { th32ThreadID DWORD }
+    { th32OwnerProcessID DWORD }
+    { tpBasePri LONG }
+    { tpDeltaPri LONG }
+    { dwFlags DWORD } ;
+TYPEDEF: THREADENTRY32* PTHREADENTRY32
+TYPEDEF: THREADENTRY32* LPTHREADENTRY32
+
 ! Resource IDs
 : MAKEINTRESOURCE ( int -- resource ) 0xffff bitand <alien> ; inline
 
@@ -1588,13 +1654,14 @@ FUNCTION: BOOL GlobalMemoryStatusEx ( LPMEMORYSTATUSEX lpBuffer )
 FUNCTION: BOOL GlobalUnlock ( HGLOBAL hMem )
 ! FUNCTION: GlobalUnWire
 ! FUNCTION: GlobalWire
-! FUNCTION: Heap32First
-! FUNCTION: Heap32ListFirst
-! FUNCTION: Heap32ListNext
-! FUNCTION: Heap32Next
+FUNCTION: BOOL Heap32First ( LPHEAPENTRY32 lphe, DWORD th32ProcessID, ULONG_PTR th32HeapID )
+FUNCTION: BOOL Heap32ListFirst ( HANDLE hSnapshot, LPHEAPLIST32 lphl )
+FUNCTION: BOOL Heap32ListNext ( HANDLE hSnapshot, LPHEAPLIST32 lphl )
+FUNCTION: BOOL Heap32Next ( LPHEAPENTRY32 lphe )
 FUNCTION: LPVOID HeapAlloc ( HANDLE hHeap, DWORD dwFlags, SIZE_T dwBytes )
 ! FUNCTION: HeapCompact
-! FUNCTION: HeapCreate
+
+FUNCTION: HANDLE HeapCreate ( DWORD  flOptions, SIZE_T dwInitialSize, SIZE_T dwMaximumSize )
 ! FUNCTION: HeapCreateTagsW
 ! FUNCTION: HeapDestroy
 ! FUNCTION: HeapExtend
@@ -1709,10 +1776,10 @@ FUNCTION: LPVOID MapViewOfFileEx ( HANDLE hFileMappingObject,
                                  SIZE_T dwNumberOfBytesToMap,
                                  LPVOID lpBaseAddress )
 
-! FUNCTION: Module32First
-! FUNCTION: Module32FirstW
-! FUNCTION: Module32Next
-! FUNCTION: Module32NextW
+! FUNCTION: BOOL Module32First ( HANDLE hSnapshot, LPMODULEENTRY32 lpme )
+FUNCTION: BOOL Module32FirstW ( HANDLE hSnapshot, LPMODULEENTRY32W lpme )
+! FUNCTION: BOOL Module32Next ( HANDLE hSnapshot, LPMODULEENTRY32 lpme )
+FUNCTION: BOOL Module32NextW ( HANDLE hSnapshot, LPMODULEENTRY32W lpme )
 ! FUNCTION: MoveFileA
 ! FUNCTION: MoveFileExA
 FUNCTION: BOOL MoveFileExW ( LPCSTR lpExistingFile, LPCSTR lpNewFileName, DWORD dwFlags )
@@ -1770,6 +1837,8 @@ ALIAS: Process32Next Process32NextW
 ! FUNCTION: QueryDepthSList
 ! FUNCTION: QueryDosDeviceA
 ! FUNCTION: QueryDosDeviceW
+CONSTANT: PROCESS_NAME_NATIVE 1
+FUNCTION: BOOL QueryFullProcessImageNameA ( HANDLE hProcess, DWORD dwFlags, LPSTR lpExeName, PDWORD lpdwSize )
 ! FUNCTION: QueryInformationJobObject
 ! FUNCTION: QueryMemoryResourceNotification
 FUNCTION: BOOL QueryPerformanceCounter ( LARGE_INTEGER* lpPerformanceCount )
@@ -1962,13 +2031,13 @@ FUNCTION: BOOL SystemTimeToFileTime ( SYSTEMTIME* lpSystemTime, LPFILETIME lpFil
 FUNCTION: BOOL TerminateProcess ( HANDLE hProcess, DWORD uExit )
 ! FUNCTION: TerminateThread
 ! FUNCTION: TermsrvAppInstallMode
-! FUNCTION: Thread32First
-! FUNCTION: Thread32Next
+FUNCTION: BOOL Thread32First ( HANDLE hSnapshot, LPTHREADENTRY32 lpte )
+FUNCTION: BOOL Thread32Next ( HANDLE hSnapshot, LPTHREADENTRY32 lpte )
 ! FUNCTION: TlsAlloc
 ! FUNCTION: TlsFree
 ! FUNCTION: TlsGetValue
 ! FUNCTION: TlsSetValue
-! FUNCTION: Toolhelp32ReadProcessMemory
+FUNCTION: BOOL Toolhelp32ReadProcessMemory ( DWORD th32ProcessID, LPCVOID lpBaseAddress, LPVOID lpBuffer, SIZE_T cbRead, SIZE_T *lpNumberOfBytesRead )
 ! FUNCTION: TransactNamedPipe
 ! FUNCTION: TransmitCommChar
 ! FUNCTION: TrimVirtualBuffer

diff --git a/basis/windows/processes/authors.txt b/basis/windows/processes/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /dev/null
+++ b/basis/windows/processes/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

diff --git a/basis/windows/processes/processes.factor b/basis/windows/processes/processes.factor
new file mode 100644 (file)
index 0000000..b904003
--- /dev/null
+++ b/basis/windows/processes/processes.factor
@@ -0,0 +1,125 @@
+! Copyright (C) 2021 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.data arrays
+classes.struct destructors io.binary kernel literals sequences
+strings windows windows.errors windows.handles windows.kernel32
+windows.types ;
+IN: windows.processes
+
+: with-open-process ( access 1/0 processid quot --  )
+    [ OpenProcess dup win32-error=0/f ] dip
+    '[ _ <win32-handle> &dispose @ ] with-destructors ; inline
+
+: with-open-process-all-access ( processid quot -- )
+    [ PROCESS_ALL_ACCESS FALSE ] 2dip with-open-process ; inline
+
+: with-create-toolhelp32-snapshot ( flags processId quot: ( alien -- alien ) -- )
+    [ CreateToolhelp32Snapshot dup win32-error=0/f ] dip
+    '[
+        _ [ <win32-handle> &dispose drop ] keep @
+    ] with-destructors ; inline
+
+: with-create-toolhelp32-snapshot-processes ( quot: ( alien -- processes ) -- )
+    [ TH32CS_SNAPPROCESS 0 ] dip with-create-toolhelp32-snapshot ; inline
+
+: with-create-toolhelp32-snapshot-modules ( processId quot: ( alien -- processes ) -- )
+    [ TH32CS_SNAPMODULE ] 2dip with-create-toolhelp32-snapshot ; inline
+
+: with-create-toolhelp32-snapshot-threads ( processId quot: ( alien -- processes ) -- )
+    [ TH32CS_SNAPTHREAD ] 2dip with-create-toolhelp32-snapshot ; inline
+
+: with-create-toolhelp32-snapshot-heaplists ( quot: ( alien -- heaplists ) -- )
+    [ TH32CS_SNAPHEAPLIST GetCurrentProcessId ] dip with-create-toolhelp32-snapshot ; inline
+
+: check-snapshot ( n -- continue? )
+    ${ ERROR_NO_MORE_FILES } win32-error=0/f-allowed 1 = ;
+
+: get-process-list ( -- processes )
+    [
+        PROCESSENTRY32 <struct> [ dup byte-length >>dwSize Process32FirstW check-snapshot ] 2keep rot [
+            [
+                [
+                    PROCESSENTRY32 <struct> [
+                        dup byte-length >>dwSize Process32NextW
+                        check-snapshot
+                    ] 2keep rot
+                ] [
+                ] produce
+            ] dip prefix 2nip
+        ] [
+            1array nip
+        ] if
+    ] with-create-toolhelp32-snapshot-processes ;
+
+: get-process-modules ( dwPid -- processes )
+    [
+        MODULEENTRY32W <struct> [
+            dup byte-length >>dwSize Module32FirstW check-snapshot ] 2keep rot [
+            [
+                [
+                    MODULEENTRY32W <struct> [
+                        dup byte-length >>dwSize
+                        Module32NextW check-snapshot
+                    ] 2keep rot
+                ] [
+                ] produce
+            ] dip prefix 2nip
+        ] [
+            1array nip
+        ] if
+    ] with-create-toolhelp32-snapshot-modules ;
+
+: get-process-threads ( dwPid -- processes )
+    [
+        THREADENTRY32 <struct> [
+            dup byte-length >>dwSize Thread32First check-snapshot ] 2keep rot [
+            [
+                [
+                    THREADENTRY32 <struct> [
+                        dup byte-length >>dwSize
+                        Thread32Next check-snapshot
+                    ] 2keep rot
+                ] [
+                ] produce
+            ] dip prefix 2nip
+        ] [
+            1array nip
+        ] if
+    ] with-create-toolhelp32-snapshot-threads ;
+
+: get-heap-entries ( heapId -- heap-entries )
+    [
+        HEAPENTRY32 <struct> dup byte-length >>dwSize GetCurrentProcessId
+    ] dip [ Heap32First check-snapshot ] 3keep 2drop dup clone rot
+    [
+        [
+            [ Heap32Next check-snapshot ] keep swap
+        ] [ dup clone ] produce swap prefix nip
+    ] [
+        1array nip
+    ] if ;
+
+: get-heap-lists ( -- heaplists )
+    [
+        HEAPLIST32 <struct> [ dup byte-length >>dwSize Heap32ListFirst check-snapshot ] 2keep rot [
+            ! dup th32HeapID>> get-heap-entries describe
+            [
+                [
+                    HEAPLIST32 <struct>
+                    [ dup byte-length >>dwSize Heap32ListNext check-snapshot ] 2keep rot
+                ] [
+                ] produce
+            ] dip prefix 2nip
+        ] [
+            2drop { }
+        ] if
+    ] with-create-toolhelp32-snapshot-heaplists ;
+
+: get-process-image-name ( processId -- string )
+    0 MAX_UNICODE_PATH
+    [ uchar <c-array> ] [ DWORD <ref> ] bi
+    [ QueryFullProcessImageNameA win32-error=0/f ] 2keep
+    le> head >string ;
+
+: get-my-process-image-name ( -- string )
+    GetCurrentProcess get-process-image-name ;
\ No newline at end of file

diff --git a/basis/windows/psapi/psapi.factor b/basis/windows/psapi/psapi.factor
index a4d8ccff2319b9918793887b3aa9e623261bcc1a..cc475cb15f175ddc4711dd71ac7f0b692c625348 100644 (file)
--- a/basis/windows/psapi/psapi.factor
+++ b/basis/windows/psapi/psapi.factor
@@ -10,3 +10,15 @@ FUNCTION: BOOL EnumDeviceDrivers ( LPVOID* lpImageBase, DWORD cb, LPDWORD lpcbNe
 FUNCTION: DWORD GetDeviceDriverBaseNameW ( LPVOID ImageBase, LPTSTR lpBaseName, DWORD nSize )
 
 ALIAS: GetDeviceDriverBaseName GetDeviceDriverBaseNameW
+
+FUNCTION: DWORD GetModuleFileNameExW ( HANDLE hProcess,
+  HMODULE hModule,
+  LPWSTR  lpFilename,
+  DWORD   nSize
+)
+
+FUNCTION: DWORD GetProcessImageFileNameA (
+  HANDLE hProcess,
+  LPSTR  lpImageFileName,
+  DWORD  nSize
+)