Implement killpg() for MSWin32

Message-ID: <m8hjo2pasv3hdbhd1sj9sasen7tm38hrhp@4ax.com>

p4raw-id: //depot/perl@29605

11 files changed, 199 insertions, 60 deletions

diff --git a/win32/config.bc b/win32/config.bc
index f87e399a81..b769d48996 100644
--- a/win32/config.bc
+++ b/win32/config.bc
@@ -266,7 +266,7 @@ d_isfinite='undef'
 d_isinf='undef'
 d_isnan='define'
 d_isnanl='undef'
-d_killpg='undef'
+d_killpg='define'
 d_lchown='undef'
 d_ldbl_dig='define'
 d_libm_lib_version='undef'
diff --git a/win32/config.gc b/win32/config.gc
index 72afe61bcf..db6db85597 100644
--- a/win32/config.gc
+++ b/win32/config.gc
@@ -266,7 +266,7 @@ d_isfinite='undef'
 d_isinf='undef'
 d_isnan='define'
 d_isnanl='undef'
-d_killpg='undef'
+d_killpg='define'
 d_lchown='undef'
 d_ldbl_dig='define'
 d_libm_lib_version='undef'
diff --git a/win32/config.vc b/win32/config.vc
index 5339125612..bf0f22329b 100644
--- a/win32/config.vc
+++ b/win32/config.vc
@@ -266,7 +266,7 @@ d_isfinite='undef'
 d_isinf='undef'
 d_isnan='define'
 d_isnanl='undef'
-d_killpg='undef'
+d_killpg='define'
 d_lchown='undef'
 d_ldbl_dig='define'
 d_libm_lib_version='undef'
diff --git a/win32/config.vc64 b/win32/config.vc64
index 06025559fc..b5d296282e 100644
--- a/win32/config.vc64
+++ b/win32/config.vc64
@@ -266,7 +266,7 @@ d_isfinite='undef'
 d_isinf='undef'
 d_isnan='define'
 d_isnanl='undef'
-d_killpg='undef'
+d_killpg='define'
 d_lchown='undef'
 d_ldbl_dig='define'
 d_libm_lib_version='undef'
diff --git a/win32/config_H.bc b/win32/config_H.bc
index 3a759074e4..daee5ca89e 100644
--- a/win32/config_H.bc
+++ b/win32/config_H.bc
@@ -221,7 +221,7 @@
  *	to kill process groups.  If unavailable, you probably should use kill
  *	with a negative process number.
  */
-/*#define HAS_KILLPG	/**/
+#define HAS_KILLPG	/**/
 
 /* HAS_LINK:
  *	This symbol, if defined, indicates that the link routine is
diff --git a/win32/config_H.gc b/win32/config_H.gc
index 0fdff1895e..afea855be3 100644
--- a/win32/config_H.gc
+++ b/win32/config_H.gc
@@ -221,7 +221,7 @@
  *	to kill process groups.  If unavailable, you probably should use kill
  *	with a negative process number.
  */
-/*#define HAS_KILLPG	/**/
+#define HAS_KILLPG	/**/
 
 /* HAS_LINK:
  *	This symbol, if defined, indicates that the link routine is
diff --git a/win32/config_H.vc b/win32/config_H.vc
index c85f0aa57d..344fb7dd3b 100644
--- a/win32/config_H.vc
+++ b/win32/config_H.vc
@@ -221,7 +221,7 @@
  *	to kill process groups.  If unavailable, you probably should use kill
  *	with a negative process number.
  */
-/*#define HAS_KILLPG	/**/
+#define HAS_KILLPG	/**/
 
 /* HAS_LINK:
  *	This symbol, if defined, indicates that the link routine is
diff --git a/win32/config_H.vc64 b/win32/config_H.vc64
index b5d708c6cf..f9708aeb14 100644
--- a/win32/config_H.vc64
+++ b/win32/config_H.vc64
@@ -221,7 +221,7 @@
  *	to kill process groups.  If unavailable, you probably should use kill
  *	with a negative process number.
  */
