blob: f7b023ecfe9453adac0dc4ed877f2bc28fe6f821 (
plain)
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
|
/*
* 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.
*/
#ifndef TCL_OO_SCRIPT_H
#define TCL_OO_SCRIPT_H
/*
* The scripted part of the definitions of TclOO.
*
* Compiled from tools/tclOOScript.tcl by tools/makeHeader.tcl, which
* contains the commented version of everything; *this* file is automatically
* generated.
*/
static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
"::namespace eval ::oo {\n"
"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
"\t\tset originDelegate [DelegateName $originObject]\n"
"\t\tset targetDelegate [DelegateName $targetObject]\n"
"\t\tif {\n"
"\t\t\t[info object isa class $originDelegate]\n"
"\t\t\t&& ![info object isa class $targetDelegate]\n"
"\t\t} then {\n"
"\t\t\tcopy $originDelegate $targetDelegate\n"
"\t\t\tobjdefine $targetObject ::oo::objdefine::mixin -set \\\n"
"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
"\t\t\t\t}]\n"
"\t\t}\n"
"\t}\n"
"\tproc define::classmethod {name args} {\n"
"\t\t::set argc [::llength [::info level 0]]\n"
"\t\t::if {$argc == 3} {\n"
"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
"\t\t\t\t[::lindex [::info level 0] 0]]\n"
"\t\t}\n"
"\t\t::set cls [::uplevel 1 self]\n"
"\t\t::if {$argc == 4} {\n"
"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n"
"\t\t}\n"
"\t\t::tailcall forward $name myclass $name\n"
"\t}\n"
"\tdefine Slot forward --default-operation my -append\n"
"\tdefine Slot unexport destroy\n"
"\tobjdefine define::superclass forward --default-operation my -set\n"
"\tobjdefine define::mixin forward --default-operation my -set\n"
"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
"\tdefine object method <cloned> -unexport {originObject} {\n"
"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
"\t\t\tset args [info args $p]\n"
"\t\t\tset idx -1\n"
"\t\t\tforeach a $args {\n"
"\t\t\t\tif {[info default $p $a d]} {\n"
"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\tlset args [incr idx] [list $a]\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\tset b [info body $p]\n"
"\t\t\tset p [namespace tail $p]\n"
"\t\t\tproc $p $args $b\n"
"\t\t}\n"
"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
"\t\t\tupvar 0 $v vOrigin\n"
"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
"\t\t\tif {[info exists vOrigin]} {\n"
"\t\t\t\tif {[array exists vOrigin]} {\n"
"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\tset vNew $vOrigin\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t}\n"
"\tdefine class method <cloned> -unexport {originObject} {\n"
"\t\tnext $originObject\n"
"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
"\t}\n"
"\tclass create singleton\n"
"\tdefine singleton superclass -set class\n"
"\tdefine singleton variable -set object\n"
"\tdefine singleton unexport create createWithNamespace\n"
"\tdefine singleton method new args {\n"
"\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\tset object [next {*}$args]\n"
"\t\t\t::oo::objdefine $object {\n"
"\t\t\t\tmethod destroy {} {\n"
"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
"\t\t\t\t}\n"
"\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\t\t\t\"may not clone a singleton object\"\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t\treturn $object\n"
"\t}\n"
"\tclass create abstract\n"
"\tdefine abstract superclass -set class\n"
"\tdefine abstract unexport create createWithNamespace new\n"
"\tnamespace eval configuresupport::configurableclass {\n"
"\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t::namespace path ::oo::define\n"
"\t\t::namespace export property\n"
"\t}\n"
"\tnamespace eval configuresupport::configurableobject {\n"
"\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t::namespace path ::oo::objdefine\n"
"\t\t::namespace export property\n"
"\t}\n"
"\tdefine configuresupport::configurable {\n"
"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n"
"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
"\t}\n"
"\tclass create configurable\n"
"\tdefine configurable superclass -set class\n"
"\tdefine configurable constructor {{definitionScript \"\"}} {\n"
"\t\tnext {mixin ::oo::configuresupport::configurable}\n"
"\t\tnext $definitionScript\n"
"\t}\n"
"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"
"}\n"
/* !END!: Do not edit above this line. */
;
#endif /* TCL_OO_SCRIPT_H */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
