Code

Merge branch 'rs/optim-text-wrap' into maint
[git.git] / git-gui / lib / class.tcl
1 # git-gui simple class/object fake-alike
2 # Copyright (C) 2007 Shawn Pearce
4 proc class {class body} {
5         if {[namespace exists $class]} {
6                 error "class $class already declared"
7         }
8         namespace eval $class "
9                 variable __nextid     0
10                 variable __sealed     0
11                 variable __field_list {}
12                 variable __field_array
14                 proc cb {name args} {
15                         upvar this this
16                         concat \[list ${class}::\$name \$this\] \$args
17                 }
18         "
19         namespace eval $class $body
20 }
22 proc field {name args} {
23         set class [uplevel {namespace current}]
24         variable ${class}::__sealed
25         variable ${class}::__field_array
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         }
33         if {$__sealed} {
34                 error "class $class is sealed (cannot add new fields)"
35         }
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 }
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 {}
52         append mbodyc {set this } $class
53         append mbodyc {::__o[incr } $class {::__nextid]::__d} \;
54         append mbodyc {create_this } $class \;
55         append mbodyc {set __this [namespace qualifiers $this]} \;
57         if {$__field_list ne {}} {
58                 append mbodyc {upvar #0}
59                 foreach n $__field_list {
60                         set n [lindex $n 0]
61                         append mbodyc { ${__this}::} $n { } $n
62                         regsub -all @$n\\M $body "\${__this}::$n" body
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 }
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 {}
83         append mbodyc {set __this [namespace qualifiers $this]} \;
85         switch $deleted {
86         {} {}
87         ifdeleted {
88                 append mbodyc {if {![namespace exists $__this]} }
89                 append mbodyc \{ $del_body \; return \} \;
90         }
91         default {
92                 error "wrong # args: method name args body (ifdeleted body)?"
93         }
94         }
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
101                                 && [regexp -all -- \\\$$n\\M $body] == 1
102                                 && [regexp -all -- \\\$$n\\( $body] == 0} {
103                                 regsub -all \
104                                         \\\$$n\\M $body \
105                                         "\[set \${__this}::$n\]" body
106                         } else {
107                                 append decl { ${__this}::} $n { } $n
108                                 regsub -all @$n\\M $body "\${__this}::$n" body
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]
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         ]
128 proc delete_this {{t {}}} {
129         if {$t eq {}} {
130                 upvar this this
131                 set t $this
132         }
133         set t [namespace qualifiers $t]
134         if {[namespace exists $t]} {namespace delete $t}
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]
141         pave_toplevel $pfx
144 proc make_toplevel {t w args} {
145         upvar $t top $w pfx this this
147         if {[llength $args] % 2} {
148                 error "make_toplevel topvar winvar {options}"
149         }
150         set autodelete 1
151         foreach {name value} $args {
152                 switch -exact -- $name {
153                 -autodelete {set autodelete $value}
154                 default     {error "unsupported option $name"}
155                 }
156         }
158         if {$::root_exists || [winfo ismapped .]} {
159                 regsub -all {::} $this {__} w
160                 set top .$w
161                 set pfx $top
162                 toplevel $top
163                 set ::root_exists 1
164         } else {
165                 set top .
166                 set pfx {}
167         }
169         if {$autodelete} {
170                 wm protocol $top WM_DELETE_WINDOW "
171                         [list delete_this $this]
172                         [list destroy $top]
173                 "
174         }
178 ## auto_mkindex support for class/constructor/method
179 ##
180 auto_mkindex_parser::command class {name body} {
181         variable parser
182         variable contextStack
183         set contextStack [linsert $contextStack 0 $name]
184         $parser eval [list _%@namespace eval $name] $body
185         set contextStack [lrange $contextStack 1 end]
187 auto_mkindex_parser::command constructor {name args} {
188         variable index
189         variable scriptFile
190         append index [list set auto_index([fullname $name])] \
191                 [format { [list source [file join $dir %s]]} \
192                 [file split $scriptFile]] "\n"