-/*#define HAS_KILLPG	/**/
+#define HAS_KILLPG	/**/
 
 /* HAS_LINK:
  *	This symbol, if defined, indicates that the link routine is
diff --git a/win32/perlhost.h b/win32/perlhost.h
index d6e1e0fe33..3860507be6 100644
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -1611,9 +1611,7 @@ PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
 int
 PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
 {
-    dTHX;
-    Perl_croak(aTHX_ "killpg not implemented!\n");
-    return 0;
+    return win32_kill(pid, -sig);
 }
 
 int
diff --git a/win32/win32.c b/win32/win32.c
index 3d00bb895e..948aa257d2 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -22,9 +22,34 @@
 #  define WC_NO_BEST_FIT_CHARS 0x00000400
 #endif
 #include <winnt.h>
+#include <tlhelp32.h>
 #include <io.h>
 #include <signal.h>
 
+#define SystemProcessesAndThreadsInformation 5
+
+/* Inline some definitions from the DDK */
+typedef struct {
+    USHORT	    Length;
+    USHORT	    MaximumLength;
+    PWSTR	    Buffer;
+}   UNICODE_STRING;
+
+typedef struct {
+    ULONG           NextEntryDelta;
+    ULONG	    ThreadCount;
+    ULONG	    Reserved1[6];
+    LARGE_INTEGER   CreateTime;
+    LARGE_INTEGER   UserTime;
+    LARGE_INTEGER   KernelTime;
+    UNICODE_STRING  ProcessName;
+    LONG	    BasePriority;
+    ULONG	    ProcessId;
+    ULONG	    InheritedFromProcessId;
+    /* Remainder of the structure depends on the Windows version,
+     * but we don't need those additional fields anyways... */
+}   SYSTEM_PROCESSES;
+
 /* #include "config.h" */
 
 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
@@ -124,6 +149,11 @@ END_EXTERN_C
 
 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
 
