Merge branch 'ep/cvstag'
[git] / git-gui / lib / class.tcl
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         }
8         namespace eval $class {
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
16                         set args [linsert $args 0 $name $this]
17                         return [uplevel [list namespace code $args]]
18                 }
19         }
20         namespace eval $class $body
21 }
22
23 proc field {name args} {
24         set class [uplevel {namespace current}]
25         variable ${class}::__sealed
26         variable ${class}::__field_array
27
28         switch [llength $args] {
29         0 { set new [list $name] }
30         1 { set new [list $name [lindex $args 0]] }
31         default { error "wrong # args: field name value?" }
32         }
33
34         if {$__sealed} {
35                 error "class $class is sealed (cannot add new fields)"
36         }
37
38         if {[catch {set old $__field_array($name)}]} {
39                 variable ${class}::__field_list
40                 lappend __field_list $new
41                 set __field_array($name) 1
42         } else {
43                 error "field $name already declared"
44         }
45 }
46
47 proc constructor {name params body} {
48         set class [uplevel {namespace current}]
49         set ${class}::__sealed 1
50         variable ${class}::__field_list
51         set mbodyc {}
52
53         append mbodyc {set this } $class
54         append mbodyc {::__o[incr } $class {::__nextid]} \;
55         append mbodyc {namespace eval $this {}} \;
56
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 }
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
83         switch $deleted {
84         {} {}
85         ifdeleted {
86                 append mbodyc {if {![namespace exists $this]} }
87                 append mbodyc \{ $del_body \; return \} \;
88         }
89         default {
90                 error "wrong # args: method name args body (ifdeleted body)?"
91         }
92         }
93
94         set decl {}
95         foreach n $__field_list {
96                 set n [lindex $n 0]
97                 if {[regexp -- $n\\M $body]} {
98                         if {   [regexp -all -- $n\\M $body] == 1
99                                 && [regexp -all -- \\\$$n\\M $body] == 1
100                                 && [regexp -all -- \\\$$n\\( $body] == 0} {
101                                 regsub -all \\\$$n\\M $body "\[set \${this}::$n\]" body
102                         } else {
103                                 append decl { ${this}::} $n { } $n
104                                 regsub -all @$n\\M $body "\${this}::$n" body
105                         }
106                 }
107         }
108         if {$decl ne {}} {
109                 append mbodyc {upvar #0} $decl \;
110         }
111         append mbodyc $body
112         namespace eval $class [list proc $name $params $mbodyc]
113 }
114
115 proc delete_this {{t {}}} {
116         if {$t eq {}} {
117                 upvar this this
118                 set t $this
119         }
120         if {[namespace exists $t]} {namespace delete $t}
121 }
122
123 proc make_toplevel {t w args} {
124         upvar $t top $w pfx this this
125
126         if {[llength $args] % 2} {
127                 error "make_toplevel topvar winvar {options}"
128         }
129         set autodelete 1
130         foreach {name value} $args {
131                 switch -exact -- $name {
132                 -autodelete {set autodelete $value}
133                 default     {error "unsupported option $name"}
134                 }
135         }
136
137         if {[winfo ismapped .]} {
138                 regsub -all {::} $this {__} w
139                 set top .$w
140                 set pfx $top
141                 toplevel $top
142         } else {
143                 set top .
144                 set pfx {}
145         }
146
147         if {$autodelete} {
148                 wm protocol $top WM_DELETE_WINDOW "
149                         [list delete_this $this]
150                         [list destroy $top]
151                 "
152         }
153 }
154
155
156 ## auto_mkindex support for class/constructor/method
157 ##
158 auto_mkindex_parser::command class {name body} {
159         variable parser
160         variable contextStack
161         set contextStack [linsert $contextStack 0 $name]
162         $parser eval [list _%@namespace eval $name] $body
163         set contextStack [lrange $contextStack 1 end]
164 }
165 auto_mkindex_parser::command constructor {name args} {
166         variable index
167         variable scriptFile
168         append index [list set auto_index([fullname $name])] \
169                 [format { [list source [file join $dir %s]]} \
170                 [file split $scriptFile]] "\n"
171 }