]>
Commit | Line | Data |
---|---|---|
1f07c4e5 SP |
1 | # git-gui simple class/object fake-alike |
2 | # Copyright (C) 2007 Shawn Pearce | |
3 | ||
4 | proc class {class body} { | |
5 | if {[namespace exists $class]} { | |
6 | error "class $class already declared" | |
7 | } | |
6233ab17 | 8 | namespace eval $class " |
1f07c4e5 SP |
9 | variable __nextid 0 |
10 | variable __sealed 0 | |
11 | variable __field_list {} | |
12 | variable __field_array | |
13 | ||
14 | proc cb {name args} { | |
15 | upvar this this | |
6233ab17 | 16 | concat \[list ${class}::\$name \$this\] \$args |
1f07c4e5 | 17 | } |
6233ab17 | 18 | " |
1f07c4e5 SP |
19 | namespace eval $class $body |
20 | } | |
21 | ||
22 | proc field {name args} { | |
23 | set class [uplevel {namespace current}] | |
24 | variable ${class}::__sealed | |
25 | variable ${class}::__field_array | |
26 | ||
27 | switch [llength $args] { | |
28 | 0 { set new [list $name] } | |
29 | 1 { set new [list $name [lindex $args 0]] } | |
30 | default { error "wrong # args: field name value?" } | |
31 | } | |
32 | ||
33 | if {$__sealed} { | |
34 | error "class $class is sealed (cannot add new fields)" | |
35 | } | |
36 | ||
37 | if {[catch {set old $__field_array($name)}]} { | |
38 | variable ${class}::__field_list | |
39 | lappend __field_list $new | |
40 | set __field_array($name) 1 | |
41 | } else { | |
42 | error "field $name already declared" | |
43 | } | |
44 | } | |
45 | ||
46 | proc constructor {name params body} { | |
47 | set class [uplevel {namespace current}] | |
48 | set ${class}::__sealed 1 | |
49 | variable ${class}::__field_list | |
50 | set mbodyc {} | |
51 | ||
52 | append mbodyc {set this } $class | |
6233ab17 SP |
53 | append mbodyc {::__o[incr } $class {::__nextid]::__d} \; |
54 | append mbodyc {create_this } $class \; | |
55 | append mbodyc {set __this [namespace qualifiers $this]} \; | |
1f07c4e5 SP |
56 | |
57 | if {$__field_list ne {}} { | |
58 | append mbodyc {upvar #0} | |
59 | foreach n $__field_list { | |
60 | set n [lindex $n 0] | |
6233ab17 SP |
61 | append mbodyc { ${__this}::} $n { } $n |
62 | regsub -all @$n\\M $body "\${__this}::$n" body | |
1f07c4e5 SP |
63 | } |
64 | append mbodyc \; | |
65 | foreach n $__field_list { | |
66 | if {[llength $n] == 2} { | |
67 | append mbodyc \ | |
68 | {set } [lindex $n 0] { } [list [lindex $n 1]] \; | |
69 | } | |
70 | } | |
71 | } | |
72 | append mbodyc $body | |
73 | namespace eval $class [list proc $name $params $mbodyc] | |
74 | } | |
75 | ||
76 | proc method {name params body {deleted {}} {del_body {}}} { | |
77 | set class [uplevel {namespace current}] | |
78 | set ${class}::__sealed 1 | |
79 | variable ${class}::__field_list | |
80 | set params [linsert $params 0 this] | |
81 | set mbodyc {} | |
82 | ||
6233ab17 SP |
83 | append mbodyc {set __this [namespace qualifiers $this]} \; |
84 | ||
1f07c4e5 SP |
85 | switch $deleted { |
86 | {} {} | |
87 | ifdeleted { | |
6233ab17 | 88 | append mbodyc {if {![namespace exists $__this]} } |
1f07c4e5 SP |
89 | append mbodyc \{ $del_body \; return \} \; |
90 | } | |
91 | default { | |
92 | error "wrong # args: method name args body (ifdeleted body)?" | |
93 | } | |
94 | } | |
95 | ||
96 | set decl {} | |
97 | foreach n $__field_list { | |
98 | set n [lindex $n 0] | |
99 | if {[regexp -- $n\\M $body]} { | |
100 | if { [regexp -all -- $n\\M $body] == 1 | |
28bf928c SP |
101 | && [regexp -all -- \\\$$n\\M $body] == 1 |
102 | && [regexp -all -- \\\$$n\\( $body] == 0} { | |
6233ab17 SP |
103 | regsub -all \ |
104 | \\\$$n\\M $body \ | |
105 | "\[set \${__this}::$n\]" body | |
1f07c4e5 | 106 | } else { |
6233ab17 SP |
107 | append decl { ${__this}::} $n { } $n |
108 | regsub -all @$n\\M $body "\${__this}::$n" body | |
1f07c4e5 SP |
109 | } |
110 | } | |
111 | } | |
112 | if {$decl ne {}} { | |
113 | append mbodyc {upvar #0} $decl \; | |
114 | } | |
115 | append mbodyc $body | |
116 | namespace eval $class [list proc $name $params $mbodyc] | |
117 | } | |
118 | ||
6233ab17 SP |
119 | proc create_this {class} { |
120 | upvar this this | |
121 | namespace eval [namespace qualifiers $this] [list proc \ | |
122 | [namespace tail $this] \ | |
123 | [list name args] \ | |
124 | "eval \[list ${class}::\$name $this\] \$args" \ | |
125 | ] | |
126 | } | |
127 | ||
1f07c4e5 SP |
128 | proc delete_this {{t {}}} { |
129 | if {$t eq {}} { | |
130 | upvar this this | |
131 | set t $this | |
132 | } | |
6233ab17 | 133 | set t [namespace qualifiers $t] |
1f07c4e5 SP |
134 | if {[namespace exists $t]} {namespace delete $t} |
135 | } | |
136 | ||
c80d7be5 PT |
137 | proc make_dialog {t w args} { |
138 | upvar $t top $w pfx this this | |
139 | global use_ttk | |
140 | uplevel [linsert $args 0 make_toplevel $t $w] | |
508dee31 | 141 | catch {wm attributes $top -type dialog} |
c80d7be5 PT |
142 | pave_toplevel $pfx |
143 | } | |
144 | ||
39fa2a98 SP |
145 | proc make_toplevel {t w args} { |
146 | upvar $t top $w pfx this this | |
147 | ||
148 | if {[llength $args] % 2} { | |
149 | error "make_toplevel topvar winvar {options}" | |
150 | } | |
151 | set autodelete 1 | |
152 | foreach {name value} $args { | |
153 | switch -exact -- $name { | |
154 | -autodelete {set autodelete $value} | |
155 | default {error "unsupported option $name"} | |
156 | } | |
157 | } | |
158 | ||
c6951ddb | 159 | if {$::root_exists || [winfo ismapped .]} { |
1f07c4e5 SP |
160 | regsub -all {::} $this {__} w |
161 | set top .$w | |
162 | set pfx $top | |
163 | toplevel $top | |
c6951ddb | 164 | set ::root_exists 1 |
1f07c4e5 SP |
165 | } else { |
166 | set top . | |
167 | set pfx {} | |
168 | } | |
39fa2a98 SP |
169 | |
170 | if {$autodelete} { | |
171 | wm protocol $top WM_DELETE_WINDOW " | |
172 | [list delete_this $this] | |
173 | [list destroy $top] | |
174 | " | |
175 | } | |
1f07c4e5 SP |
176 | } |
177 | ||
178 | ||
179 | ## auto_mkindex support for class/constructor/method | |
180 | ## | |
181 | auto_mkindex_parser::command class {name body} { | |
182 | variable parser | |
183 | variable contextStack | |
184 | set contextStack [linsert $contextStack 0 $name] | |
185 | $parser eval [list _%@namespace eval $name] $body | |
186 | set contextStack [lrange $contextStack 1 end] | |
187 | } | |
188 | auto_mkindex_parser::command constructor {name args} { | |
189 | variable index | |
190 | variable scriptFile | |
191 | append index [list set auto_index([fullname $name])] \ | |
192 | [format { [list source [file join $dir %s]]} \ | |
193 | [file split $scriptFile]] "\n" | |
194 | } |