From 5b8b2aba52cd1aa06eb66bbc336a9ce97a61bbf6 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Thu, 25 Feb 2010 11:07:45 +0000 Subject: [PATCH] Rearrange startup to make gitk reloadable for development and testing. This patch moves the startup code into procedures so that the script can be re-sourced during interactive development. This also permits the script to be loaded as a library to permit unit-testing of gitk functions. In the global namespace where gitk lives, variable and global are equivalent commands except that variable can assign a value when initializing the global variable while global just declares a name in the global table. Signed-off-by: Pat Thoyts --- gitk | 683 +++++++++++++++++++++++++++++++---------------------------- 1 file changed, 365 insertions(+), 318 deletions(-) diff --git a/gitk b/gitk index 1f36a3e..7f573e0 100755 --- a/gitk +++ b/gitk @@ -7,8 +7,6 @@ exec wish "$0" -- "$@" # and distributed under the terms of the GNU General Public Licence, # either version 2, or (at your option) any later version. -package require Tk - proc gitdir {} { global env if {[info exists env(GIT_DIR)]} { @@ -3085,6 +3083,7 @@ proc setfilelist {id} { } } +proc create_bitmaps {} { image create bitmap tri-rt -background black -foreground blue -data { #define tri-rt_width 13 #define tri-rt_height 13 @@ -3147,6 +3146,7 @@ image create bitmap reficon-H -background black -foreground green \ -data $rectdata -maskdata $rectmask image create bitmap reficon-o -background black -foreground "#ddddff" \ -data $rectdata -maskdata $rectmask +} proc init_flist {first} { global cflist cflist_top difffilestart @@ -10634,9 +10634,10 @@ proc fontcan {} { } } -if {[package vsatisfies [package provide Tk] 8.6]} { +proc init_font_chooser {} { # In Tk 8.6 we have a native font chooser dialog. Overwrite the above # function to make use of it. + if {![package vsatisfies [package provide Tk] 8.6]} { return } proc choosefont {font which} { tk fontchooser configure -title $which -font $font \ -command [list on_choosefont $font $which] @@ -11289,327 +11290,373 @@ proc get_path_encoding {path} { return $tcl_enc } -# First check that Tcl/Tk is recent enough -if {[catch {package require Tk 8.4} err]} { - show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\ - Gitk requires at least Tcl/Tk 8.4." list - exit 1 -} - -# defaults... -set wrcomcmd "git diff-tree --stdin -p --pretty" - -set gitencoding {} -catch { - set gitencoding [exec git config --get i18n.commitencoding] -} -catch { - set gitencoding [exec git config --get i18n.logoutputencoding] -} -if {$gitencoding == ""} { - set gitencoding "utf-8" -} -set tclencoding [tcl_encoding $gitencoding] -if {$tclencoding == {}} { - puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk" -} +# main is capable of being evaluated by Tcl 8.2 and above. +# this means no eq/ne in the body. +proc main {args} { + global env argv0 -set gui_encoding [encoding system] -catch { - set enc [exec git config --get gui.encoding] - if {$enc ne {}} { - set tclenc [tcl_encoding $enc] - if {$tclenc ne {}} { - set gui_encoding $tclenc - } else { - puts stderr "Warning: encoding $enc is not supported by Tcl/Tk" - } - } -} - -if {[tk windowingsystem] eq "aqua"} { - set mainfont {{Lucida Grande} 9} - set textfont {Monaco 9} - set uifont {{Lucida Grande} 9 bold} -} else { - set mainfont {Helvetica 9} - set textfont {Courier 9} - set uifont {Helvetica 9 bold} -} -set tabstop 8 -set findmergefiles 0 -set maxgraphpct 50 -set maxwidth 16 -set revlistorder 0 -set fastdate 0 -set uparrowlen 5 -set downarrowlen 5 -set mingaplen 100 -set cmitmode "patch" -set wrapcomment "none" -set showneartags 1 -set hideremotes 0 -set maxrefs 20 -set maxlinelen 200 -set showlocalchanges 1 -set limitdiffs 1 -set datetimeformat "%Y-%m-%d %H:%M:%S" -set autoselect 1 -set perfile_attrs 0 -set want_ttk 1 - -if {[tk windowingsystem] eq "aqua"} { - set extdifftool "opendiff" -} else { - set extdifftool "meld" -} - -set colors {green red blue magenta darkgrey brown orange} -if {[tk windowingsystem] eq "win32"} { - set uicolor SystemButtonFace - set bgcolor SystemWindow - set fgcolor SystemButtonText - set selectbgcolor SystemHighlight -} else { - set uicolor grey85 - set bgcolor white - set fgcolor black - set selectbgcolor gray85 -} -set diffcolors {red "#00a000" blue} -set diffcontext 3 -set ignorespace 0 -set markbgcolor "#e0e0ff" - -set circlecolors {white blue gray blue blue} - -# button for popping up context menus -if {[tk windowingsystem] eq "aqua"} { - set ctxbut -} else { - set ctxbut -} - -## For msgcat loading, first locate the installation location. -if { [info exists ::env(GITK_MSGSDIR)] } { - ## Msgsdir was manually set in the environment. - set gitk_msgsdir $::env(GITK_MSGSDIR) -} else { - ## Let's guess the prefix from argv0. - set gitk_prefix [file dirname [file dirname [file normalize $argv0]]] - set gitk_libdir [file join $gitk_prefix share gitk lib] - set gitk_msgsdir [file join $gitk_libdir msgs] - unset gitk_prefix -} - -## Internationalization (i18n) through msgcat and gettext. See -## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html -package require msgcat -namespace import ::msgcat::mc -## And eventually load the actual message catalog -::msgcat::mcload $gitk_msgsdir - -catch {source ~/.gitk} - -font create optionfont -family sans-serif -size -12 - -parsefont mainfont $mainfont -eval font create mainfont [fontflags mainfont] -eval font create mainfontbold [fontflags mainfont 1] - -parsefont textfont $textfont -eval font create textfont [fontflags textfont] -eval font create textfontbold [fontflags textfont 1] - -parsefont uifont $uifont -eval font create uifont [fontflags uifont] - -setui $uicolor - -setoptions - -# check that we can find a .git directory somewhere... -if {[catch {set gitdir [gitdir]}]} { - show_error {} . [mc "Cannot find a git repository here."] - exit 1 -} -if {![file isdirectory $gitdir]} { - show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir] - exit 1 -} - -set selecthead {} -set selectheadid {} - -set revtreeargs {} -set cmdline_files {} -set i 0 -set revtreeargscmd {} -foreach arg $argv { - switch -glob -- $arg { - "" { } - "--" { - set cmdline_files [lrange $argv [expr {$i + 1}] end] - break - } - "--select-commit=*" { - set selecthead [string range $arg 16 end] - } - "--argscmd=*" { - set revtreeargscmd [string range $arg 10 end] - } - default { - lappend revtreeargs $arg - } + # First check that Tcl/Tk is recent enough + if {[catch {package require Tk 8.4} err]} { + return -code error "Sorry, gitk cannot run with this version of\ + Tcl/Tk.\nGitk requires at least Tcl/Tk 8.4." } - incr i -} -if {$selecthead eq "HEAD"} { - set selecthead {} -} + ## For msgcat loading, first locate the installation location. + if { [info exists ::env(GITK_MSGSDIR)] } { + ## Msgsdir was manually set in the environment. + variable gitk_msgsdir $::env(GITK_MSGSDIR) + } else { + ## Let's guess the prefix from argv0. + set gitk_prefix [file dirname [file dirname [file normalize $argv0]]] + set gitk_libdir [file join $gitk_prefix share gitk lib] + variable gitk_msgsdir [file join $gitk_libdir msgs] + } + + ## Internationalization (i18n) through msgcat and gettext. See + ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html + package require msgcat + namespace import ::msgcat::mc + ## And eventually load the actual message catalog + ::msgcat::mcload $gitk_msgsdir + + # continue initialization with 8.4+ + eval init $args + + tkwait window . +} + +# Initialization code requires 8.4+ for eval/byte-compilation. +proc init {args} { + global env argv0 tk_version + + # Hide the main window until all is ready + wm withdraw . + + # defaults... + variable wrcomcmd "git diff-tree --stdin -p --pretty" + + set gitencoding {} + catch { + set gitencoding [exec git config --get i18n.commitencoding] + } + catch { + set gitencoding [exec git config --get i18n.logoutputencoding] + } + if {$gitencoding == ""} { + set gitencoding "utf-8" + } + variable tclencoding [tcl_encoding $gitencoding] + if {$tclencoding == {}} { + puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk" + } + + variable gui_encoding [encoding system] + catch { + set enc [exec git config --get gui.encoding] + if {$enc ne {}} { + set tclenc [tcl_encoding $enc] + if {$tclenc ne {}} { + set gui_encoding $tclenc + } else { + puts stderr "Warning: encoding $enc is not supported by Tcl/Tk" + } + } + } + + if {[tk windowingsystem] eq "aqua"} { + variable mainfont {{Lucida Grande} 9} + variable textfont {Monaco 9} + variable uifont {{Lucida Grande} 9 bold} + } else { + variable mainfont {Helvetica 9} + variable textfont {Courier 9} + variable uifont {Helvetica 9 bold} + } + variable tabstop 8 + variable findmergefiles 0 + variable maxgraphpct 50 + variable maxwidth 16 + variable revlistorder 0 + variable fastdate 0 + variable uparrowlen 5 + variable downarrowlen 5 + variable mingaplen 100 + variable cmitmode "patch" + variable wrapcomment "none" + variable showneartags 1 + variable hideremotes 0 + variable maxrefs 20 + variable maxlinelen 200 + variable showlocalchanges 1 + variable limitdiffs 1 + variable datetimeformat "%Y-%m-%d %H:%M:%S" + variable autoselect 1 + variable perfile_attrs 0 + variable want_ttk 1 + + if {[tk windowingsystem] eq "aqua"} { + variable extdifftool "opendiff" + } else { + variable extdifftool "meld" + } -if {$i >= [llength $argv] && $revtreeargs ne {}} { - # no -- on command line, but some arguments (other than --argscmd) - if {[catch { - set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs] - set cmdline_files [split $f "\n"] - set n [llength $cmdline_files] - set revtreeargs [lrange $revtreeargs 0 end-$n] - # Unfortunately git rev-parse doesn't produce an error when - # something is both a revision and a filename. To be consistent - # with git log and git rev-list, check revtreeargs for filenames. - foreach arg $revtreeargs { - if {[file exists $arg]} { - show_error {} . [mc "Ambiguous argument '%s': both revision\ + variable colors {green red blue magenta darkgrey brown orange} + if {[tk windowingsystem] eq "win32"} { + variable uicolor SystemButtonFace + variable bgcolor SystemWindow + variable fgcolor SystemButtonText + variable selectbgcolor SystemHighlight + } else { + variable uicolor grey85 + variable bgcolor white + variable fgcolor black + variable selectbgcolor gray85 + } + variable diffcolors {red "#00a000" blue} + variable diffcontext 3 + variable ignorespace 0 + variable markbgcolor "#e0e0ff" + + variable circlecolors {white blue gray blue blue} + + # button for popping up context menus + if {[tk windowingsystem] eq "aqua"} { + variable ctxbut + } else { + variable ctxbut + } + + create_bitmaps + init_font_chooser + catch {uplevel #0 [list source ~/.gitk]} + + font create optionfont -family sans-serif -size -12 + + parsefont mainfont $mainfont + eval font create mainfont [fontflags mainfont] + eval font create mainfontbold [fontflags mainfont 1] + + parsefont textfont $textfont + eval font create textfont [fontflags textfont] + eval font create textfontbold [fontflags textfont 1] + + parsefont uifont $uifont + eval font create uifont [fontflags uifont] + + setui $uicolor + + setoptions + + # check that we can find a .git directory somewhere... + if {[catch {set gitdir [gitdir]}]} { + show_error {} . [mc "Cannot find a git repository here."] + exit 1 + } + if {![file isdirectory $gitdir]} { + show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir] + exit 1 + } + + variable selecthead {} + variable selectheadid {} + + variable revtreeargs {} + set cmdline_files {} + set i 0 + set revtreeargscmd {} + foreach arg $args { + switch -glob -- $arg { + "" { } + "--" { + set cmdline_files [lrange $args [expr {$i + 1}] end] + break + } + "--select-commit=*" { + set selecthead [string range $arg 16 end] + } + "--argscmd=*" { + set revtreeargscmd [string range $arg 10 end] + } + default { + lappend revtreeargs $arg + } + } + incr i + } + + if {$selecthead eq "HEAD"} { + set selecthead {} + } + + if {$i >= [llength $args] && $revtreeargs ne {}} { + # no -- on command line, but some arguments (other than --argscmd) + if {[catch { + set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs] + set cmdline_files [split $f "\n"] + set n [llength $cmdline_files] + set revtreeargs [lrange $revtreeargs 0 end-$n] + # Unfortunately git rev-parse doesn't produce an error when + # something is both a revision and a filename. To be consistent + # with git log and git rev-list, check revtreeargs for filenames. + foreach arg $revtreeargs { + if {[file exists $arg]} { + show_error {} . [mc "Ambiguous argument '%s': both revision\ and filename" $arg] - exit 1 - } - } - } err]} { - # unfortunately we get both stdout and stderr in $err, - # so look for "fatal:". - set i [string first "fatal:" $err] - if {$i > 0} { - set err [string range $err [expr {$i + 6}] end] - } - show_error {} . "[mc "Bad arguments to gitk:"]\n$err" - exit 1 + exit 1 + } + } + } err]} { + # unfortunately we get both stdout and stderr in $err, + # so look for "fatal:". + set i [string first "fatal:" $err] + if {$i > 0} { + set err [string range $err [expr {$i + 6}] end] + } + show_error {} . "[mc "Bad arguments to gitk:"]\n$err" + exit 1 + } } -} -set nullid "0000000000000000000000000000000000000000" -set nullid2 "0000000000000000000000000000000000000001" -set nullfile "/dev/null" - -set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}] -if {![info exists have_ttk]} { - set have_ttk [llength [info commands ::ttk::style]] -} -set use_ttk [expr {$have_ttk && $want_ttk}] -set NS [expr {$use_ttk ? "ttk" : ""}] - -set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .] - -set runq {} -set history {} -set historyindex 0 -set fh_serial 0 -set nhl_names {} -set highlight_paths {} -set findpattern {} -set searchdirn -forwards -set boldids {} -set boldnameids {} -set diffelide {0 0} -set markingmatches 0 -set linkentercount 0 -set need_redisplay 0 -set nrows_drawn 0 -set firsttabstop 0 - -set nextviewnum 1 -set curview 0 -set selectedview 0 -set selectedhlview [mc "None"] -set highlight_related [mc "None"] -set highlight_files {} -set viewfiles(0) {} -set viewperm(0) 0 -set viewargs(0) {} -set viewargscmd(0) {} - -set selectedline {} -set numcommits 0 -set loginstance 0 -set cmdlineok 0 -set stopped 0 -set stuffsaved 0 -set patchnum 0 -set lserial 0 -set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}] -setcoords -makewindow -catch { - image create photo gitlogo -width 16 -height 16 - - image create photo gitlogominus -width 4 -height 2 - gitlogominus put #C00000 -to 0 0 4 2 - gitlogo copy gitlogominus -to 1 5 - gitlogo copy gitlogominus -to 6 5 - gitlogo copy gitlogominus -to 11 5 - image delete gitlogominus - - image create photo gitlogoplus -width 4 -height 4 - gitlogoplus put #008000 -to 1 0 3 4 - gitlogoplus put #008000 -to 0 1 4 3 - gitlogo copy gitlogoplus -to 1 9 - gitlogo copy gitlogoplus -to 6 9 - gitlogo copy gitlogoplus -to 11 9 - image delete gitlogoplus - - image create photo gitlogo32 -width 32 -height 32 - gitlogo32 copy gitlogo -zoom 2 2 - - wm iconphoto . -default gitlogo gitlogo32 -} -# wait for the window to become visible -tkwait visibility . -wm title . "[file tail $argv0]: [file tail [pwd]]" -update -readrefs - -if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} { - # create a view for the files/dirs specified on the command line - set curview 1 - set selectedview 1 - set nextviewnum 2 - set viewname(1) [mc "Command line"] - set viewfiles(1) $cmdline_files - set viewargs(1) $revtreeargs - set viewargscmd(1) $revtreeargscmd - set viewperm(1) 0 - set vdatemode(1) 0 - addviewmenu 1 - .bar.view entryconf [mca "Edit view..."] -state normal - .bar.view entryconf [mca "Delete view"] -state normal -} - -if {[info exists permviews]} { - foreach v $permviews { - set n $nextviewnum - incr nextviewnum - set viewname($n) [lindex $v 0] - set viewfiles($n) [lindex $v 1] - set viewargs($n) [lindex $v 2] - set viewargscmd($n) [lindex $v 3] - set viewperm($n) 1 - addviewmenu $n - } -} + variable nullid "0000000000000000000000000000000000000000" + variable nullid2 "0000000000000000000000000000000000000001" + variable nullfile "/dev/null" + + variable have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}] + if {![info exists have_ttk]} { + variable have_ttk [llength [info commands ::ttk::style]] + } + variable use_ttk [expr {$have_ttk && $want_ttk}] + variable NS [expr {$use_ttk ? "ttk" : ""}] + + variable git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .] + + variable runq {} + variable history {} + variable historyindex 0 + variable fh_serial 0 + variable nhl_names {} + variable highlight_paths {} + variable findpattern {} + variable searchdirn -forwards + variable boldids {} + variable boldnameids {} + variable diffelide {0 0} + variable markingmatches 0 + variable linkentercount 0 + variable need_redisplay 0 + variable nrows_drawn 0 + variable firsttabstop 0 + + variable nextviewnum 1 + variable curview 0 + variable selectedview 0 + variable selectedhlview [mc "None"] + variable highlight_related [mc "None"] + variable highlight_files {} + + global viewfiles viewperm viewargs viewargscmd + global viewcomplete viewactive viewname viewinstances + global viewfiles viewargs viewargscmd viewperm + global vdatemode + + set viewfiles(0) {} + set viewperm(0) 0 + set viewargs(0) {} + set viewargscmd(0) {} + + variable selectedline {} + variable numcommits 0 + variable loginstance 0 + variable cmdlineok 0 + variable stopped 0 + variable stuffsaved 0 + variable patchnum 0 + variable lserial 0 + variable isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}] + setcoords + makewindow + catch { + image create photo gitlogo -width 16 -height 16 + + image create photo gitlogominus -width 4 -height 2 + gitlogominus put #C00000 -to 0 0 4 2 + gitlogo copy gitlogominus -to 1 5 + gitlogo copy gitlogominus -to 6 5 + gitlogo copy gitlogominus -to 11 5 + image delete gitlogominus + + image create photo gitlogoplus -width 4 -height 4 + gitlogoplus put #008000 -to 1 0 3 4 + gitlogoplus put #008000 -to 0 1 4 3 + gitlogo copy gitlogoplus -to 1 9 + gitlogo copy gitlogoplus -to 6 9 + gitlogo copy gitlogoplus -to 11 9 + image delete gitlogoplus + + image create photo gitlogo32 -width 32 -height 32 + gitlogo32 copy gitlogo -zoom 2 2 + + wm iconphoto . -default gitlogo gitlogo32 + } + # wait for the window to become visible + wm deiconify . + tkwait visibility . + wm title . "[file tail $argv0]: [file tail [pwd]]" + update + readrefs -if {[tk windowingsystem] eq "win32"} { - focus -force . -} + if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} { + # create a view for the files/dirs specified on the command line + set curview 1 + set selectedview 1 + set nextviewnum 2 + set viewname(1) [mc "Command line"] + set viewfiles(1) $cmdline_files + set viewargs(1) $revtreeargs + set viewargscmd(1) $revtreeargscmd + set viewperm(1) 0 + set vdatemode(1) 0 + addviewmenu 1 + .bar.view entryconf [mca "Edit view..."] -state normal + .bar.view entryconf [mca "Delete view"] -state normal + } + + if {[info exists ::permviews]} { + foreach v $::permviews { + set n $nextviewnum + incr nextviewnum + set viewname($n) [lindex $v 0] + set viewfiles($n) [lindex $v 1] + set viewargs($n) [lindex $v 2] + set viewargscmd($n) [lindex $v 3] + set viewperm($n) 1 + addviewmenu $n + } + } -getcommits {} + if {[tk windowingsystem] eq "win32"} { + focus -force . + bind . {console show} + } + + getcommits {} +} + +if {!$tcl_interactive} { + if {[llength [package provide tcltest]]>0} { return } + if {![info exists initialized]} { + set initialized 1 + package require Tk + wm withdraw . + set r [catch [linsert $argv 0 main] err] + if {$r} { + if {[string equal $tcl_platform(platform) "windows"]} { + tk_messageBox -icon error -title "Gitk error" \ + -message $err + } else { + puts stderr $err + } + } + exit $r + } +} \ No newline at end of file -- 2.23.0