mirror of
https://github.com/git/git
synced 2024-10-31 08:44:08 +00:00
508dee31f3
This patch uses recent Tk attributes support to specify the intended use of new toplevels by setting the correct EWMH hint. This helps modern window managers to apply sensible decoration for the tooltip and dialogs. Signed-off-by: Pat Thoyts <patthoyts@users.sourceforge.net>
194 lines
4.4 KiB
Tcl
194 lines
4.4 KiB
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"
|
|
}
|