https://github.com/git/git
Tip revision: ca00f80b58d679e59fc271650f68cd25cdb72b09 authored by Junio C Hamano on 27 July 2015, 19:25:42 UTC
Git 2.4.7
Git 2.4.7
Tip revision: ca00f80
class.tcl
# git-gui simple class/object fake-alike
# Copyright (C) 2007 Shawn Pearce
proc class {class body} {
if {[namespace exists $class]} {
error "class $class already declared"
}
namespace eval $class "
variable __nextid 0
variable __sealed 0
variable __field_list {}
variable __field_array
proc cb {name args} {
upvar this this
concat \[list ${class}::\$name \$this\] \$args
}
"
namespace eval $class $body
}
proc field {name args} {
set class [uplevel {namespace current}]
variable ${class}::__sealed
variable ${class}::__field_array
switch [llength $args] {
0 { set new [list $name] }
1 { set new [list $name [lindex $args 0]] }
default { error "wrong # args: field name value?" }
}
if {$__sealed} {
error "class $class is sealed (cannot add new fields)"
}
if {[catch {set old $__field_array($name)}]} {
variable ${class}::__field_list
lappend __field_list $new
set __field_array($name) 1
} else {
error "field $name already declared"
}
}
proc constructor {name params body} {
set class [uplevel {namespace current}]
set ${class}::__sealed 1
variable ${class}::__field_list
set mbodyc {}
append mbodyc {set this } $class
append mbodyc {::__o[incr } $class {::__nextid]::__d} \;
append mbodyc {create_this } $class \;
append mbodyc {set __this [namespace qualifiers $this]} \;
if {$__field_list ne {}} {
append mbodyc {upvar #0}
foreach n $__field_list {
set n [lindex $n 0]
append mbodyc { ${__this}::} $n { } $n
regsub -all @$n\\M $body "\${__this}::$n" body
}
append mbodyc \;
foreach n $__field_list {
if {[llength $n] == 2} {
append mbodyc \
{set } [lindex $n 0] { } [list [lindex $n 1]] \;
}
}
}
append mbodyc $body
namespace eval $class [list proc $name $params $mbodyc]
}
proc method {name params body {deleted {}} {del_body {}}} {
set class [uplevel {namespace current}]
set ${class}::__sealed 1
variable ${class}::__field_list
set params [linsert $params 0 this]
set mbodyc {}
append mbodyc {set __this [namespace qualifiers $this]} \;
switch $deleted {
{} {}
ifdeleted {
append mbodyc {if {![namespace exists $__this]} }
append mbodyc \{ $del_body \; return \} \;
}
default {
error "wrong # args: method name args body (ifdeleted body)?"
}
}
set decl {}
foreach n $__field_list {
set n [lindex $n 0]
if {[regexp -- $n\\M $body]} {
if { [regexp -all -- $n\\M $body] == 1
&& [regexp -all -- \\\$$n\\M $body] == 1
&& [regexp -all -- \\\$$n\\( $body] == 0} {
regsub -all \
\\\$$n\\M $body \
"\[set \${__this}::$n\]" body
} else {
append decl { ${__this}::} $n { } $n
regsub -all @$n\\M $body "\${__this}::$n" body
}
}
}
if {$decl ne {}} {
append mbodyc {upvar #0} $decl \;
}
append mbodyc $body
namespace eval $class [list proc $name $params $mbodyc]
}
proc create_this {class} {
upvar this this
namespace eval [namespace qualifiers $this] [list proc \
[namespace tail $this] \
[list name args] \
"eval \[list ${class}::\$name $this\] \$args" \
]
}
proc delete_this {{t {}}} {
if {$t eq {}} {
upvar this this
set t $this
}
set t [namespace qualifiers $t]
if {[namespace exists $t]} {namespace delete $t}
}
proc make_dialog {t w args} {
upvar $t top $w pfx this this
global use_ttk
uplevel [linsert $args 0 make_toplevel $t $w]
catch {wm attributes $top -type dialog}
pave_toplevel $pfx
}
proc make_toplevel {t w args} {
upvar $t top $w pfx this this
if {[llength $args] % 2} {
error "make_toplevel topvar winvar {options}"
}
set autodelete 1
foreach {name value} $args {
switch -exact -- $name {
-autodelete {set autodelete $value}
default {error "unsupported option $name"}
}
}
if {$::root_exists || [winfo ismapped .]} {
regsub -all {::} $this {__} w
set top .$w
set pfx $top
toplevel $top
set ::root_exists 1
} else {
set top .
set pfx {}
}
if {$autodelete} {
wm protocol $top WM_DELETE_WINDOW "
[list delete_this $this]
[list destroy $top]
"
}
}
## auto_mkindex support for class/constructor/method
##
auto_mkindex_parser::command class {name body} {
variable parser
variable contextStack
set contextStack [linsert $contextStack 0 $name]
$parser eval [list _%@namespace eval $name] $body
set contextStack [lrange $contextStack 1 end]
}
auto_mkindex_parser::command constructor {name args} {
variable index
variable scriptFile
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
}