Make it much easier to maintain the TclOO initialisation script.

4 files changed, 379 insertions, 21 deletions

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index ffdedb8..1f345fb 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -21,16 +21,17 @@
  */
 
 static const char *tclOOSetupScript =
+/* !BEGIN!: Do not edit below this line. */
 "::proc ::oo::Helpers::callback {method args} {\n"
 "    list [uplevel 1 {namespace which my}] $method {*}$args\n"
 "}\n"
-
+"\n"
 "::proc ::oo::Helpers::mymethod {method args} {\n"
 "    list [uplevel 1 {namespace which my}] $method {*}$args\n"
 "}\n"
-
+"\n"
 "::proc ::oo::Helpers::classvariable {name args} {\n"
-"    # Get a reference to the class's namespace\n"
+"    # Get a reference to the class\'s namespace\n"
 "    set ns [info object namespace [uplevel 1 {self class}]]\n"
 "    # Double up the list of variable names\n"
 "    foreach v [list $name {*}$args] {\n"
@@ -42,10 +43,10 @@ static const char *tclOOSetupScript =
 "        }\n"
 "        lappend vs $v $v\n"
 "    }\n"
-"    # Lastly, link the caller's local variables to the class's variables\n"
+"    # Lastly, link the caller\'s local variables to the class\'s variables\n"
 "    tailcall namespace upvar $ns {*}$vs\n"
 "}\n"
-
+"\n"
 "::proc ::oo::Helpers::link {args} {\n"
 "    set ns [uplevel 1 {namespace current}]\n"
 "    foreach link $args {\n"
@@ -68,11 +69,11 @@ static const char *tclOOSetupScript =
 "        rename $cmd {}\n"
 "    }\n"
 "}\n"
-
+"\n"
 "::proc ::oo::DelegateName {class} {\n"
 "    string cat [info object namespace $class] {:: oo ::delegate}\n"
 "}\n"
-
+"\n"
 "proc ::oo::MixinClassDelegates {class} {\n"
 "    if {![info object isa class $class]} {\n"
 "        return\n"
@@ -81,7 +82,7 @@ static const char *tclOOSetupScript =
 "    if {![info object isa class $delegate]} {\n"
 "        return\n"
 "    }\n"
-"    foreach c [info class superclass $class] {"
+"    foreach c [info class superclass $class] {\n"
 "        set d [::oo::DelegateName $c]\n"
 "        if {![info object isa class $d]} {\n"
 "            continue\n"
@@ -90,14 +91,14 @@ static const char *tclOOSetupScript =
 "    }\n"
 "    ::oo::objdefine $class mixin -append $delegate\n"
 "}\n"
-
-"::namespace eval ::oo::define {"
+"\n"
+"::namespace eval ::oo::define {\n"
 "    ::proc classmethod {name {args {}} {body {}}} {\n"
 "        # Create the method on the class if the caller gave arguments and body\n"
 "        ::set argc [::llength [::info level 0]]\n"
 "        ::if {$argc == 3} {\n"
-"            ::return -code error [::string cat {wrong # args: should be \"}"
-"                    [::lindex [::info level 0] 0] { name ?args body?\"}]\n"
+"            ::return -code error [::string cat {wrong # args: should be \"} \\\n"
+"                    [::lindex [::info level 0] 0] { name \?args body\?\"}]\n"
 "        }\n"
 "        ::set cls [::uplevel 1 self]\n"
 "        ::if {$argc == 4} {\n"
@@ -106,12 +107,12 @@ static const char *tclOOSetupScript =
 "        # Make the connection by forwarding\n"
 "        ::tailcall forward $name myclass $name\n"
 "    }\n"
-
+"\n"
 "    ::proc initialise {body} {\n"
 "        ::set clsns [::info object namespace [::uplevel 1 self]]\n"
 "        ::tailcall apply [::list {} $body $clsns]\n"
 "    }\n"
-
+"\n"
 "    # Make the initialise command appear with US spelling too\n"
 "    ::namespace export initialise\n"
 "    ::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
@@ -119,11 +120,11 @@ static const char *tclOOSetupScript =
 "    ::namespace delete tmp\n"
 "    ::namespace export -clear\n"
 "}\n"
-
+"\n"
 "::oo::define ::oo::Slot {\n"
 "    method Get {} {return -code error unimplemented}\n"
 "    method Set list {return -code error unimplemented}\n"
