Tcl Source Code

Check-in [a769968834]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Make it much easier to maintain the TclOO initialisation script.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: a76996883424789270d481f91c42ab7464e033f099fced4c79293e78bcf2b180
User & Date: dkf 2018-08-05 15:01:30
Context
2018-08-05
20:14
Combine the two bits of scripted code inside TclOO's definition into one. check-in: af7aa1c82c user: dkf tags: tip-478
15:01
Make it much easier to maintain the TclOO initialisation script. check-in: a769968834 user: dkf tags: tip-478
2018-07-15
15:46
Added more tests and made [initialize] an alternate spelling for [initialise]. check-in: 155bc7ab0b user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOOScript.h.

17
18
19
20
21
22
23

24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48

49
50
51
52
53
54
55
..
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93

94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
...
176
177
178
179
180
181
182
183
184
185
186
187

188
189
190
191
192
193
194
#define TCL_OO_SCRIPT_H
 
/*
 * The scripted part of the definitions of TclOO.
 */

static const char *tclOOSetupScript =

"::proc ::oo::Helpers::callback {method args} {\n"
"    list [uplevel 1 {namespace which my}] $method {*}$args\n"
"}\n"

"::proc ::oo::Helpers::mymethod {method args} {\n"
"    list [uplevel 1 {namespace which my}] $method {*}$args\n"
"}\n"


"::proc ::oo::Helpers::classvariable {name args} {\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"
"        if {[string match *(*) $v]} {\n"
"            return -code error [string cat {bad variable name \"} $v {\": can\'t create a scalar variable that looks like an array element}]\n"
"        }\n"
"        if {[string match *::* $v]} {\n"
"            return -code error [string cat {bad variable name \"} $v {\": can\'t create a local variable with a namespace separator in it}]\n"
"        }\n"
"        lappend vs $v $v\n"
"    }\n"
"    # Lastly, link the caller's local variables to the class's variables\n"
"    tailcall namespace upvar $ns {*}$vs\n"
"}\n"


"::proc ::oo::Helpers::link {args} {\n"
"    set ns [uplevel 1 {namespace current}]\n"
"    foreach link $args {\n"
"        if {[llength $link] == 2} {\n"
"            lassign $link src dst\n"
"        } else {\n"
"            lassign $link src\n"
................................................................................
"    return\n"
"}\n"
"::proc ::oo::Helpers::Unlink {cmd args} {\n"
"    if {[namespace which $cmd] ne {}} {\n"
"        rename $cmd {}\n"
"    }\n"
"}\n"

"::proc ::oo::DelegateName {class} {\n"
"    string cat [info object namespace $class] {:: oo ::delegate}\n"
"}\n"

"proc ::oo::MixinClassDelegates {class} {\n"
"    if {![info object isa class $class]} {\n"
"        return\n"
"    }\n"
"    set delegate [::oo::DelegateName $class]\n"
"    if {![info object isa class $delegate]} {\n"
"        return\n"
"    }\n"
"    foreach c [info class superclass $class] {"
"        set d [::oo::DelegateName $c]\n"
"        if {![info object isa class $d]} {\n"
"            continue\n"
"        }\n"
"        ::oo::define $delegate superclass -append $d\n"
"    }\n"
"    ::oo::objdefine $class mixin -append $delegate\n"
"}\n"


"::namespace eval ::oo::define {"
"    ::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"
"        }\n"
"        ::set cls [::uplevel 1 self]\n"
"        ::if {$argc == 4} {\n"
"            ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
"        }\n"
"        # Make the connection by forwarding\n"
"        ::tailcall forward $name myclass $name\n"
"    }\n"

"    ::proc initialise {body} {\n"
"        ::set clsns [::info object namespace [::uplevel 1 self]]\n"
"        ::tailcall apply [::list {} $body $clsns]\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"
"    ::rename ::oo::define::tmp::initialise initialize\n"
"    ::namespace delete tmp\n"
"    ::namespace export -clear\n"
"}\n"

"::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"

"::oo::define ::oo::class method <cloned> {originObject} {\n"
"    next $originObject\n"
"    # Rebuild the class inheritance delegation class\n"
"    set originDelegate [::oo::DelegateName $originObject]\n"
"    set targetDelegate [::oo::DelegateName [self]]\n"
"    if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {\n"
"        ::oo::copy $originDelegate $targetDelegate\n"
"        ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {\n"
"            if {$c eq $originDelegate} {set targetDelegate} {set c}\n"
"        }]\n"
"    }\n"
"}\n"

"::oo::class create ::oo::singleton {\n"
"    superclass ::oo::class\n"
"    variable object\n"
"    unexport create createWithNamespace\n"
"    method new args {\n"
"        if {![info exists object] || ![info object isa object $object]} {\n"
"            set object [next {*}$args]\n"
................................................................................
"            ::oo::objdefine $object method <cloned> {originObject} {\n"
"                return -code error {may not clone a singleton object}\n"
"            }\n"
"        }\n"
"        return $object\n"
"    }\n"
"}\n"