+static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL;
+static BOOL   (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL;
+static BOOL   (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL;
+static LONG   (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG);
+
 #ifdef __BORLANDC__
 /* Silence STDERR grumblings from Borland's math library. */
 DllExport int
@@ -1107,13 +1137,148 @@ remove_dead_pseudo_process(long child)
 }
 #endif
 
+static int
+terminate_process(DWORD pid, HANDLE process_handle, int sig)
+{
+    switch(sig) {
+    case 0:
+        /* "Does process exist?" use of kill */
+        return 1;
+    case 2:
+        if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
+            return 1;
+        break;
+    case SIGBREAK:
+    case SIGTERM:
+        if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
+            return 1;
+        break;
+    default: /* For now be backwards compatible with perl 5.6 */
+    case 9:
+        /* Note that we will only be able to kill processes owned by the
+         * current process owner, even when we are running as an administrator.
+         * To kill processes of other owners we would need to set the
+         * 'SeDebugPrivilege' privilege before obtaining the process handle.
+         */
+        if (TerminateProcess(process_handle, sig))
+            return 1;
+        break;
+    }
+    return 0;
+}
+
+/* Traverse process tree using ToolHelp functions */
+static int
+kill_process_tree_toolhelp(DWORD pid, int sig)
+{
+    HANDLE process_handle;
+    HANDLE snapshot_handle;
+    int killed = 0;
+
+    process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
+    if (process_handle == INVALID_HANDLE_VALUE)
+        return 0;
+
+    killed += terminate_process(pid, process_handle, sig);
+
+    snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
+    if (snapshot_handle != INVALID_HANDLE_VALUE) {
+        PROCESSENTRY32 entry;
+
+        entry.dwSize = sizeof(entry);
+        if (pfnProcess32First(snapshot_handle, &entry)) {
+            do {
+                if (entry.th32ParentProcessID == pid)
+                    killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
+                entry.dwSize = sizeof(entry);
+            }
+            while (pfnProcess32Next(snapshot_handle, &entry));
+        }
+        CloseHandle(snapshot_handle);
+    }
+    CloseHandle(process_handle);
+    return killed;
+}
+
+/* Traverse process tree using undocumented system information structures.
+ * This is only necessary on Windows NT, which lacks the ToolHelp functions.
+ */
+static int
+kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
+{
+    HANDLE process_handle;
+    SYSTEM_PROCESSES *p = process_info;
+    int killed = 0;
+
+    process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
+    if (process_handle == INVALID_HANDLE_VALUE)
+        return 0;
+
+    killed += terminate_process(pid, process_handle, sig);
+
+    while (1) {
+        if (p->InheritedFromProcessId == (DWORD)pid)
+            killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
+
+        if (p->NextEntryDelta == 0)
+            break;
+
+        p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
+    }
+
+    CloseHandle(process_handle);
+    return killed;
+}
+
+int
+killpg(int pid, int sig)
+{
+    /* Use "documented" method whenever available */
+    if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
+        return kill_process_tree_toolhelp((DWORD)pid, sig);
+    }
+
+    /* Fall back to undocumented Windows internals on Windows NT */
+    if (pfnZwQuerySystemInformation) {
+        dTHX;
+        char *buffer;
+        DWORD size = 0;
+
+        pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
+        Newx(buffer, size, char);
+
+        if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
+            int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
+            Safefree(buffer);
+            return killed;
+        }
+    }
+    return 0;
+}
+
+static int
+my_kill(int pid, int sig)
+{
+    int retval = 0;
+    HANDLE process_handle;
+
+    if (sig < 0)
+        return killpg(pid, -sig);
+
+    process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
+    if (process_handle != INVALID_HANDLE_VALUE) {
+        retval = terminate_process(pid, process_handle, sig);
+        CloseHandle(process_handle);
+    }
+    return retval;
+}
+
 DllExport int
 win32_kill(int pid, int sig)
 {
     dTHX;
     HANDLE hProcess;
     long child;
-    int retval;
 #ifdef USE_ITHREADS
     if (pid < 0) {
 	/* it is a pseudo-forked child */
@@ -1168,58 +1333,19 @@ win32_kill(int pid, int sig)
     {
 	child = find_pid(pid);
 	if (child >= 0) {
-            hProcess = w32_child_handles[child];
-	    switch(sig) {
-	    case 0:
-		/* "Does process exist?" use of kill */
-		return 0;
-	    case 2:
-		if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
-		    return 0;
-		break;
-            case SIGBREAK:
-            case SIGTERM:
-                if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
-                    return 0;
-                break;
-	    default: /* For now be backwards compatible with perl5.6 */
-	    case 9:
-	        if (TerminateProcess(hProcess, sig)) {
-		    remove_dead_process(child);
-		    return 0;
-	    	}
-		break;
+            if (my_kill(pid, sig)) {
+                DWORD exitcode = 0;
+                if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
+                    exitcode != STILL_ACTIVE)
+                {
+                    remove_dead_process(child);
+                }
+                return 0;
             }
 	}
 	else {
 alien_process:
-            retval = -1;
-	    hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
-				   (IsWin95() ? -pid : pid));
-	    if (hProcess) {
-		switch(sig) {
-		case 0:
-		    /* "Does process exist?" use of kill */
-		    retval = 0;
-                    break;
-		case 2:
-		    if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
-			retval = 0;
-		    break;
-                case SIGBREAK:
-                case SIGTERM:
-                    if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
-                       retval = 0;
-                    break;
-		default: /* For now be backwards compatible with perl5.6 */
-                case 9:
-		    if (TerminateProcess(hProcess, sig))
-			retval = 0;
-                    break;
-		}
-	    }
-            CloseHandle(hProcess);
-            if (retval == 0)
+            if (my_kill((IsWin95() ? -pid : pid), sig))
                 return 0;
 	}
     }
@@ -4490,6 +4616,8 @@ win32_ctrlhandler(DWORD dwCtrlType)
 void
 Perl_win32_init(int *argcp, char ***argvp)
 {
+    HMODULE module;
+
 #if _MSC_VER >= 1400
     _invalid_parameter_handler oldHandler, newHandler;
     newHandler = my_invalid_parameter_handler;
@@ -4506,6 +4634,18 @@ Perl_win32_init(int *argcp, char ***argvp)
     _control87(MCW_EM, MCW_EM);
 #endif
     MALLOC_INIT;
+
+    module = GetModuleHandle("ntdll.dll");
+    if (module) {
+        *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
+    }
+
+    module = GetModuleHandle("kernel32.dll");
+    if (module) {
+        *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
+        *(FARPROC*)&pfnProcess32First           = GetProcAddress(module, "Process32First");
+        *(FARPROC*)&pfnProcess32Next            = GetProcAddress(module, "Process32Next");
+    }
 }
 
 void
diff --git a/win32/win32.h b/win32/win32.h
index 2a87528f1d..b065a35a89 100644
--- a/win32/win32.h
+++ b/win32/win32.h
@@ -282,6 +282,7 @@ extern  gid_t	getegid(void);
 extern  int	setuid(uid_t uid);
 extern  int	setgid(gid_t gid);
 extern  int	kill(int pid, int sig);
+extern  int	killpg(int pid, int sig);
 #ifndef USE_PERL_SBRK
 extern  void	*sbrk(ptrdiff_t need);
 #  define HAS_SBRK_PROTO