-
+"\n"
 "    method -set args {tailcall my Set $args}\n"
 "    method -append args {\n"
 "        set current [uplevel 1 [list [namespace which my] Get]]\n"
@@ -131,7 +132,7 @@ static const char *tclOOSetupScript =
 "    }\n"
 "    method -clear {} {tailcall my Set {}}\n"
 "    forward --default-operation my -append\n"
-
+"\n"
 "    method unknown {args} {\n"
 "        set def --default-operation\n"
 "        if {[llength $args] == 0} {\n"
@@ -141,7 +142,7 @@ static const char *tclOOSetupScript =
 "        }\n"
 "        next {*}$args\n"
 "    }\n"
-
+"\n"
 "    export -set -append -clear\n"
 "    unexport unknown destroy\n"
 "}\n"
@@ -149,7 +150,7 @@ static const char *tclOOSetupScript =
 "::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"
-
+"\n"
 "::oo::define ::oo::class method <cloned> {originObject} {\n"
 "    next $originObject\n"
 "    # Rebuild the class inheritance delegation class\n"
@@ -162,7 +163,7 @@ static const char *tclOOSetupScript =
 "        }]\n"
 "    }\n"
 "}\n"
-
+"\n"
 "::oo::class create ::oo::singleton {\n"
 "    superclass ::oo::class\n"
 "    variable object\n"
@@ -180,11 +181,12 @@ static const char *tclOOSetupScript =
 "        return $object\n"
 "    }\n"
 "}\n"
-
+"\n"
 "::oo::class create ::oo::abstract {\n"
 "    superclass ::oo::class\n"
 "    unexport create createWithNamespace new\n"
 "}\n"
