git-gui: allow Ctrl+T to toggle multiple paths
[git/git.git] / lib / class.tcl
CommitLineData
1f07c4e5
SP
1# git-gui simple class/object fake-alike
2# Copyright (C) 2007 Shawn Pearce
3
4proc 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
22proc 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
46proc 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
76proc 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
119proc 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
128proc 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
137proc 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
145proc 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##
181auto_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}
188auto_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}