blob: 51a8a5634bb0116f4e29787e00e0bf64a0e8c5b9 (
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
|
/*
* 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:
*/
|
