| #!/bin/sh |
| # Tcl ignores the next line -*- tcl -*- \ |
| exec wish "$0" -- "$@" |
| |
| # Copyright © 2005-2014 Paul Mackerras. All rights reserved. |
| # This program is free software; it may be used, copied, modified |
| # 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 hasworktree {} { |
| return [expr {[exec git rev-parse --is-bare-repository] == "false" && |
| [exec git rev-parse --is-inside-git-dir] == "false"}] |
| } |
| |
| proc reponame {} { |
| global gitdir |
| set n [file normalize $gitdir] |
| if {[string match "*/.git" $n]} { |
| set n [string range $n 0 end-5] |
| } |
| return [file tail $n] |
| } |
| |
| proc gitworktree {} { |
| variable _gitworktree |
| if {[info exists _gitworktree]} { |
| return $_gitworktree |
| } |
| # v1.7.0 introduced --show-toplevel to return the canonical work-tree |
| if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} { |
| # try to set work tree from environment, core.worktree or use |
| # cdup to obtain a relative path to the top of the worktree. If |
| # run from the top, the ./ prefix ensures normalize expands pwd. |
| if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} { |
| catch {set _gitworktree [exec git config --get core.worktree]} |
| if {$_gitworktree eq ""} { |
| set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]] |
| } |
| } |
| } |
| return $_gitworktree |
| } |
| |
| # A simple scheduler for compute-intensive stuff. |
| # The aim is to make sure that event handlers for GUI actions can |
| # run at least every 50-100 ms. Unfortunately fileevent handlers are |
| # run before X event handlers, so reading from a fast source can |
| # make the GUI completely unresponsive. |
| proc run args { |
| global isonrunq runq currunq |
| |
| set script $args |
| if {[info exists isonrunq($script)]} return |
| if {$runq eq {} && ![info exists currunq]} { |
| after idle dorunq |
| } |
| lappend runq [list {} $script] |
| set isonrunq($script) 1 |
| } |
| |
| proc filerun {fd script} { |
| fileevent $fd readable [list filereadable $fd $script] |
| } |
| |
| proc filereadable {fd script} { |
| global runq currunq |
| |
| fileevent $fd readable {} |
| if {$runq eq {} && ![info exists currunq]} { |
| after idle dorunq |
| } |
| lappend runq [list $fd $script] |
| } |
| |
| proc nukefile {fd} { |
| global runq |
| |
| for {set i 0} {$i < [llength $runq]} {} { |
| if {[lindex $runq $i 0] eq $fd} { |
| set runq [lreplace $runq $i $i] |
| } else { |
| incr i |
| } |
| } |
| } |
| |
| proc dorunq {} { |
| global isonrunq runq currunq |
| |
| set tstart [clock clicks -milliseconds] |
| set t0 $tstart |
| while {[llength $runq] > 0} { |
| set fd [lindex $runq 0 0] |
| set script [lindex $runq 0 1] |
| set currunq [lindex $runq 0] |
| set runq [lrange $runq 1 end] |
| set repeat [eval $script] |
| unset currunq |
| set t1 [clock clicks -milliseconds] |
| set t [expr {$t1 - $t0}] |
| if {$repeat ne {} && $repeat} { |
| if {$fd eq {} || $repeat == 2} { |
| # script returns 1 if it wants to be readded |
| # file readers return 2 if they could do more straight away |
| lappend runq [list $fd $script] |
| } else { |
| fileevent $fd readable [list filereadable $fd $script] |
| } |
| } elseif {$fd eq {}} { |
| unset isonrunq($script) |
| } |
| set t0 $t1 |
| if {$t1 - $tstart >= 80} break |
| } |
| if {$runq ne {}} { |
| after idle dorunq |
| } |
| } |
| |
| proc reg_instance {fd} { |
| global commfd leftover loginstance |
| |
| set i [incr loginstance] |
| set commfd($i) $fd |
| set leftover($i) {} |
| return $i |
| } |
| |
| proc unmerged_files {files} { |
| global nr_unmerged |
| |
| # find the list of unmerged files |
| set mlist {} |
| set nr_unmerged 0 |
| if {[catch { |
| set fd [open "| git ls-files -u" r] |
| } err]} { |
| show_error {} . "[mc "Couldn't get list of unmerged files:"] $err" |
| exit 1 |
| } |
| while {[gets $fd line] >= 0} { |
| set i [string first "\t" $line] |
| if {$i < 0} continue |
| set fname [string range $line [expr {$i+1}] end] |
| if {[lsearch -exact $mlist $fname] >= 0} continue |
| incr nr_unmerged |
| if {$files eq {} || [path_filter $files $fname]} { |
| lappend mlist $fname |
| } |
| } |
| catch {close $fd} |
| return $mlist |
| } |
| |
| proc parseviewargs {n arglist} { |
| global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env |
| global vinlinediff |
| global worddiff git_version |
| |
| set vdatemode($n) 0 |
| set vmergeonly($n) 0 |
| set vinlinediff($n) 0 |
| set glflags {} |
| set diffargs {} |
| set nextisval 0 |
| set revargs {} |
| set origargs $arglist |
| set allknown 1 |
| set filtered 0 |
| set i -1 |
| foreach arg $arglist { |
| incr i |
| if {$nextisval} { |
| lappend glflags $arg |
| set nextisval 0 |
| continue |
| } |
| switch -glob -- $arg { |
| "-d" - |
| "--date-order" { |
| set vdatemode($n) 1 |
| # remove from origargs in case we hit an unknown option |
| set origargs [lreplace $origargs $i $i] |
| incr i -1 |
| } |
| "-[puabwcrRBMC]" - |
| "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" - |
| "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" - |
| "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" - |
| "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" - |
| "--ignore-space-change" - "-U*" - "--unified=*" { |
| # These request or affect diff output, which we don't want. |
| # Some could be used to set our defaults for diff display. |
| lappend diffargs $arg |
| } |
| "--raw" - "--patch-with-raw" - "--patch-with-stat" - |
| "--name-only" - "--name-status" - "--color" - |
| "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" - |
| "--cc" - "-z" - "--header" - "--parents" - "--boundary" - |
| "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" - |
| "--timestamp" - "relative-date" - "--date=*" - "--stdin" - |
| "--objects" - "--objects-edge" - "--reverse" { |
| # These cause our parsing of git log's output to fail, or else |
| # they're options we want to set ourselves, so ignore them. |
| } |
| "--color-words*" - "--word-diff=color" { |
| # These trigger a word diff in the console interface, |
| # so help the user by enabling our own support |
| if {[package vcompare $git_version "1.7.2"] >= 0} { |
| set worddiff [mc "Color words"] |
| } |
| } |
| "--word-diff*" { |
| if {[package vcompare $git_version "1.7.2"] >= 0} { |
| set worddiff [mc "Markup words"] |
| } |
| } |
| "--stat=*" - "--numstat" - "--shortstat" - "--summary" - |
| "--check" - "--exit-code" - "--quiet" - "--topo-order" - |
| "--full-history" - "--dense" - "--sparse" - |
| "--follow" - "--left-right" - "--encoding=*" { |
| # These are harmless, and some are even useful |
| lappend glflags $arg |
| } |
| "--diff-filter=*" - "--no-merges" - "--unpacked" - |
| "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" - |
| "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" - |
| "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" - |
| "--remove-empty" - "--first-parent" - "--cherry-pick" - |
| "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" - |
| "--simplify-by-decoration" { |
| # These mean that we get a subset of the commits |
| set filtered 1 |
| lappend glflags $arg |
| } |
| "-L*" { |
| # Line-log with 'stuck' argument (unstuck form is |
| # not supported) |
| set filtered 1 |
| set vinlinediff($n) 1 |
| set allknown 0 |
| lappend glflags $arg |
| } |
| "-n" { |
| # This appears to be the only one that has a value as a |
| # separate word following it |
| set filtered 1 |
| set nextisval 1 |
| lappend glflags $arg |
| } |
| "--not" - "--all" { |
| lappend revargs $arg |
| } |
| "--merge" { |
| set vmergeonly($n) 1 |
| # git rev-parse doesn't understand --merge |
| lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD |
| } |
| "--no-replace-objects" { |
| set env(GIT_NO_REPLACE_OBJECTS) "1" |
| } |
| "-*" { |
| # Other flag arguments including -<n> |
| if {[string is digit -strict [string range $arg 1 end]]} { |
| set filtered 1 |
| } else { |
| # a flag argument that we don't recognize; |
| # that means we can't optimize |
| set allknown 0 |
| } |
| lappend glflags $arg |
| } |
| default { |
| # Non-flag arguments specify commits or ranges of commits |
| if {[string match "*...*" $arg]} { |
| lappend revargs --gitk-symmetric-diff-marker |
| } |
| lappend revargs $arg |
| } |
| } |
| } |
| set vdflags($n) $diffargs |
| set vflags($n) $glflags |
| set vrevs($n) $revargs |
| set vfiltered($n) $filtered |
| set vorigargs($n) $origargs |
| return $allknown |
| } |
| |
| proc parseviewrevs {view revs} { |
| global vposids vnegids |
| |
| if {$revs eq {}} { |
| set revs HEAD |
| } elseif {[lsearch -exact $revs --all] >= 0} { |
| lappend revs HEAD |
| } |
| if {[catch {set ids [eval exec git rev-parse $revs]} err]} { |
| # we get stdout followed by stderr in $err |
| # for an unknown rev, git rev-parse echoes it and then errors out |
| set errlines [split $err "\n"] |
| set badrev {} |
| for {set l 0} {$l < [llength $errlines]} {incr l} { |
| set line [lindex $errlines $l] |
| if {!([string length $line] == 40 && [string is xdigit $line])} { |
| if {[string match "fatal:*" $line]} { |
| if {[string match "fatal: ambiguous argument*" $line] |
| && $badrev ne {}} { |
| if {[llength $badrev] == 1} { |
| set err "unknown revision $badrev" |
| } else { |
| set err "unknown revisions: [join $badrev ", "]" |
| } |
| } else { |
| set err [join [lrange $errlines $l end] "\n"] |
| } |
| break |
| } |
| lappend badrev $line |
| } |
| } |
| error_popup "[mc "Error parsing revisions:"] $err" |
| return {} |
| } |
| set ret {} |
| set pos {} |
| set neg {} |
| set sdm 0 |
| foreach id [split $ids "\n"] { |
| if {$id eq "--gitk-symmetric-diff-marker"} { |
| set sdm 4 |
| } elseif {[string match "^*" $id]} { |
| if {$sdm != 1} { |
| lappend ret $id |
| if {$sdm == 3} { |
| set sdm 0 |
| } |
| } |
| lappend neg [string range $id 1 end] |
| } else { |
| if {$sdm != 2} { |
| lappend ret $id |
| } else { |
| lset ret end $id...[lindex $ret end] |
| } |
| lappend pos $id |
| } |
| incr sdm -1 |
| } |
| set vposids($view) $pos |
| set vnegids($view) $neg |
| return $ret |
| } |
| |
| # Start off a git log process and arrange to read its output |
| proc start_rev_list {view} { |
| global startmsecs commitidx viewcomplete curview |
| global tclencoding |
| global viewargs viewargscmd viewfiles vfilelimit |
| global showlocalchanges |
| global viewactive viewinstances vmergeonly |
| global mainheadid viewmainheadid viewmainheadid_orig |
| global vcanopt vflags vrevs vorigargs |
| global show_notes |
| |
| set startmsecs [clock clicks -milliseconds] |
| set commitidx($view) 0 |
| # these are set this way for the error exits |
| set viewcomplete($view) 1 |
| set viewactive($view) 0 |
| varcinit $view |
| |
| set args $viewargs($view) |
| if {$viewargscmd($view) ne {}} { |
| if {[catch { |
| set str [exec sh -c $viewargscmd($view)] |
| } err]} { |
| error_popup "[mc "Error executing --argscmd command:"] $err" |
| return 0 |
| } |
| set args [concat $args [split $str "\n"]] |
| } |
| set vcanopt($view) [parseviewargs $view $args] |
| |
| set files $viewfiles($view) |
| if {$vmergeonly($view)} { |
| set files [unmerged_files $files] |
| if {$files eq {}} { |
| global nr_unmerged |
| if {$nr_unmerged == 0} { |
| error_popup [mc "No files selected: --merge specified but\ |
| no files are unmerged."] |
| } else { |
| error_popup [mc "No files selected: --merge specified but\ |
| no unmerged files are within file limit."] |
| } |
| return 0 |
| } |
| } |
| set vfilelimit($view) $files |
| |
| if {$vcanopt($view)} { |
| set revs [parseviewrevs $view $vrevs($view)] |
| if {$revs eq {}} { |
| return 0 |
| } |
| set args [concat $vflags($view) $revs] |
| } else { |
| set args $vorigargs($view) |
| } |
| |
| if {[catch { |
| set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \ |
| --parents --boundary $args "--" $files] r] |
| } err]} { |
| error_popup "[mc "Error executing git log:"] $err" |
| return 0 |
| } |
| set i [reg_instance $fd] |
| set viewinstances($view) [list $i] |
| set viewmainheadid($view) $mainheadid |
| set viewmainheadid_orig($view) $mainheadid |
| if {$files ne {} && $mainheadid ne {}} { |
| get_viewmainhead $view |
| } |
| if {$showlocalchanges && $viewmainheadid($view) ne {}} { |
| interestedin $viewmainheadid($view) dodiffindex |
| } |
| fconfigure $fd -blocking 0 -translation lf -eofchar {} |
| if {$tclencoding != {}} { |
| fconfigure $fd -encoding $tclencoding |
| } |
| filerun $fd [list getcommitlines $fd $i $view 0] |
| nowbusy $view [mc "Reading"] |
| set viewcomplete($view) 0 |
| set viewactive($view) 1 |
| return 1 |
| } |
| |
| proc stop_instance {inst} { |
| global commfd leftover |
| |
| set fd $commfd($inst) |
| catch { |
| set pid [pid $fd] |
| |
| if {$::tcl_platform(platform) eq {windows}} { |
| exec taskkill /pid $pid |
| } else { |
| exec kill $pid |
| } |
| } |
| catch {close $fd} |
| nukefile $fd |
| unset commfd($inst) |
| unset leftover($inst) |
| } |
| |
| proc stop_backends {} { |
| global commfd |
| |
| foreach inst [array names commfd] { |
| stop_instance $inst |
| } |
| } |
| |
| proc stop_rev_list {view} { |
| global viewinstances |
| |
| foreach inst $viewinstances($view) { |
| stop_instance $inst |
| } |
| set viewinstances($view) {} |
| } |
| |
| proc reset_pending_select {selid} { |
| global pending_select mainheadid selectheadid |
| |
| if {$selid ne {}} { |
| set pending_select $selid |
| } elseif {$selectheadid ne {}} { |
| set pending_select $selectheadid |
| } else { |
| set pending_select $mainheadid |
| } |
| } |
| |
| proc getcommits {selid} { |
| global canv curview need_redisplay viewactive |
| |
| initlayout |
| if {[start_rev_list $curview]} { |
| reset_pending_select $selid |
| show_status [mc "Reading commits..."] |
| set need_redisplay 1 |
| } else { |
| show_status [mc "No commits selected"] |
| } |
| } |
| |
| proc updatecommits {} { |
| global curview vcanopt vorigargs vfilelimit viewinstances |
| global viewactive viewcomplete tclencoding |
| global startmsecs showneartags showlocalchanges |
| global mainheadid viewmainheadid viewmainheadid_orig pending_select |
| global hasworktree |
| global varcid vposids vnegids vflags vrevs |
| global show_notes |
| |
| set hasworktree [hasworktree] |
| rereadrefs |
| set view $curview |
| if {$mainheadid ne $viewmainheadid_orig($view)} { |
| if {$showlocalchanges} { |
| dohidelocalchanges |
| } |
| set viewmainheadid($view) $mainheadid |
| set viewmainheadid_orig($view) $mainheadid |
| if {$vfilelimit($view) ne {}} { |
| get_viewmainhead $view |
| } |
| } |
| if {$showlocalchanges} { |
| doshowlocalchanges |
| } |
| if {$vcanopt($view)} { |
| set oldpos $vposids($view) |
| set oldneg $vnegids($view) |
| set revs [parseviewrevs $view $vrevs($view)] |
| if {$revs eq {}} { |
| return |
| } |
| # note: getting the delta when negative refs change is hard, |
| # and could require multiple git log invocations, so in that |
| # case we ask git log for all the commits (not just the delta) |
| if {$oldneg eq $vnegids($view)} { |
| set newrevs {} |
| set npos 0 |
| # take out positive refs that we asked for before or |
| # that we have already seen |
| foreach rev $revs { |
| if {[string length $rev] == 40} { |
| if {[lsearch -exact $oldpos $rev] < 0 |
| && ![info exists varcid($view,$rev)]} { |
| lappend newrevs $rev |
| incr npos |
| } |
| } else { |
| lappend $newrevs $rev |
| } |
| } |
| if {$npos == 0} return |
| set revs $newrevs |
| set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]] |
| } |
| set args [concat $vflags($view) $revs --not $oldpos] |
| } else { |
| set args $vorigargs($view) |
| } |
| if {[catch { |
| set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \ |
| --parents --boundary $args "--" $vfilelimit($view)] r] |
| } err]} { |
| error_popup "[mc "Error executing git log:"] $err" |
| return |
| } |
| if {$viewactive($view) == 0} { |
| set startmsecs [clock clicks -milliseconds] |
| } |
| set i [reg_instance $fd] |
| lappend viewinstances($view) $i |
| fconfigure $fd -blocking 0 -translation lf -eofchar {} |
| if {$tclencoding != {}} { |
| fconfigure $fd -encoding $tclencoding |
| } |
| filerun $fd [list getcommitlines $fd $i $view 1] |
| incr viewactive($view) |
| set viewcomplete($view) 0 |
| reset_pending_select {} |
| nowbusy $view [mc "Reading"] |
| if {$showneartags} { |
| getallcommits |
| } |
| } |
| |
| proc reloadcommits {} { |
| global curview viewcomplete selectedline currentid thickerline |
| global showneartags treediffs commitinterest cached_commitrow |
| global targetid |
| |
| set selid {} |
| if {$selectedline ne {}} { |
| set selid $currentid |
| } |
| |
| if {!$viewcomplete($curview)} { |
| stop_rev_list $curview |
| } |
| resetvarcs $curview |
| set selectedline {} |
| unset -nocomplain currentid |
| unset -nocomplain thickerline |
| unset -nocomplain treediffs |
| readrefs |
| changedrefs |
| if {$showneartags} { |
| getallcommits |
| } |
| clear_display |
| unset -nocomplain commitinterest |
| unset -nocomplain cached_commitrow |
| unset -nocomplain targetid |
| setcanvscroll |
| getcommits $selid |
| return 0 |
| } |
| |
| # This makes a string representation of a positive integer which |
| # sorts as a string in numerical order |
| proc strrep {n} { |
| if {$n < 16} { |
| return [format "%x" $n] |
| } elseif {$n < 256} { |
| return [format "x%.2x" $n] |
| } elseif {$n < 65536} { |
| return [format "y%.4x" $n] |
| } |
| return [format "z%.8x" $n] |
| } |
| |
| # Procedures used in reordering commits from git log (without |
| # --topo-order) into the order for display. |
| |
| proc varcinit {view} { |
| global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow |
| global vtokmod varcmod vrowmod varcix vlastins |
| |
| set varcstart($view) {{}} |
| set vupptr($view) {0} |
| set vdownptr($view) {0} |
| set vleftptr($view) {0} |
| set vbackptr($view) {0} |
| set varctok($view) {{}} |
| set varcrow($view) {{}} |
| set vtokmod($view) {} |
| set varcmod($view) 0 |
| set vrowmod($view) 0 |
| set varcix($view) {{}} |
| set vlastins($view) {0} |
| } |
| |
| proc resetvarcs {view} { |
| global varcid varccommits parents children vseedcount ordertok |
| global vshortids |
| |
| foreach vid [array names varcid $view,*] { |
| unset varcid($vid) |
| unset children($vid) |
| unset parents($vid) |
| } |
| foreach vid [array names vshortids $view,*] { |
| unset vshortids($vid) |
| } |
| # some commits might have children but haven't been seen yet |
| foreach vid [array names children $view,*] { |
| unset children($vid) |
| } |
| foreach va [array names varccommits $view,*] { |
| unset varccommits($va) |
| } |
| foreach vd [array names vseedcount $view,*] { |
| unset vseedcount($vd) |
| } |
| unset -nocomplain ordertok |
| } |
| |
| # returns a list of the commits with no children |
| proc seeds {v} { |
| global vdownptr vleftptr varcstart |
| |
| set ret {} |
| set a [lindex $vdownptr($v) 0] |
| while {$a != 0} { |
| lappend ret [lindex $varcstart($v) $a] |
| set a [lindex $vleftptr($v) $a] |
| } |
| return $ret |
| } |
| |
| proc newvarc {view id} { |
| global varcid varctok parents children vdatemode |
| global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart |
| global commitdata commitinfo vseedcount varccommits vlastins |
| |
| set a [llength $varctok($view)] |
| set vid $view,$id |
| if {[llength $children($vid)] == 0 || $vdatemode($view)} { |
| if {![info exists commitinfo($id)]} { |
| parsecommit $id $commitdata($id) 1 |
| } |
| set cdate [lindex [lindex $commitinfo($id) 4] 0] |
| if {![string is integer -strict $cdate]} { |
| set cdate 0 |
| } |
| if {![info exists vseedcount($view,$cdate)]} { |
| set vseedcount($view,$cdate) -1 |
| } |
| set c [incr vseedcount($view,$cdate)] |
| set cdate [expr {$cdate ^ 0xffffffff}] |
| set tok "s[strrep $cdate][strrep $c]" |
| } else { |
| set tok {} |
| } |
| set ka 0 |
| if {[llength $children($vid)] > 0} { |
| set kid [lindex $children($vid) end] |
| set k $varcid($view,$kid) |
| if {[string compare [lindex $varctok($view) $k] $tok] > 0} { |
| set ki $kid |
| set ka $k |
| set tok [lindex $varctok($view) $k] |
| } |
| } |
| if {$ka != 0} { |
| set i [lsearch -exact $parents($view,$ki) $id] |
| set j [expr {[llength $parents($view,$ki)] - 1 - $i}] |
| append tok [strrep $j] |
| } |
| set c [lindex $vlastins($view) $ka] |
| if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} { |
| set c $ka |
| set b [lindex $vdownptr($view) $ka] |
| } else { |
| set b [lindex $vleftptr($view) $c] |
| } |
| while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} { |
| set c $b |
| set b [lindex $vleftptr($view) $c] |
| } |
| if {$c == $ka} { |
| lset vdownptr($view) $ka $a |
| lappend vbackptr($view) 0 |
| } else { |
| lset vleftptr($view) $c $a |
| lappend vbackptr($view) $c |
| } |
| lset vlastins($view) $ka $a |
| lappend vupptr($view) $ka |
| lappend vleftptr($view) $b |
| if {$b != 0} { |
| lset vbackptr($view) $b $a |
| } |
| lappend varctok($view) $tok |
| lappend varcstart($view) $id |
| lappend vdownptr($view) 0 |
| lappend varcrow($view) {} |
| lappend varcix($view) {} |
| set varccommits($view,$a) {} |
| lappend vlastins($view) 0 |
| return $a |
| } |
| |
| proc splitvarc {p v} { |
| global varcid varcstart varccommits varctok vtokmod |
| global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins |
| |
| set oa $varcid($v,$p) |
| set otok [lindex $varctok($v) $oa] |
| set ac $varccommits($v,$oa) |
| set i [lsearch -exact $varccommits($v,$oa) $p] |
| if {$i <= 0} return |
| set na [llength $varctok($v)] |
| # "%" sorts before "0"... |
| set tok "$otok%[strrep $i]" |
| lappend varctok($v) $tok |
| lappend varcrow($v) {} |
| lappend varcix($v) {} |
| set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]] |
| set varccommits($v,$na) [lrange $ac $i end] |
| lappend varcstart($v) $p |
| foreach id $varccommits($v,$na) { |
| set varcid($v,$id) $na |
| } |
| lappend vdownptr($v) [lindex $vdownptr($v) $oa] |
| lappend vlastins($v) [lindex $vlastins($v) $oa] |
| lset vdownptr($v) $oa $na |
| lset vlastins($v) $oa 0 |
| lappend vupptr($v) $oa |
| lappend vleftptr($v) 0 |
| lappend vbackptr($v) 0 |
| for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} { |
| lset vupptr($v) $b $na |
| } |
| if {[string compare $otok $vtokmod($v)] <= 0} { |
| modify_arc $v $oa |
| } |
| } |
| |
| proc renumbervarc {a v} { |
| global parents children varctok varcstart varccommits |
| global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode |
| |
| set t1 [clock clicks -milliseconds] |
| set todo {} |
| set isrelated($a) 1 |
| set kidchanged($a) 1 |
| set ntot 0 |
| while {$a != 0} { |
| if {[info exists isrelated($a)]} { |
| lappend todo $a |
| set id [lindex $varccommits($v,$a) end] |
| foreach p $parents($v,$id) { |
| if {[info exists varcid($v,$p)]} { |
| set isrelated($varcid($v,$p)) 1 |
| } |
| } |
| } |
| incr ntot |
| set b [lindex $vdownptr($v) $a] |
| if {$b == 0} { |
| while {$a != 0} { |
| set b [lindex $vleftptr($v) $a] |
| if {$b != 0} break |
| set a [lindex $vupptr($v) $a] |
| } |
| } |
| set a $b |
| } |
| foreach a $todo { |
| if {![info exists kidchanged($a)]} continue |
| set id [lindex $varcstart($v) $a] |
| if {[llength $children($v,$id)] > 1} { |
| set children($v,$id) [lsort -command [list vtokcmp $v] \ |
| $children($v,$id)] |
| } |
| set oldtok [lindex $varctok($v) $a] |
| if {!$vdatemode($v)} { |
| set tok {} |
| } else { |
| set tok $oldtok |
| } |
| set ka 0 |
| set kid [last_real_child $v,$id] |
| if {$kid ne {}} { |
| set k $varcid($v,$kid) |
| if {[string compare [lindex $varctok($v) $k] $tok] > 0} { |
| set ki $kid |
| set ka $k |
| set tok [lindex $varctok($v) $k] |
| } |
| } |
| if {$ka != 0} { |
| set i [lsearch -exact $parents($v,$ki) $id] |
| set j [expr {[llength $parents($v,$ki)] - 1 - $i}] |
| append tok [strrep $j] |
| } |
| if {$tok eq $oldtok} { |
| continue |
| } |
| set id [lindex $varccommits($v,$a) end] |
| foreach p $parents($v,$id) { |
| if {[info exists varcid($v,$p)]} { |
| set kidchanged($varcid($v,$p)) 1 |
| } else { |
| set sortkids($p) 1 |
| } |
| } |
| lset varctok($v) $a $tok |
| set b [lindex $vupptr($v) $a] |
| if {$b != $ka} { |
| if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} { |
| modify_arc $v $ka |
| } |
| if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} { |
| modify_arc $v $b |
| } |
| set c [lindex $vbackptr($v) $a] |
| set d [lindex $vleftptr($v) $a] |
| if {$c == 0} { |
| lset vdownptr($v) $b $d |
| } else { |
| lset vleftptr($v) $c $d |
| } |
| if {$d != 0} { |
| lset vbackptr($v) $d $c |
| } |
| if {[lindex $vlastins($v) $b] == $a} { |
| lset vlastins($v) $b $c |
| } |
| lset vupptr($v) $a $ka |
| set c [lindex $vlastins($v) $ka] |
| if {$c == 0 || \ |
| [string compare $tok [lindex $varctok($v) $c]] < 0} { |
| set c $ka |
| set b [lindex $vdownptr($v) $ka] |
| } else { |
| set b [lindex $vleftptr($v) $c] |
| } |
| while {$b != 0 && \ |
| [string compare $tok [lindex $varctok($v) $b]] >= 0} { |
| set c $b |
| set b [lindex $vleftptr($v) $c] |
| } |
| if {$c == $ka} { |
| lset vdownptr($v) $ka $a |
| lset vbackptr($v) $a 0 |
| } else { |
| lset vleftptr($v) $c $a |
| lset vbackptr($v) $a $c |
| } |
| lset vleftptr($v) $a $b |
| if {$b != 0} { |
| lset vbackptr($v) $b $a |
| } |
| lset vlastins($v) $ka $a |
| } |
| } |
| foreach id [array names sortkids] { |
| if {[llength $children($v,$id)] > 1} { |
| set children($v,$id) [lsort -command [list vtokcmp $v] \ |
| $children($v,$id)] |
| } |
| } |
| set t2 [clock clicks -milliseconds] |
| #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms" |
| } |
| |
| # Fix up the graph after we have found out that in view $v, |
| # $p (a commit that we have already seen) is actually the parent |
| # of the last commit in arc $a. |
| proc fix_reversal {p a v} { |
| global varcid varcstart varctok vupptr |
| |
| set pa $varcid($v,$p) |
| if {$p ne [lindex $varcstart($v) $pa]} { |
| splitvarc $p $v |
| set pa $varcid($v,$p) |
| } |
| # seeds always need to be renumbered |
| if {[lindex $vupptr($v) $pa] == 0 || |
| [string compare [lindex $varctok($v) $a] \ |
| [lindex $varctok($v) $pa]] > 0} { |
| renumbervarc $pa $v |
| } |
| } |
| |
| proc insertrow {id p v} { |
| global cmitlisted children parents varcid varctok vtokmod |
| global varccommits ordertok commitidx numcommits curview |
| global targetid targetrow vshortids |
| |
| readcommit $id |
| set vid $v,$id |
| set cmitlisted($vid) 1 |
| set children($vid) {} |
| set parents($vid) [list $p] |
| set a [newvarc $v $id] |
| set varcid($vid) $a |
| lappend vshortids($v,[string range $id 0 3]) $id |
| if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} { |
| modify_arc $v $a |
| } |
| lappend varccommits($v,$a) $id |
| set vp $v,$p |
| if {[llength [lappend children($vp) $id]] > 1} { |
| set children($vp) [lsort -command [list vtokcmp $v] $children($vp)] |
| unset -nocomplain ordertok |
| } |
| fix_reversal $p $a $v |
| incr commitidx($v) |
| if {$v == $curview} { |
| set numcommits $commitidx($v) |
| setcanvscroll |
| if {[info exists targetid]} { |
| if {![comes_before $targetid $p]} { |
| incr targetrow |
| } |
| } |
| } |
| } |
| |
| proc insertfakerow {id p} { |
| global varcid varccommits parents children cmitlisted |
| global commitidx varctok vtokmod targetid targetrow curview numcommits |
| |
| set v $curview |
| set a $varcid($v,$p) |
| set i [lsearch -exact $varccommits($v,$a) $p] |
| if {$i < 0} { |
| puts "oops: insertfakerow can't find [shortids $p] on arc $a" |
| return |
| } |
| set children($v,$id) {} |
| set parents($v,$id) [list $p] |
| set varcid($v,$id) $a |
| lappend children($v,$p) $id |
| set cmitlisted($v,$id) 1 |
| set numcommits [incr commitidx($v)] |
| # note we deliberately don't update varcstart($v) even if $i == 0 |
| set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id] |
| modify_arc $v $a $i |
| if {[info exists targetid]} { |
| if {![comes_before $targetid $p]} { |
| incr targetrow |
| } |
| } |
| setcanvscroll |
| drawvisible |
| } |
| |
| proc removefakerow {id} { |
| global varcid varccommits parents children commitidx |
| global varctok vtokmod cmitlisted currentid selectedline |
| global targetid curview numcommits |
| |
| set v $curview |
| if {[llength $parents($v,$id)] != 1} { |
| puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents" |
| return |
| } |
| set p [lindex $parents($v,$id) 0] |
| set a $varcid($v,$id) |
| set i [lsearch -exact $varccommits($v,$a) $id] |
| if {$i < 0} { |
| puts "oops: removefakerow can't find [shortids $id] on arc $a" |
| return |
| } |
| unset varcid($v,$id) |
| set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i] |
| unset parents($v,$id) |
| unset children($v,$id) |
| unset cmitlisted($v,$id) |
| set numcommits [incr commitidx($v) -1] |
| set j [lsearch -exact $children($v,$p) $id] |
| if {$j >= 0} { |
| set children($v,$p) [lreplace $children($v,$p) $j $j] |
| } |
| modify_arc $v $a $i |
| if {[info exist currentid] && $id eq $currentid} { |
| unset currentid |
| set selectedline {} |
| } |
| if {[info exists targetid] && $targetid eq $id} { |
| set targetid $p |
| } |
| setcanvscroll |
| drawvisible |
| } |
| |
| proc real_children {vp} { |
| global children nullid nullid2 |
| |
| set kids {} |
| foreach id $children($vp) { |
| if {$id ne $nullid && $id ne $nullid2} { |
| lappend kids $id |
| } |
| } |
| return $kids |
| } |
| |
| proc first_real_child {vp} { |
| global children nullid nullid2 |
| |
| foreach id $children($vp) { |
| if {$id ne $nullid && $id ne $nullid2} { |
| return $id |
| } |
| } |
| return {} |
| } |
| |
| proc last_real_child {vp} { |
| global children nullid nullid2 |
| |
| set kids $children($vp) |
| for {set i [llength $kids]} {[incr i -1] >= 0} {} { |
| set id [lindex $kids $i] |
| if {$id ne $nullid && $id ne $nullid2} { |
| return $id |
| } |
| } |
| return {} |
| } |
| |
| proc vtokcmp {v a b} { |
| global varctok varcid |
| |
| return [string compare [lindex $varctok($v) $varcid($v,$a)] \ |
| [lindex $varctok($v) $varcid($v,$b)]] |
| } |
| |
| # This assumes that if lim is not given, the caller has checked that |
| # arc a's token is less than $vtokmod($v) |
| proc modify_arc {v a {lim {}}} { |
| global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits |
| |
| if {$lim ne {}} { |
| set c [string compare [lindex $varctok($v) $a] $vtokmod($v)] |
| if {$c > 0} return |
| if {$c == 0} { |
| set r [lindex $varcrow($v) $a] |
| if {$r ne {} && $vrowmod($v) <= $r + $lim} return |
| } |
| } |
| set vtokmod($v) [lindex $varctok($v) $a] |
| set varcmod($v) $a |
| if {$v == $curview} { |
| while {$a != 0 && [lindex $varcrow($v) $a] eq {}} { |
| set a [lindex $vupptr($v) $a] |
| set lim {} |
| } |
| set r 0 |
| if {$a != 0} { |
| if {$lim eq {}} { |
| set lim [llength $varccommits($v,$a)] |
| } |
| set r [expr {[lindex $varcrow($v) $a] + $lim}] |
| } |
| set vrowmod($v) $r |
| undolayout $r |
| } |
| } |
| |
| proc update_arcrows {v} { |
| global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline |
| global varcid vrownum varcorder varcix varccommits |
| global vupptr vdownptr vleftptr varctok |
| global displayorder parentlist curview cached_commitrow |
| |
| if {$vrowmod($v) == $commitidx($v)} return |
| if {$v == $curview} { |
| if {[llength $displayorder] > $vrowmod($v)} { |
| set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]] |
| set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]] |
| } |
| unset -nocomplain cached_commitrow |
| } |
| set narctot [expr {[llength $varctok($v)] - 1}] |
| set a $varcmod($v) |
| while {$a != 0 && [lindex $varcix($v) $a] eq {}} { |
| # go up the tree until we find something that has a row number, |
| # or we get to a seed |
| set a [lindex $vupptr($v) $a] |
| } |
| if {$a == 0} { |
| set a [lindex $vdownptr($v) 0] |
| if {$a == 0} return |
| set vrownum($v) {0} |
| set varcorder($v) [list $a] |
| lset varcix($v) $a 0 |
| lset varcrow($v) $a 0 |
| set arcn 0 |
| set row 0 |
| } else { |
| set arcn [lindex $varcix($v) $a] |
| if {[llength $vrownum($v)] > $arcn + 1} { |
| set vrownum($v) [lrange $vrownum($v) 0 $arcn] |
| set varcorder($v) [lrange $varcorder($v) 0 $arcn] |
| } |
| set row [lindex $varcrow($v) $a] |
| } |
| while {1} { |
| set p $a |
| incr row [llength $varccommits($v,$a)] |
| # go down if possible |
| set b [lindex $vdownptr($v) $a] |
| if {$b == 0} { |
| # if not, go left, or go up until we can go left |
| while {$a != 0} { |
| set b [lindex $vleftptr($v) $a] |
| if {$b != 0} break |
| set a [lindex $vupptr($v) $a] |
| } |
| if {$a == 0} break |
| } |
| set a $b |
| incr arcn |
| lappend vrownum($v) $row |
| lappend varcorder($v) $a |
| lset varcix($v) $a $arcn |
| lset varcrow($v) $a $row |
| } |
| set vtokmod($v) [lindex $varctok($v) $p] |
| set varcmod($v) $p |
| set vrowmod($v) $row |
| if {[info exists currentid]} { |
| set selectedline [rowofcommit $currentid] |
| } |
| } |
| |
| # Test whether view $v contains commit $id |
| proc commitinview {id v} { |
| global varcid |
| |
| return [info exists varcid($v,$id)] |
| } |
| |
| # Return the row number for commit $id in the current view |
| proc rowofcommit {id} { |
| global varcid varccommits varcrow curview cached_commitrow |
| global varctok vtokmod |
| |
| set v $curview |
| if {![info exists varcid($v,$id)]} { |
| puts "oops rowofcommit no arc for [shortids $id]" |
| return {} |
| } |
| set a $varcid($v,$id) |
| if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} { |
| update_arcrows $v |
| } |
| if {[info exists cached_commitrow($id)]} { |
| return $cached_commitrow($id) |
| } |
| set i [lsearch -exact $varccommits($v,$a) $id] |
| if {$i < 0} { |
| puts "oops didn't find commit [shortids $id] in arc $a" |
| return {} |
| } |
| incr i [lindex $varcrow($v) $a] |
| set cached_commitrow($id) $i |
| return $i |
| } |
| |
| # Returns 1 if a is on an earlier row than b, otherwise 0 |
| proc comes_before {a b} { |
| global varcid varctok curview |
| |
| set v $curview |
| if {$a eq $b || ![info exists varcid($v,$a)] || \ |
| ![info exists varcid($v,$b)]} { |
| return 0 |
| } |
| if {$varcid($v,$a) != $varcid($v,$b)} { |
| return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \ |
| [lindex $varctok($v) $varcid($v,$b)]] < 0}] |
| } |
| return [expr {[rowofcommit $a] < [rowofcommit $b]}] |
| } |
| |
| proc bsearch {l elt} { |
| if {[llength $l] == 0 || $elt <= [lindex $l 0]} { |
| return 0 |
| } |
| set lo 0 |
| set hi [llength $l] |
| while {$hi - $lo > 1} { |
| set mid [expr {int(($lo + $hi) / 2)}] |
| set t [lindex $l $mid] |
| if {$elt < $t} { |
| set hi $mid |
| } elseif {$elt > $t} { |
| set lo $mid |
| } else { |
| return $mid |
| } |
| } |
| return $lo |
| } |
| |
| # Make sure rows $start..$end-1 are valid in displayorder and parentlist |
| proc make_disporder {start end} { |
| global vrownum curview commitidx displayorder parentlist |
| global varccommits varcorder parents vrowmod varcrow |
| global d_valid_start d_valid_end |
| |
| if {$end > $vrowmod($curview)} { |
| update_arcrows $curview |
| } |
| set ai [bsearch $vrownum($curview) $start] |
| set start [lindex $vrownum($curview) $ai] |
| set narc [llength $vrownum($curview)] |
| for {set r $start} {$ai < $narc && $r < $end} {incr ai} { |
| set a [lindex $varcorder($curview) $ai] |
| set l [llength $displayorder] |
| set al [llength $varccommits($curview,$a)] |
| if {$l < $r + $al} { |
| if {$l < $r} { |
| set pad [ntimes [expr {$r - $l}] {}] |
| set displayorder [concat $displayorder $pad] |
| set parentlist [concat $parentlist $pad] |
| } elseif {$l > $r} { |
| set displayorder [lrange $displayorder 0 [expr {$r - 1}]] |
| set parentlist [lrange $parentlist 0 [expr {$r - 1}]] |
| } |
| foreach id $varccommits($curview,$a) { |
| lappend displayorder $id |
| lappend parentlist $parents($curview,$id) |
| } |
| } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} { |
| set i $r |
| foreach id $varccommits($curview,$a) { |
| lset displayorder $i $id |
| lset parentlist $i $parents($curview,$id) |
| incr i |
| } |
| } |
| incr r $al |
| } |
| } |
| |
| proc commitonrow {row} { |
| global displayorder |
| |
| set id [lindex $displayorder $row] |
| if {$id eq {}} { |
| make_disporder $row [expr {$row + 1}] |
| set id [lindex $displayorder $row] |
| } |
| return $id |
| } |
| |
| proc closevarcs {v} { |
| global varctok varccommits varcid parents children |
| global cmitlisted commitidx vtokmod |
| |
| set missing_parents 0 |
| set scripts {} |
| set narcs [llength $varctok($v)] |
| for {set a 1} {$a < $narcs} {incr a} { |
| set id [lindex $varccommits($v,$a) end] |
| foreach p $parents($v,$id) { |
| if {[info exists varcid($v,$p)]} continue |
| # add p as a new commit |
| incr missing_parents |
| set cmitlisted($v,$p) 0 |
| set parents($v,$p) {} |
| if {[llength $children($v,$p)] == 1 && |
| [llength $parents($v,$id)] == 1} { |
| set b $a |
| } else { |
| set b [newvarc $v $p] |
| } |
| set varcid($v,$p) $b |
| if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} { |
| modify_arc $v $b |
| } |
| lappend varccommits($v,$b) $p |
| incr commitidx($v) |
| set scripts [check_interest $p $scripts] |
| } |
| } |
| if {$missing_parents > 0} { |
| foreach s $scripts { |
| eval $s |
| } |
| } |
| } |
| |
| # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid |
| # Assumes we already have an arc for $rwid. |
| proc rewrite_commit {v id rwid} { |
| global children parents varcid varctok vtokmod varccommits |
| |
| foreach ch $children($v,$id) { |
| # make $rwid be $ch's parent in place of $id |
| set i [lsearch -exact $parents($v,$ch) $id] |
| if {$i < 0} { |
| puts "oops rewrite_commit didn't find $id in parent list for $ch" |
| } |
| set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid] |
| # add $ch to $rwid's children and sort the list if necessary |
| if {[llength [lappend children($v,$rwid) $ch]] > 1} { |
| set children($v,$rwid) [lsort -command [list vtokcmp $v] \ |
| $children($v,$rwid)] |
| } |
| # fix the graph after joining $id to $rwid |
| set a $varcid($v,$ch) |
| fix_reversal $rwid $a $v |
| # parentlist is wrong for the last element of arc $a |
| # even if displayorder is right, hence the 3rd arg here |
| modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}] |
| } |
| } |
| |
| # Mechanism for registering a command to be executed when we come |
| # across a particular commit. To handle the case when only the |
| # prefix of the commit is known, the commitinterest array is now |
| # indexed by the first 4 characters of the ID. Each element is a |
| # list of id, cmd pairs. |
| proc interestedin {id cmd} { |
| global commitinterest |
| |
| lappend commitinterest([string range $id 0 3]) $id $cmd |
| } |
| |
| proc check_interest {id scripts} { |
| global commitinterest |
| |
| set prefix [string range $id 0 3] |
| if {[info exists commitinterest($prefix)]} { |
| set newlist {} |
| foreach {i script} $commitinterest($prefix) { |
| if {[string match "$i*" $id]} { |
| lappend scripts [string map [list "%I" $id "%P" $i] $script] |
| } else { |
| lappend newlist $i $script |
| } |
| } |
| if {$newlist ne {}} { |
| set commitinterest($prefix) $newlist |
| } else { |
| unset commitinterest($prefix) |
| } |
| } |
| return $scripts |
| } |
| |
| proc getcommitlines {fd inst view updating} { |
| global cmitlisted leftover |
| global commitidx commitdata vdatemode |
| global parents children curview hlview |
| global idpending ordertok |
| global varccommits varcid varctok vtokmod vfilelimit vshortids |
| |
| set stuff [read $fd 500000] |
| # git log doesn't terminate the last commit with a null... |
| if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} { |
| set stuff "\0" |
| } |
| if {$stuff == {}} { |
| if {![eof $fd]} { |
| return 1 |
| } |
| global commfd viewcomplete viewactive viewname |
| global viewinstances |
| unset commfd($inst) |
| set i [lsearch -exact $viewinstances($view) $inst] |
| if {$i >= 0} { |
| set viewinstances($view) [lreplace $viewinstances($view) $i $i] |
| } |
| # set it blocking so we wait for the process to terminate |
| fconfigure $fd -blocking 1 |
| if {[catch {close $fd} err]} { |
| set fv {} |
| if {$view != $curview} { |
| set fv " for the \"$viewname($view)\" view" |
| } |
| if {[string range $err 0 4] == "usage"} { |
| set err "Gitk: error reading commits$fv:\ |
| bad arguments to git log." |
| if {$viewname($view) eq [mc "Command line"]} { |
| append err \ |
| " (Note: arguments to gitk are passed to git log\ |
| to allow selection of commits to be displayed.)" |
| } |
| } else { |
| set err "Error reading commits$fv: $err" |
| } |
| error_popup $err |
| } |
| if {[incr viewactive($view) -1] <= 0} { |
| set viewcomplete($view) 1 |
| # Check if we have seen any ids listed as parents that haven't |
| # appeared in the list |
| closevarcs $view |
| notbusy $view |
| } |
| if {$view == $curview} { |
| run chewcommits |
| } |
| return 0 |
| } |
| set start 0 |
| set gotsome 0 |
| set scripts {} |
| while 1 { |
| set i [string first "\0" $stuff $start] |
| if {$i < 0} { |
| append leftover($inst) [string range $stuff $start end] |
| break |
| } |
| if {$start == 0} { |
| set cmit $leftover($inst) |
| append cmit [string range $stuff 0 [expr {$i - 1}]] |
| set leftover($inst) {} |
| } else { |
| set cmit [string range $stuff $start [expr {$i - 1}]] |
| } |
| set start [expr {$i + 1}] |
| set j [string first "\n" $cmit] |
| set ok 0 |
| set listed 1 |
| if {$j >= 0 && [string match "commit *" $cmit]} { |
| set ids [string range $cmit 7 [expr {$j - 1}]] |
| if {[string match {[-^<>]*} $ids]} { |
| switch -- [string index $ids 0] { |
| "-" {set listed 0} |
| "^" {set listed 2} |
| "<" {set listed 3} |
| ">" {set listed 4} |
| } |
| set ids [string range $ids 1 end] |
| } |
| set ok 1 |
| foreach id $ids { |
| if {[string length $id] != 40} { |
| set ok 0 |
| break |
| } |
| } |
| } |
| if {!$ok} { |
| set shortcmit $cmit |
| if {[string length $shortcmit] > 80} { |
| set shortcmit "[string range $shortcmit 0 80]..." |
| } |
| error_popup "[mc "Can't parse git log output:"] {$shortcmit}" |
| exit 1 |
| } |
| set id [lindex $ids 0] |
| set vid $view,$id |
| |
| lappend vshortids($view,[string range $id 0 3]) $id |
| |
| if {!$listed && $updating && ![info exists varcid($vid)] && |
| $vfilelimit($view) ne {}} { |
| # git log doesn't rewrite parents for unlisted commits |
| # when doing path limiting, so work around that here |
| # by working out the rewritten parent with git rev-list |
| # and if we already know about it, using the rewritten |
| # parent as a substitute parent for $id's children. |
| if {![catch { |
| set rwid [exec git rev-list --first-parent --max-count=1 \ |
| $id -- $vfilelimit($view)] |
| }]} { |
| if {$rwid ne {} && [info exists varcid($view,$rwid)]} { |
| # use $rwid in place of $id |
| rewrite_commit $view $id $rwid |
| continue |
| } |
| } |
| } |
| |
| set a 0 |
| if {[info exists varcid($vid)]} { |
| if {$cmitlisted($vid) || !$listed} continue |
| set a $varcid($vid) |
| } |
| if {$listed} { |
| set olds [lrange $ids 1 end] |
| } else { |
| set olds {} |
| } |
| set commitdata($id) [string range $cmit [expr {$j + 1}] end] |
| set cmitlisted($vid) $listed |
| set parents($vid) $olds |
| if {![info exists children($vid)]} { |
| set children($vid) {} |
| } elseif {$a == 0 && [llength $children($vid)] == 1} { |
| set k [lindex $children($vid) 0] |
| if {[llength $parents($view,$k)] == 1 && |
| (!$vdatemode($view) || |
| $varcid($view,$k) == [llength $varctok($view)] - 1)} { |
| set a $varcid($view,$k) |
| } |
| } |
| if {$a == 0} { |
| # new arc |
| set a [newvarc $view $id] |
| } |
| if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} { |
| modify_arc $view $a |
| } |
| if {![info exists varcid($vid)]} { |
| set varcid($vid) $a |
| lappend varccommits($view,$a) $id |
| incr commitidx($view) |
| } |
| |
| set i 0 |
| foreach p $olds { |
| if {$i == 0 || [lsearch -exact $olds $p] >= $i} { |
| set vp $view,$p |
| if {[llength [lappend children($vp) $id]] > 1 && |
| [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} { |
| set children($vp) [lsort -command [list vtokcmp $view] \ |
| $children($vp)] |
| unset -nocomplain ordertok |
| } |
| if {[info exists varcid($view,$p)]} { |
| fix_reversal $p $a $view |
| } |
| } |
| incr i |
| } |
| |
| set scripts [check_interest $id $scripts] |
| set gotsome 1 |
| } |
| if {$gotsome} { |
| global numcommits hlview |
| |
| if {$view == $curview} { |
| set numcommits $commitidx($view) |
| run chewcommits |
| } |
| if {[info exists hlview] && $view == $hlview} { |
| # we never actually get here... |
| run vhighlightmore |
| } |
| foreach s $scripts { |
| eval $s |
| } |
| } |
| return 2 |
| } |
| |
| proc chewcommits {} { |
| global curview hlview viewcomplete |
| global pending_select |
| |
| layoutmore |
| if {$viewcomplete($curview)} { |
| global commitidx varctok |
| global numcommits startmsecs |
| |
| if {[info exists pending_select]} { |
| update |
| reset_pending_select {} |
| |
| if {[commitinview $pending_select $curview]} { |
| selectline [rowofcommit $pending_select] 1 |
| } else { |
| set row [first_real_row] |
| selectline $row 1 |
| } |
| } |
| if {$commitidx($curview) > 0} { |
| #set ms [expr {[clock clicks -milliseconds] - $startmsecs}] |
| #puts "overall $ms ms for $numcommits commits" |
| #puts "[llength $varctok($view)] arcs, $commitidx($view) commits" |
| } else { |
| show_status [mc "No commits selected"] |
| } |
| notbusy layout |
| } |
| return 0 |
| } |
| |
| proc do_readcommit {id} { |
| global tclencoding |
| |
| # Invoke git-log to handle automatic encoding conversion |
| set fd [open [concat | git log --no-color --pretty=raw -1 $id] r] |
| # Read the results using i18n.logoutputencoding |
| fconfigure $fd -translation lf -eofchar {} |
| if {$tclencoding != {}} { |
| fconfigure $fd -encoding $tclencoding |
| } |
| set contents [read $fd] |
| close $fd |
| # Remove the heading line |
| regsub {^commit [0-9a-f]+\n} $contents {} contents |
| |
| return $contents |
| } |
| |
| proc readcommit {id} { |
| if {[catch {set contents [do_readcommit $id]}]} return |
| parsecommit $id $contents 1 |
| } |
| |
| proc parsecommit {id contents listed} { |
| global commitinfo |
| |
| set inhdr 1 |
| set comment {} |
| set headline {} |
| set auname {} |
| set audate {} |
| set comname {} |
| set comdate {} |
| set hdrend [string first "\n\n" $contents] |
| if {$hdrend < 0} { |
| # should never happen... |
| set hdrend [string length $contents] |
| } |
| set header [string range $contents 0 [expr {$hdrend - 1}]] |
| set comment [string range $contents [expr {$hdrend + 2}] end] |
| foreach line [split $header "\n"] { |
| set line [split $line " "] |
| set tag [lindex $line 0] |
| if {$tag == "author"} { |
| set audate [lrange $line end-1 end] |
| set auname [join [lrange $line 1 end-2] " "] |
| } elseif {$tag == "committer"} { |
| set comdate [lrange $line end-1 end] |
| set comname [join [lrange $line 1 end-2] " "] |
| } |
| } |
| set headline {} |
| # take the first non-blank line of the comment as the headline |
| set headline [string trimleft $comment] |
| set i [string first "\n" $headline] |
| if {$i >= 0} { |
| set headline [string range $headline 0 $i] |
| } |
| set headline [string trimright $headline] |
| set i [string first "\r" $headline] |
| if {$i >= 0} { |
| set headline [string trimright [string range $headline 0 $i]] |
| } |
| if {!$listed} { |
| # git log indents the comment by 4 spaces; |
| # if we got this via git cat-file, add the indentation |
| set newcomment {} |
| foreach line [split $comment "\n"] { |
| append newcomment " " |
| append newcomment $line |
| append newcomment "\n" |
| } |
| set comment $newcomment |
| } |
| set hasnote [string first "\nNotes:\n" $contents] |
| set diff "" |
| # If there is diff output shown in the git-log stream, split it |
| # out. But get rid of the empty line that always precedes the |
| # diff. |
| set i [string first "\n\ndiff" $comment] |
| if {$i >= 0} { |
| set diff [string range $comment $i+1 end] |
| set comment [string range $comment 0 $i-1] |
| } |
| set commitinfo($id) [list $headline $auname $audate \ |
| $comname $comdate $comment $hasnote $diff] |
| } |
| |
| proc getcommit {id} { |
| global commitdata commitinfo |
| |
| if {[info exists commitdata($id)]} { |
| parsecommit $id $commitdata($id) 1 |
| } else { |
| readcommit $id |
| if {![info exists commitinfo($id)]} { |
| set commitinfo($id) [list [mc "No commit information available"]] |
| } |
| } |
| return 1 |
| } |
| |
| # Expand an abbreviated commit ID to a list of full 40-char IDs that match |
| # and are present in the current view. |
| # This is fairly slow... |
| proc longid {prefix} { |
| global varcid curview vshortids |
| |
| set ids {} |
| if {[string length $prefix] >= 4} { |
| set vshortid $curview,[string range $prefix 0 3] |
| if {[info exists vshortids($vshortid)]} { |
| foreach id $vshortids($vshortid) { |
| if {[string match "$prefix*" $id]} { |
| if {[lsearch -exact $ids $id] < 0} { |
| lappend ids $id |
| if {[llength $ids] >= 2} break |
| } |
| } |
| } |
| } |
| } else { |
| foreach match [array names varcid "$curview,$prefix*"] { |
| lappend ids [lindex [split $match ","] 1] |
| if {[llength $ids] >= 2} break |
| } |
| } |
| return $ids |
| } |
| |
| proc readrefs {} { |
| global tagids idtags headids idheads tagobjid |
| global otherrefids idotherrefs mainhead mainheadid |
| global selecthead selectheadid |
| global hideremotes |
| |
| foreach v {tagids idtags headids idheads otherrefids idotherrefs} { |
| unset -nocomplain $v |
| } |
| set refd [open [list | git show-ref -d] r] |
| while {[gets $refd line] >= 0} { |
| if {[string index $line 40] ne " "} continue |
| set id [string range $line 0 39] |
| set ref [string range $line 41 end] |
| if {![string match "refs/*" $ref]} continue |
| set name [string range $ref 5 end] |
| if {[string match "remotes/*" $name]} { |
| if {![string match "*/HEAD" $name] && !$hideremotes} { |
| set headids($name) $id |
| lappend idheads($id) $name |
| } |
| } elseif {[string match "heads/*" $name]} { |
| set name [string range $name 6 end] |
| set headids($name) $id |
| lappend idheads($id) $name |
| } elseif {[string match "tags/*" $name]} { |
| # this lets refs/tags/foo^{} overwrite refs/tags/foo, |
| # which is what we want since the former is the commit ID |
| set name [string range $name 5 end] |
| if {[string match "*^{}" $name]} { |
| set name [string range $name 0 end-3] |
| } else { |
| set tagobjid($name) $id |
| } |
| set tagids($name) $id |
| lappend idtags($id) $name |
| } else { |
| set otherrefids($name) $id |
| lappend idotherrefs($id) $name |
| } |
| } |
| catch {close $refd} |
| set mainhead {} |
| set mainheadid {} |
| catch { |
| set mainheadid [exec git rev-parse HEAD] |
| set thehead [exec git symbolic-ref HEAD] |
| if {[string match "refs/heads/*" $thehead]} { |
| set mainhead [string range $thehead 11 end] |
| } |
| } |
| set selectheadid {} |
| if {$selecthead ne {}} { |
| catch { |
| set selectheadid [exec git rev-parse --verify $selecthead] |
| } |
| } |
| } |
| |
| # skip over fake commits |
| proc first_real_row {} { |
| global nullid nullid2 numcommits |
| |
| for {set row 0} {$row < $numcommits} {incr row} { |
| set id [commitonrow $row] |
| if {$id ne $nullid && $id ne $nullid2} { |
| break |
| } |
| } |
| return $row |
| } |
| |
| # update things for a head moved to a child of its previous location |
| proc movehead {id name} { |
| global headids idheads |
| |
| removehead $headids($name) $name |
| set headids($name) $id |
| lappend idheads($id) $name |
| } |
| |
| # update things when a head has been removed |
| proc removehead {id name} { |
| global headids idheads |
| |
| if {$idheads($id) eq $name} { |
| unset idheads($id) |
| } else { |
| set i [lsearch -exact $idheads($id) $name] |
| if {$i >= 0} { |
| set idheads($id) [lreplace $idheads($id) $i $i] |
| } |
| } |
| unset headids($name) |
| } |
| |
| proc ttk_toplevel {w args} { |
| global use_ttk |
| eval [linsert $args 0 ::toplevel $w] |
| if {$use_ttk} { |
| place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1 |
| } |
| return $w |
| } |
| |
| proc make_transient {window origin} { |
| global have_tk85 |
| |
| # In MacOS Tk 8.4 transient appears to work by setting |
| # overrideredirect, which is utterly useless, since the |
| # windows get no border, and are not even kept above |
| # the parent. |
| if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return |
| |
| wm transient $window $origin |
| |
| # Windows fails to place transient windows normally, so |
| # schedule a callback to center them on the parent. |
| if {[tk windowingsystem] eq {win32}} { |
| after idle [list tk::PlaceWindow $window widget $origin] |
| } |
| } |
| |
| proc show_error {w top msg} { |
| global NS |
| if {![info exists NS]} {set NS ""} |
| if {[wm state $top] eq "withdrawn"} { wm deiconify $top } |
| message $w.m -text $msg -justify center -aspect 400 |
| pack $w.m -side top -fill x -padx 20 -pady 20 |
| ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top" |
| pack $w.ok -side bottom -fill x |
| bind $top <Visibility> "grab $top; focus $top" |
| bind $top <Key-Return> "destroy $top" |
| bind $top <Key-space> "destroy $top" |
| bind $top <Key-Escape> "destroy $top" |
| tkwait window $top |
| } |
| |
| proc error_popup {msg {owner .}} { |
| if {[tk windowingsystem] eq "win32"} { |
| tk_messageBox -icon error -type ok -title [wm title .] \ |
| -parent $owner -message $msg |
| } else { |
| set w .error |
| ttk_toplevel $w |
| make_transient $w $owner |
| show_error $w $w $msg |
| } |
| } |
| |
| proc confirm_popup {msg {owner .}} { |
| global confirm_ok NS |
| set confirm_ok 0 |
| set w .confirm |
| ttk_toplevel $w |
| make_transient $w $owner |
| message $w.m -text $msg -justify center -aspect 400 |
| pack $w.m -side top -fill x -padx 20 -pady 20 |
| ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w" |
| pack $w.ok -side left -fill x |
| ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w" |
| pack $w.cancel -side right -fill x |
| bind $w <Visibility> "grab $w; focus $w" |
| bind $w <Key-Return> "set confirm_ok 1; destroy $w" |
| bind $w <Key-space> "set confirm_ok 1; destroy $w" |
| bind $w <Key-Escape> "destroy $w" |
| tk::PlaceWindow $w widget $owner |
| tkwait window $w |
| return $confirm_ok |
| } |
| |
| proc setoptions {} { |
| global use_ttk |
| |
| if {[tk windowingsystem] ne "win32"} { |
| option add *Panedwindow.showHandle 1 startupFile |
| option add *Panedwindow.sashRelief raised startupFile |
| if {[tk windowingsystem] ne "aqua"} { |
| option add *Menu.font uifont startupFile |
| } |
| } else { |
| option add *Menu.TearOff 0 startupFile |
| } |
| option add *Button.font uifont startupFile |
| option add *Checkbutton.font uifont startupFile |
| option add *Radiobutton.font uifont startupFile |
| option add *Menubutton.font uifont startupFile |
| option add *Label.font uifont startupFile |
| option add *Message.font uifont startupFile |
| option add *Entry.font textfont startupFile |
| option add *Text.font textfont startupFile |
| option add *Labelframe.font uifont startupFile |
| option add *Spinbox.font textfont startupFile |
| option add *Listbox.font mainfont startupFile |
| } |
| |
| proc setttkstyle {} { |
| eval font configure TkDefaultFont [fontflags mainfont] |
| eval font configure TkTextFont [fontflags textfont] |
| eval font configure TkHeadingFont [fontflags mainfont] |
| eval font configure TkCaptionFont [fontflags mainfont] -weight bold |
| eval font configure TkTooltipFont [fontflags uifont] |
| eval font configure TkFixedFont [fontflags textfont] |
| eval font configure TkIconFont [fontflags uifont] |
| eval font configure TkMenuFont [fontflags uifont] |
| eval font configure TkSmallCaptionFont [fontflags uifont] |
| } |
| |
| # Make a menu and submenus. |
| # m is the window name for the menu, items is the list of menu items to add. |
| # Each item is a list {mc label type description options...} |
| # mc is ignored; it's so we can put mc there to alert xgettext |
| # label is the string that appears in the menu |
| # type is cascade, command or radiobutton (should add checkbutton) |
| # description depends on type; it's the sublist for cascade, the |
| # command to invoke for command, or {variable value} for radiobutton |
| proc makemenu {m items} { |
| menu $m |
| if {[tk windowingsystem] eq {aqua}} { |
| set Meta1 Cmd |
| } else { |
| set Meta1 Ctrl |
| } |
| foreach i $items { |
| set name [mc [lindex $i 1]] |
| set type [lindex $i 2] |
| set thing [lindex $i 3] |
| set params [list $type] |
| if {$name ne {}} { |
| set u [string first "&" [string map {&& x} $name]] |
| lappend params -label [string map {&& & & {}} $name] |
| if {$u >= 0} { |
| lappend params -underline $u |
| } |
| } |
| switch -- $type { |
| "cascade" { |
| set submenu [string tolower [string map {& ""} [lindex $i 1]]] |
| lappend params -menu $m.$submenu |
| } |
| "command" { |
| lappend params -command $thing |
| } |
| "radiobutton" { |
| lappend params -variable [lindex $thing 0] \ |
| -value [lindex $thing 1] |
| } |
| } |
| set tail [lrange $i 4 end] |
| regsub -all {\yMeta1\y} $tail $Meta1 tail |
| eval $m add $params $tail |
| if {$type eq "cascade"} { |
| makemenu $m.$submenu $thing |
| } |
| } |
| } |
| |
| # translate string and remove ampersands |
| proc mca {str} { |
| return [string map {&& & & {}} [mc $str]] |
| } |
| |
| proc cleardropsel {w} { |
| $w selection clear |
| } |
| proc makedroplist {w varname args} { |
| global use_ttk |
| if {$use_ttk} { |
| set width 0 |
| foreach label $args { |
| set cx [string length $label] |
| if {$cx > $width} {set width $cx} |
| } |
| set gm [ttk::combobox $w -width $width -state readonly\ |
| -textvariable $varname -values $args \ |
| -exportselection false] |
| bind $gm <<ComboboxSelected>> [list $gm selection clear] |
| } else { |
| set gm [eval [linsert $args 0 tk_optionMenu $w $varname]] |
| } |
| return $gm |
| } |
| |
| proc makewindow {} { |
| global canv canv2 canv3 linespc charspc ctext cflist cscroll |
| global tabstop |
| global findtype findtypemenu findloc findstring fstring geometry |
| global entries sha1entry sha1string sha1but |
| global diffcontextstring diffcontext |
| global ignorespace |
| global maincursor textcursor curtextcursor |
| global rowctxmenu fakerowmenu mergemax wrapcomment |
| global highlight_files gdttype |
| global searchstring sstring |
| global bgcolor fgcolor bglist fglist diffcolors selectbgcolor |
| global uifgcolor uifgdisabledcolor |
| global filesepbgcolor filesepfgcolor |
| global mergecolors foundbgcolor currentsearchhitbgcolor |
| global headctxmenu progresscanv progressitem progresscoords statusw |
| global fprogitem fprogcoord lastprogupdate progupdatepending |
| global rprogitem rprogcoord rownumsel numcommits |
| global have_tk85 use_ttk NS |
| global git_version |
| global worddiff |
| |
| # The "mc" arguments here are purely so that xgettext |
| # sees the following string as needing to be translated |
| set file { |
| mc "&File" cascade { |
| {mc "&Update" command updatecommits -accelerator F5} |
| {mc "&Reload" command reloadcommits -accelerator Shift-F5} |
| {mc "Reread re&ferences" command rereadrefs} |
| {mc "&List references" command showrefs -accelerator F2} |
| {xx "" separator} |
| {mc "Start git &gui" command {exec git gui &}} |
| {xx "" separator} |
| {mc "&Quit" command doquit -accelerator Meta1-Q} |
| }} |
| set edit { |
| mc "&Edit" cascade { |
| {mc "&Preferences" command doprefs} |
| }} |
| set view { |
| mc "&View" cascade { |
| {mc "&New view..." command {newview 0} -accelerator Shift-F4} |
| {mc "&Edit view..." command editview -state disabled -accelerator F4} |
| {mc "&Delete view" command delview -state disabled} |
| {xx "" separator} |
| {mc "&All files" radiobutton {selectedview 0} -command {showview 0}} |
| }} |
| if {[tk windowingsystem] ne "aqua"} { |
| set help { |
| mc "&Help" cascade { |
| {mc "&About gitk" command about} |
| {mc "&Key bindings" command keys} |
| }} |
| set bar [list $file $edit $view $help] |
| } else { |
| proc ::tk::mac::ShowPreferences {} {doprefs} |
| proc ::tk::mac::Quit {} {doquit} |
| lset file end [lreplace [lindex $file end] end-1 end] |
| set apple { |
| xx "&Apple" cascade { |
| {mc "&About gitk" command about} |
| {xx "" separator} |
| }} |
| set help { |
| mc "&Help" cascade { |
| {mc "&Key bindings" command keys} |
| }} |
| set bar [list $apple $file $view $help] |
| } |
| makemenu .bar $bar |
| . configure -menu .bar |
| |
| if {$use_ttk} { |
| # cover the non-themed toplevel with a themed frame. |
| place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1 |
| } |
| |
| # the gui has upper and lower half, parts of a paned window. |
| ${NS}::panedwindow .ctop -orient vertical |
| |
| # possibly use assumed geometry |
| if {![info exists geometry(pwsash0)]} { |
| set geometry(topheight) [expr {15 * $linespc}] |
| set geometry(topwidth) [expr {80 * $charspc}] |
| set geometry(botheight) [expr {15 * $linespc}] |
| set geometry(botwidth) [expr {50 * $charspc}] |
| set geometry(pwsash0) [list [expr {40 * $charspc}] 2] |
| set geometry(pwsash1) [list [expr {60 * $charspc}] 2] |
| } |
| |
| # the upper half will have a paned window, a scroll bar to the right, and some stuff below |
| ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth) |
| ${NS}::frame .tf.histframe |
| ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal |
| if {!$use_ttk} { |
| .tf.histframe.pwclist configure -sashpad 0 -handlesize 4 |
| } |
| |
| # create three canvases |
| set cscroll .tf.histframe.csb |
| set canv .tf.histframe.pwclist.canv |
| canvas $canv \ |
| -selectbackground $selectbgcolor \ |
| -background $bgcolor -bd 0 \ |
| -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll" |
| .tf.histframe.pwclist add $canv |
| set canv2 .tf.histframe.pwclist.canv2 |
| canvas $canv2 \ |
| -selectbackground $selectbgcolor \ |
| -background $bgcolor -bd 0 -yscrollincr $linespc |
| .tf.histframe.pwclist add $canv2 |
| set canv3 .tf.histframe.pwclist.canv3 |
| canvas $canv3 \ |
| -selectbackground $selectbgcolor \ |
| -background $bgcolor -bd 0 -yscrollincr $linespc |
| .tf.histframe.pwclist add $canv3 |
| if {$use_ttk} { |
| bind .tf.histframe.pwclist <Map> { |
| bind %W <Map> {} |
| .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0] |
| .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0] |
| } |
| } else { |
| eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0) |
| eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1) |
| } |
| |
| # a scroll bar to rule them |
| ${NS}::scrollbar $cscroll -command {allcanvs yview} |
| if {!$use_ttk} {$cscroll configure -highlightthickness 0} |
| pack $cscroll -side right -fill y |
| bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w} |
| lappend bglist $canv $canv2 $canv3 |
| pack .tf.histframe.pwclist -fill both -expand 1 -side left |
| |
| # we have two button bars at bottom of top frame. Bar 1 |
| ${NS}::frame .tf.bar |
| ${NS}::frame .tf.lbar -height 15 |
| |
| set sha1entry .tf.bar.sha1 |
| set entries $sha1entry |
| set sha1but .tf.bar.sha1label |
| button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \ |
| -command gotocommit -width 8 |
| $sha1but conf -disabledforeground [$sha1but cget -foreground] |
| pack .tf.bar.sha1label -side left |
| ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string |
| trace add variable sha1string write sha1change |
| pack $sha1entry -side left -pady 2 |
| |
| set bm_left_data { |
| #define left_width 16 |
| #define left_height 16 |
| static unsigned char left_bits[] = { |
| 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00, |
| 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00, |
| 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01}; |
| } |
| set bm_right_data { |
| #define right_width 16 |
| #define right_height 16 |
| static unsigned char right_bits[] = { |
| 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c, |
| 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c, |
| 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01}; |
| } |
| image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor |
| image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor |
| image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor |
| image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor |
| |
| ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26 |
| if {$use_ttk} { |
| .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray] |
| } else { |
| .tf.bar.leftbut configure -image bm-left |
| } |
| pack .tf.bar.leftbut -side left -fill y |
| ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26 |
| if {$use_ttk} { |
| .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray] |
| } else { |
| .tf.bar.rightbut configure -image bm-right |
| } |
| pack .tf.bar.rightbut -side left -fill y |
| |
| ${NS}::label .tf.bar.rowlabel -text [mc "Row"] |
| set rownumsel {} |
| ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \ |
| -relief sunken -anchor e |
| ${NS}::label .tf.bar.rowlabel2 -text "/" |
| ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \ |
| -relief sunken -anchor e |
| pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \ |
| -side left |
| if {!$use_ttk} { |
| foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont} |
| } |
| global selectedline |
| trace add variable selectedline write selectedline_change |
| |
| # Status label and progress bar |
| set statusw .tf.bar.status |
| ${NS}::label $statusw -width 15 -relief sunken |
| pack $statusw -side left -padx 5 |
| if {$use_ttk} { |
| set progresscanv [ttk::progressbar .tf.bar.progress] |
| } else { |
| set h [expr {[font metrics uifont -linespace] + 2}] |
| set progresscanv .tf.bar.progress |
| canvas $progresscanv -relief sunken -height $h -borderwidth 2 |
| set progressitem [$progresscanv create rect -1 0 0 $h -fill lime] |
| set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow] |
| set rprogitem [$progresscanv create rect -1 0 0 $h -fill red] |
| } |
| pack $progresscanv -side right -expand 1 -fill x -padx {0 2} |
| set progresscoords {0 0} |
| set fprogcoord 0 |
| set rprogcoord 0 |
| bind $progresscanv <Configure> adjustprogress |
| set lastprogupdate [clock clicks -milliseconds] |
| set progupdatepending 0 |
| |
| # build up the bottom bar of upper window |
| ${NS}::label .tf.lbar.flabel -text "[mc "Find"] " |
| |
| set bm_down_data { |
| #define down_width 16 |
| #define down_height 16 |
| static unsigned char down_bits[] = { |
| 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, |
| 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, |
| 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d, |
| 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01}; |
| } |
| image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor |
| ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1} |
| .tf.lbar.fnext configure -image bm-down |
| |
| set bm_up_data { |
| #define up_width 16 |
| #define up_height 16 |
| static unsigned char up_bits[] = { |
| 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f, |
| 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1, |
| 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, |
| 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01}; |
| } |
| image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor |
| ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1} |
| .tf.lbar.fprev configure -image bm-up |
| |
| ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] " |
| |
| pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \ |
| -side left -fill y |
| set gdttype [mc "containing:"] |
| set gm [makedroplist .tf.lbar.gdttype gdttype \ |
| [mc "containing:"] \ |
| [mc "touching paths:"] \ |
| [mc "adding/removing string:"] \ |
| [mc "changing lines matching:"]] |
| trace add variable gdttype write gdttype_change |
| pack .tf.lbar.gdttype -side left -fill y |
| |
| set findstring {} |
| set fstring .tf.lbar.findstring |
| lappend entries $fstring |
| ${NS}::entry $fstring -width 30 -textvariable findstring |
| trace add variable findstring write find_change |
| set findtype [mc "Exact"] |
| set findtypemenu [makedroplist .tf.lbar.findtype \ |
| findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]] |
| trace add variable findtype write findcom_change |
| set findloc [mc "All fields"] |
| makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \ |
| [mc "Comments"] [mc "Author"] [mc "Committer"] |
| trace add variable findloc write find_change |
| pack .tf.lbar.findloc -side right |
| pack .tf.lbar.findtype -side right |
| pack $fstring -side left -expand 1 -fill x |
| |
| # Finish putting the upper half of the viewer together |
| pack .tf.lbar -in .tf -side bottom -fill x |
| pack .tf.bar -in .tf -side bottom -fill x |
| pack .tf.histframe -fill both -side top -expand 1 |
| .ctop add .tf |
| if {!$use_ttk} { |
| .ctop paneconfigure .tf -height $geometry(topheight) |
| .ctop paneconfigure .tf -width $geometry(topwidth) |
| } |
| |
| # now build up the bottom |
| ${NS}::panedwindow .pwbottom -orient horizontal |
| |
| # lower left, a text box over search bar, scroll bar to the right |
| # if we know window height, then that will set the lower text height, otherwise |
| # we set lower text height which will drive window height |
| if {[info exists geometry(main)]} { |
| ${NS}::frame .bleft -width $geometry(botwidth) |
| } else { |
| ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight) |
| } |
| ${NS}::frame .bleft.top |
| ${NS}::frame .bleft.mid |
| ${NS}::frame .bleft.bottom |
| |
| # gap between sub-widgets |
| set wgap [font measure uifont "i"] |
| |
| ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch |
| pack .bleft.top.search -side left -padx 5 |
| set sstring .bleft.top.sstring |
| set searchstring "" |
| ${NS}::entry $sstring -width 20 -textvariable searchstring |
| lappend entries $sstring |
| trace add variable searchstring write incrsearch |
| pack $sstring -side left -expand 1 -fill x |
| ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \ |
| -command changediffdisp -variable diffelide -value {0 0} |
| ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \ |
| -command changediffdisp -variable diffelide -value {0 1} |
| ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \ |
| -command changediffdisp -variable diffelide -value {1 0} |
| |
| ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: " |
| pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left -ipadx $wgap |
| spinbox .bleft.mid.diffcontext -width 5 \ |
| -from 0 -increment 1 -to 10000000 \ |
| -validate all -validatecommand "diffcontextvalidate %P" \ |
| -textvariable diffcontextstring |
| .bleft.mid.diffcontext set $diffcontext |
| trace add variable diffcontextstring write diffcontextchange |
| lappend entries .bleft.mid.diffcontext |
| pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left -ipadx $wgap |
| ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \ |
| -command changeignorespace -variable ignorespace |
| pack .bleft.mid.ignspace -side left -padx 5 |
| |
| set worddiff [mc "Line diff"] |
| if {[package vcompare $git_version "1.7.2"] >= 0} { |
| makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \ |
| [mc "Markup words"] [mc "Color words"] |
| trace add variable worddiff write changeworddiff |
| pack .bleft.mid.worddiff -side left -padx 5 |
| } |
| |
| set ctext .bleft.bottom.ctext |
| text $ctext -background $bgcolor -foreground $fgcolor \ |
| -state disabled -font textfont \ |
| -yscrollcommand scrolltext -wrap none \ |
| -xscrollcommand ".bleft.bottom.sbhorizontal set" |
| if {$have_tk85} { |
| $ctext conf -tabstyle wordprocessor |
| } |
| ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview" |
| ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h |
| pack .bleft.top -side top -fill x |
| pack .bleft.mid -side top -fill x |
| grid $ctext .bleft.bottom.sb -sticky nsew |
| grid .bleft.bottom.sbhorizontal -sticky ew |
| grid columnconfigure .bleft.bottom 0 -weight 1 |
| grid rowconfigure .bleft.bottom 0 -weight 1 |
| grid rowconfigure .bleft.bottom 1 -weight 0 |
| pack .bleft.bottom -side top -fill both -expand 1 |
| lappend bglist $ctext |
| lappend fglist $ctext |
| |
| $ctext tag conf comment -wrap $wrapcomment |
| $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor |
| $ctext tag conf hunksep -fore [lindex $diffcolors 2] |
| $ctext tag conf d0 -fore [lindex $diffcolors 0] |
| $ctext tag conf dresult -fore [lindex $diffcolors 1] |
| $ctext tag conf m0 -fore [lindex $mergecolors 0] |
| $ctext tag conf m1 -fore [lindex $mergecolors 1] |
| $ctext tag conf m2 -fore [lindex $mergecolors 2] |
| $ctext tag conf m3 -fore [lindex $mergecolors 3] |
| $ctext tag conf m4 -fore [lindex $mergecolors 4] |
| $ctext tag conf m5 -fore [lindex $mergecolors 5] |
| $ctext tag conf m6 -fore [lindex $mergecolors 6] |
| $ctext tag conf m7 -fore [lindex $mergecolors 7] |
| $ctext tag conf m8 -fore [lindex $mergecolors 8] |
| $ctext tag conf m9 -fore [lindex $mergecolors 9] |
| $ctext tag conf m10 -fore [lindex $mergecolors 10] |
| $ctext tag conf m11 -fore [lindex $mergecolors 11] |
| $ctext tag conf m12 -fore [lindex $mergecolors 12] |
| $ctext tag conf m13 -fore [lindex $mergecolors 13] |
| $ctext tag conf m14 -fore [lindex $mergecolors 14] |
| $ctext tag conf m15 -fore [lindex $mergecolors 15] |
| $ctext tag conf mmax -fore darkgrey |
| set mergemax 16 |
| $ctext tag conf mresult -font textfontbold |
| $ctext tag conf msep -font textfontbold |
| $ctext tag conf found -back $foundbgcolor |
| $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor |
| $ctext tag conf wwrap -wrap word -lmargin2 1c |
| $ctext tag conf bold -font textfontbold |
| |
| .pwbottom add .bleft |
| if {!$use_ttk} { |
| .pwbottom paneconfigure .bleft -width $geometry(botwidth) |
| } |
| |
| # lower right |
| ${NS}::frame .bright |
| ${NS}::frame .bright.mode |
| ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \ |
| -command reselectline -variable cmitmode -value "patch" |
| ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \ |
| -command reselectline -variable cmitmode -value "tree" |
| grid .bright.mode.patch .bright.mode.tree -sticky ew |
| pack .bright.mode -side top -fill x |
| set cflist .bright.cfiles |
| set indent [font measure mainfont "nn"] |
| text $cflist \ |
| -selectbackground $selectbgcolor \ |
| -background $bgcolor -foreground $fgcolor \ |
| -font mainfont \ |
| -tabs [list $indent [expr {2 * $indent}]] \ |
| -yscrollcommand ".bright.sb set" \ |
| -cursor [. cget -cursor] \ |
| -spacing1 1 -spacing3 1 |
| lappend bglist $cflist |
| lappend fglist $cflist |
| ${NS}::scrollbar .bright.sb -command "$cflist yview" |
| pack .bright.sb -side right -fill y |
| pack $cflist -side left -fill both -expand 1 |
| $cflist tag configure highlight \ |
| -background [$cflist cget -selectbackground] |
| $cflist tag configure bold -font mainfontbold |
| |
| .pwbottom add .bright |
| .ctop add .pwbottom |
| |
| # restore window width & height if known |
| if {[info exists geometry(main)]} { |
| if {[scan $geometry(main) "%dx%d" w h] >= 2} { |
| if {$w > [winfo screenwidth .]} { |
| set w [winfo screenwidth .] |
| } |
| if {$h > [winfo screenheight .]} { |
| set h [winfo screenheight .] |
| } |
| wm geometry . "${w}x$h" |
| } |
| } |
| |
| if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} { |
| wm state . $geometry(state) |
| } |
| |
| if {[tk windowingsystem] eq {aqua}} { |
| set M1B M1 |
| set ::BM "3" |
| } else { |
| set M1B Control |
| set ::BM "2" |
| } |
| |
| if {$use_ttk} { |
| bind .ctop <Map> { |
| bind %W <Map> {} |
| %W sashpos 0 $::geometry(topheight) |
| } |
| bind .pwbottom <Map> { |
| bind %W <Map> {} |
| %W sashpos 0 $::geometry(botwidth) |
| } |
| } |
| |
| bind .pwbottom <Configure> {resizecdetpanes %W %w} |
| pack .ctop -fill both -expand 1 |
| bindall <1> {selcanvline %W %x %y} |
| #bindall <B1-Motion> {selcanvline %W %x %y} |
| if {[tk windowingsystem] == "win32"} { |
| bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D } |
| bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break } |
| } else { |
| bindall <ButtonRelease-4> "allcanvs yview scroll -5 units" |
| bindall <ButtonRelease-5> "allcanvs yview scroll 5 units" |
| bind $ctext <Button> { |
| if {"%b" eq 6} { |
| $ctext xview scroll -5 units |
| } elseif {"%b" eq 7} { |
| $ctext xview scroll 5 units |
| } |
| } |
| if {[tk windowingsystem] eq "aqua"} { |
| bindall <MouseWheel> { |
| set delta [expr {- (%D)}] |
| allcanvs yview scroll $delta units |
| } |
| bindall <Shift-MouseWheel> { |
| set delta [expr {- (%D)}] |
| $canv xview scroll $delta units |
| } |
| } |
| } |
| bindall <$::BM> "canvscan mark %W %x %y" |
| bindall <B$::BM-Motion> "canvscan dragto %W %x %y" |
| bind all <$M1B-Key-w> {destroy [winfo toplevel %W]} |
| bind . <$M1B-Key-w> doquit |
| bindkey <Home> selfirstline |
| bindkey <End> sellastline |
| bind . <Key-Up> "selnextline -1" |
| bind . <Key-Down> "selnextline 1" |
| bind . <Shift-Key-Up> "dofind -1 0" |
| bind . <Shift-Key-Down> "dofind 1 0" |
| bindkey <Key-Right> "goforw" |
| bindkey <Key-Left> "goback" |
| bind . <Key-Prior> "selnextpage -1" |
| bind . <Key-Next> "selnextpage 1" |
| bind . <$M1B-Home> "allcanvs yview moveto 0.0" |
| bind . <$M1B-End> "allcanvs yview moveto 1.0" |
| bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units" |
| bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units" |
| bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages" |
| bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages" |
| bindkey <Key-Delete> "$ctext yview scroll -1 pages" |
| bindkey <Key-BackSpace> "$ctext yview scroll -1 pages" |
| bindkey <Key-space> "$ctext yview scroll 1 pages" |
| bindkey p "selnextline -1" |
| bindkey n "selnextline 1" |
| bindkey z "goback" |
| bindkey x "goforw" |
| bindkey k "selnextline -1" |
| bindkey j "selnextline 1" |
| bindkey h "goback" |
| bindkey l "goforw" |
| bindkey b prevfile |
| bindkey d "$ctext yview scroll 18 units" |
| bindkey u "$ctext yview scroll -18 units" |
| bindkey g {$sha1entry delete 0 end; focus $sha1entry} |
| bindkey / {focus $fstring} |
| bindkey <Key-KP_Divide> {focus $fstring} |
| bindkey <Key-Return> {dofind 1 1} |
| bindkey ? {dofind -1 1} |
| bindkey f nextfile |
| bind . <F5> updatecommits |
| bindmodfunctionkey Shift 5 reloadcommits |
| bind . <F2> showrefs |
| bindmodfunctionkey Shift 4 {newview 0} |
| bind . <F4> edit_or_newview |
| bind . <$M1B-q> doquit |
| bind . <$M1B-f> {dofind 1 1} |
| bind . <$M1B-g> {dofind 1 0} |
| bind . <$M1B-r> dosearchback |
| bind . <$M1B-s> dosearch |
| bind . <$M1B-equal> {incrfont 1} |
| bind . <$M1B-plus> {incrfont 1} |
| bind . <$M1B-KP_Add> {incrfont 1} |
| bind . <$M1B-minus> {incrfont -1} |
| bind . <$M1B-KP_Subtract> {incrfont -1} |
| wm protocol . WM_DELETE_WINDOW doquit |
| bind . <Destroy> {stop_backends} |
| bind . <Button-1> "click %W" |
| bind $fstring <Key-Return> {dofind 1 1} |
| bind $sha1entry <Key-Return> {gotocommit; break} |
| bind $sha1entry <<PasteSelection>> clearsha1 |
| bind $sha1entry <<Paste>> clearsha1 |
| bind $cflist <1> {sel_flist %W %x %y; break} |
| bind $cflist <B1-Motion> {sel_flist %W %x %y; break} |
| bind $cflist <ButtonRelease-1> {treeclick %W %x %y} |
| global ctxbut |
| bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y} |
| bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y} |
| bind $ctext <Button-1> {focus %W} |
| bind $ctext <<Selection>> rehighlight_search_results |
| for {set i 1} {$i < 10} {incr i} { |
| bind . <$M1B-Key-$i> [list go_to_parent $i] |
| } |
| |
| set maincursor [. cget -cursor] |
| set textcursor [$ctext cget -cursor] |
| set curtextcursor $textcursor |
| |
| set rowctxmenu .rowctxmenu |
| makemenu $rowctxmenu { |
| {mc "Diff this -> selected" command {diffvssel 0}} |
| {mc "Diff selected -> this" command {diffvssel 1}} |
| {mc "Make patch" command mkpatch} |
| {mc "Create tag" command mktag} |
| {mc "Copy commit summary" command copysummary} |
| {mc "Write commit to file" command writecommit} |
| {mc "Create new branch" command mkbranch} |
| {mc "Cherry-pick this commit" command cherrypick} |
| {mc "Reset HEAD branch to here" command resethead} |
| {mc "Mark this commit" command markhere} |
| {mc "Return to mark" command gotomark} |
| {mc "Find descendant of this and mark" command find_common_desc} |
| {mc "Compare with marked commit" command compare_commits} |
| {mc "Diff this -> marked commit" command {diffvsmark 0}} |
| {mc "Diff marked commit -> this" command {diffvsmark 1}} |
| {mc "Revert this commit" command revert} |
| } |
| $rowctxmenu configure -tearoff 0 |
| |
| set fakerowmenu .fakerowmenu |
| makemenu $fakerowmenu { |
| {mc "Diff this -> selected" command {diffvssel 0}} |
| {mc "Diff selected -> this" command {diffvssel 1}} |
| {mc "Make patch" command mkpatch} |
| {mc "Diff this -> marked commit" command {diffvsmark 0}} |
| {mc "Diff marked commit -> this" command {diffvsmark 1}} |
| } |
| $fakerowmenu configure -tearoff 0 |
| |
| set headctxmenu .headctxmenu |
| makemenu $headctxmenu { |
| {mc "Check out this branch" command cobranch} |
| {mc "Remove this branch" command rmbranch} |
| {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}} |
| } |
| $headctxmenu configure -tearoff 0 |
| |
| global flist_menu |
| set flist_menu .flistctxmenu |
| makemenu $flist_menu { |
| {mc "Highlight this too" command {flist_hl 0}} |
| {mc "Highlight this only" command {flist_hl 1}} |
| {mc "External diff" command {external_diff}} |
| {mc "Blame parent commit" command {external_blame 1}} |
| {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}} |
| } |
| $flist_menu configure -tearoff 0 |
| |
| global diff_menu |
| set diff_menu .diffctxmenu |
| makemenu $diff_menu { |
| {mc "Show origin of this line" command show_line_source} |
| {mc "Run git gui blame on this line" command {external_blame_diff}} |
| } |
| $diff_menu configure -tearoff 0 |
| } |
| |
| # Windows sends all mouse wheel events to the current focused window, not |
| # the one where the mouse hovers, so bind those events here and redirect |
| # to the correct window |
| proc windows_mousewheel_redirector {W X Y D} { |
| global canv canv2 canv3 |
| set w [winfo containing -displayof $W $X $Y] |
| if {$w ne ""} { |
| set u [expr {$D < 0 ? 5 : -5}] |
| if {$w == $canv || $w == $canv2 || $w == $canv3} { |
| allcanvs yview scroll $u units |
| } else { |
| catch { |
| $w yview scroll $u units |
| } |
| } |
| } |
| } |
| |
| # Update row number label when selectedline changes |
| proc selectedline_change {n1 n2 op} { |
| global selectedline rownumsel |
| |
| if {$selectedline eq {}} { |
| set rownumsel {} |
| } else { |
| set rownumsel [expr {$selectedline + 1}] |
| } |
| } |
| |
| # mouse-2 makes all windows scan vertically, but only the one |
| # the cursor is in scans horizontally |
| proc canvscan {op w x y} { |
| global canv canv2 canv3 |
| foreach c [list $canv $canv2 $canv3] { |
| if {$c == $w} { |
| $c scan $op $x $y |
| } else { |
| $c scan $op 0 $y |
| } |
| } |
| } |
| |
| proc scrollcanv {cscroll f0 f1} { |
| $cscroll set $f0 $f1 |
| drawvisible |
| flushhighlights |
| } |
| |
| # when we make a key binding for the toplevel, make sure |
| # it doesn't get triggered when that key is pressed in the |
| # find string entry widget. |
| proc bindkey {ev script} { |
| global entries |
| bind . $ev $script |
| set escript [bind Entry $ev] |
| if {$escript == {}} { |
| set escript [bind Entry <Key>] |
| } |
| foreach e $entries { |
| bind $e $ev "$escript; break" |
| } |
| } |
| |
| proc bindmodfunctionkey {mod n script} { |
| bind . <$mod-F$n> $script |
| catch { bind . <$mod-XF86_Switch_VT_$n> $script } |
| } |
| |
| # set the focus back to the toplevel for any click outside |
| # the entry widgets |
| proc click {w} { |
| global ctext entries |
| foreach e [concat $entries $ctext] { |
| if {$w == $e} return |
| } |
| focus . |
| } |
| |
| # Adjust the progress bar for a change in requested extent or canvas size |
| proc adjustprogress {} { |
| global progresscanv progressitem progresscoords |
| global fprogitem fprogcoord lastprogupdate progupdatepending |
| global rprogitem rprogcoord use_ttk |
| |
| if {$use_ttk} { |
| $progresscanv configure -value [expr {int($fprogcoord * 100)}] |
| return |
| } |
| |
| set w [expr {[winfo width $progresscanv] - 4}] |
| set x0 [expr {$w * [lindex $progresscoords 0]}] |
| set x1 [expr {$w * [lindex $progresscoords 1]}] |
| set h [winfo height $progresscanv] |
| $progresscanv coords $progressitem $x0 0 $x1 $h |
| $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h |
| $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h |
| set now [clock clicks -milliseconds] |
| if {$now >= $lastprogupdate + 100} { |
| set progupdatepending 0 |
| update |
| } elseif {!$progupdatepending} { |
| set progupdatepending 1 |
| after [expr {$lastprogupdate + 100 - $now}] doprogupdate |
| } |
| } |
| |
| proc doprogupdate {} { |
| global lastprogupdate progupdatepending |
| |
| if {$progupdatepending} { |
| set progupdatepending 0 |
| set lastprogupdate [clock clicks -milliseconds] |
| update |
| } |
| } |
| |
| proc config_check_tmp_exists {tries_left} { |
| global config_file_tmp |
| |
| if {[file exists $config_file_tmp]} { |
| incr tries_left -1 |
| if {$tries_left > 0} { |
| after 100 [list config_check_tmp_exists $tries_left] |
| } else { |
| error_popup "There appears to be a stale $config_file_tmp\ |
| file, which will prevent gitk from saving its configuration on exit.\ |
| Please remove it if it is not being used by any existing gitk process." |
| } |
| } |
| } |
| |
| proc config_init_trace {name} { |
| global config_variable_changed config_variable_original |
| |
| upvar #0 $name var |
| set config_variable_changed($name) 0 |
| set config_variable_original($name) $var |
| } |
| |
| proc config_variable_change_cb {name name2 op} { |
| global config_variable_changed config_variable_original |
| |
| upvar #0 $name var |
| if {$op eq "write" && |
| (![info exists config_variable_original($name)] || |
| $config_variable_original($name) ne $var)} { |
| set config_variable_changed($name) 1 |
| } |
| } |
| |
| proc savestuff {w} { |
| global stuffsaved |
| global config_file config_file_tmp |
| global config_variables config_variable_changed |
| global viewchanged |
| |
| upvar #0 viewname current_viewname |
| upvar #0 viewfiles current_viewfiles |
| upvar #0 viewargs current_viewargs |
| upvar #0 viewargscmd current_viewargscmd |
| upvar #0 viewperm current_viewperm |
| upvar #0 nextviewnum current_nextviewnum |
| upvar #0 use_ttk current_use_ttk |
| |
| if {$stuffsaved} return |
| if {![winfo viewable .]} return |
| set remove_tmp 0 |
| if {[catch { |
| set try_count 0 |
| while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} { |
| if {[incr try_count] > 50} { |
| error "Unable to write config file: $config_file_tmp exists" |
| } |
| after 100 |
| } |
| set remove_tmp 1 |
| if {$::tcl_platform(platform) eq {windows}} { |
| file attributes $config_file_tmp -hidden true |
| } |
| if {[file exists $config_file]} { |
| source $config_file |
| } |
| foreach var_name $config_variables { |
| upvar #0 $var_name var |
| upvar 0 $var_name old_var |
| if {!$config_variable_changed($var_name) && [info exists old_var]} { |
| puts $f [list set $var_name $old_var] |
| } else { |
| puts $f [list set $var_name $var] |
| } |
| } |
| |
| puts $f "set geometry(main) [wm geometry .]" |
| puts $f "set geometry(state) [wm state .]" |
| puts $f "set geometry(topwidth) [winfo width .tf]" |
| puts $f "set geometry(topheight) [winfo height .tf]" |
| if {$current_use_ttk} { |
| puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\"" |
| puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\"" |
| } else { |
| puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\"" |
| puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\"" |
| } |
| puts $f "set geometry(botwidth) [winfo width .bleft]" |
| puts $f "set geometry(botheight) [winfo height .bleft]" |
| |
| array set view_save {} |
| array set views {} |
| if {![info exists permviews]} { set permviews {} } |
| foreach view $permviews { |
| set view_save([lindex $view 0]) 1 |
| set views([lindex $view 0]) $view |
| } |
| puts -nonewline $f "set permviews {" |
| for {set v 1} {$v < $current_nextviewnum} {incr v} { |
| if {$viewchanged($v)} { |
| if {$current_viewperm($v)} { |
| set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)] |
| } else { |
| set view_save($current_viewname($v)) 0 |
| } |
| } |
|
