2007-05-09 01:54:05 +02:00
|
|
|
# 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"
|
|
|
|
}
|
2007-06-30 10:34:59 +02:00
|
|
|
namespace eval $class "
|
2007-05-09 01:54:05 +02:00
|
|
|
variable __nextid 0
|
|
|
|
variable __sealed 0
|
|
|
|
variable __field_list {}
|
|
|
|
variable __field_array
|
|
|
|
|
|
|
|
proc cb {name args} {
|
|
|
|
upvar this this
|
2007-06-30 10:34:59 +02:00
|
|
|
concat \[list ${class}::\$name \$this\] \$args
|
2007-05-09 01:54:05 +02:00
|
|
|
}
|
2007-06-30 10:34:59 +02:00
|
|
|
"
|
2007-05-09 01:54:05 +02:00
|
|
|
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
|
2007-06-30 10:34:59 +02:00
|
|
|
append mbodyc {::__o[incr } $class {::__nextid]::__d} \;
|
|
|
|
append mbodyc {create_this } $class \;
|
|
|
|
append mbodyc {set __this [namespace qualifiers $this]} \;
|
2007-05-09 01:54:05 +02:00
|
|
|
|
|
|
|
if {$__field_list ne {}} {
|
|
|
|
append mbodyc {upvar #0}
|
|
|
|
foreach n $__field_list {
|
|
|
|
set n [lindex $n 0]
|
2007-06-30 10:34:59 +02:00
|
|
|
append mbodyc { ${__this}::} $n { } $n
|
|
|
|
regsub -all @$n\\M $body "\${__this}::$n" body
|
2007-05-09 01:54:05 +02:00
|
|
|
}
|
|
|
|
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 {}
|
|
|
|
|
2007-06-30 10:34:59 +02:00
|
|
|
append mbodyc {set __this [namespace qualifiers $this]} \;
|
|
|
|
|
2007-05-09 01:54:05 +02:00
|
|
|
switch $deleted {
|
|
|
|
{} {}
|
|
|
|
ifdeleted {
|
2007-06-30 10:34:59 +02:00
|
|
|
append mbodyc {if {![namespace exists $__this]} }
|
2007-05-09 01:54:05 +02:00
|
|
|
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
|
2007-05-09 03:31:31 +02:00
|
|
|
&& [regexp -all -- \\\$$n\\M $body] == 1
|
|
|
|
&& [regexp -all -- \\\$$n\\( $body] == 0} {
|
2007-06-30 10:34:59 +02:00
|
|
|
regsub -all \
|
|
|
|
\\\$$n\\M $body \
|
|
|
|
"\[set \${__this}::$n\]" body
|
2007-05-09 01:54:05 +02:00
|
|
|
} else {
|
2007-06-30 10:34:59 +02:00
|
|
|
append decl { ${__this}::} $n { } $n
|
|
|
|
regsub -all @$n\\M $body "\${__this}::$n" body
|
2007-05-09 01:54:05 +02:00
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
if {$decl ne {}} {
|
|
|
|
append mbodyc {upvar #0} $decl \;
|
|
|
|
}
|
|
|
|
append mbodyc $body
|
|
|
|
namespace eval $class [list proc $name $params $mbodyc]
|
|
|
|
}
|
|
|
|
|
2007-06-30 10:34:59 +02:00
|
|
|
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" \
|
|
|
|
]
|
|
|
|
}
|
|
|
|
|
2007-05-09 01:54:05 +02:00
|
|
|
proc delete_this {{t {}}} {
|
|
|
|
if {$t eq {}} {
|
|
|
|
upvar this this
|
|
|
|
set t $this
|
|
|
|
}
|
2007-06-30 10:34:59 +02:00
|
|
|
set t [namespace qualifiers $t]
|
2007-05-09 01:54:05 +02:00
|
|
|
if {[namespace exists $t]} {namespace delete $t}
|
|
|
|
}
|
|
|
|
|
2010-01-26 01:05:31 +01:00
|
|
|
proc make_dialog {t w args} {
|
|
|
|
upvar $t top $w pfx this this
|
|
|
|
global use_ttk
|
|
|
|
uplevel [linsert $args 0 make_toplevel $t $w]
|
2011-10-19 15:26:29 +02:00
|
|
|
catch {wm attributes $top -type dialog}
|
2010-01-26 01:05:31 +01:00
|
|
|
pave_toplevel $pfx
|
|
|
|
}
|
|
|
|
|
2007-06-12 05:52:43 +02:00
|
|
|
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"}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2007-08-20 06:53:04 +02:00
|
|
|
if {$::root_exists || [winfo ismapped .]} {
|
2007-05-09 01:54:05 +02:00
|
|
|
regsub -all {::} $this {__} w
|
|
|
|
set top .$w
|
|
|
|
set pfx $top
|
|
|
|
toplevel $top
|
2007-08-20 06:53:04 +02:00
|
|
|
set ::root_exists 1
|
2007-05-09 01:54:05 +02:00
|
|
|
} else {
|
|
|
|
set top .
|
|
|
|
set pfx {}
|
|
|
|
}
|
2007-06-12 05:52:43 +02:00
|
|
|
|
|
|
|
if {$autodelete} {
|
|
|
|
wm protocol $top WM_DELETE_WINDOW "
|
|
|
|
[list delete_this $this]
|
|
|
|
[list destroy $top]
|
|
|
|
"
|
|
|
|
}
|
2007-05-09 01:54:05 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
## 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"
|
|
|
|
}
|