Split scripted parts of TclOO into their own file.

3 files changed, 94 insertions, 59 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 6aa03fa..7f609b2 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -152,65 +152,10 @@ static const char *initScript =
 /* " tcloo.tcl OO_LIBRARY oo::library;"; */
 
 /*
- * The scripted part of the definitions of slots.
+ * The scripted part of the definitions of TclOO.
  */
 
-static const char *slotScript =
-"::oo::define ::oo::Slot {\n"
-"    method Get {} {error unimplemented}\n"
-"    method Set list {error unimplemented}\n"
-"    method -set args {\n"
-"        uplevel 1 [list [namespace which my] Set $args]\n"
-"    }\n"
-"    method -append args {\n"
-"        uplevel 1 [list [namespace which my] Set [list"
-"                {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
-"    }\n"
-"    method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
-"    forward --default-operation my -append\n"
-"    method unknown {args} {\n"
-"        set def --default-operation\n"
-"        if {[llength $args] == 0} {\n"
-"            return [uplevel 1 [list [namespace which my] $def]]\n"
-"        } elseif {![string match -* [lindex $args 0]]} {\n"
-"            return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
-"        }\n"
-"        next {*}$args\n"
-"    }\n"
-"    export -set -append -clear\n"
-"    unexport unknown destroy\n"
-"}\n"
-"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
-"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
-"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
-
-/*
- * The body of the <cloned> method of oo::object.
- */
-
-static const char *clonedBody =
-"foreach p [info procs [info object namespace $originObject]::*] {"
-"    set args [info args $p];"
-"    set idx -1;"
-"    foreach a $args {"
-"        lset args [incr idx] "
-"            [if {[info default $p $a d]} {list $a $d} {list $a}]"
-"    };"
-"    set b [info body $p];"
-"    set p [namespace tail $p];"
-"    proc $p $args $b;"
-"};"
-"foreach v [info vars [info object namespace $originObject]::*] {"
-"    upvar 0 $v vOrigin;"
-"    namespace upvar [namespace current] [namespace tail $v] vNew;"
-"    if {[info exists vOrigin]} {"
-"        if {[array exists vOrigin]} {"
-"            array set vNew [array get vOrigin];"
-"        } else {"
-"            set vNew $vOrigin;"
-"        }"
-"    }"
-"}";
+#include "tclOOScript.h"
 
 /*
  * The actual definition of the variable holding the TclOO stub table.
@@ -491,7 +436,12 @@ InitFoundation(
     if (TclOODefineSlots(fPtr) != TCL_OK) {
 	return TCL_ERROR;
     }
-    return Tcl_EvalEx(interp, slotScript, -1, 0);
+
+    /*
+     * Evaluate the remaining definitions, which are a compiled-in Tcl script.
+     */
+
+    return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0);
 }
 
 /*
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
new file mode 100644
index 0000000..51a8a56
--- /dev/null
+++ b/generic/tclOOScript.h
@@ -0,0 +1,85 @@
+/*
+ * tclOOScript.h --
+ *
+ *	This file contains support scripts for TclOO. They are defined here so
+ *	that the code can be definitely run even in safe interpreters; TclOO's
+ *	core setup is safe.
+ *
+ * Copyright (c) 2012-2018 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef TCL_OO_SCRIPT_H
+#define TCL_OO_SCRIPT_H
+
+/*
+ * The scripted part of the definitions of TclOO.
+ */
+
+static const char *tclOOSetupScript =
+"::oo::define ::oo::Slot {\n"
+"    method Get {} {return -code error unimplemented}\n"
+"    method Set list {return -code error unimplemented}\n"
+"    method -set args {tailcall my Set $args}\n"
+"    method -append args {\n"
+"        set current [uplevel 1 [list [namespace which my] Get]]\n"
+"        tailcall my Set [list {*}$current {*}$args]\n"
+"    }\n"
+"    method -clear {} {tailcall my Set {}}\n"
+"    forward --default-operation my -append\n"
+"    method unknown {args} {\n"
+"        set def --default-operation\n"
+"        if {[llength $args] == 0} {\n"
+"            tailcall my $def\n"
+"        } elseif {![string match -* [lindex $args 0]]} {\n"
+"            tailcall my $def {*}$args\n"
+"        }\n"
+"        next {*}$args\n"
+"    }\n"
+"    export -set -append -clear\n"
+"    unexport unknown destroy\n"
+"}\n"
+"\n"
+"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
+"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
+"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
+
+/*
+ * The body of the <cloned> method of oo::object.
+ */
+
+static const char *clonedBody =
+"foreach p [info procs [info object namespace $originObject]::*] {\n"
+"    set args [info args $p]\n"
+"    set idx -1\n"
+"    foreach a $args {\n"
+"        lset args [incr idx]"
+"            [if {[info default $p $a d]} {list $a $d} {list $a}]\n"
+"    }\n"
+"    set b [info body $p]\n"
+"    set p [namespace tail $p]\n"
+"    proc $p $args $b\n"
+"}\n"
+"foreach v [info vars [info object namespace $originObject]::*] {\n"
+"    upvar 0 $v vOrigin\n"
+"    namespace upvar [namespace current] [namespace tail $v] vNew\n"
+"    if {[info exists vOrigin]} {\n"
+"        if {[array exists vOrigin]} {\n"
+"            array set vNew [array get vOrigin]\n"
+"        } else {\n"
+"            set vNew $vOrigin\n"
+"        }\n"
+"    }\n"
+"}\n";
+
+#endif /* TCL_OO_SCRIPT_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/unix/Makefile.in b/unix/Makefile.in
index f044e41..9aa67fb 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -1220,7 +1220,7 @@ tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR)
 tclNotify.o: $(GENERIC_DIR)/tclNotify.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c
 
-tclOO.o: $(GENERIC_DIR)/tclOO.c
+tclOO.o: $(GENERIC_DIR)/tclOO.c $(GENERIC_DIR)/tclOOScript.h
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c
 
 tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c