Bug 1263012

2 files changed, 63 insertions, 0 deletions

diff --git a/ChangeLog b/ChangeLog
index d8e46ca..cf3989b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2005-11-04  Kevin Kenny  <kennykb@acm.org>
+
+	* tools/findBadExternals.tcl: Added this script, which locates
+	external symbols that do not begin with 'Tcl' or 'tcl' and hence
+	might be in conflict with other link libraries.  Thanks to George
+	Peter Staplin for the idea and the initial version of the script.
+	
 2005-11-04  Miguel Sofer <msofer@users.sf.net>
 
 	* generic/tclInt.h:
diff --git a/tools/findBadExternals.tcl b/tools/findBadExternals.tcl
new file mode 100755
index 0000000..6696801
--- /dev/null
+++ b/tools/findBadExternals.tcl
@@ -0,0 +1,56 @@
+# findBadExternals.tcl --
+# 
+#	This script scans the Tcl load library for exported symbols
+#	that do not begin with 'Tcl' or 'tcl'.  It reports them on the
+#	standard output.  It is used to make sure that the library does
+#	not inadvertently export externals that may be in conflict with
+#	other code.
+#
+# Usage:
+#
+#	tclsh findBadExternals.tcl /path/to/tclXX.so-or-.dll
+#
+# Copyright (c) 2005 George Peter Staplin and Kevin Kenny
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: findBadExternals.tcl,v 1.1 2005/11/04 19:37:57 kennykb Exp $
+#
+#----------------------------------------------------------------------
+
+proc main {argc argv} {
+
+    if {$argc != 1} {
+	puts stderr "syntax is: [info script] libtcl"
+	return 1
+    }
+
+
+    switch -exact -- $::tcl_platform(platform) {
+	unix -
+	macosx {
+	    set status [catch {
+		exec nm --extern-only --defined-only [lindex $argv 0]
+	    } result] 
+	}
+	windows {
+	    set status [catch {
+		exec dumpbin /exports [lindex $argv 0]
+	    } result]
+	}
+    }
+    if {$status != 0 && $::errorCode ne "NONE"} {
+	puts $result
+	return 1
+    }
+
+    foreach line [split $result \n] {
+	if {! [string match {* [Tt]cl*} $line]} {
+	    puts $line
+	}
+    }
+
+    return 0
+}
+exit [main $::argc $::argv]