+/* !END!: Do not edit above this line. */
 ;
 
 /*
diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl
new file mode 100644
index 0000000..e0af23f
--- /dev/null
+++ b/generic/tclOOScript.tcl
@@ -0,0 +1,183 @@
+# 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 Donal K. Fellows
+# Copyright (c) 2013 Andreas Kupries
+# Copyright (c) 2017 Gerald Lester
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+::proc ::oo::Helpers::callback {method args} {
+    list [uplevel 1 {namespace which my}] $method {*}$args
+}
+
+::proc ::oo::Helpers::mymethod {method args} {
+    list [uplevel 1 {namespace which my}] $method {*}$args
+}
+
+::proc ::oo::Helpers::classvariable {name args} {
+    # Get a reference to the class's namespace
+    set ns [info object namespace [uplevel 1 {self class}]]
+    # Double up the list of variable names
+    foreach v [list $name {*}$args] {
+        if {[string match *(*) $v]} {
+            return -code error [string cat {bad variable name "} $v {": can't create a scalar variable that looks like an array element}]
+        }
+        if {[string match *::* $v]} {
+            return -code error [string cat {bad variable name "} $v {": can't create a local variable with a namespace separator in it}]
+        }
+        lappend vs $v $v
+    }
+    # Lastly, link the caller's local variables to the class's variables
+    tailcall namespace upvar $ns {*}$vs
+}
+
+::proc ::oo::Helpers::link {args} {
+    set ns [uplevel 1 {namespace current}]
+    foreach link $args {
+        if {[llength $link] == 2} {
+            lassign $link src dst
+        } else {
+            lassign $link src
+            set dst $src
+        }
+        if {![string match ::* $src]} {
+            set src [string cat $ns :: $src]
+        }
+        interp alias {} $src {} ${ns}::my $dst
+        trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src]
+    }
+    return
+}
+::proc ::oo::Helpers::Unlink {cmd args} {
+    if {[namespace which $cmd] ne {}} {
+        rename $cmd {}
+    }
+}
+
+::proc ::oo::DelegateName {class} {
+    string cat [info object namespace $class] {:: oo ::delegate}
+}
+
+proc ::oo::MixinClassDelegates {class} {
+    if {![info object isa class $class]} {
+        return
+    }
+    set delegate [::oo::DelegateName $class]
+    if {![info object isa class $delegate]} {
+        return
+    }
+    foreach c [info class superclass $class] {
+        set d [::oo::DelegateName $c]
+        if {![info object isa class $d]} {
+            continue
+        }
+        ::oo::define $delegate superclass -append $d
+    }
+    ::oo::objdefine $class mixin -append $delegate
+}
+
+::namespace eval ::oo::define {
+    ::proc classmethod {name {args {}} {body {}}} {
+        # Create the method on the class if the caller gave arguments and body
+        ::set argc [::llength [::info level 0]]
+        ::if {$argc == 3} {
+            ::return -code error [::string cat {wrong # args: should be "} \
+                    [::lindex [::info level 0] 0] { name ?args body?"}]
+        }
+        ::set cls [::uplevel 1 self]
+        ::if {$argc == 4} {
+            ::oo::define [::oo::DelegateName $cls] method $name $args $body
+        }
+        # Make the connection by forwarding
+        ::tailcall forward $name myclass $name
+    }
+
+    ::proc initialise {body} {
+        ::set clsns [::info object namespace [::uplevel 1 self]]
+        ::tailcall apply [::list {} $body $clsns]
+    }
+
+    # Make the initialise command appear with US spelling too
+    ::namespace export initialise
+    ::namespace eval tmp {::namespace import ::oo::define::initialise}
+    ::rename ::oo::define::tmp::initialise initialize
+    ::namespace delete tmp
+    ::namespace export -clear
+}
+
+::oo::define ::oo::Slot {
+    method Get {} {return -code error unimplemented}
+    method Set list {return -code error unimplemented}
+
+    method -set args {tailcall my Set $args}
+    method -append args {
+        set current [uplevel 1 [list [namespace which my] Get]]
+        tailcall my Set [list {*}$current {*}$args]
+    }
+    method -clear {} {tailcall my Set {}}
+    forward --default-operation my -append
+
+    method unknown {args} {
+        set def --default-operation
+        if {[llength $args] == 0} {
+            tailcall my $def
+        } elseif {![string match -* [lindex $args 0]]} {
+            tailcall my $def {*}$args
+        }
+        next {*}$args
+    }
+
+    export -set -append -clear
+    unexport unknown destroy
+}
+
+::oo::objdefine ::oo::define::superclass forward --default-operation my -set
+::oo::objdefine ::oo::define::mixin forward --default-operation my -set
+::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set
+
+::oo::define ::oo::class method <cloned> {originObject} {
+    next $originObject
+    # Rebuild the class inheritance delegation class
+    set originDelegate [::oo::DelegateName $originObject]
+    set targetDelegate [::oo::DelegateName [self]]
+    if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {
+        ::oo::copy $originDelegate $targetDelegate
+        ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {
+            if {$c eq $originDelegate} {set targetDelegate} {set c}
+        }]
+    }
+}
+
+::oo::class create ::oo::singleton {
+    superclass ::oo::class
+    variable object
+    unexport create createWithNamespace
+    method new args {
+        if {![info exists object] || ![info object isa object $object]} {
+            set object [next {*}$args]
+            ::oo::objdefine $object method destroy {} {
+                return -code error {may not destroy a singleton object}
+            }
+            ::oo::objdefine $object method <cloned> {originObject} {
+                return -code error {may not clone a singleton object}
+            }
+        }
+        return $object
+    }
+}
+
+::oo::class create ::oo::abstract {
+    superclass ::oo::class
+    unexport create createWithNamespace new
+}
+
+# Local Variables:
+# mode: tcl
+# c-basic-offset: 4
+# fill-column: 78
+# End:
diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl
new file mode 100644
index 0000000..8af35fc
--- /dev/null
+++ b/tools/makeHeader.tcl
@@ -0,0 +1,164 @@
+# makeHeader.tcl --
+#
+#	This script generates embeddable C source (in a .h file) from a .tcl
+#	script.
+#
+# Copyright (c) 2018 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.6
+
+namespace eval makeHeader {
+
+    ####################################################################
+    #
+    # mapSpecial --
+    #	Transform a single line so that it is able to be put in a C string.
+    #
+    proc mapSpecial {str} {
+	# All Tcl metacharacters and key C backslash sequences
+	set MAP {
+	    \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
+	    \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
+	}
+	set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}
+
+	subst [regsub -all {[^\u0020-\u007e]} [string map $MAP $str] $XFORM]
+    }
+
+    ####################################################################
+    #
+    # processScript --
+    #	Transform a whole sequence of lines with [mapSpecial].
+    #
+    proc processScript {scriptLines} {
+	lmap line $scriptLines {
+	    format {"%s"} [mapSpecial $line\n]
+	}
+    }
+
+    ####################################################################
+    #
+    # updateTemplate --
+    #	Rewrite a template to contain the content from the input script.
+    #
+    proc updateTemplate {dataVar scriptLines} {
+	set BEGIN "*!BEGIN!: Do not edit below this line.*"
+	set END "*!END!: Do not edit above this line.*"
+
+	upvar 1 $dataVar data
+
+	set from [lsearch -glob $data $BEGIN]
+	set to [lsearch -glob $data $END]
+	if {$from == -1 || $to == -1 || $from >= $to} {
+	    throw BAD "not a template"
+	}
+
+	set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]]
+    }
+
+    ####################################################################
+    #
+    # stripSurround --
+    #	Removes the header and footer comments from a (line-split list of
+    #	lines of) Tcl script code.
+    #
+    proc stripSurround {lines} {
+	set RE {^\s*$|^#}
+	set state 0
+	set lines [lmap line [lreverse $lines] {
+	    if {!$state && [regexp $RE $line]} continue {
+		set state 1
+		set line
+	    }
+	}]
+	return [lmap line [lreverse $lines] {
+	    if {$state && [regexp $RE $line]} continue {
+		set state 0
+		set line
+	    }
+	}]
+    }
+
+    ####################################################################
+    #
+    # updateTemplateFile --
+    #	Rewrites a template file with the lines of the given script.
+    #
+    proc updateTemplateFile {headerFile scriptLines} {
+	set f [open $headerFile "r+"]
+	try {
+	    set content [split [chan read -nonewline $f] "\n"]
+	    updateTemplate content [stripSurround $scriptLines]
+	    chan seek $f 0
+	    chan puts $f [join $content \n]
+	    chan truncate $f
+	} trap BAD msg {
+	    # Add the filename to the message
+	    throw BAD "${headerFile}: $msg"
+	} finally {
+	    chan close $f
+	}
+    }
+
+    ####################################################################
+    #
+    # readScript --
+    #	Read a script from a file and return its lines.
+    #
+    proc readScript {script} {
+	set f [open $script]
+	try {
+	    chan configure $f -encoding utf-8
+	    return [split [string trim [chan read $f]] "\n"]
+	} finally {
+	    chan close $f
+	}
+    }
+
+    ####################################################################
+    #
+    # run --
+    #	The main program of this script.
+    #
+    proc run {args} {
+	try {
+	    if {[llength $args] != 2} {
+		throw ARGS "inputTclScript templateFile"
+	    }
+	    lassign $args inputTclScript templateFile
+
+	    puts "Inserting $inputTclScript into $templateFile"
+	    set scriptLines [readScript $inputTclScript]
+	    updateTemplateFile $templateFile $scriptLines
+	    exit 0
+	} trap ARGS msg {
+	    puts stderr "wrong # args: should be \"[file tail $::argv0] $msg\""
+	    exit 2
+	} trap BAD msg {
+	    puts stderr $msg
+	    exit 1
+	} trap POSIX msg {
+	    puts stderr $msg
+	    exit 1
+	} on error {- opts} {
+	    puts stderr [dict get $opts -errorinfo]
+	    exit 3
+	}
+    }
+}
+
+########################################################################
+#
+# Launch the main program
+#
+if {[info script] eq $::argv0} {
+    makeHeader::run {*}$::argv
+}
+
+# Local-Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/unix/Makefile.in b/unix/Makefile.in
index e4d77e6..6ae2b0d 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -1895,6 +1895,11 @@ $(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls
 	@echo "Developers may want to run \"make genstubs\" to regenerate."
 	@echo "This warning can be safely ignored, do not report as a bug!"
 
+$(GENERIC_DIR)/tclOOScript.h: $(GENERIC_DIR)/tclOOScript.tcl
+	@echo "Warning: tclOOScript.h may be out of date."
+	@echo "Developers may want to run \"make genscript\" to regenerate."
+	@echo "This warning can be safely ignored, do not report as a bug!"
+
 genstubs:
 	$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
 		$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \
@@ -1902,6 +1907,10 @@ genstubs:
 	$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
 		$(GENERIC_DIR)/tclOO.decls
 
+genscript:
+	$(NATIVE_TCLSH) $(TOOL_DIR)/makeHeader.tcl \
+		$(GENERIC_DIR)/tclOOScript.tcl $(GENERIC_DIR)/tclOOScript.h
+
 #
 # Target to check that all exported functions have an entry in the stubs
 # tables.