Merge 1.5.1.5 in
[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} {
124         upvar $t top $w pfx
125         if {[winfo ismapped .]} {
126                 upvar this this
127                 regsub -all {::} $this {__} w
128                 set top .$w
129                 set pfx $top
130                 toplevel $top
131         } else {
132                 set top .
133                 set pfx {}
134         }
135 }
136
137
138 ## auto_mkindex support for class/constructor/method
139 ##
140 auto_mkindex_parser::command class {name body} {
141         variable parser
142         variable contextStack
143         set contextStack [linsert $contextStack 0 $name]
144         $parser eval [list _%@namespace eval $name] $body
145         set contextStack [lrange $contextStack 1 end]
146 }
147 auto_mkindex_parser::command constructor {name args} {
148         variable index
149         variable scriptFile
150         append index [list set auto_index([fullname $name])] \
151                 [format { [list source [file join $dir %s]]} \
152                 [file split $scriptFile]] "\n"
153 }
154