From b8aefcc068ba0ea1d0259b9321757135e1315167 Mon Sep 17 00:00:00 2001
From: nijtmans <nijtmans>
Date: Mon, 13 Dec 2010 13:57:58 +0000
Subject: Use gcc's __builtin_trap(), when available, to enter the debugger
 after a panic. Undocumented feature, see [Patch 3124554]: Move WishPanic from
 Tk to Tcl.

---
 ChangeLog          |  7 +++++++
 generic/tclPanic.c | 14 ++++++++++----
 win/tclWinFile.c   | 53 +++++++++++++++++++++++++++++++++++++++++++++++++----
 3 files changed, 66 insertions(+), 8 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 054fd00..b943834 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2010-12-13  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* win/tclPanic.c:    Use gcc's __builtin_trap(), when available,
+	to enter the debugger after a panic.
+	* win/tclWinFile.c:  Undocumented feature, only meant to be
+	used by Tk_Main. See [Patch 3124554]: Move WishPanic from Tk to Tcl
+
 2010-12-12  Stuart Cassoff  <stwo@users.sourceforge.net>
 
 	* unix/tcl.m4: Better building on OpenBSD.
diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index 9aa0627..73059a0 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclPanic.c,v 1.15 2010/12/01 10:43:36 nijtmans Exp $
+ * RCS: @(#) $Id: tclPanic.c,v 1.16 2010/12/13 13:57:58 nijtmans Exp $
  */
 
 #include "tclInt.h"
@@ -90,13 +90,19 @@ Tcl_PanicVA(
 		arg8);
 	fprintf(stderr, "\n");
 	fflush(stderr);
+    }
+    /* In case the users panic proc does not abort, we do it here */
+#ifdef __GNUC__
+    __builtin_trap();
+#endif
 #ifdef _WIN32
-    DebugBreak();
+#   ifdef _MSC_VER
+	DebugBreak();
+#   endif
     ExitProcess(1);
 #else
-	abort();
+    abort();
 #endif
-    }
 }
 
 /*
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 6ef6f8c..0cd5f94 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclWinFile.c,v 1.116 2010/11/03 12:09:23 nijtmans Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.117 2010/12/13 13:57:58 nijtmans Exp $
  */
 
 #include "tclWinInt.h"
@@ -784,6 +784,49 @@ NativeWriteReparse(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * WishPanic --
+ *
+ *	Display a message.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PanicMessageBox(
+    const char *format, ...)
+{
+#define TCL_MAX_WARN_LEN 1024
+    va_list argList;
+    char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX];
+    WCHAR msgString[TCL_MAX_WARN_LEN];
+
+    va_start(argList, format);
+    vsnprintf(buf, sizeof(buf), format, argList);
+
+    msgString[TCL_MAX_WARN_LEN-1] = L'\0';
+    MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN);
+    /*
+     * Truncate MessageBox string if it is too long to not overflow the screen
+     * and cause possible oversized window error.
+     */
+    if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') {
+		memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
+	}
+    MessageBeep(MB_ICONEXCLAMATION);
+    MessageBoxW(NULL, msgString, L"Fatal Error",
+	    MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
+    /* We don't need to abort here, because our caller already does. */
+}
+
+/*
  *---------------------------------------------------------------------------
  *
  * TclpFindExecutable --
@@ -802,16 +845,18 @@ NativeWriteReparse(
 
 void
 TclpFindExecutable(
-    const char *argv0)		/* The value of the application's argv[0]
-				 * (native). */
+    const char *argv0)		/* If NULL, install PanicMessageBox, otherwise ignore */
 {
     WCHAR wName[MAX_PATH];
     char name[MAX_PATH * TCL_UTF_MAX];
 
     /*
      * Under Windows we ignore argv0, and return the path for the file used to
-     * create this process.
+     * create this process. Only if it is NULL, install a new panic handler.
      */
+    if (argv0 == NULL) {
+	Tcl_SetPanicProc(PanicMessageBox);
+    }
 
 #ifdef UNICODE
     GetModuleFileNameW(NULL, wName, MAX_PATH);
-- 
cgit v0.12