| 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 | concat \[list ${class}::\$name \$this\] \$args |
| 17 | } |
| 18 | " |
| 19 | namespace eval $class $body |
| 20 | } |
| 21 | |
| 22 | proc 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 | |
| 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 {} |
| 51 | |
| 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]} \; |
| 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 | append mbodyc {set __this [namespace qualifiers $this]} \; |
| 84 | |
| 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 | } |
| 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 |
| 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] |
| 117 | } |
| 118 | |
| 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 | ] |
| 126 | } |
| 127 | |
| 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} |
| 135 | } |
| 136 | |
| 137 | proc make_dialog {t w args} { |
| 138 | upvar $t top $w pfx this this |
| 139 | uplevel [linsert $args 0 make_toplevel $t $w] |
| 140 | catch {wm attributes $top -type dialog} |
| 141 | pave_toplevel $pfx |
| 142 | } |
| 143 | |
| 144 | proc make_toplevel {t w args} { |
| 145 | upvar $t top $w pfx this this |
| 146 | |
| 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 | } |
| 157 | |
| 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 | } |
| 168 | |
| 169 | if {$autodelete} { |
| 170 | wm protocol $top WM_DELETE_WINDOW " |
| 171 | [list delete_this $this] |
| 172 | [list destroy $top] |
| 173 | " |
| 174 | } |
| 175 | } |
| 176 | |
| 177 | |
| 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] |
| 186 | } |
| 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" |
| 193 | } |