]>
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 | } | |
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 | |
28bf928c SP |
99 | && [regexp -all -- \\\$$n\\M $body] == 1 |
100 | && [regexp -all -- \\\$$n\\( $body] == 0} { | |
1f07c4e5 SP |
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 | } |