"::oo::class create ::oo::abstract {\n"
"    superclass ::oo::class\n"
"    unexport create createWithNamespace new\n"
"}\n"

;

/*
 * The body of the <cloned> method of oo::object.
 */

static const char *clonedBody =






>



|



<
>

|











|


<
>







 







|



|








|








<
>
|




|
|








|




|







|



|







|









|







|












|







 







|




>







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48

49
50
51
52
53
54
55
56
..
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93

94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
...
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
#define TCL_OO_SCRIPT_H
 
/*
 * The scripted part of the definitions of TclOO.
 */

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"
"    set ns [info object namespace [uplevel 1 {self class}]]\n"
"    # Double up the list of variable names\n"
"    foreach v [list $name {*}$args] {\n"
"        if {[string match *(*) $v]} {\n"
"            return -code error [string cat {bad variable name \"} $v {\": can\'t create a scalar variable that looks like an array element}]\n"
"        }\n"
"        if {[string match *::* $v]} {\n"
"            return -code error [string cat {bad variable name \"} $v {\": can\'t create a local variable with a namespace separator in it}]\n"
"        }\n"
"        lappend vs $v $v\n"
"    }\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"
"        if {[llength $link] == 2} {\n"
"            lassign $link src dst\n"
"        } else {\n"
"            lassign $link src\n"
................................................................................
"    return\n"
"}\n"
"::proc ::oo::Helpers::Unlink {cmd args} {\n"
"    if {[namespace which $cmd] ne {}} {\n"
"        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"
"    }\n"
"    set delegate [::oo::DelegateName $class]\n"
"    if {![info object isa class $delegate]} {\n"
"        return\n"
"    }\n"
"    foreach c [info class superclass $class] {\n"
"        set d [::oo::DelegateName $c]\n"
"        if {![info object isa class $d]} {\n"
"            continue\n"
"        }\n"
"        ::oo::define $delegate superclass -append $d\n"
"    }\n"
"    ::oo::objdefine $class mixin -append $delegate\n"
"}\n"

"\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 \"} \\\n"
"                    [::lindex [::info level 0] 0] { name \?args body\?\"}]\n"
"        }\n"
"        ::set cls [::uplevel 1 self]\n"
"        ::if {$argc == 4} {\n"
"            ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
"        }\n"
"        # 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"
"    ::rename ::oo::define::tmp::initialise initialize\n"
"    ::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"
"        tailcall my Set [list {*}$current {*}$args]\n"
"    }\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"
"            tailcall my $def\n"
"        } elseif {![string match -* [lindex $args 0]]} {\n"
"            tailcall my $def {*}$args\n"
"        }\n"
"        next {*}$args\n"
"    }\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"
"\n"
"::oo::define ::oo::class method <cloned> {originObject} {\n"
"    next $originObject\n"
"    # Rebuild the class inheritance delegation class\n"
"    set originDelegate [::oo::DelegateName $originObject]\n"
"    set targetDelegate [::oo::DelegateName [self]]\n"
"    if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {\n"
"        ::oo::copy $originDelegate $targetDelegate\n"
"        ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {\n"
"            if {$c eq $originDelegate} {set targetDelegate} {set c}\n"
"        }]\n"
"    }\n"
"}\n"
"\n"
"::oo::class create ::oo::singleton {\n"
"    superclass ::oo::class\n"
"    variable object\n"
"    unexport create createWithNamespace\n"
"    method new args {\n"
"        if {![info exists object] || ![info object isa object $object]} {\n"
"            set object [next {*}$args]\n"
................................................................................
"            ::oo::objdefine $object method <cloned> {originObject} {\n"
"                return -code error {may not clone a singleton object}\n"
"            }\n"
"        }\n"
"        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. */
;

/*
 * The body of the <cloned> method of oo::object.
 */

static const char *clonedBody =

Added generic/tclOOScript.tcl.














































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
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:

Added tools/makeHeader.tcl.








































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
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:

Changes to unix/Makefile.in.

1891
1892
1893
1894
1895
1896
1897





1898
1899
1900
1901
1902
1903
1904




1905
1906
1907
1908
1909
1910
1911
	@echo "This warning can be safely ignored, do not report as a bug!"

$(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls
	@echo "Warning: tclOOStubInit.c may be out of date."
	@echo "Developers may want to run \"make genstubs\" 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 \
		$(GENERIC_DIR)/tclTomMath.decls
	$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
		$(GENERIC_DIR)/tclOO.decls





#
# Target to check that all exported functions have an entry in the stubs
# tables.
#

checkstubs: $(TCL_LIB_FILE)
	[email protected] i in `nm -p $(TCL_LIB_FILE) \






>
>
>
>
>







>
>
>
>







1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
	@echo "This warning can be safely ignored, do not report as a bug!"

$(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls
	@echo "Warning: tclOOStubInit.c may be out of date."
	@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 \
		$(GENERIC_DIR)/tclTomMath.decls
	$(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.
#

checkstubs: $(TCL_LIB_FILE)
	[email protected] i in `nm -p $(TCL_LIB_FILE) \