2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
12 if {[info exists env(GIT_DIR)]} {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
25 global isonrunq runq currunq
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {} && ![info exists currunq]} {
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
43 fileevent $fd readable {}
44 if {$runq eq {} && ![info exists currunq]} {
47 lappend runq [list $fd $script]
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
63 global isonrunq runq currunq
65 set tstart [clock clicks -milliseconds]
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set currunq [lindex $runq 0]
71 set runq [lrange $runq 1 end]
72 set repeat [eval $script]
74 set t1 [clock clicks -milliseconds]
75 set t [expr {$t1 - $t0}]
76 if {$repeat ne {} && $repeat} {
77 if {$fd eq {} || $repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq [list $fd $script]
82 fileevent $fd readable [list filereadable $fd $script]
84 } elseif {$fd eq {}} {
85 unset isonrunq($script)
88 if {$t1 - $tstart >= 80} break
95 proc reg_instance {fd} {
96 global commfd leftover loginstance
98 set i [incr loginstance]
104 proc unmerged_files {files} {
107 # find the list of unmerged files
111 set fd [open "| git ls-files -u" r]
113 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
122 if {$files eq {} || [path_filter $files $fname]} {
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
139 set origargs $arglist
143 foreach arg $arglist {
150 switch -glob -- $arg {
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
159 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163 "--ignore-space-change" - "-U*" - "--unified=*" {
164 # These request or affect diff output, which we don't want.
165 # Some could be used to set our defaults for diff display.
166 lappend diffargs $arg
168 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169 "--name-only" - "--name-status" - "--color" - "--color-words" -
170 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174 "--objects" - "--objects-edge" - "--reverse" {
175 # These cause our parsing of git log's output to fail, or else
176 # they're options we want to set ourselves, so ignore them.
178 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
179 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
180 "--full-history" - "--dense" - "--sparse" -
181 "--follow" - "--left-right" - "--encoding=*" {
182 # These are harmless, and some are even useful
185 "--diff-filter=*" - "--no-merges" - "--unpacked" -
186 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
187 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
188 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
189 "--remove-empty" - "--first-parent" - "--cherry-pick" -
190 "-S*" - "--pickaxe-all" - "--pickaxe-regex" {
191 # These mean that we get a subset of the commits
196 # This appears to be the only one that has a value as a
197 # separate word following it
207 # git rev-parse doesn't understand --merge
208 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
211 # Other flag arguments including -<n>
212 if {[string is digit -strict [string range $arg 1 end]]} {
215 # a flag argument that we don't recognize;
216 # that means we can't optimize
222 # Non-flag arguments specify commits or ranges of commits
223 if {[string match "*...*" $arg]} {
224 lappend revargs --gitk-symmetric-diff-marker
230 set vdflags($n) $diffargs
231 set vflags($n) $glflags
232 set vrevs($n) $revargs
233 set vfiltered($n) $filtered
234 set vorigargs($n) $origargs
238 proc parseviewrevs {view revs} {
239 global vposids vnegids
244 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
245 # we get stdout followed by stderr in $err
246 # for an unknown rev, git rev-parse echoes it and then errors out
247 set errlines [split $err "\n"]
249 for {set l 0} {$l < [llength $errlines]} {incr l} {
250 set line [lindex $errlines $l]
251 if {!([string length $line] == 40 && [string is xdigit $line])} {
252 if {[string match "fatal:*" $line]} {
253 if {[string match "fatal: ambiguous argument*" $line]
255 if {[llength $badrev] == 1} {
256 set err "unknown revision $badrev"
258 set err "unknown revisions: [join $badrev ", "]"
261 set err [join [lrange $errlines $l end] "\n"]
268 error_popup "[mc "Error parsing revisions:"] $err"
275 foreach id [split $ids "\n"] {
276 if {$id eq "--gitk-symmetric-diff-marker"} {
278 } elseif {[string match "^*" $id]} {
285 lappend neg [string range $id 1 end]
290 lset ret end [lindex $ret end]...$id
296 set vposids($view) $pos
297 set vnegids($view) $neg
301 # Start off a git log process and arrange to read its output
302 proc start_rev_list {view} {
303 global startmsecs commitidx viewcomplete curview
305 global viewargs viewargscmd viewfiles vfilelimit
306 global showlocalchanges
307 global viewactive viewinstances vmergeonly
308 global mainheadid viewmainheadid viewmainheadid_orig
309 global vcanopt vflags vrevs vorigargs
311 set startmsecs [clock clicks -milliseconds]
312 set commitidx($view) 0
313 # these are set this way for the error exits
314 set viewcomplete($view) 1
315 set viewactive($view) 0
318 set args $viewargs($view)
319 if {$viewargscmd($view) ne {}} {
321 set str [exec sh -c $viewargscmd($view)]
323 error_popup "[mc "Error executing --argscmd command:"] $err"
326 set args [concat $args [split $str "\n"]]
328 set vcanopt($view) [parseviewargs $view $args]
330 set files $viewfiles($view)
331 if {$vmergeonly($view)} {
332 set files [unmerged_files $files]
335 if {$nr_unmerged == 0} {
336 error_popup [mc "No files selected: --merge specified but\
337 no files are unmerged."]
339 error_popup [mc "No files selected: --merge specified but\
340 no unmerged files are within file limit."]
345 set vfilelimit($view) $files
347 if {$vcanopt($view)} {
348 set revs [parseviewrevs $view $vrevs($view)]
352 set args [concat $vflags($view) $revs]
354 set args $vorigargs($view)
358 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
359 --boundary $args "--" $files] r]
361 error_popup "[mc "Error executing git log:"] $err"
364 set i [reg_instance $fd]
365 set viewinstances($view) [list $i]
366 set viewmainheadid($view) $mainheadid
367 set viewmainheadid_orig($view) $mainheadid
368 if {$files ne {} && $mainheadid ne {}} {
369 get_viewmainhead $view
371 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
372 interestedin $viewmainheadid($view) dodiffindex
374 fconfigure $fd -blocking 0 -translation lf -eofchar {}
375 if {$tclencoding != {}} {
376 fconfigure $fd -encoding $tclencoding
378 filerun $fd [list getcommitlines $fd $i $view 0]
379 nowbusy $view [mc "Reading"]
380 set viewcomplete($view) 0
381 set viewactive($view) 1
385 proc stop_instance {inst} {
386 global commfd leftover
388 set fd $commfd($inst)
392 if {$::tcl_platform(platform) eq {windows}} {
401 unset leftover($inst)
404 proc stop_backends {} {
407 foreach inst [array names commfd] {
412 proc stop_rev_list {view} {
415 foreach inst $viewinstances($view) {
418 set viewinstances($view) {}
421 proc reset_pending_select {selid} {
422 global pending_select mainheadid selectheadid
425 set pending_select $selid
426 } elseif {$selectheadid ne {}} {
427 set pending_select $selectheadid
429 set pending_select $mainheadid
433 proc getcommits {selid} {
434 global canv curview need_redisplay viewactive
437 if {[start_rev_list $curview]} {
438 reset_pending_select $selid
439 show_status [mc "Reading commits..."]
442 show_status [mc "No commits selected"]
446 proc updatecommits {} {
447 global curview vcanopt vorigargs vfilelimit viewinstances
448 global viewactive viewcomplete tclencoding
449 global startmsecs showneartags showlocalchanges
450 global mainheadid viewmainheadid viewmainheadid_orig pending_select
452 global varcid vposids vnegids vflags vrevs
454 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
457 if {$mainheadid ne $viewmainheadid_orig($view)} {
458 if {$showlocalchanges} {
461 set viewmainheadid($view) $mainheadid
462 set viewmainheadid_orig($view) $mainheadid
463 if {$vfilelimit($view) ne {}} {
464 get_viewmainhead $view
467 if {$showlocalchanges} {
470 if {$vcanopt($view)} {
471 set oldpos $vposids($view)
472 set oldneg $vnegids($view)
473 set revs [parseviewrevs $view $vrevs($view)]
477 # note: getting the delta when negative refs change is hard,
478 # and could require multiple git log invocations, so in that
479 # case we ask git log for all the commits (not just the delta)
480 if {$oldneg eq $vnegids($view)} {
483 # take out positive refs that we asked for before or
484 # that we have already seen
486 if {[string length $rev] == 40} {
487 if {[lsearch -exact $oldpos $rev] < 0
488 && ![info exists varcid($view,$rev)]} {
493 lappend $newrevs $rev
496 if {$npos == 0} return
498 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
500 set args [concat $vflags($view) $revs --not $oldpos]
502 set args $vorigargs($view)
505 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
506 --boundary $args "--" $vfilelimit($view)] r]
508 error_popup "[mc "Error executing git log:"] $err"
511 if {$viewactive($view) == 0} {
512 set startmsecs [clock clicks -milliseconds]
514 set i [reg_instance $fd]
515 lappend viewinstances($view) $i
516 fconfigure $fd -blocking 0 -translation lf -eofchar {}
517 if {$tclencoding != {}} {
518 fconfigure $fd -encoding $tclencoding
520 filerun $fd [list getcommitlines $fd $i $view 1]
521 incr viewactive($view)
522 set viewcomplete($view) 0
523 reset_pending_select {}
524 nowbusy $view "Reading"
530 proc reloadcommits {} {
531 global curview viewcomplete selectedline currentid thickerline
532 global showneartags treediffs commitinterest cached_commitrow
536 if {$selectedline ne {}} {
540 if {!$viewcomplete($curview)} {
541 stop_rev_list $curview
545 catch {unset currentid}
546 catch {unset thickerline}
547 catch {unset treediffs}
554 catch {unset commitinterest}
555 catch {unset cached_commitrow}
556 catch {unset targetid}
562 # This makes a string representation of a positive integer which
563 # sorts as a string in numerical order
566 return [format "%x" $n]
567 } elseif {$n < 256} {
568 return [format "x%.2x" $n]
569 } elseif {$n < 65536} {
570 return [format "y%.4x" $n]
572 return [format "z%.8x" $n]
575 # Procedures used in reordering commits from git log (without
576 # --topo-order) into the order for display.
578 proc varcinit {view} {
579 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
580 global vtokmod varcmod vrowmod varcix vlastins
582 set varcstart($view) {{}}
583 set vupptr($view) {0}
584 set vdownptr($view) {0}
585 set vleftptr($view) {0}
586 set vbackptr($view) {0}
587 set varctok($view) {{}}
588 set varcrow($view) {{}}
589 set vtokmod($view) {}
592 set varcix($view) {{}}
593 set vlastins($view) {0}
596 proc resetvarcs {view} {
597 global varcid varccommits parents children vseedcount ordertok
599 foreach vid [array names varcid $view,*] {
604 # some commits might have children but haven't been seen yet
605 foreach vid [array names children $view,*] {
608 foreach va [array names varccommits $view,*] {
609 unset varccommits($va)
611 foreach vd [array names vseedcount $view,*] {
612 unset vseedcount($vd)
614 catch {unset ordertok}
617 # returns a list of the commits with no children
619 global vdownptr vleftptr varcstart
622 set a [lindex $vdownptr($v) 0]
624 lappend ret [lindex $varcstart($v) $a]
625 set a [lindex $vleftptr($v) $a]
630 proc newvarc {view id} {
631 global varcid varctok parents children vdatemode
632 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
633 global commitdata commitinfo vseedcount varccommits vlastins
635 set a [llength $varctok($view)]
637 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
638 if {![info exists commitinfo($id)]} {
639 parsecommit $id $commitdata($id) 1
641 set cdate [lindex $commitinfo($id) 4]
642 if {![string is integer -strict $cdate]} {
645 if {![info exists vseedcount($view,$cdate)]} {
646 set vseedcount($view,$cdate) -1
648 set c [incr vseedcount($view,$cdate)]
649 set cdate [expr {$cdate ^ 0xffffffff}]
650 set tok "s[strrep $cdate][strrep $c]"
655 if {[llength $children($vid)] > 0} {
656 set kid [lindex $children($vid) end]
657 set k $varcid($view,$kid)
658 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
661 set tok [lindex $varctok($view) $k]
665 set i [lsearch -exact $parents($view,$ki) $id]
666 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
667 append tok [strrep $j]
669 set c [lindex $vlastins($view) $ka]
670 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
672 set b [lindex $vdownptr($view) $ka]
674 set b [lindex $vleftptr($view) $c]
676 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
678 set b [lindex $vleftptr($view) $c]
681 lset vdownptr($view) $ka $a
682 lappend vbackptr($view) 0
684 lset vleftptr($view) $c $a
685 lappend vbackptr($view) $c
687 lset vlastins($view) $ka $a
688 lappend vupptr($view) $ka
689 lappend vleftptr($view) $b
691 lset vbackptr($view) $b $a
693 lappend varctok($view) $tok
694 lappend varcstart($view) $id
695 lappend vdownptr($view) 0
696 lappend varcrow($view) {}
697 lappend varcix($view) {}
698 set varccommits($view,$a) {}
699 lappend vlastins($view) 0
703 proc splitvarc {p v} {
704 global varcid varcstart varccommits varctok
705 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
707 set oa $varcid($v,$p)
708 set ac $varccommits($v,$oa)
709 set i [lsearch -exact $varccommits($v,$oa) $p]
711 set na [llength $varctok($v)]
712 # "%" sorts before "0"...
713 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
714 lappend varctok($v) $tok
715 lappend varcrow($v) {}
716 lappend varcix($v) {}
717 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
718 set varccommits($v,$na) [lrange $ac $i end]
719 lappend varcstart($v) $p
720 foreach id $varccommits($v,$na) {
721 set varcid($v,$id) $na
723 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
724 lappend vlastins($v) [lindex $vlastins($v) $oa]
725 lset vdownptr($v) $oa $na
726 lset vlastins($v) $oa 0
727 lappend vupptr($v) $oa
728 lappend vleftptr($v) 0
729 lappend vbackptr($v) 0
730 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
731 lset vupptr($v) $b $na
735 proc renumbervarc {a v} {
736 global parents children varctok varcstart varccommits
737 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
739 set t1 [clock clicks -milliseconds]
745 if {[info exists isrelated($a)]} {
747 set id [lindex $varccommits($v,$a) end]
748 foreach p $parents($v,$id) {
749 if {[info exists varcid($v,$p)]} {
750 set isrelated($varcid($v,$p)) 1
755 set b [lindex $vdownptr($v) $a]
758 set b [lindex $vleftptr($v) $a]
760 set a [lindex $vupptr($v) $a]
766 if {![info exists kidchanged($a)]} continue
767 set id [lindex $varcstart($v) $a]
768 if {[llength $children($v,$id)] > 1} {
769 set children($v,$id) [lsort -command [list vtokcmp $v] \
772 set oldtok [lindex $varctok($v) $a]
773 if {!$vdatemode($v)} {
779 set kid [last_real_child $v,$id]
781 set k $varcid($v,$kid)
782 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
785 set tok [lindex $varctok($v) $k]
789 set i [lsearch -exact $parents($v,$ki) $id]
790 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
791 append tok [strrep $j]
793 if {$tok eq $oldtok} {
796 set id [lindex $varccommits($v,$a) end]
797 foreach p $parents($v,$id) {
798 if {[info exists varcid($v,$p)]} {
799 set kidchanged($varcid($v,$p)) 1
804 lset varctok($v) $a $tok
805 set b [lindex $vupptr($v) $a]
807 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
810 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
813 set c [lindex $vbackptr($v) $a]
814 set d [lindex $vleftptr($v) $a]
816 lset vdownptr($v) $b $d
818 lset vleftptr($v) $c $d
821 lset vbackptr($v) $d $c
823 if {[lindex $vlastins($v) $b] == $a} {
824 lset vlastins($v) $b $c
826 lset vupptr($v) $a $ka
827 set c [lindex $vlastins($v) $ka]
829 [string compare $tok [lindex $varctok($v) $c]] < 0} {
831 set b [lindex $vdownptr($v) $ka]
833 set b [lindex $vleftptr($v) $c]
836 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
838 set b [lindex $vleftptr($v) $c]
841 lset vdownptr($v) $ka $a
842 lset vbackptr($v) $a 0
844 lset vleftptr($v) $c $a
845 lset vbackptr($v) $a $c
847 lset vleftptr($v) $a $b
849 lset vbackptr($v) $b $a
851 lset vlastins($v) $ka $a
854 foreach id [array names sortkids] {
855 if {[llength $children($v,$id)] > 1} {
856 set children($v,$id) [lsort -command [list vtokcmp $v] \
860 set t2 [clock clicks -milliseconds]
861 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
864 # Fix up the graph after we have found out that in view $v,
865 # $p (a commit that we have already seen) is actually the parent
866 # of the last commit in arc $a.
867 proc fix_reversal {p a v} {
868 global varcid varcstart varctok vupptr
870 set pa $varcid($v,$p)
871 if {$p ne [lindex $varcstart($v) $pa]} {
873 set pa $varcid($v,$p)
875 # seeds always need to be renumbered
876 if {[lindex $vupptr($v) $pa] == 0 ||
877 [string compare [lindex $varctok($v) $a] \
878 [lindex $varctok($v) $pa]] > 0} {
883 proc insertrow {id p v} {
884 global cmitlisted children parents varcid varctok vtokmod
885 global varccommits ordertok commitidx numcommits curview
886 global targetid targetrow
890 set cmitlisted($vid) 1
891 set children($vid) {}
892 set parents($vid) [list $p]
893 set a [newvarc $v $id]
895 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
898 lappend varccommits($v,$a) $id
900 if {[llength [lappend children($vp) $id]] > 1} {
901 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
902 catch {unset ordertok}
904 fix_reversal $p $a $v
906 if {$v == $curview} {
907 set numcommits $commitidx($v)
909 if {[info exists targetid]} {
910 if {![comes_before $targetid $p]} {
917 proc insertfakerow {id p} {
918 global varcid varccommits parents children cmitlisted
919 global commitidx varctok vtokmod targetid targetrow curview numcommits
923 set i [lsearch -exact $varccommits($v,$a) $p]
925 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
928 set children($v,$id) {}
929 set parents($v,$id) [list $p]
930 set varcid($v,$id) $a
931 lappend children($v,$p) $id
932 set cmitlisted($v,$id) 1
933 set numcommits [incr commitidx($v)]
934 # note we deliberately don't update varcstart($v) even if $i == 0
935 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
937 if {[info exists targetid]} {
938 if {![comes_before $targetid $p]} {
946 proc removefakerow {id} {
947 global varcid varccommits parents children commitidx
948 global varctok vtokmod cmitlisted currentid selectedline
949 global targetid curview numcommits
952 if {[llength $parents($v,$id)] != 1} {
953 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
956 set p [lindex $parents($v,$id) 0]
957 set a $varcid($v,$id)
958 set i [lsearch -exact $varccommits($v,$a) $id]
960 puts "oops: removefakerow can't find [shortids $id] on arc $a"
964 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
965 unset parents($v,$id)
966 unset children($v,$id)
967 unset cmitlisted($v,$id)
968 set numcommits [incr commitidx($v) -1]
969 set j [lsearch -exact $children($v,$p) $id]
971 set children($v,$p) [lreplace $children($v,$p) $j $j]
974 if {[info exist currentid] && $id eq $currentid} {
978 if {[info exists targetid] && $targetid eq $id} {
985 proc first_real_child {vp} {
986 global children nullid nullid2
988 foreach id $children($vp) {
989 if {$id ne $nullid && $id ne $nullid2} {
996 proc last_real_child {vp} {
997 global children nullid nullid2
999 set kids $children($vp)
1000 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1001 set id [lindex $kids $i]
1002 if {$id ne $nullid && $id ne $nullid2} {
1009 proc vtokcmp {v a b} {
1010 global varctok varcid
1012 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1013 [lindex $varctok($v) $varcid($v,$b)]]
1016 # This assumes that if lim is not given, the caller has checked that
1017 # arc a's token is less than $vtokmod($v)
1018 proc modify_arc {v a {lim {}}} {
1019 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1022 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1025 set r [lindex $varcrow($v) $a]
1026 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1029 set vtokmod($v) [lindex $varctok($v) $a]
1031 if {$v == $curview} {
1032 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1033 set a [lindex $vupptr($v) $a]
1039 set lim [llength $varccommits($v,$a)]
1041 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1048 proc update_arcrows {v} {
1049 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1050 global varcid vrownum varcorder varcix varccommits
1051 global vupptr vdownptr vleftptr varctok
1052 global displayorder parentlist curview cached_commitrow
1054 if {$vrowmod($v) == $commitidx($v)} return
1055 if {$v == $curview} {
1056 if {[llength $displayorder] > $vrowmod($v)} {
1057 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1058 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1060 catch {unset cached_commitrow}
1062 set narctot [expr {[llength $varctok($v)] - 1}]
1064 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1065 # go up the tree until we find something that has a row number,
1066 # or we get to a seed
1067 set a [lindex $vupptr($v) $a]
1070 set a [lindex $vdownptr($v) 0]
1073 set varcorder($v) [list $a]
1074 lset varcix($v) $a 0
1075 lset varcrow($v) $a 0
1079 set arcn [lindex $varcix($v) $a]
1080 if {[llength $vrownum($v)] > $arcn + 1} {
1081 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1082 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1084 set row [lindex $varcrow($v) $a]
1088 incr row [llength $varccommits($v,$a)]
1089 # go down if possible
1090 set b [lindex $vdownptr($v) $a]
1092 # if not, go left, or go up until we can go left
1094 set b [lindex $vleftptr($v) $a]
1096 set a [lindex $vupptr($v) $a]
1102 lappend vrownum($v) $row
1103 lappend varcorder($v) $a
1104 lset varcix($v) $a $arcn
1105 lset varcrow($v) $a $row
1107 set vtokmod($v) [lindex $varctok($v) $p]
1109 set vrowmod($v) $row
1110 if {[info exists currentid]} {
1111 set selectedline [rowofcommit $currentid]
1115 # Test whether view $v contains commit $id
1116 proc commitinview {id v} {
1119 return [info exists varcid($v,$id)]
1122 # Return the row number for commit $id in the current view
1123 proc rowofcommit {id} {
1124 global varcid varccommits varcrow curview cached_commitrow
1125 global varctok vtokmod
1128 if {![info exists varcid($v,$id)]} {
1129 puts "oops rowofcommit no arc for [shortids $id]"
1132 set a $varcid($v,$id)
1133 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1136 if {[info exists cached_commitrow($id)]} {
1137 return $cached_commitrow($id)
1139 set i [lsearch -exact $varccommits($v,$a) $id]
1141 puts "oops didn't find commit [shortids $id] in arc $a"
1144 incr i [lindex $varcrow($v) $a]
1145 set cached_commitrow($id) $i
1149 # Returns 1 if a is on an earlier row than b, otherwise 0
1150 proc comes_before {a b} {
1151 global varcid varctok curview
1154 if {$a eq $b || ![info exists varcid($v,$a)] || \
1155 ![info exists varcid($v,$b)]} {
1158 if {$varcid($v,$a) != $varcid($v,$b)} {
1159 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1160 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1162 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1165 proc bsearch {l elt} {
1166 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1171 while {$hi - $lo > 1} {
1172 set mid [expr {int(($lo + $hi) / 2)}]
1173 set t [lindex $l $mid]
1176 } elseif {$elt > $t} {
1185 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1186 proc make_disporder {start end} {
1187 global vrownum curview commitidx displayorder parentlist
1188 global varccommits varcorder parents vrowmod varcrow
1189 global d_valid_start d_valid_end
1191 if {$end > $vrowmod($curview)} {
1192 update_arcrows $curview
1194 set ai [bsearch $vrownum($curview) $start]
1195 set start [lindex $vrownum($curview) $ai]
1196 set narc [llength $vrownum($curview)]
1197 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1198 set a [lindex $varcorder($curview) $ai]
1199 set l [llength $displayorder]
1200 set al [llength $varccommits($curview,$a)]
1201 if {$l < $r + $al} {
1203 set pad [ntimes [expr {$r - $l}] {}]
1204 set displayorder [concat $displayorder $pad]
1205 set parentlist [concat $parentlist $pad]
1206 } elseif {$l > $r} {
1207 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1208 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1210 foreach id $varccommits($curview,$a) {
1211 lappend displayorder $id
1212 lappend parentlist $parents($curview,$id)
1214 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1216 foreach id $varccommits($curview,$a) {
1217 lset displayorder $i $id
1218 lset parentlist $i $parents($curview,$id)
1226 proc commitonrow {row} {
1229 set id [lindex $displayorder $row]
1231 make_disporder $row [expr {$row + 1}]
1232 set id [lindex $displayorder $row]
1237 proc closevarcs {v} {
1238 global varctok varccommits varcid parents children
1239 global cmitlisted commitidx vtokmod
1241 set missing_parents 0
1243 set narcs [llength $varctok($v)]
1244 for {set a 1} {$a < $narcs} {incr a} {
1245 set id [lindex $varccommits($v,$a) end]
1246 foreach p $parents($v,$id) {
1247 if {[info exists varcid($v,$p)]} continue
1248 # add p as a new commit
1249 incr missing_parents
1250 set cmitlisted($v,$p) 0
1251 set parents($v,$p) {}
1252 if {[llength $children($v,$p)] == 1 &&
1253 [llength $parents($v,$id)] == 1} {
1256 set b [newvarc $v $p]
1258 set varcid($v,$p) $b
1259 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1262 lappend varccommits($v,$b) $p
1264 set scripts [check_interest $p $scripts]
1267 if {$missing_parents > 0} {
1268 foreach s $scripts {
1274 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1275 # Assumes we already have an arc for $rwid.
1276 proc rewrite_commit {v id rwid} {
1277 global children parents varcid varctok vtokmod varccommits
1279 foreach ch $children($v,$id) {
1280 # make $rwid be $ch's parent in place of $id
1281 set i [lsearch -exact $parents($v,$ch) $id]
1283 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1285 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1286 # add $ch to $rwid's children and sort the list if necessary
1287 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1288 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1289 $children($v,$rwid)]
1291 # fix the graph after joining $id to $rwid
1292 set a $varcid($v,$ch)
1293 fix_reversal $rwid $a $v
1294 # parentlist is wrong for the last element of arc $a
1295 # even if displayorder is right, hence the 3rd arg here
1296 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1300 # Mechanism for registering a command to be executed when we come
1301 # across a particular commit. To handle the case when only the
1302 # prefix of the commit is known, the commitinterest array is now
1303 # indexed by the first 4 characters of the ID. Each element is a
1304 # list of id, cmd pairs.
1305 proc interestedin {id cmd} {
1306 global commitinterest
1308 lappend commitinterest([string range $id 0 3]) $id $cmd
1311 proc check_interest {id scripts} {
1312 global commitinterest
1314 set prefix [string range $id 0 3]
1315 if {[info exists commitinterest($prefix)]} {
1317 foreach {i script} $commitinterest($prefix) {
1318 if {[string match "$i*" $id]} {
1319 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1321 lappend newlist $i $script
1324 if {$newlist ne {}} {
1325 set commitinterest($prefix) $newlist
1327 unset commitinterest($prefix)
1333 proc getcommitlines {fd inst view updating} {
1334 global cmitlisted leftover
1335 global commitidx commitdata vdatemode
1336 global parents children curview hlview
1337 global idpending ordertok
1338 global varccommits varcid varctok vtokmod vfilelimit
1340 set stuff [read $fd 500000]
1341 # git log doesn't terminate the last commit with a null...
1342 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1349 global commfd viewcomplete viewactive viewname
1350 global viewinstances
1352 set i [lsearch -exact $viewinstances($view) $inst]
1354 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1356 # set it blocking so we wait for the process to terminate
1357 fconfigure $fd -blocking 1
1358 if {[catch {close $fd} err]} {
1360 if {$view != $curview} {
1361 set fv " for the \"$viewname($view)\" view"
1363 if {[string range $err 0 4] == "usage"} {
1364 set err "Gitk: error reading commits$fv:\
1365 bad arguments to git log."
1366 if {$viewname($view) eq "Command line"} {
1368 " (Note: arguments to gitk are passed to git log\
1369 to allow selection of commits to be displayed.)"
1372 set err "Error reading commits$fv: $err"
1376 if {[incr viewactive($view) -1] <= 0} {
1377 set viewcomplete($view) 1
1378 # Check if we have seen any ids listed as parents that haven't
1379 # appeared in the list
1383 if {$view == $curview} {
1392 set i [string first "\0" $stuff $start]
1394 append leftover($inst) [string range $stuff $start end]
1398 set cmit $leftover($inst)
1399 append cmit [string range $stuff 0 [expr {$i - 1}]]
1400 set leftover($inst) {}
1402 set cmit [string range $stuff $start [expr {$i - 1}]]
1404 set start [expr {$i + 1}]
1405 set j [string first "\n" $cmit]
1408 if {$j >= 0 && [string match "commit *" $cmit]} {
1409 set ids [string range $cmit 7 [expr {$j - 1}]]
1410 if {[string match {[-^<>]*} $ids]} {
1411 switch -- [string index $ids 0] {
1417 set ids [string range $ids 1 end]
1421 if {[string length $id] != 40} {
1429 if {[string length $shortcmit] > 80} {
1430 set shortcmit "[string range $shortcmit 0 80]..."
1432 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1435 set id [lindex $ids 0]
1438 if {!$listed && $updating && ![info exists varcid($vid)] &&
1439 $vfilelimit($view) ne {}} {
1440 # git log doesn't rewrite parents for unlisted commits
1441 # when doing path limiting, so work around that here
1442 # by working out the rewritten parent with git rev-list
1443 # and if we already know about it, using the rewritten
1444 # parent as a substitute parent for $id's children.
1446 set rwid [exec git rev-list --first-parent --max-count=1 \
1447 $id -- $vfilelimit($view)]
1449 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1450 # use $rwid in place of $id
1451 rewrite_commit $view $id $rwid
1458 if {[info exists varcid($vid)]} {
1459 if {$cmitlisted($vid) || !$listed} continue
1463 set olds [lrange $ids 1 end]
1467 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1468 set cmitlisted($vid) $listed
1469 set parents($vid) $olds
1470 if {![info exists children($vid)]} {
1471 set children($vid) {}
1472 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1473 set k [lindex $children($vid) 0]
1474 if {[llength $parents($view,$k)] == 1 &&
1475 (!$vdatemode($view) ||
1476 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1477 set a $varcid($view,$k)
1482 set a [newvarc $view $id]
1484 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1487 if {![info exists varcid($vid)]} {
1489 lappend varccommits($view,$a) $id
1490 incr commitidx($view)
1495 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1497 if {[llength [lappend children($vp) $id]] > 1 &&
1498 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1499 set children($vp) [lsort -command [list vtokcmp $view] \
1501 catch {unset ordertok}
1503 if {[info exists varcid($view,$p)]} {
1504 fix_reversal $p $a $view
1510 set scripts [check_interest $id $scripts]
1514 global numcommits hlview
1516 if {$view == $curview} {
1517 set numcommits $commitidx($view)
1520 if {[info exists hlview] && $view == $hlview} {
1521 # we never actually get here...
1524 foreach s $scripts {
1531 proc chewcommits {} {
1532 global curview hlview viewcomplete
1533 global pending_select
1536 if {$viewcomplete($curview)} {
1537 global commitidx varctok
1538 global numcommits startmsecs
1540 if {[info exists pending_select]} {
1542 reset_pending_select {}
1544 if {[commitinview $pending_select $curview]} {
1545 selectline [rowofcommit $pending_select] 1
1547 set row [first_real_row]
1551 if {$commitidx($curview) > 0} {
1552 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1553 #puts "overall $ms ms for $numcommits commits"
1554 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1556 show_status [mc "No commits selected"]
1563 proc do_readcommit {id} {
1566 # Invoke git-log to handle automatic encoding conversion
1567 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1568 # Read the results using i18n.logoutputencoding
1569 fconfigure $fd -translation lf -eofchar {}
1570 if {$tclencoding != {}} {
1571 fconfigure $fd -encoding $tclencoding
1573 set contents [read $fd]
1575 # Remove the heading line
1576 regsub {^commit [0-9a-f]+\n} $contents {} contents
1581 proc readcommit {id} {
1582 if {[catch {set contents [do_readcommit $id]}]} return
1583 parsecommit $id $contents 1
1586 proc parsecommit {id contents listed} {
1587 global commitinfo cdate
1596 set hdrend [string first "\n\n" $contents]
1598 # should never happen...
1599 set hdrend [string length $contents]
1601 set header [string range $contents 0 [expr {$hdrend - 1}]]
1602 set comment [string range $contents [expr {$hdrend + 2}] end]
1603 foreach line [split $header "\n"] {
1604 set line [split $line " "]
1605 set tag [lindex $line 0]
1606 if {$tag == "author"} {
1607 set audate [lindex $line end-1]
1608 set auname [join [lrange $line 1 end-2] " "]
1609 } elseif {$tag == "committer"} {
1610 set comdate [lindex $line end-1]
1611 set comname [join [lrange $line 1 end-2] " "]
1615 # take the first non-blank line of the comment as the headline
1616 set headline [string trimleft $comment]
1617 set i [string first "\n" $headline]
1619 set headline [string range $headline 0 $i]
1621 set headline [string trimright $headline]
1622 set i [string first "\r" $headline]
1624 set headline [string trimright [string range $headline 0 $i]]
1627 # git log indents the comment by 4 spaces;
1628 # if we got this via git cat-file, add the indentation
1630 foreach line [split $comment "\n"] {
1631 append newcomment " "
1632 append newcomment $line
1633 append newcomment "\n"
1635 set comment $newcomment
1637 if {$comdate != {}} {
1638 set cdate($id) $comdate
1640 set commitinfo($id) [list $headline $auname $audate \
1641 $comname $comdate $comment]
1644 proc getcommit {id} {
1645 global commitdata commitinfo
1647 if {[info exists commitdata($id)]} {
1648 parsecommit $id $commitdata($id) 1
1651 if {![info exists commitinfo($id)]} {
1652 set commitinfo($id) [list [mc "No commit information available"]]
1658 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1659 # and are present in the current view.
1660 # This is fairly slow...
1661 proc longid {prefix} {
1662 global varcid curview
1665 foreach match [array names varcid "$curview,$prefix*"] {
1666 lappend ids [lindex [split $match ","] 1]
1672 global tagids idtags headids idheads tagobjid
1673 global otherrefids idotherrefs mainhead mainheadid
1674 global selecthead selectheadid
1676 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1679 set refd [open [list | git show-ref -d] r]
1680 while {[gets $refd line] >= 0} {
1681 if {[string index $line 40] ne " "} continue
1682 set id [string range $line 0 39]
1683 set ref [string range $line 41 end]
1684 if {![string match "refs/*" $ref]} continue
1685 set name [string range $ref 5 end]
1686 if {[string match "remotes/*" $name]} {
1687 if {![string match "*/HEAD" $name]} {
1688 set headids($name) $id
1689 lappend idheads($id) $name
1691 } elseif {[string match "heads/*" $name]} {
1692 set name [string range $name 6 end]
1693 set headids($name) $id
1694 lappend idheads($id) $name
1695 } elseif {[string match "tags/*" $name]} {
1696 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1697 # which is what we want since the former is the commit ID
1698 set name [string range $name 5 end]
1699 if {[string match "*^{}" $name]} {
1700 set name [string range $name 0 end-3]
1702 set tagobjid($name) $id
1704 set tagids($name) $id
1705 lappend idtags($id) $name
1707 set otherrefids($name) $id
1708 lappend idotherrefs($id) $name
1715 set mainheadid [exec git rev-parse HEAD]
1716 set thehead [exec git symbolic-ref HEAD]
1717 if {[string match "refs/heads/*" $thehead]} {
1718 set mainhead [string range $thehead 11 end]
1722 if {$selecthead ne {}} {
1724 set selectheadid [exec git rev-parse --verify $selecthead]
1729 # skip over fake commits
1730 proc first_real_row {} {
1731 global nullid nullid2 numcommits
1733 for {set row 0} {$row < $numcommits} {incr row} {
1734 set id [commitonrow $row]
1735 if {$id ne $nullid && $id ne $nullid2} {
1742 # update things for a head moved to a child of its previous location
1743 proc movehead {id name} {
1744 global headids idheads
1746 removehead $headids($name) $name
1747 set headids($name) $id
1748 lappend idheads($id) $name
1751 # update things when a head has been removed
1752 proc removehead {id name} {
1753 global headids idheads
1755 if {$idheads($id) eq $name} {
1758 set i [lsearch -exact $idheads($id) $name]
1760 set idheads($id) [lreplace $idheads($id) $i $i]
1763 unset headids($name)
1766 proc make_transient {window origin} {
1769 # In MacOS Tk 8.4 transient appears to work by setting
1770 # overrideredirect, which is utterly useless, since the
1771 # windows get no border, and are not even kept above
1773 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1775 wm transient $window $origin
1777 # Windows fails to place transient windows normally, so
1778 # schedule a callback to center them on the parent.
1779 if {[tk windowingsystem] eq {win32}} {
1780 after idle [list tk::PlaceWindow $window widget $origin]
1784 proc show_error {w top msg} {
1785 message $w.m -text $msg -justify center -aspect 400
1786 pack $w.m -side top -fill x -padx 20 -pady 20
1787 button $w.ok -text [mc OK] -command "destroy $top"
1788 pack $w.ok -side bottom -fill x
1789 bind $top <Visibility> "grab $top; focus $top"
1790 bind $top <Key-Return> "destroy $top"
1791 bind $top <Key-space> "destroy $top"
1792 bind $top <Key-Escape> "destroy $top"
1796 proc error_popup {msg {owner .}} {
1799 make_transient $w $owner
1800 show_error $w $w $msg
1803 proc confirm_popup {msg {owner .}} {
1808 make_transient $w $owner
1809 message $w.m -text $msg -justify center -aspect 400
1810 pack $w.m -side top -fill x -padx 20 -pady 20
1811 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1812 pack $w.ok -side left -fill x
1813 button $w.cancel -text [mc Cancel] -command "destroy $w"
1814 pack $w.cancel -side right -fill x
1815 bind $w <Visibility> "grab $w; focus $w"
1816 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1817 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1818 bind $w <Key-Escape> "destroy $w"
1823 proc setoptions {} {
1824 option add *Panedwindow.showHandle 1 startupFile
1825 option add *Panedwindow.sashRelief raised startupFile
1826 option add *Button.font uifont startupFile
1827 option add *Checkbutton.font uifont startupFile
1828 option add *Radiobutton.font uifont startupFile
1829 option add *Menu.font uifont startupFile
1830 option add *Menubutton.font uifont startupFile
1831 option add *Label.font uifont startupFile
1832 option add *Message.font uifont startupFile
1833 option add *Entry.font uifont startupFile
1836 # Make a menu and submenus.
1837 # m is the window name for the menu, items is the list of menu items to add.
1838 # Each item is a list {mc label type description options...}
1839 # mc is ignored; it's so we can put mc there to alert xgettext
1840 # label is the string that appears in the menu
1841 # type is cascade, command or radiobutton (should add checkbutton)
1842 # description depends on type; it's the sublist for cascade, the
1843 # command to invoke for command, or {variable value} for radiobutton
1844 proc makemenu {m items} {
1846 if {[tk windowingsystem] eq {aqua}} {
1852 set name [mc [lindex $i 1]]
1853 set type [lindex $i 2]
1854 set thing [lindex $i 3]
1855 set params [list $type]
1857 set u [string first "&" [string map {&& x} $name]]
1858 lappend params -label [string map {&& & & {}} $name]
1860 lappend params -underline $u
1865 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1866 lappend params -menu $m.$submenu
1869 lappend params -command $thing
1872 lappend params -variable [lindex $thing 0] \
1873 -value [lindex $thing 1]
1876 set tail [lrange $i 4 end]
1877 regsub -all {\yMeta1\y} $tail $Meta1 tail
1878 eval $m add $params $tail
1879 if {$type eq "cascade"} {
1880 makemenu $m.$submenu $thing
1885 # translate string and remove ampersands
1887 return [string map {&& & & {}} [mc $str]]
1890 proc makewindow {} {
1891 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1893 global findtype findtypemenu findloc findstring fstring geometry
1894 global entries sha1entry sha1string sha1but
1895 global diffcontextstring diffcontext
1897 global maincursor textcursor curtextcursor
1898 global rowctxmenu fakerowmenu mergemax wrapcomment
1899 global highlight_files gdttype
1900 global searchstring sstring
1901 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1902 global headctxmenu progresscanv progressitem progresscoords statusw
1903 global fprogitem fprogcoord lastprogupdate progupdatepending
1904 global rprogitem rprogcoord rownumsel numcommits
1907 # The "mc" arguments here are purely so that xgettext
1908 # sees the following string as needing to be translated
1910 {mc "File" cascade {
1911 {mc "Update" command updatecommits -accelerator F5}
1912 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1913 {mc "Reread references" command rereadrefs}
1914 {mc "List references" command showrefs -accelerator F2}
1916 {mc "Start git gui" command {exec git gui &}}
1918 {mc "Quit" command doquit -accelerator Meta1-Q}
1920 {mc "Edit" cascade {
1921 {mc "Preferences" command doprefs}
1923 {mc "View" cascade {
1924 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1925 {mc "Edit view..." command editview -state disabled -accelerator F4}
1926 {mc "Delete view" command delview -state disabled}
1928 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1930 {mc "Help" cascade {
1931 {mc "About gitk" command about}
1932 {mc "Key bindings" command keys}
1935 . configure -menu .bar
1937 # the gui has upper and lower half, parts of a paned window.
1938 panedwindow .ctop -orient vertical
1940 # possibly use assumed geometry
1941 if {![info exists geometry(pwsash0)]} {
1942 set geometry(topheight) [expr {15 * $linespc}]
1943 set geometry(topwidth) [expr {80 * $charspc}]
1944 set geometry(botheight) [expr {15 * $linespc}]
1945 set geometry(botwidth) [expr {50 * $charspc}]
1946 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1947 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1950 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1951 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1953 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1955 # create three canvases
1956 set cscroll .tf.histframe.csb
1957 set canv .tf.histframe.pwclist.canv
1959 -selectbackground $selectbgcolor \
1960 -background $bgcolor -bd 0 \
1961 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1962 .tf.histframe.pwclist add $canv
1963 set canv2 .tf.histframe.pwclist.canv2
1965 -selectbackground $selectbgcolor \
1966 -background $bgcolor -bd 0 -yscrollincr $linespc
1967 .tf.histframe.pwclist add $canv2
1968 set canv3 .tf.histframe.pwclist.canv3
1970 -selectbackground $selectbgcolor \
1971 -background $bgcolor -bd 0 -yscrollincr $linespc
1972 .tf.histframe.pwclist add $canv3
1973 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1974 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1976 # a scroll bar to rule them
1977 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1978 pack $cscroll -side right -fill y
1979 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1980 lappend bglist $canv $canv2 $canv3
1981 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1983 # we have two button bars at bottom of top frame. Bar 1
1985 frame .tf.lbar -height 15
1987 set sha1entry .tf.bar.sha1
1988 set entries $sha1entry
1989 set sha1but .tf.bar.sha1label
1990 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1991 -command gotocommit -width 8
1992 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1993 pack .tf.bar.sha1label -side left
1994 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1995 trace add variable sha1string write sha1change
1996 pack $sha1entry -side left -pady 2
1998 image create bitmap bm-left -data {
1999 #define left_width 16
2000 #define left_height 16
2001 static unsigned char left_bits[] = {
2002 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2003 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2004 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2006 image create bitmap bm-right -data {
2007 #define right_width 16
2008 #define right_height 16
2009 static unsigned char right_bits[] = {
2010 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2011 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2012 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2014 button .tf.bar.leftbut -image bm-left -command goback \
2015 -state disabled -width 26
2016 pack .tf.bar.leftbut -side left -fill y
2017 button .tf.bar.rightbut -image bm-right -command goforw \
2018 -state disabled -width 26
2019 pack .tf.bar.rightbut -side left -fill y
2021 label .tf.bar.rowlabel -text [mc "Row"]
2023 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2024 -relief sunken -anchor e
2025 label .tf.bar.rowlabel2 -text "/"
2026 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2027 -relief sunken -anchor e
2028 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2031 trace add variable selectedline write selectedline_change
2033 # Status label and progress bar
2034 set statusw .tf.bar.status
2035 label $statusw -width 15 -relief sunken
2036 pack $statusw -side left -padx 5
2037 set h [expr {[font metrics uifont -linespace] + 2}]
2038 set progresscanv .tf.bar.progress
2039 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2040 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2041 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2042 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2043 pack $progresscanv -side right -expand 1 -fill x
2044 set progresscoords {0 0}
2047 bind $progresscanv <Configure> adjustprogress
2048 set lastprogupdate [clock clicks -milliseconds]
2049 set progupdatepending 0
2051 # build up the bottom bar of upper window
2052 label .tf.lbar.flabel -text "[mc "Find"] "
2053 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2054 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2055 label .tf.lbar.flab2 -text " [mc "commit"] "
2056 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2058 set gdttype [mc "containing:"]
2059 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2060 [mc "containing:"] \
2061 [mc "touching paths:"] \
2062 [mc "adding/removing string:"]]
2063 trace add variable gdttype write gdttype_change
2064 pack .tf.lbar.gdttype -side left -fill y
2067 set fstring .tf.lbar.findstring
2068 lappend entries $fstring
2069 entry $fstring -width 30 -font textfont -textvariable findstring
2070 trace add variable findstring write find_change
2071 set findtype [mc "Exact"]
2072 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2073 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2074 trace add variable findtype write findcom_change
2075 set findloc [mc "All fields"]
2076 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2077 [mc "Comments"] [mc "Author"] [mc "Committer"]
2078 trace add variable findloc write find_change
2079 pack .tf.lbar.findloc -side right
2080 pack .tf.lbar.findtype -side right
2081 pack $fstring -side left -expand 1 -fill x
2083 # Finish putting the upper half of the viewer together
2084 pack .tf.lbar -in .tf -side bottom -fill x
2085 pack .tf.bar -in .tf -side bottom -fill x
2086 pack .tf.histframe -fill both -side top -expand 1
2088 .ctop paneconfigure .tf -height $geometry(topheight)
2089 .ctop paneconfigure .tf -width $geometry(topwidth)
2091 # now build up the bottom
2092 panedwindow .pwbottom -orient horizontal
2094 # lower left, a text box over search bar, scroll bar to the right
2095 # if we know window height, then that will set the lower text height, otherwise
2096 # we set lower text height which will drive window height
2097 if {[info exists geometry(main)]} {
2098 frame .bleft -width $geometry(botwidth)
2100 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2106 button .bleft.top.search -text [mc "Search"] -command dosearch
2107 pack .bleft.top.search -side left -padx 5
2108 set sstring .bleft.top.sstring
2109 entry $sstring -width 20 -font textfont -textvariable searchstring
2110 lappend entries $sstring
2111 trace add variable searchstring write incrsearch
2112 pack $sstring -side left -expand 1 -fill x
2113 radiobutton .bleft.mid.diff -text [mc "Diff"] \
2114 -command changediffdisp -variable diffelide -value {0 0}
2115 radiobutton .bleft.mid.old -text [mc "Old version"] \
2116 -command changediffdisp -variable diffelide -value {0 1}
2117 radiobutton .bleft.mid.new -text [mc "New version"] \
2118 -command changediffdisp -variable diffelide -value {1 0}
2119 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2120 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2121 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2122 -from 1 -increment 1 -to 10000000 \
2123 -validate all -validatecommand "diffcontextvalidate %P" \
2124 -textvariable diffcontextstring
2125 .bleft.mid.diffcontext set $diffcontext
2126 trace add variable diffcontextstring write diffcontextchange
2127 lappend entries .bleft.mid.diffcontext
2128 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2129 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2130 -command changeignorespace -variable ignorespace
2131 pack .bleft.mid.ignspace -side left -padx 5
2132 set ctext .bleft.bottom.ctext
2133 text $ctext -background $bgcolor -foreground $fgcolor \
2134 -state disabled -font textfont \
2135 -yscrollcommand scrolltext -wrap none \
2136 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2138 $ctext conf -tabstyle wordprocessor
2140 scrollbar .bleft.bottom.sb -command "$ctext yview"
2141 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2143 pack .bleft.top -side top -fill x
2144 pack .bleft.mid -side top -fill x
2145 grid $ctext .bleft.bottom.sb -sticky nsew
2146 grid .bleft.bottom.sbhorizontal -sticky ew
2147 grid columnconfigure .bleft.bottom 0 -weight 1
2148 grid rowconfigure .bleft.bottom 0 -weight 1
2149 grid rowconfigure .bleft.bottom 1 -weight 0
2150 pack .bleft.bottom -side top -fill both -expand 1
2151 lappend bglist $ctext
2152 lappend fglist $ctext
2154 $ctext tag conf comment -wrap $wrapcomment
2155 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2156 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2157 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2158 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2159 $ctext tag conf m0 -fore red
2160 $ctext tag conf m1 -fore blue
2161 $ctext tag conf m2 -fore green
2162 $ctext tag conf m3 -fore purple
2163 $ctext tag conf m4 -fore brown
2164 $ctext tag conf m5 -fore "#009090"
2165 $ctext tag conf m6 -fore magenta
2166 $ctext tag conf m7 -fore "#808000"
2167 $ctext tag conf m8 -fore "#009000"
2168 $ctext tag conf m9 -fore "#ff0080"
2169 $ctext tag conf m10 -fore cyan
2170 $ctext tag conf m11 -fore "#b07070"
2171 $ctext tag conf m12 -fore "#70b0f0"
2172 $ctext tag conf m13 -fore "#70f0b0"
2173 $ctext tag conf m14 -fore "#f0b070"
2174 $ctext tag conf m15 -fore "#ff70b0"
2175 $ctext tag conf mmax -fore darkgrey
2177 $ctext tag conf mresult -font textfontbold
2178 $ctext tag conf msep -font textfontbold
2179 $ctext tag conf found -back yellow
2181 .pwbottom add .bleft
2182 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2187 radiobutton .bright.mode.patch -text [mc "Patch"] \
2188 -command reselectline -variable cmitmode -value "patch"
2189 radiobutton .bright.mode.tree -text [mc "Tree"] \
2190 -command reselectline -variable cmitmode -value "tree"
2191 grid .bright.mode.patch .bright.mode.tree -sticky ew
2192 pack .bright.mode -side top -fill x
2193 set cflist .bright.cfiles
2194 set indent [font measure mainfont "nn"]
2196 -selectbackground $selectbgcolor \
2197 -background $bgcolor -foreground $fgcolor \
2199 -tabs [list $indent [expr {2 * $indent}]] \
2200 -yscrollcommand ".bright.sb set" \
2201 -cursor [. cget -cursor] \
2202 -spacing1 1 -spacing3 1
2203 lappend bglist $cflist
2204 lappend fglist $cflist
2205 scrollbar .bright.sb -command "$cflist yview"
2206 pack .bright.sb -side right -fill y
2207 pack $cflist -side left -fill both -expand 1
2208 $cflist tag configure highlight \
2209 -background [$cflist cget -selectbackground]
2210 $cflist tag configure bold -font mainfontbold
2212 .pwbottom add .bright
2215 # restore window width & height if known
2216 if {[info exists geometry(main)]} {
2217 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2218 if {$w > [winfo screenwidth .]} {
2219 set w [winfo screenwidth .]
2221 if {$h > [winfo screenheight .]} {
2222 set h [winfo screenheight .]
2224 wm geometry . "${w}x$h"
2228 if {[tk windowingsystem] eq {aqua}} {
2234 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2235 pack .ctop -fill both -expand 1
2236 bindall <1> {selcanvline %W %x %y}
2237 #bindall <B1-Motion> {selcanvline %W %x %y}
2238 if {[tk windowingsystem] == "win32"} {
2239 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2240 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2242 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2243 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2244 if {[tk windowingsystem] eq "aqua"} {
2245 bindall <MouseWheel> {
2246 set delta [expr {- (%D)}]
2247 allcanvs yview scroll $delta units
2251 bindall <2> "canvscan mark %W %x %y"
2252 bindall <B2-Motion> "canvscan dragto %W %x %y"
2253 bindkey <Home> selfirstline
2254 bindkey <End> sellastline
2255 bind . <Key-Up> "selnextline -1"
2256 bind . <Key-Down> "selnextline 1"
2257 bind . <Shift-Key-Up> "dofind -1 0"
2258 bind . <Shift-Key-Down> "dofind 1 0"
2259 bindkey <Key-Right> "goforw"
2260 bindkey <Key-Left> "goback"
2261 bind . <Key-Prior> "selnextpage -1"
2262 bind . <Key-Next> "selnextpage 1"
2263 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2264 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2265 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2266 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2267 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2268 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2269 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2270 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2271 bindkey <Key-space> "$ctext yview scroll 1 pages"
2272 bindkey p "selnextline -1"
2273 bindkey n "selnextline 1"
2276 bindkey i "selnextline -1"
2277 bindkey k "selnextline 1"
2281 bindkey d "$ctext yview scroll 18 units"
2282 bindkey u "$ctext yview scroll -18 units"
2283 bindkey / {focus $fstring}
2284 bindkey <Key-Return> {dofind 1 1}
2285 bindkey ? {dofind -1 1}
2287 bind . <F5> updatecommits
2288 bind . <$M1B-F5> reloadcommits
2289 bind . <F2> showrefs
2290 bind . <Shift-F4> {newview 0}
2291 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2292 bind . <F4> edit_or_newview
2293 bind . <$M1B-q> doquit
2294 bind . <$M1B-f> {dofind 1 1}
2295 bind . <$M1B-g> {dofind 1 0}
2296 bind . <$M1B-r> dosearchback
2297 bind . <$M1B-s> dosearch
2298 bind . <$M1B-equal> {incrfont 1}
2299 bind . <$M1B-plus> {incrfont 1}
2300 bind . <$M1B-KP_Add> {incrfont 1}
2301 bind . <$M1B-minus> {incrfont -1}
2302 bind . <$M1B-KP_Subtract> {incrfont -1}
2303 wm protocol . WM_DELETE_WINDOW doquit
2304 bind . <Destroy> {stop_backends}
2305 bind . <Button-1> "click %W"
2306 bind $fstring <Key-Return> {dofind 1 1}
2307 bind $sha1entry <Key-Return> {gotocommit; break}
2308 bind $sha1entry <<PasteSelection>> clearsha1
2309 bind $cflist <1> {sel_flist %W %x %y; break}
2310 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2311 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2313 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2314 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2316 set maincursor [. cget -cursor]
2317 set textcursor [$ctext cget -cursor]
2318 set curtextcursor $textcursor
2320 set rowctxmenu .rowctxmenu
2321 makemenu $rowctxmenu {
2322 {mc "Diff this -> selected" command {diffvssel 0}}
2323 {mc "Diff selected -> this" command {diffvssel 1}}
2324 {mc "Make patch" command mkpatch}
2325 {mc "Create tag" command mktag}
2326 {mc "Write commit to file" command writecommit}
2327 {mc "Create new branch" command mkbranch}
2328 {mc "Cherry-pick this commit" command cherrypick}
2329 {mc "Reset HEAD branch to here" command resethead}
2331 $rowctxmenu configure -tearoff 0
2333 set fakerowmenu .fakerowmenu
2334 makemenu $fakerowmenu {
2335 {mc "Diff this -> selected" command {diffvssel 0}}
2336 {mc "Diff selected -> this" command {diffvssel 1}}
2337 {mc "Make patch" command mkpatch}
2339 $fakerowmenu configure -tearoff 0
2341 set headctxmenu .headctxmenu
2342 makemenu $headctxmenu {
2343 {mc "Check out this branch" command cobranch}
2344 {mc "Remove this branch" command rmbranch}
2346 $headctxmenu configure -tearoff 0
2349 set flist_menu .flistctxmenu
2350 makemenu $flist_menu {
2351 {mc "Highlight this too" command {flist_hl 0}}
2352 {mc "Highlight this only" command {flist_hl 1}}
2353 {mc "External diff" command {external_diff}}
2354 {mc "Blame parent commit" command {external_blame 1}}
2356 $flist_menu configure -tearoff 0
2359 set diff_menu .diffctxmenu
2360 makemenu $diff_menu {
2361 {mc "Show origin of this line" command show_line_source}
2362 {mc "Run git gui blame on this line" command {external_blame_diff}}
2364 $diff_menu configure -tearoff 0
2367 # Windows sends all mouse wheel events to the current focused window, not
2368 # the one where the mouse hovers, so bind those events here and redirect
2369 # to the correct window
2370 proc windows_mousewheel_redirector {W X Y D} {
2371 global canv canv2 canv3
2372 set w [winfo containing -displayof $W $X $Y]
2374 set u [expr {$D < 0 ? 5 : -5}]
2375 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2376 allcanvs yview scroll $u units
2379 $w yview scroll $u units
2385 # Update row number label when selectedline changes
2386 proc selectedline_change {n1 n2 op} {
2387 global selectedline rownumsel
2389 if {$selectedline eq {}} {
2392 set rownumsel [expr {$selectedline + 1}]
2396 # mouse-2 makes all windows scan vertically, but only the one
2397 # the cursor is in scans horizontally
2398 proc canvscan {op w x y} {
2399 global canv canv2 canv3
2400 foreach c [list $canv $canv2 $canv3] {
2409 proc scrollcanv {cscroll f0 f1} {
2410 $cscroll set $f0 $f1
2415 # when we make a key binding for the toplevel, make sure
2416 # it doesn't get triggered when that key is pressed in the
2417 # find string entry widget.
2418 proc bindkey {ev script} {
2421 set escript [bind Entry $ev]
2422 if {$escript == {}} {
2423 set escript [bind Entry <Key>]
2425 foreach e $entries {
2426 bind $e $ev "$escript; break"
2430 # set the focus back to the toplevel for any click outside
2433 global ctext entries
2434 foreach e [concat $entries $ctext] {
2435 if {$w == $e} return
2440 # Adjust the progress bar for a change in requested extent or canvas size
2441 proc adjustprogress {} {
2442 global progresscanv progressitem progresscoords
2443 global fprogitem fprogcoord lastprogupdate progupdatepending
2444 global rprogitem rprogcoord
2446 set w [expr {[winfo width $progresscanv] - 4}]
2447 set x0 [expr {$w * [lindex $progresscoords 0]}]
2448 set x1 [expr {$w * [lindex $progresscoords 1]}]
2449 set h [winfo height $progresscanv]
2450 $progresscanv coords $progressitem $x0 0 $x1 $h
2451 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2452 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2453 set now [clock clicks -milliseconds]
2454 if {$now >= $lastprogupdate + 100} {
2455 set progupdatepending 0
2457 } elseif {!$progupdatepending} {
2458 set progupdatepending 1
2459 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2463 proc doprogupdate {} {
2464 global lastprogupdate progupdatepending
2466 if {$progupdatepending} {
2467 set progupdatepending 0
2468 set lastprogupdate [clock clicks -milliseconds]
2473 proc savestuff {w} {
2474 global canv canv2 canv3 mainfont textfont uifont tabstop
2475 global stuffsaved findmergefiles maxgraphpct
2476 global maxwidth showneartags showlocalchanges
2477 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2478 global cmitmode wrapcomment datetimeformat limitdiffs
2479 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2480 global autoselect extdifftool perfile_attrs markbgcolor
2482 if {$stuffsaved} return
2483 if {![winfo viewable .]} return
2485 set f [open "~/.gitk-new" w]
2486 puts $f [list set mainfont $mainfont]
2487 puts $f [list set textfont $textfont]
2488 puts $f [list set uifont $uifont]
2489 puts $f [list set tabstop $tabstop]
2490 puts $f [list set findmergefiles $findmergefiles]
2491 puts $f [list set maxgraphpct $maxgraphpct]
2492 puts $f [list set maxwidth $maxwidth]
2493 puts $f [list set cmitmode $cmitmode]
2494 puts $f [list set wrapcomment $wrapcomment]
2495 puts $f [list set autoselect $autoselect]
2496 puts $f [list set showneartags $showneartags]
2497 puts $f [list set showlocalchanges $showlocalchanges]
2498 puts $f [list set datetimeformat $datetimeformat]
2499 puts $f [list set limitdiffs $limitdiffs]
2500 puts $f [list set bgcolor $bgcolor]
2501 puts $f [list set fgcolor $fgcolor]
2502 puts $f [list set colors $colors]
2503 puts $f [list set diffcolors $diffcolors]
2504 puts $f [list set markbgcolor $markbgcolor]
2505 puts $f [list set diffcontext $diffcontext]
2506 puts $f [list set selectbgcolor $selectbgcolor]
2507 puts $f [list set extdifftool $extdifftool]
2508 puts $f [list set perfile_attrs $perfile_attrs]
2510 puts $f "set geometry(main) [wm geometry .]"
2511 puts $f "set geometry(topwidth) [winfo width .tf]"
2512 puts $f "set geometry(topheight) [winfo height .tf]"
2513 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2514 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2515 puts $f "set geometry(botwidth) [winfo width .bleft]"
2516 puts $f "set geometry(botheight) [winfo height .bleft]"
2518 puts -nonewline $f "set permviews {"
2519 for {set v 0} {$v < $nextviewnum} {incr v} {
2520 if {$viewperm($v)} {
2521 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2526 file rename -force "~/.gitk-new" "~/.gitk"
2531 proc resizeclistpanes {win w} {
2533 if {[info exists oldwidth($win)]} {
2534 set s0 [$win sash coord 0]
2535 set s1 [$win sash coord 1]
2537 set sash0 [expr {int($w/2 - 2)}]
2538 set sash1 [expr {int($w*5/6 - 2)}]
2540 set factor [expr {1.0 * $w / $oldwidth($win)}]
2541 set sash0 [expr {int($factor * [lindex $s0 0])}]
2542 set sash1 [expr {int($factor * [lindex $s1 0])}]
2546 if {$sash1 < $sash0 + 20} {
2547 set sash1 [expr {$sash0 + 20}]
2549 if {$sash1 > $w - 10} {
2550 set sash1 [expr {$w - 10}]
2551 if {$sash0 > $sash1 - 20} {
2552 set sash0 [expr {$sash1 - 20}]
2556 $win sash place 0 $sash0 [lindex $s0 1]
2557 $win sash place 1 $sash1 [lindex $s1 1]
2559 set oldwidth($win) $w
2562 proc resizecdetpanes {win w} {
2564 if {[info exists oldwidth($win)]} {
2565 set s0 [$win sash coord 0]
2567 set sash0 [expr {int($w*3/4 - 2)}]
2569 set factor [expr {1.0 * $w / $oldwidth($win)}]
2570 set sash0 [expr {int($factor * [lindex $s0 0])}]
2574 if {$sash0 > $w - 15} {
2575 set sash0 [expr {$w - 15}]
2578 $win sash place 0 $sash0 [lindex $s0 1]
2580 set oldwidth($win) $w
2583 proc allcanvs args {
2584 global canv canv2 canv3
2590 proc bindall {event action} {
2591 global canv canv2 canv3
2592 bind $canv $event $action
2593 bind $canv2 $event $action
2594 bind $canv3 $event $action
2600 if {[winfo exists $w]} {
2605 wm title $w [mc "About gitk"]
2607 message $w.m -text [mc "
2608 Gitk - a commit viewer for git
2610 Copyright © 2005-2008 Paul Mackerras
2612 Use and redistribute under the terms of the GNU General Public License"] \
2613 -justify center -aspect 400 -border 2 -bg white -relief groove
2614 pack $w.m -side top -fill x -padx 2 -pady 2
2615 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2616 pack $w.ok -side bottom
2617 bind $w <Visibility> "focus $w.ok"
2618 bind $w <Key-Escape> "destroy $w"
2619 bind $w <Key-Return> "destroy $w"
2624 if {[winfo exists $w]} {
2628 if {[tk windowingsystem] eq {aqua}} {
2634 wm title $w [mc "Gitk key bindings"]
2636 message $w.m -text "
2637 [mc "Gitk key bindings:"]
2639 [mc "<%s-Q> Quit" $M1T]
2640 [mc "<Home> Move to first commit"]
2641 [mc "<End> Move to last commit"]
2642 [mc "<Up>, p, i Move up one commit"]
2643 [mc "<Down>, n, k Move down one commit"]
2644 [mc "<Left>, z, j Go back in history list"]
2645 [mc "<Right>, x, l Go forward in history list"]
2646 [mc "<PageUp> Move up one page in commit list"]
2647 [mc "<PageDown> Move down one page in commit list"]
2648 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2649 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2650 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2651 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2652 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2653 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2654 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2655 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2656 [mc "<Delete>, b Scroll diff view up one page"]
2657 [mc "<Backspace> Scroll diff view up one page"]
2658 [mc "<Space> Scroll diff view down one page"]
2659 [mc "u Scroll diff view up 18 lines"]
2660 [mc "d Scroll diff view down 18 lines"]
2661 [mc "<%s-F> Find" $M1T]
2662 [mc "<%s-G> Move to next find hit" $M1T]
2663 [mc "<Return> Move to next find hit"]
2664 [mc "/ Focus the search box"]
2665 [mc "? Move to previous find hit"]
2666 [mc "f Scroll diff view to next file"]
2667 [mc "<%s-S> Search for next hit in diff view" $M1T]
2668 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2669 [mc "<%s-KP+> Increase font size" $M1T]
2670 [mc "<%s-plus> Increase font size" $M1T]
2671 [mc "<%s-KP-> Decrease font size" $M1T]
2672 [mc "<%s-minus> Decrease font size" $M1T]
2675 -justify left -bg white -border 2 -relief groove
2676 pack $w.m -side top -fill both -padx 2 -pady 2
2677 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2678 bind $w <Key-Escape> [list destroy $w]
2679 pack $w.ok -side bottom
2680 bind $w <Visibility> "focus $w.ok"
2681 bind $w <Key-Escape> "destroy $w"
2682 bind $w <Key-Return> "destroy $w"
2685 # Procedures for manipulating the file list window at the
2686 # bottom right of the overall window.
2688 proc treeview {w l openlevs} {
2689 global treecontents treediropen treeheight treeparent treeindex
2699 set treecontents() {}
2700 $w conf -state normal
2702 while {[string range $f 0 $prefixend] ne $prefix} {
2703 if {$lev <= $openlevs} {
2704 $w mark set e:$treeindex($prefix) "end -1c"
2705 $w mark gravity e:$treeindex($prefix) left
2707 set treeheight($prefix) $ht
2708 incr ht [lindex $htstack end]
2709 set htstack [lreplace $htstack end end]
2710 set prefixend [lindex $prefendstack end]
2711 set prefendstack [lreplace $prefendstack end end]
2712 set prefix [string range $prefix 0 $prefixend]
2715 set tail [string range $f [expr {$prefixend+1}] end]
2716 while {[set slash [string first "/" $tail]] >= 0} {
2719 lappend prefendstack $prefixend
2720 incr prefixend [expr {$slash + 1}]
2721 set d [string range $tail 0 $slash]
2722 lappend treecontents($prefix) $d
2723 set oldprefix $prefix
2725 set treecontents($prefix) {}
2726 set treeindex($prefix) [incr ix]
2727 set treeparent($prefix) $oldprefix
2728 set tail [string range $tail [expr {$slash+1}] end]
2729 if {$lev <= $openlevs} {
2731 set treediropen($prefix) [expr {$lev < $openlevs}]
2732 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2733 $w mark set d:$ix "end -1c"
2734 $w mark gravity d:$ix left
2736 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2738 $w image create end -align center -image $bm -padx 1 \
2740 $w insert end $d [highlight_tag $prefix]
2741 $w mark set s:$ix "end -1c"
2742 $w mark gravity s:$ix left
2747 if {$lev <= $openlevs} {
2750 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2752 $w insert end $tail [highlight_tag $f]
2754 lappend treecontents($prefix) $tail
2757 while {$htstack ne {}} {
2758 set treeheight($prefix) $ht
2759 incr ht [lindex $htstack end]
2760 set htstack [lreplace $htstack end end]
2761 set prefixend [lindex $prefendstack end]
2762 set prefendstack [lreplace $prefendstack end end]
2763 set prefix [string range $prefix 0 $prefixend]
2765 $w conf -state disabled
2768 proc linetoelt {l} {
2769 global treeheight treecontents
2774 foreach e $treecontents($prefix) {
2779 if {[string index $e end] eq "/"} {
2780 set n $treeheight($prefix$e)
2792 proc highlight_tree {y prefix} {
2793 global treeheight treecontents cflist
2795 foreach e $treecontents($prefix) {
2797 if {[highlight_tag $path] ne {}} {
2798 $cflist tag add bold $y.0 "$y.0 lineend"
2801 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2802 set y [highlight_tree $y $path]
2808 proc treeclosedir {w dir} {
2809 global treediropen treeheight treeparent treeindex
2811 set ix $treeindex($dir)
2812 $w conf -state normal
2813 $w delete s:$ix e:$ix
2814 set treediropen($dir) 0
2815 $w image configure a:$ix -image tri-rt
2816 $w conf -state disabled
2817 set n [expr {1 - $treeheight($dir)}]
2818 while {$dir ne {}} {
2819 incr treeheight($dir) $n
2820 set dir $treeparent($dir)
2824 proc treeopendir {w dir} {
2825 global treediropen treeheight treeparent treecontents treeindex
2827 set ix $treeindex($dir)
2828 $w conf -state normal
2829 $w image configure a:$ix -image tri-dn
2830 $w mark set e:$ix s:$ix
2831 $w mark gravity e:$ix right
2834 set n [llength $treecontents($dir)]
2835 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2838 incr treeheight($x) $n
2840 foreach e $treecontents($dir) {
2842 if {[string index $e end] eq "/"} {
2843 set iy $treeindex($de)
2844 $w mark set d:$iy e:$ix
2845 $w mark gravity d:$iy left
2846 $w insert e:$ix $str
2847 set treediropen($de) 0
2848 $w image create e:$ix -align center -image tri-rt -padx 1 \
2850 $w insert e:$ix $e [highlight_tag $de]
2851 $w mark set s:$iy e:$ix
2852 $w mark gravity s:$iy left
2853 set treeheight($de) 1
2855 $w insert e:$ix $str
2856 $w insert e:$ix $e [highlight_tag $de]
2859 $w mark gravity e:$ix right
2860 $w conf -state disabled
2861 set treediropen($dir) 1
2862 set top [lindex [split [$w index @0,0] .] 0]
2863 set ht [$w cget -height]
2864 set l [lindex [split [$w index s:$ix] .] 0]
2867 } elseif {$l + $n + 1 > $top + $ht} {
2868 set top [expr {$l + $n + 2 - $ht}]
2876 proc treeclick {w x y} {
2877 global treediropen cmitmode ctext cflist cflist_top
2879 if {$cmitmode ne "tree"} return
2880 if {![info exists cflist_top]} return
2881 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2882 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2883 $cflist tag add highlight $l.0 "$l.0 lineend"
2889 set e [linetoelt $l]
2890 if {[string index $e end] ne "/"} {
2892 } elseif {$treediropen($e)} {
2899 proc setfilelist {id} {
2900 global treefilelist cflist jump_to_here
2902 treeview $cflist $treefilelist($id) 0
2903 if {$jump_to_here ne {}} {
2904 set f [lindex $jump_to_here 0]
2905 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2911 image create bitmap tri-rt -background black -foreground blue -data {
2912 #define tri-rt_width 13
2913 #define tri-rt_height 13
2914 static unsigned char tri-rt_bits[] = {
2915 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2916 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2919 #define tri-rt-mask_width 13
2920 #define tri-rt-mask_height 13
2921 static unsigned char tri-rt-mask_bits[] = {
2922 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2923 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2926 image create bitmap tri-dn -background black -foreground blue -data {
2927 #define tri-dn_width 13
2928 #define tri-dn_height 13
2929 static unsigned char tri-dn_bits[] = {
2930 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2931 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2934 #define tri-dn-mask_width 13
2935 #define tri-dn-mask_height 13
2936 static unsigned char tri-dn-mask_bits[] = {
2937 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2938 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2942 image create bitmap reficon-T -background black -foreground yellow -data {
2943 #define tagicon_width 13
2944 #define tagicon_height 9
2945 static unsigned char tagicon_bits[] = {
2946 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2947 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2949 #define tagicon-mask_width 13
2950 #define tagicon-mask_height 9
2951 static unsigned char tagicon-mask_bits[] = {
2952 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2953 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2956 #define headicon_width 13
2957 #define headicon_height 9
2958 static unsigned char headicon_bits[] = {
2959 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2960 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2963 #define headicon-mask_width 13
2964 #define headicon-mask_height 9
2965 static unsigned char headicon-mask_bits[] = {
2966 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2967 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2969 image create bitmap reficon-H -background black -foreground green \
2970 -data $rectdata -maskdata $rectmask
2971 image create bitmap reficon-o -background black -foreground "#ddddff" \
2972 -data $rectdata -maskdata $rectmask
2974 proc init_flist {first} {
2975 global cflist cflist_top difffilestart
2977 $cflist conf -state normal
2978 $cflist delete 0.0 end
2980 $cflist insert end $first
2982 $cflist tag add highlight 1.0 "1.0 lineend"
2984 catch {unset cflist_top}
2986 $cflist conf -state disabled
2987 set difffilestart {}
2990 proc highlight_tag {f} {
2991 global highlight_paths
2993 foreach p $highlight_paths {
2994 if {[string match $p $f]} {
3001 proc highlight_filelist {} {
3002 global cmitmode cflist
3004 $cflist conf -state normal
3005 if {$cmitmode ne "tree"} {
3006 set end [lindex [split [$cflist index end] .] 0]
3007 for {set l 2} {$l < $end} {incr l} {
3008 set line [$cflist get $l.0 "$l.0 lineend"]
3009 if {[highlight_tag $line] ne {}} {
3010 $cflist tag add bold $l.0 "$l.0 lineend"
3016 $cflist conf -state disabled
3019 proc unhighlight_filelist {} {
3022 $cflist conf -state normal
3023 $cflist tag remove bold 1.0 end
3024 $cflist conf -state disabled
3027 proc add_flist {fl} {
3030 $cflist conf -state normal
3032 $cflist insert end "\n"
3033 $cflist insert end $f [highlight_tag $f]
3035 $cflist conf -state disabled
3038 proc sel_flist {w x y} {
3039 global ctext difffilestart cflist cflist_top cmitmode
3041 if {$cmitmode eq "tree"} return
3042 if {![info exists cflist_top]} return
3043 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3044 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3045 $cflist tag add highlight $l.0 "$l.0 lineend"
3050 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3054 proc pop_flist_menu {w X Y x y} {
3055 global ctext cflist cmitmode flist_menu flist_menu_file
3056 global treediffs diffids
3059 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3061 if {$cmitmode eq "tree"} {
3062 set e [linetoelt $l]
3063 if {[string index $e end] eq "/"} return
3065 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3067 set flist_menu_file $e
3068 set xdiffstate "normal"
3069 if {$cmitmode eq "tree"} {
3070 set xdiffstate "disabled"
3072 # Disable "External diff" item in tree mode
3073 $flist_menu entryconf 2 -state $xdiffstate
3074 tk_popup $flist_menu $X $Y
3077 proc find_ctext_fileinfo {line} {
3078 global ctext_file_names ctext_file_lines
3080 set ok [bsearch $ctext_file_lines $line]
3081 set tline [lindex $ctext_file_lines $ok]
3083 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3086 return [list [lindex $ctext_file_names $ok] $tline]
3090 proc pop_diff_menu {w X Y x y} {
3091 global ctext diff_menu flist_menu_file
3092 global diff_menu_txtpos diff_menu_line
3093 global diff_menu_filebase
3095 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3096 set diff_menu_line [lindex $diff_menu_txtpos 0]
3097 # don't pop up the menu on hunk-separator or file-separator lines
3098 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3102 set f [find_ctext_fileinfo $diff_menu_line]
3103 if {$f eq {}} return
3104 set flist_menu_file [lindex $f 0]
3105 set diff_menu_filebase [lindex $f 1]
3106 tk_popup $diff_menu $X $Y
3109 proc flist_hl {only} {
3110 global flist_menu_file findstring gdttype
3112 set x [shellquote $flist_menu_file]
3113 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3116 append findstring " " $x
3118 set gdttype [mc "touching paths:"]
3121 proc save_file_from_commit {filename output what} {
3124 if {[catch {exec git show $filename -- > $output} err]} {
3125 if {[string match "fatal: bad revision *" $err]} {
3128 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3134 proc external_diff_get_one_file {diffid filename diffdir} {
3135 global nullid nullid2 nullfile
3138 if {$diffid == $nullid} {
3139 set difffile [file join [file dirname $gitdir] $filename]
3140 if {[file exists $difffile]} {
3145 if {$diffid == $nullid2} {
3146 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3147 return [save_file_from_commit :$filename $difffile index]
3149 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3150 return [save_file_from_commit $diffid:$filename $difffile \
3154 proc external_diff {} {
3155 global gitktmpdir nullid nullid2
3156 global flist_menu_file
3159 global gitdir extdifftool
3161 if {[llength $diffids] == 1} {
3162 # no reference commit given
3163 set diffidto [lindex $diffids 0]
3164 if {$diffidto eq $nullid} {
3165 # diffing working copy with index
3166 set diffidfrom $nullid2
3167 } elseif {$diffidto eq $nullid2} {
3168 # diffing index with HEAD
3169 set diffidfrom "HEAD"
3171 # use first parent commit
3172 global parentlist selectedline
3173 set diffidfrom [lindex $parentlist $selectedline 0]
3176 set diffidfrom [lindex $diffids 0]
3177 set diffidto [lindex $diffids 1]
3180 # make sure that several diffs wont collide
3181 if {![info exists gitktmpdir]} {
3182 set gitktmpdir [file join [file dirname $gitdir] \
3183 [format ".gitk-tmp.%s" [pid]]]
3184 if {[catch {file mkdir $gitktmpdir} err]} {
3185 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3192 set diffdir [file join $gitktmpdir $diffnum]
3193 if {[catch {file mkdir $diffdir} err]} {
3194 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3198 # gather files to diff
3199 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3200 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3202 if {$difffromfile ne {} && $difftofile ne {}} {
3203 set cmd [concat | [shellsplit $extdifftool] \
3204 [list $difffromfile $difftofile]]
3205 if {[catch {set fl [open $cmd r]} err]} {
3206 file delete -force $diffdir
3207 error_popup "$extdifftool: [mc "command failed:"] $err"
3209 fconfigure $fl -blocking 0
3210 filerun $fl [list delete_at_eof $fl $diffdir]
3215 proc find_hunk_blamespec {base line} {
3218 # Find and parse the hunk header
3219 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3220 if {$s_lix eq {}} return
3222 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3223 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3224 s_line old_specs osz osz1 new_line nsz]} {
3228 # base lines for the parents
3229 set base_lines [list $new_line]
3230 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3231 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3232 old_spec old_line osz]} {
3235 lappend base_lines $old_line
3238 # Now scan the lines to determine offset within the hunk
3239 set max_parent [expr {[llength $base_lines]-2}]
3241 set s_lno [lindex [split $s_lix "."] 0]
3243 # Determine if the line is removed
3244 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3245 if {[string match {[-+ ]*} $chunk]} {
3246 set removed_idx [string first "-" $chunk]
3247 # Choose a parent index
3248 if {$removed_idx >= 0} {
3249 set parent $removed_idx
3251 set unchanged_idx [string first " " $chunk]
3252 if {$unchanged_idx >= 0} {
3253 set parent $unchanged_idx
3255 # blame the current commit
3259 # then count other lines that belong to it
3260 for {set i $line} {[incr i -1] > $s_lno} {} {
3261 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3262 # Determine if the line is removed
3263 set removed_idx [string first "-" $chunk]
3265 set code [string index $chunk $parent]
3266 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3270 if {$removed_idx < 0} {
3280 incr dline [lindex $base_lines $parent]
3281 return [list $parent $dline]
3284 proc external_blame_diff {} {
3285 global currentid cmitmode
3286 global diff_menu_txtpos diff_menu_line
3287 global diff_menu_filebase flist_menu_file
3289 if {$cmitmode eq "tree"} {
3291 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3293 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3295 set parent_idx [lindex $hinfo 0]
3296 set line [lindex $hinfo 1]
3303 external_blame $parent_idx $line
3306 # Find the SHA1 ID of the blob for file $fname in the index
3308 proc index_sha1 {fname} {
3309 set f [open [list | git ls-files -s $fname] r]
3310 while {[gets $f line] >= 0} {
3311 set info [lindex [split $line "\t"] 0]
3312 set stage [lindex $info 2]
3313 if {$stage eq "0" || $stage eq "2"} {
3315 return [lindex $info 1]
3322 # Turn an absolute path into one relative to the current directory
3323 proc make_relative {f} {
3324 set elts [file split $f]
3325 set here [file split [pwd]]
3330 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3337 set elts [concat $res [lrange $elts $ei end]]
3338 return [eval file join $elts]
3341 proc external_blame {parent_idx {line {}}} {
3342 global flist_menu_file gitdir
3343 global nullid nullid2
3344 global parentlist selectedline currentid
3346 if {$parent_idx > 0} {
3347 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3349 set base_commit $currentid
3352 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3353 error_popup [mc "No such commit"]
3357 set cmdline [list git gui blame]
3358 if {$line ne {} && $line > 1} {
3359 lappend cmdline "--line=$line"
3361 set f [file join [file dirname $gitdir] $flist_menu_file]
3362 # Unfortunately it seems git gui blame doesn't like
3363 # being given an absolute path...
3364 set f [make_relative $f]
3365 lappend cmdline $base_commit $f
3366 puts "cmdline={$cmdline}"
3367 if {[catch {eval exec $cmdline &} err]} {
3368 error_popup "[mc "git gui blame: command failed:"] $err"
3372 proc show_line_source {} {
3373 global cmitmode currentid parents curview blamestuff blameinst
3374 global diff_menu_line diff_menu_filebase flist_menu_file
3375 global nullid nullid2 gitdir
3378 if {$cmitmode eq "tree"} {
3380 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3382 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3383 if {$h eq {}} return
3384 set pi [lindex $h 0]
3386 mark_ctext_line $diff_menu_line
3390 if {$currentid eq $nullid} {
3392 # must be a merge in progress...
3394 # get the last line from .git/MERGE_HEAD
3395 set f [open [file join $gitdir MERGE_HEAD] r]
3396 set id [lindex [split [read $f] "\n"] end-1]
3399 error_popup [mc "Couldn't read merge head: %s" $err]
3402 } elseif {$parents($curview,$currentid) eq $nullid2} {
3403 # need to do the blame from the index
3405 set from_index [index_sha1 $flist_menu_file]
3407 error_popup [mc "Error reading index: %s" $err]
3411 set id $parents($curview,$currentid)
3414 set id [lindex $parents($curview,$currentid) $pi]
3416 set line [lindex $h 1]
3419 if {$from_index ne {}} {
3420 lappend blameargs | git cat-file blob $from_index
3422 lappend blameargs | git blame -p -L$line,+1
3423 if {$from_index ne {}} {
3424 lappend blameargs --contents -
3426 lappend blameargs $id
3428 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3430 set f [open $blameargs r]
3432 error_popup [mc "Couldn't start git blame: %s" $err]
3435 nowbusy blaming [mc "Searching"]
3436 fconfigure $f -blocking 0
3437 set i [reg_instance $f]
3438 set blamestuff($i) {}
3440 filerun $f [list read_line_source $f $i]
3443 proc stopblaming {} {
3446 if {[info exists blameinst]} {
3447 stop_instance $blameinst
3453 proc read_line_source {fd inst} {
3454 global blamestuff curview commfd blameinst nullid nullid2
3456 while {[gets $fd line] >= 0} {
3457 lappend blamestuff($inst) $line
3465 fconfigure $fd -blocking 1
3466 if {[catch {close $fd} err]} {
3467 error_popup [mc "Error running git blame: %s" $err]
3472 set line [split [lindex $blamestuff($inst) 0] " "]
3473 set id [lindex $line 0]
3474 set lnum [lindex $line 1]
3475 if {[string length $id] == 40 && [string is xdigit $id] &&
3476 [string is digit -strict $lnum]} {
3477 # look for "filename" line
3478 foreach l $blamestuff($inst) {
3479 if {[string match "filename *" $l]} {
3480 set fname [string range $l 9 end]
3486 # all looks good, select it
3487 if {$id eq $nullid} {
3488 # blame uses all-zeroes to mean not committed,
3489 # which would mean a change in the index
3492 if {[commitinview $id $curview]} {
3493 selectline [rowofcommit $id] 1 [list $fname $lnum]
3495 error_popup [mc "That line comes from commit %s, \
3496 which is not in this view" [shortids $id]]
3499 puts "oops couldn't parse git blame output"
3504 # delete $dir when we see eof on $f (presumably because the child has exited)
3505 proc delete_at_eof {f dir} {
3506 while {[gets $f line] >= 0} {}
3508 if {[catch {close $f} err]} {
3509 error_popup "[mc "External diff viewer failed:"] $err"
3511 file delete -force $dir
3517 # Functions for adding and removing shell-type quoting
3519 proc shellquote {str} {
3520 if {![string match "*\['\"\\ \t]*" $str]} {
3523 if {![string match "*\['\"\\]*" $str]} {
3526 if {![string match "*'*" $str]} {
3529 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3532 proc shellarglist {l} {
3538 append str [shellquote $a]
3543 proc shelldequote {str} {
3548 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3549 append ret [string range $str $used end]
3550 set used [string length $str]
3553 set first [lindex $first 0]
3554 set ch [string index $str $first]
3555 if {$first > $used} {
3556 append ret [string range $str $used [expr {$first - 1}]]
3559 if {$ch eq " " || $ch eq "\t"} break
3562 set first [string first "'" $str $used]
3564 error "unmatched single-quote"
3566 append ret [string range $str $used [expr {$first - 1}]]
3571 if {$used >= [string length $str]} {
3572 error "trailing backslash"
3574 append ret [string index $str $used]
3579 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3580 error "unmatched double-quote"
3582 set first [lindex $first 0]
3583 set ch [string index $str $first]
3584 if {$first > $used} {
3585 append ret [string range $str $used [expr {$first - 1}]]
3588 if {$ch eq "\""} break
3590 append ret [string index $str $used]
3594 return [list $used $ret]
3597 proc shellsplit {str} {
3600 set str [string trimleft $str]
3601 if {$str eq {}} break
3602 set dq [shelldequote $str]
3603 set n [lindex $dq 0]
3604 set word [lindex $dq 1]
3605 set str [string range $str $n end]
3611 # Code to implement multiple views
3613 proc newview {ishighlight} {
3614 global nextviewnum newviewname newishighlight
3615 global revtreeargs viewargscmd newviewopts curview
3617 set newishighlight $ishighlight
3619 if {[winfo exists $top]} {
3623 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3624 set newviewopts($nextviewnum,perm) 0
3625 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3626 decode_view_opts $nextviewnum $revtreeargs
3627 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3630 set known_view_options {
3631 {perm b . {} {mc "Remember this view"}}
3632 {args t50= + {} {mc "Commits to include (arguments to git log):"}}
3633 {all b * "--all" {mc "Use all refs"}}
3634 {dorder b . {"--date-order" "-d"} {mc "Strictly sort by date"}}
3635 {lright b . "--left-right" {mc "Mark branch sides"}}
3636 {since t15 + {"--since=*" "--after=*"} {mc "Since date:"}}
3637 {until t15 . {"--until=*" "--before=*"} {mc "Until date:"}}
3638 {limit t10 + "--max-count=*" {mc "Max count:"}}
3639 {skip t10 . "--skip=*" {mc "Skip:"}}
3640 {first b . "--first-parent" {mc "Limit to first parent"}}
3641 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3644 proc encode_view_opts {n} {
3645 global known_view_options newviewopts
3648 foreach opt $known_view_options {
3649 set patterns [lindex $opt 3]
3650 if {$patterns eq {}} continue
3651 set pattern [lindex $patterns 0]
3653 set val $newviewopts($n,[lindex $opt 0])
3655 if {[lindex $opt 1] eq "b"} {
3657 lappend rargs $pattern
3660 set val [string trim $val]
3662 set pfix [string range $pattern 0 end-1]
3663 lappend rargs $pfix$val
3667 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3670 proc decode_view_opts {n view_args} {
3671 global known_view_options newviewopts
3673 foreach opt $known_view_options {
3674 if {[lindex $opt 1] eq "b"} {
3679 set newviewopts($n,[lindex $opt 0]) $val
3682 foreach arg $view_args {
3683 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3684 && ![info exists found(limit)]} {
3685 set newviewopts($n,limit) $cnt
3690 foreach opt $known_view_options {
3691 set id [lindex $opt 0]
3692 if {[info exists found($id)]} continue
3693 foreach pattern [lindex $opt 3] {
3694 if {![string match $pattern $arg]} continue
3695 if {[lindex $opt 1] ne "b"} {
3696 set size [string length $pattern]
3697 set val [string range $arg [expr {$size-1}] end]
3701 set newviewopts($n,$id) $val
3705 if {[info exists val]} break
3707 if {[info exists val]} continue
3710 set newviewopts($n,args) [shellarglist $oargs]
3713 proc edit_or_newview {} {
3725 global viewname viewperm newviewname newviewopts
3726 global viewargs viewargscmd
3728 set top .gitkvedit-$curview
3729 if {[winfo exists $top]} {
3733 set newviewname($curview) $viewname($curview)
3734 set newviewopts($curview,perm) $viewperm($curview)
3735 set newviewopts($curview,cmd) $viewargscmd($curview)
3736 decode_view_opts $curview $viewargs($curview)
3737 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3740 proc vieweditor {top n title} {
3741 global newviewname newviewopts viewfiles bgcolor
3742 global known_view_options
3745 wm title $top $title
3746 make_transient $top .
3750 label $top.nl -text [mc "Name"]
3751 entry $top.name -width 20 -textvariable newviewname($n)
3752 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3753 pack $top.nl -in $top.nfr -side left -padx {0 30}
3754 pack $top.name -in $top.nfr -side left
3760 foreach opt $known_view_options {
3761 set id [lindex $opt 0]
3762 set type [lindex $opt 1]
3763 set flags [lindex $opt 2]
3764 set title [eval [lindex $opt 4]]
3767 if {$flags eq "+" || $flags eq "*"} {
3768 set cframe $top.fr$cnt
3771 pack $cframe -in $top -fill x -pady 3 -padx 3
3772 set cexpand [expr {$flags eq "*"}]
3778 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3779 pack $cframe.c_$id -in $cframe -side left \
3780 -padx [list $lxpad 0] -expand $cexpand -anchor w
3781 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3782 message $cframe.l_$id -aspect 1500 -text $title
3783 entry $cframe.e_$id -width $sz -background $bgcolor \
3784 -textvariable newviewopts($n,$id)
3785 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3786 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3787 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3788 message $cframe.l_$id -aspect 1500 -text $title
3789 entry $cframe.e_$id -width $sz -background $bgcolor \
3790 -textvariable newviewopts($n,$id)
3791 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3792 pack $cframe.e_$id -in $cframe -side top -fill x
3797 message $top.l -aspect 1500 \
3798 -text [mc "Enter files and directories to include, one per line:"]
3799 pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3800 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3801 if {[info exists viewfiles($n)]} {
3802 foreach f $viewfiles($n) {
3803 $top.t insert end $f
3804 $top.t insert end "\n"
3806 $top.t delete {end - 1c} end
3807 $top.t mark set insert 0.0
3809 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3811 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3812 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3813 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3814 bind $top <Control-Return> [list newviewok $top $n]
3815 bind $top <F5> [list newviewok $top $n 1]
3816 bind $top <Escape> [list destroy $top]
3817 grid $top.buts.ok $top.buts.apply $top.buts.can
3818 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3819 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3820 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3821 pack $top.buts -in $top -side top -fill x
3825 proc doviewmenu {m first cmd op argv} {
3826 set nmenu [$m index end]
3827 for {set i $first} {$i <= $nmenu} {incr i} {
3828 if {[$m entrycget $i -command] eq $cmd} {
3829 eval $m $op $i $argv
3835 proc allviewmenus {n op args} {
3838 doviewmenu .bar.view 5 [list showview $n] $op $args
3839 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3842 proc newviewok {top n {apply 0}} {
3843 global nextviewnum newviewperm newviewname newishighlight
3844 global viewname viewfiles viewperm selectedview curview
3845 global viewargs viewargscmd newviewopts viewhlmenu
3848 set newargs [encode_view_opts $n]
3850 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3854 foreach f [split [$top.t get 0.0 end] "\n"] {
3855 set ft [string trim $f]
3860 if {![info exists viewfiles($n)]} {
3861 # creating a new view
3863 set viewname($n) $newviewname($n)
3864 set viewperm($n) $newviewopts($n,perm)
3865 set viewfiles($n) $files
3866 set viewargs($n) $newargs
3867 set viewargscmd($n) $newviewopts($n,cmd)
3869 if {!$newishighlight} {
3872 run addvhighlight $n
3875 # editing an existing view
3876 set viewperm($n) $newviewopts($n,perm)
3877 if {$newviewname($n) ne $viewname($n)} {
3878 set viewname($n) $newviewname($n)
3879 doviewmenu .bar.view 5 [list showview $n] \
3880 entryconf [list -label $viewname($n)]
3881 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3882 # entryconf [list -label $viewname($n) -value $viewname($n)]
3884 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3885 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3886 set viewfiles($n) $files
3887 set viewargs($n) $newargs
3888 set viewargscmd($n) $newviewopts($n,cmd)
3889 if {$curview == $n} {
3895 catch {destroy $top}
3899 global curview viewperm hlview selectedhlview
3901 if {$curview == 0} return
3902 if {[info exists hlview] && $hlview == $curview} {
3903 set selectedhlview [mc "None"]
3906 allviewmenus $curview delete
3907 set viewperm($curview) 0
3911 proc addviewmenu {n} {
3912 global viewname viewhlmenu
3914 .bar.view add radiobutton -label $viewname($n) \
3915 -command [list showview $n] -variable selectedview -value $n
3916 #$viewhlmenu add radiobutton -label $viewname($n) \
3917 # -command [list addvhighlight $n] -variable selectedhlview
3921 global curview cached_commitrow ordertok
3922 global displayorder parentlist rowidlist rowisopt rowfinal
3923 global colormap rowtextx nextcolor canvxmax
3924 global numcommits viewcomplete
3925 global selectedline currentid canv canvy0
3927 global pending_select mainheadid
3930 global hlview selectedhlview commitinterest
3932 if {$n == $curview} return
3934 set ymax [lindex [$canv cget -scrollregion] 3]
3935 set span [$canv yview]
3936 set ytop [expr {[lindex $span 0] * $ymax}]
3937 set ybot [expr {[lindex $span 1] * $ymax}]
3938 set yscreen [expr {($ybot - $ytop) / 2}]
3939 if {$selectedline ne {}} {
3940 set selid $currentid
3941 set y [yc $selectedline]
3942 if {$ytop < $y && $y < $ybot} {
3943 set yscreen [expr {$y - $ytop}]
3945 } elseif {[info exists pending_select]} {
3946 set selid $pending_select
3947 unset pending_select
3951 catch {unset treediffs}
3953 if {[info exists hlview] && $hlview == $n} {
3955 set selectedhlview [mc "None"]
3957 catch {unset commitinterest}
3958 catch {unset cached_commitrow}
3959 catch {unset ordertok}
3963 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3964 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3967 if {![info exists viewcomplete($n)]} {
3977 set numcommits $commitidx($n)
3979 catch {unset colormap}
3980 catch {unset rowtextx}
3982 set canvxmax [$canv cget -width]
3988 if {$selid ne {} && [commitinview $selid $n]} {
3989 set row [rowofcommit $selid]
3990 # try to get the selected row in the same position on the screen
3991 set ymax [lindex [$canv cget -scrollregion] 3]
3992 set ytop [expr {[yc $row] - $yscreen}]
3996 set yf [expr {$ytop * 1.0 / $ymax}]
3998 allcanvs yview moveto $yf
4002 } elseif {!$viewcomplete($n)} {
4003 reset_pending_select $selid
4005 reset_pending_select {}
4007 if {[commitinview $pending_select $curview]} {
4008 selectline [rowofcommit $pending_select] 1
4010 set row [first_real_row]
4011 if {$row < $numcommits} {
4016 if {!$viewcomplete($n)} {
4017 if {$numcommits == 0} {
4018 show_status [mc "Reading commits..."]
4020 } elseif {$numcommits == 0} {
4021 show_status [mc "No commits selected"]
4025 # Stuff relating to the highlighting facility
4027 proc ishighlighted {id} {
4028 global vhighlights fhighlights nhighlights rhighlights
4030 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4031 return $nhighlights($id)
4033 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4034 return $vhighlights($id)
4036 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4037 return $fhighlights($id)
4039 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4040 return $rhighlights($id)
4045 proc bolden {id font} {
4046 global canv linehtag currentid boldids need_redisplay
4048 # need_redisplay = 1 means the display is stale and about to be redrawn
4049 if {$need_redisplay} return
4051 $canv itemconf $linehtag($id) -font $font
4052 if {[info exists currentid] && $id eq $currentid} {
4054 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4055 -outline {{}} -tags secsel \
4056 -fill [$canv cget -selectbackground]]
4061 proc bolden_name {id font} {
4062 global canv2 linentag currentid boldnameids need_redisplay
4064 if {$need_redisplay} return
4065 lappend boldnameids $id
4066 $canv2 itemconf $linentag($id) -font $font
4067 if {[info exists currentid] && $id eq $currentid} {
4068 $canv2 delete secsel
4069 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4070 -outline {{}} -tags secsel \
4071 -fill [$canv2 cget -selectbackground]]
4080 foreach id $boldids {
4081 if {![ishighlighted $id]} {
4084 lappend stillbold $id
4087 set boldids $stillbold
4090 proc addvhighlight {n} {
4091 global hlview viewcomplete curview vhl_done commitidx
4093 if {[info exists hlview]} {
4097 if {$n != $curview && ![info exists viewcomplete($n)]} {
4100 set vhl_done $commitidx($hlview)
4101 if {$vhl_done > 0} {
4106 proc delvhighlight {} {
4107 global hlview vhighlights
4109 if {![info exists hlview]} return
4111 catch {unset vhighlights}
4115 proc vhighlightmore {} {
4116 global hlview vhl_done commitidx vhighlights curview
4118 set max $commitidx($hlview)
4119 set vr [visiblerows]
4120 set r0 [lindex $vr 0]
4121 set r1 [lindex $vr 1]
4122 for {set i $vhl_done} {$i < $max} {incr i} {
4123 set id [commitonrow $i $hlview]
4124 if {[commitinview $id $curview]} {
4125 set row [rowofcommit $id]
4126 if {$r0 <= $row && $row <= $r1} {
4127 if {![highlighted $row]} {
4128 bolden $id mainfontbold
4130 set vhighlights($id) 1
4138 proc askvhighlight {row id} {
4139 global hlview vhighlights iddrawn
4141 if {[commitinview $id $hlview]} {
4142 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4143 bolden $id mainfontbold
4145 set vhighlights($id) 1
4147 set vhighlights($id) 0
4151 proc hfiles_change {} {
4152 global highlight_files filehighlight fhighlights fh_serial
4153 global highlight_paths
4155 if {[info exists filehighlight]} {
4156 # delete previous highlights
4157 catch {close $filehighlight}
4159 catch {unset fhighlights}
4161 unhighlight_filelist
4163 set highlight_paths {}
4164 after cancel do_file_hl $fh_serial
4166 if {$highlight_files ne {}} {
4167 after 300 do_file_hl $fh_serial
4171 proc gdttype_change {name ix op} {
4172 global gdttype highlight_files findstring findpattern
4175 if {$findstring ne {}} {
4176 if {$gdttype eq [mc "containing:"]} {
4177 if {$highlight_files ne {}} {
4178 set highlight_files {}
4183 if {$findpattern ne {}} {
4187 set highlight_files $findstring
4192 # enable/disable findtype/findloc menus too
4195 proc find_change {name ix op} {
4196 global gdttype findstring highlight_files
4199 if {$gdttype eq [mc "containing:"]} {
4202 if {$highlight_files ne $findstring} {
4203 set highlight_files $findstring
4210 proc findcom_change args {
4211 global nhighlights boldnameids
4212 global findpattern findtype findstring gdttype
4215 # delete previous highlights, if any
4216 foreach id $boldnameids {
4217 bolden_name $id mainfont
4220 catch {unset nhighlights}
4223 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4225 } elseif {$findtype eq [mc "Regexp"]} {
4226 set findpattern $findstring
4228 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4230 set findpattern "*$e*"
4234 proc makepatterns {l} {
4237 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4238 if {[string index $ee end] eq "/"} {
4248 proc do_file_hl {serial} {
4249 global highlight_files filehighlight highlight_paths gdttype fhl_list
4251 if {$gdttype eq [mc "touching paths:"]} {
4252 if {[catch {set paths [shellsplit $highlight_files]}]} return
4253 set highlight_paths [makepatterns $paths]
4255 set gdtargs [concat -- $paths]
4256 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4257 set gdtargs [list "-S$highlight_files"]
4259 # must be "containing:", i.e. we're searching commit info
4262 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4263 set filehighlight [open $cmd r+]
4264 fconfigure $filehighlight -blocking 0
4265 filerun $filehighlight readfhighlight
4271 proc flushhighlights {} {
4272 global filehighlight fhl_list
4274 if {[info exists filehighlight]} {
4276 puts $filehighlight ""
4277 flush $filehighlight
4281 proc askfilehighlight {row id} {
4282 global filehighlight fhighlights fhl_list
4284 lappend fhl_list $id
4285 set fhighlights($id) -1
4286 puts $filehighlight $id
4289 proc readfhighlight {} {
4290 global filehighlight fhighlights curview iddrawn
4291 global fhl_list find_dirn
4293 if {![info exists filehighlight]} {
4297 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4298 set line [string trim $line]
4299 set i [lsearch -exact $fhl_list $line]
4300 if {$i < 0} continue
4301 for {set j 0} {$j < $i} {incr j} {
4302 set id [lindex $fhl_list $j]
4303 set fhighlights($id) 0
4305 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4306 if {$line eq {}} continue
4307 if {![commitinview $line $curview]} continue
4308 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4309 bolden $line mainfontbold
4311 set fhighlights($line) 1
4313 if {[eof $filehighlight]} {
4315 puts "oops, git diff-tree died"
4316 catch {close $filehighlight}
4320 if {[info exists find_dirn]} {
4326 proc doesmatch {f} {
4327 global findtype findpattern
4329 if {$findtype eq [mc "Regexp"]} {
4330 return [regexp $findpattern $f]
4331 } elseif {$findtype eq [mc "IgnCase"]} {
4332 return [string match -nocase $findpattern $f]
4334 return [string match $findpattern $f]
4338 proc askfindhighlight {row id} {
4339 global nhighlights commitinfo iddrawn
4341 global markingmatches
4343 if {![info exists commitinfo($id)]} {
4346 set info $commitinfo($id)
4348 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4349 foreach f $info ty $fldtypes {
4350 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4352 if {$ty eq [mc "Author"]} {
4359 if {$isbold && [info exists iddrawn($id)]} {
4360 if {![ishighlighted $id]} {
4361 bolden $id mainfontbold
4363 bolden_name $id mainfontbold
4366 if {$markingmatches} {
4367 markrowmatches $row $id
4370 set nhighlights($id) $isbold
4373 proc markrowmatches {row id} {
4374 global canv canv2 linehtag linentag commitinfo findloc
4376 set headline [lindex $commitinfo($id) 0]
4377 set author [lindex $commitinfo($id) 1]
4378 $canv delete match$row
4379 $canv2 delete match$row
4380 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4381 set m [findmatches $headline]
4383 markmatches $canv $row $headline $linehtag($id) $m \
4384 [$canv itemcget $linehtag($id) -font] $row
4387 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4388 set m [findmatches $author]
4390 markmatches $canv2 $row $author $linentag($id) $m \
4391 [$canv2 itemcget $linentag($id) -font] $row
4396 proc vrel_change {name ix op} {
4397 global highlight_related
4400 if {$highlight_related ne [mc "None"]} {
4405 # prepare for testing whether commits are descendents or ancestors of a
4406 proc rhighlight_sel {a} {
4407 global descendent desc_todo ancestor anc_todo
4408 global highlight_related
4410 catch {unset descendent}
4411 set desc_todo [list $a]
4412 catch {unset ancestor}
4413 set anc_todo [list $a]
4414 if {$highlight_related ne [mc "None"]} {
4420 proc rhighlight_none {} {
4423 catch {unset rhighlights}
4427 proc is_descendent {a} {
4428 global curview children descendent desc_todo
4431 set la [rowofcommit $a]
4435 for {set i 0} {$i < [llength $todo]} {incr i} {
4436 set do [lindex $todo $i]
4437 if {[rowofcommit $do] < $la} {
4438 lappend leftover $do
4441 foreach nk $children($v,$do) {
4442 if {![info exists descendent($nk)]} {
4443 set descendent($nk) 1
4451 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4455 set descendent($a) 0
4456 set desc_todo $leftover
4459 proc is_ancestor {a} {
4460 global curview parents ancestor anc_todo
4463 set la [rowofcommit $a]
4467 for {set i 0} {$i < [llength $todo]} {incr i} {
4468 set do [lindex $todo $i]
4469 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4470 lappend leftover $do
4473 foreach np $parents($v,$do) {
4474 if {![info exists ancestor($np)]} {
4483 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4488 set anc_todo $leftover
4491 proc askrelhighlight {row id} {
4492 global descendent highlight_related iddrawn rhighlights
4493 global selectedline ancestor
4495 if {$selectedline eq {}} return
4497 if {$highlight_related eq [mc "Descendant"] ||
4498 $highlight_related eq [mc "Not descendant"]} {
4499 if {![info exists descendent($id)]} {
4502 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4505 } elseif {$highlight_related eq [mc "Ancestor"] ||
4506 $highlight_related eq [mc "Not ancestor"]} {
4507 if {![info exists ancestor($id)]} {
4510 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4514 if {[info exists iddrawn($id)]} {
4515 if {$isbold && ![ishighlighted $id]} {
4516 bolden $id mainfontbold
4519 set rhighlights($id) $isbold
4522 # Graph layout functions
4524 proc shortids {ids} {
4527 if {[llength $id] > 1} {
4528 lappend res [shortids $id]
4529 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4530 lappend res [string range $id 0 7]
4541 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4542 if {($n & $mask) != 0} {
4543 set ret [concat $ret $o]
4545 set o [concat $o $o]
4550 proc ordertoken {id} {
4551 global ordertok curview varcid varcstart varctok curview parents children
4552 global nullid nullid2
4554 if {[info exists ordertok($id)]} {
4555 return $ordertok($id)
4560 if {[info exists varcid($curview,$id)]} {
4561 set a $varcid($curview,$id)
4562 set p [lindex $varcstart($curview) $a]
4564 set p [lindex $children($curview,$id) 0]
4566 if {[info exists ordertok($p)]} {
4567 set tok $ordertok($p)
4570 set id [first_real_child $curview,$p]
4573 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4576 if {[llength $parents($curview,$id)] == 1} {
4577 lappend todo [list $p {}]
4579 set j [lsearch -exact $parents($curview,$id) $p]
4581 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4583 lappend todo [list $p [strrep $j]]
4586 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4587 set p [lindex $todo $i 0]
4588 append tok [lindex $todo $i 1]
4589 set ordertok($p) $tok
4591 set ordertok($origid) $tok
4595 # Work out where id should go in idlist so that order-token
4596 # values increase from left to right
4597 proc idcol {idlist id {i 0}} {
4598 set t [ordertoken $id]
4602 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4603 if {$i > [llength $idlist]} {
4604 set i [llength $idlist]
4606 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4609 if {$t > [ordertoken [lindex $idlist $i]]} {
4610 while {[incr i] < [llength $idlist] &&
4611 $t >= [ordertoken [lindex $idlist $i]]} {}
4617 proc initlayout {} {
4618 global rowidlist rowisopt rowfinal displayorder parentlist
4619 global numcommits canvxmax canv
4621 global colormap rowtextx
4630 set canvxmax [$canv cget -width]
4631 catch {unset colormap}
4632 catch {unset rowtextx}
4636 proc setcanvscroll {} {
4637 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4638 global lastscrollset lastscrollrows
4640 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4641 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4642 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4643 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4644 set lastscrollset [clock clicks -milliseconds]
4645 set lastscrollrows $numcommits
4648 proc visiblerows {} {
4649 global canv numcommits linespc
4651 set ymax [lindex [$canv cget -scrollregion] 3]
4652 if {$ymax eq {} || $ymax == 0} return
4654 set y0 [expr {int([lindex $f 0] * $ymax)}]
4655 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4659 set y1 [expr {int([lindex $f 1] * $ymax)}]
4660 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4661 if {$r1 >= $numcommits} {
4662 set r1 [expr {$numcommits - 1}]
4664 return [list $r0 $r1]
4667 proc layoutmore {} {
4668 global commitidx viewcomplete curview
4669 global numcommits pending_select curview
4670 global lastscrollset lastscrollrows
4672 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4673 [clock clicks -milliseconds] - $lastscrollset > 500} {
4676 if {[info exists pending_select] &&
4677 [commitinview $pending_select $curview]} {
4679 selectline [rowofcommit $pending_select] 1
4684 # With path limiting, we mightn't get the actual HEAD commit,
4685 # so ask git rev-list what is the first ancestor of HEAD that
4686 # touches a file in the path limit.
4687 proc get_viewmainhead {view} {
4688 global viewmainheadid vfilelimit viewinstances mainheadid
4691 set rfd [open [concat | git rev-list -1 $mainheadid \
4692 -- $vfilelimit($view)] r]
4693 set j [reg_instance $rfd]
4694 lappend viewinstances($view) $j
4695 fconfigure $rfd -blocking 0
4696 filerun $rfd [list getviewhead $rfd $j $view]
4697 set viewmainheadid($curview) {}
4701 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4702 proc getviewhead {fd inst view} {
4703 global viewmainheadid commfd curview viewinstances showlocalchanges
4706 if {[gets $fd line] < 0} {
4710 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4713 set viewmainheadid($view) $id
4716 set i [lsearch -exact $viewinstances($view) $inst]
4718 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4720 if {$showlocalchanges && $id ne {} && $view == $curview} {
4726 proc doshowlocalchanges {} {
4727 global curview viewmainheadid
4729 if {$viewmainheadid($curview) eq {}} return
4730 if {[commitinview $viewmainheadid($curview) $curview]} {
4733 interestedin $viewmainheadid($curview) dodiffindex
4737 proc dohidelocalchanges {} {
4738 global nullid nullid2 lserial curview
4740 if {[commitinview $nullid $curview]} {
4741 removefakerow $nullid
4743 if {[commitinview $nullid2 $curview]} {
4744 removefakerow $nullid2
4749 # spawn off a process to do git diff-index --cached HEAD
4750 proc dodiffindex {} {
4751 global lserial showlocalchanges vfilelimit curview
4754 if {!$showlocalchanges || !$isworktree} return
4756 set cmd "|git diff-index --cached HEAD"
4757 if {$vfilelimit($curview) ne {}} {
4758 set cmd [concat $cmd -- $vfilelimit($curview)]
4760 set fd [open $cmd r]
4761 fconfigure $fd -blocking 0
4762 set i [reg_instance $fd]
4763 filerun $fd [list readdiffindex $fd $lserial $i]
4766 proc readdiffindex {fd serial inst} {
4767 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4771 if {[gets $fd line] < 0} {
4777 # we only need to see one line and we don't really care what it says...
4780 if {$serial != $lserial} {
4784 # now see if there are any local changes not checked in to the index
4785 set cmd "|git diff-files"
4786 if {$vfilelimit($curview) ne {}} {
4787 set cmd [concat $cmd -- $vfilelimit($curview)]
4789 set fd [open $cmd r]
4790 fconfigure $fd -blocking 0
4791 set i [reg_instance $fd]
4792 filerun $fd [list readdifffiles $fd $serial $i]
4794 if {$isdiff && ![commitinview $nullid2 $curview]} {
4795 # add the line for the changes in the index to the graph
4796 set hl [mc "Local changes checked in to index but not committed"]
4797 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4798 set commitdata($nullid2) "\n $hl\n"
4799 if {[commitinview $nullid $curview]} {
4800 removefakerow $nullid
4802 insertfakerow $nullid2 $viewmainheadid($curview)
4803 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4804 if {[commitinview $nullid $curview]} {
4805 removefakerow $nullid
4807 removefakerow $nullid2
4812 proc readdifffiles {fd serial inst} {
4813 global viewmainheadid nullid nullid2 curview
4814 global commitinfo commitdata lserial
4817 if {[gets $fd line] < 0} {
4823 # we only need to see one line and we don't really care what it says...
4826 if {$serial != $lserial} {
4830 if {$isdiff && ![commitinview $nullid $curview]} {
4831 # add the line for the local diff to the graph
4832 set hl [mc "Local uncommitted changes, not checked in to index"]
4833 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4834 set commitdata($nullid) "\n $hl\n"
4835 if {[commitinview $nullid2 $curview]} {
4838 set p $viewmainheadid($curview)
4840 insertfakerow $nullid $p
4841 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4842 removefakerow $nullid
4847 proc nextuse {id row} {
4848 global curview children
4850 if {[info exists children($curview,$id)]} {
4851 foreach kid $children($curview,$id) {
4852 if {![commitinview $kid $curview]} {
4855 if {[rowofcommit $kid] > $row} {
4856 return [rowofcommit $kid]
4860 if {[commitinview $id $curview]} {
4861 return [rowofcommit $id]
4866 proc prevuse {id row} {
4867 global curview children
4870 if {[info exists children($curview,$id)]} {
4871 foreach kid $children($curview,$id) {
4872 if {![commitinview $kid $curview]} break
4873 if {[rowofcommit $kid] < $row} {
4874 set ret [rowofcommit $kid]
4881 proc make_idlist {row} {
4882 global displayorder parentlist uparrowlen downarrowlen mingaplen
4883 global commitidx curview children
4885 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4889 set ra [expr {$row - $downarrowlen}]
4893 set rb [expr {$row + $uparrowlen}]
4894 if {$rb > $commitidx($curview)} {
4895 set rb $commitidx($curview)
4897 make_disporder $r [expr {$rb + 1}]
4899 for {} {$r < $ra} {incr r} {
4900 set nextid [lindex $displayorder [expr {$r + 1}]]
4901 foreach p [lindex $parentlist $r] {
4902 if {$p eq $nextid} continue
4903 set rn [nextuse $p $r]
4905 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4906 lappend ids [list [ordertoken $p] $p]
4910 for {} {$r < $row} {incr r} {
4911 set nextid [lindex $displayorder [expr {$r + 1}]]
4912 foreach p [lindex $parentlist $r] {
4913 if {$p eq $nextid} continue
4914 set rn [nextuse $p $r]
4915 if {$rn < 0 || $rn >= $row} {
4916 lappend ids [list [ordertoken $p] $p]
4920 set id [lindex $displayorder $row]
4921 lappend ids [list [ordertoken $id] $id]
4923 foreach p [lindex $parentlist $r] {
4924 set firstkid [lindex $children($curview,$p) 0]
4925 if {[rowofcommit $firstkid] < $row} {
4926 lappend ids [list [ordertoken $p] $p]
4930 set id [lindex $displayorder $r]
4932 set firstkid [lindex $children($curview,$id) 0]
4933 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4934 lappend ids [list [ordertoken $id] $id]
4939 foreach idx [lsort -unique $ids] {
4940 lappend idlist [lindex $idx 1]
4945 proc rowsequal {a b} {
4946 while {[set i [lsearch -exact $a {}]] >= 0} {
4947 set a [lreplace $a $i $i]
4949 while {[set i [lsearch -exact $b {}]] >= 0} {
4950 set b [lreplace $b $i $i]
4952 return [expr {$a eq $b}]
4955 proc makeupline {id row rend col} {
4956 global rowidlist uparrowlen downarrowlen mingaplen
4958 for {set r $rend} {1} {set r $rstart} {
4959 set rstart [prevuse $id $r]
4960 if {$rstart < 0} return
4961 if {$rstart < $row} break
4963 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4964 set rstart [expr {$rend - $uparrowlen - 1}]
4966 for {set r $rstart} {[incr r] <= $row} {} {
4967 set idlist [lindex $rowidlist $r]
4968 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4969 set col [idcol $idlist $id $col]
4970 lset rowidlist $r [linsert $idlist $col $id]
4976 proc layoutrows {row endrow} {
4977 global rowidlist rowisopt rowfinal displayorder
4978 global uparrowlen downarrowlen maxwidth mingaplen
4979 global children parentlist
4980 global commitidx viewcomplete curview
4982 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4985 set rm1 [expr {$row - 1}]
4986 foreach id [lindex $rowidlist $rm1] {
4991 set final [lindex $rowfinal $rm1]
4993 for {} {$row < $endrow} {incr row} {
4994 set rm1 [expr {$row - 1}]
4995 if {$rm1 < 0 || $idlist eq {}} {
4996 set idlist [make_idlist $row]
4999 set id [lindex $displayorder $rm1]
5000 set col [lsearch -exact $idlist $id]
5001 set idlist [lreplace $idlist $col $col]
5002 foreach p [lindex $parentlist $rm1] {
5003 if {[lsearch -exact $idlist $p] < 0} {
5004 set col [idcol $idlist $p $col]
5005 set idlist [linsert $idlist $col $p]
5006 # if not the first child, we have to insert a line going up
5007 if {$id ne [lindex $children($curview,$p) 0]} {
5008 makeupline $p $rm1 $row $col
5012 set id [lindex $displayorder $row]
5013 if {$row > $downarrowlen} {
5014 set termrow [expr {$row - $downarrowlen - 1}]
5015 foreach p [lindex $parentlist $termrow] {
5016 set i [lsearch -exact $idlist $p]
5017 if {$i < 0} continue
5018 set nr [nextuse $p $termrow]
5019 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5020 set idlist [lreplace $idlist $i $i]
5024 set col [lsearch -exact $idlist $id]
5026 set col [idcol $idlist $id]
5027 set idlist [linsert $idlist $col $id]
5028 if {$children($curview,$id) ne {}} {
5029 makeupline $id $rm1 $row $col
5032 set r [expr {$row + $uparrowlen - 1}]
5033 if {$r < $commitidx($curview)} {
5035 foreach p [lindex $parentlist $r] {
5036 if {[lsearch -exact $idlist $p] >= 0} continue
5037 set fk [lindex $children($curview,$p) 0]
5038 if {[rowofcommit $fk] < $row} {
5039 set x [idcol $idlist $p $x]
5040 set idlist [linsert $idlist $x $p]
5043 if {[incr r] < $commitidx($curview)} {
5044 set p [lindex $displayorder $r]
5045 if {[lsearch -exact $idlist $p] < 0} {
5046 set fk [lindex $children($curview,$p) 0]
5047 if {$fk ne {} && [rowofcommit $fk] < $row} {
5048 set x [idcol $idlist $p $x]
5049 set idlist [linsert $idlist $x $p]
5055 if {$final && !$viewcomplete($curview) &&
5056 $row + $uparrowlen + $mingaplen + $downarrowlen
5057 >= $commitidx($curview)} {
5060 set l [llength $rowidlist]
5062 lappend rowidlist $idlist
5064 lappend rowfinal $final
5065 } elseif {$row < $l} {
5066 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5067 lset rowidlist $row $idlist
5070 lset rowfinal $row $final
5072 set pad [ntimes [expr {$row - $l}] {}]
5073 set rowidlist [concat $rowidlist $pad]
5074 lappend rowidlist $idlist
5075 set rowfinal [concat $rowfinal $pad]
5076 lappend rowfinal $final
5077 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5083 proc changedrow {row} {
5084 global displayorder iddrawn rowisopt need_redisplay
5086 set l [llength $rowisopt]
5088 lset rowisopt $row 0
5089 if {$row + 1 < $l} {
5090 lset rowisopt [expr {$row + 1}] 0
5091 if {$row + 2 < $l} {
5092 lset rowisopt [expr {$row + 2}] 0
5096 set id [lindex $displayorder $row]
5097 if {[info exists iddrawn($id)]} {
5098 set need_redisplay 1
5102 proc insert_pad {row col npad} {
5105 set pad [ntimes $npad {}]
5106 set idlist [lindex $rowidlist $row]
5107 set bef [lrange $idlist 0 [expr {$col - 1}]]
5108 set aft [lrange $idlist $col end]
5109 set i [lsearch -exact $aft {}]
5111 set aft [lreplace $aft $i $i]
5113 lset rowidlist $row [concat $bef $pad $aft]
5117 proc optimize_rows {row col endrow} {
5118 global rowidlist rowisopt displayorder curview children
5123 for {} {$row < $endrow} {incr row; set col 0} {
5124 if {[lindex $rowisopt $row]} continue
5126 set y0 [expr {$row - 1}]
5127 set ym [expr {$row - 2}]
5128 set idlist [lindex $rowidlist $row]
5129 set previdlist [lindex $rowidlist $y0]
5130 if {$idlist eq {} || $previdlist eq {}} continue
5132 set pprevidlist [lindex $rowidlist $ym]
5133 if {$pprevidlist eq {}} continue
5139 for {} {$col < [llength $idlist]} {incr col} {
5140 set id [lindex $idlist $col]
5141 if {[lindex $previdlist $col] eq $id} continue
5146 set x0 [lsearch -exact $previdlist $id]
5147 if {$x0 < 0} continue
5148 set z [expr {$x0 - $col}]
5152 set xm [lsearch -exact $pprevidlist $id]
5154 set z0 [expr {$xm - $x0}]
5158 # if row y0 is the first child of $id then it's not an arrow
5159 if {[lindex $children($curview,$id) 0] ne
5160 [lindex $displayorder $y0]} {
5164 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5165 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5168 # Looking at lines from this row to the previous row,
5169 # make them go straight up if they end in an arrow on
5170 # the previous row; otherwise make them go straight up
5172 if {$z < -1 || ($z < 0 && $isarrow)} {
5173 # Line currently goes left too much;
5174 # insert pads in the previous row, then optimize it
5175 set npad [expr {-1 - $z + $isarrow}]
5176 insert_pad $y0 $x0 $npad
5178 optimize_rows $y0 $x0 $row
5180 set previdlist [lindex $rowidlist $y0]
5181 set x0 [lsearch -exact $previdlist $id]
5182 set z [expr {$x0 - $col}]
5184 set pprevidlist [lindex $rowidlist $ym]
5185 set xm [lsearch -exact $pprevidlist $id]
5186 set z0 [expr {$xm - $x0}]
5188 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5189 # Line currently goes right too much;
5190 # insert pads in this line
5191 set npad [expr {$z - 1 + $isarrow}]
5192 insert_pad $row $col $npad
5193 set idlist [lindex $rowidlist $row]
5195 set z [expr {$x0 - $col}]
5198 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5199 # this line links to its first child on row $row-2
5200 set id [lindex $displayorder $ym]
5201 set xc [lsearch -exact $pprevidlist $id]
5203 set z0 [expr {$xc - $x0}]
5206 # avoid lines jigging left then immediately right
5207 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5208 insert_pad $y0 $x0 1
5210 optimize_rows $y0 $x0 $row
5211 set previdlist [lindex $rowidlist $y0]
5215 # Find the first column that doesn't have a line going right
5216 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5217 set id [lindex $idlist $col]
5218 if {$id eq {}} break
5219 set x0 [lsearch -exact $previdlist $id]
5221 # check if this is the link to the first child
5222 set kid [lindex $displayorder $y0]
5223 if {[lindex $children($curview,$id) 0] eq $kid} {
5224 # it is, work out offset to child
5225 set x0 [lsearch -exact $previdlist $kid]
5228 if {$x0 <= $col} break
5230 # Insert a pad at that column as long as it has a line and
5231 # isn't the last column
5232 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5233 set idlist [linsert $idlist $col {}]
5234 lset rowidlist $row $idlist
5242 global canvx0 linespc
5243 return [expr {$canvx0 + $col * $linespc}]
5247 global canvy0 linespc
5248 return [expr {$canvy0 + $row * $linespc}]
5251 proc linewidth {id} {
5252 global thickerline lthickness
5255 if {[info exists thickerline] && $id eq $thickerline} {
5256 set wid [expr {2 * $lthickness}]
5261 proc rowranges {id} {
5262 global curview children uparrowlen downarrowlen
5265 set kids $children($curview,$id)
5271 foreach child $kids {
5272 if {![commitinview $child $curview]} break
5273 set row [rowofcommit $child]
5274 if {![info exists prev]} {
5275 lappend ret [expr {$row + 1}]
5277 if {$row <= $prevrow} {
5278 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5280 # see if the line extends the whole way from prevrow to row
5281 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5282 [lsearch -exact [lindex $rowidlist \
5283 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5284 # it doesn't, see where it ends
5285 set r [expr {$prevrow + $downarrowlen}]
5286 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5287 while {[incr r -1] > $prevrow &&
5288 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5290 while {[incr r] <= $row &&
5291 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5295 # see where it starts up again
5296 set r [expr {$row - $uparrowlen}]
5297 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5298 while {[incr r] < $row &&
5299 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5301 while {[incr r -1] >= $prevrow &&
5302 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5308 if {$child eq $id} {
5317 proc drawlineseg {id row endrow arrowlow} {
5318 global rowidlist displayorder iddrawn linesegs
5319 global canv colormap linespc curview maxlinelen parentlist
5321 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5322 set le [expr {$row + 1}]
5325 set c [lsearch -exact [lindex $rowidlist $le] $id]
5331 set x [lindex $displayorder $le]
5336 if {[info exists iddrawn($x)] || $le == $endrow} {
5337 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5353 if {[info exists linesegs($id)]} {
5354 set lines $linesegs($id)
5356 set r0 [lindex $li 0]
5358 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5368 set li [lindex $lines [expr {$i-1}]]
5369 set r1 [lindex $li 1]
5370 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5375 set x [lindex $cols [expr {$le - $row}]]
5376 set xp [lindex $cols [expr {$le - 1 - $row}]]
5377 set dir [expr {$xp - $x}]
5379 set ith [lindex $lines $i 2]
5380 set coords [$canv coords $ith]
5381 set ah [$canv itemcget $ith -arrow]
5382 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5383 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5384 if {$x2 ne {} && $x - $x2 == $dir} {
5385 set coords [lrange $coords 0 end-2]
5388 set coords [list [xc $le $x] [yc $le]]
5391 set itl [lindex $lines [expr {$i-1}] 2]
5392 set al [$canv itemcget $itl -arrow]
5393 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5394 } elseif {$arrowlow} {
5395 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5396 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5400 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5401 for {set y $le} {[incr y -1] > $row} {} {
5403 set xp [lindex $cols [expr {$y - 1 - $row}]]
5404 set ndir [expr {$xp - $x}]
5405 if {$dir != $ndir || $xp < 0} {
5406 lappend coords [xc $y $x] [yc $y]
5412 # join parent line to first child
5413 set ch [lindex $displayorder $row]
5414 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5416 puts "oops: drawlineseg: child $ch not on row $row"
5417 } elseif {$xc != $x} {
5418 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5419 set d [expr {int(0.5 * $linespc)}]
5422 set x2 [expr {$x1 - $d}]
5424 set x2 [expr {$x1 + $d}]
5427 set y1 [expr {$y2 + $d}]
5428 lappend coords $x1 $y1 $x2 $y2
5429 } elseif {$xc < $x - 1} {
5430 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5431 } elseif {$xc > $x + 1} {
5432 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5436 lappend coords [xc $row $x] [yc $row]
5438 set xn [xc $row $xp]
5440 lappend coords $xn $yn
5444 set t [$canv create line $coords -width [linewidth $id] \
5445 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5448 set lines [linsert $lines $i [list $row $le $t]]
5450 $canv coords $ith $coords
5451 if {$arrow ne $ah} {
5452 $canv itemconf $ith -arrow $arrow
5454 lset lines $i 0 $row
5457 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5458 set ndir [expr {$xo - $xp}]
5459 set clow [$canv coords $itl]
5460 if {$dir == $ndir} {
5461 set clow [lrange $clow 2 end]
5463 set coords [concat $coords $clow]
5465 lset lines [expr {$i-1}] 1 $le
5467 # coalesce two pieces
5469 set b [lindex $lines [expr {$i-1}] 0]
5470 set e [lindex $lines $i 1]
5471 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5473 $canv coords $itl $coords
5474 if {$arrow ne $al} {
5475 $canv itemconf $itl -arrow $arrow
5479 set linesegs($id) $lines
5483 proc drawparentlinks {id row} {
5484 global rowidlist canv colormap curview parentlist
5485 global idpos linespc
5487 set rowids [lindex $rowidlist $row]
5488 set col [lsearch -exact $rowids $id]
5489 if {$col < 0} return
5490 set olds [lindex $parentlist $row]
5491 set row2 [expr {$row + 1}]
5492 set x [xc $row $col]
5495 set d [expr {int(0.5 * $linespc)}]
5496 set ymid [expr {$y + $d}]
5497 set ids [lindex $rowidlist $row2]
5498 # rmx = right-most X coord used
5501 set i [lsearch -exact $ids $p]
5503 puts "oops, parent $p of $id not in list"
5506 set x2 [xc $row2 $i]
5510 set j [lsearch -exact $rowids $p]
5512 # drawlineseg will do this one for us
5516 # should handle duplicated parents here...
5517 set coords [list $x $y]
5519 # if attaching to a vertical segment, draw a smaller
5520 # slant for visual distinctness
5523 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5525 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5527 } elseif {$i < $col && $i < $j} {
5528 # segment slants towards us already
5529 lappend coords [xc $row $j] $y
5531 if {$i < $col - 1} {
5532 lappend coords [expr {$x2 + $linespc}] $y
5533 } elseif {$i > $col + 1} {
5534 lappend coords [expr {$x2 - $linespc}] $y
5536 lappend coords $x2 $y2
5539 lappend coords $x2 $y2
5541 set t [$canv create line $coords -width [linewidth $p] \
5542 -fill $colormap($p) -tags lines.$p]
5546 if {$rmx > [lindex $idpos($id) 1]} {
5547 lset idpos($id) 1 $rmx
5552 proc drawlines {id} {
5555 $canv itemconf lines.$id -width [linewidth $id]
5558 proc drawcmittext {id row col} {
5559 global linespc canv canv2 canv3 fgcolor curview
5560 global cmitlisted commitinfo rowidlist parentlist
5561 global rowtextx idpos idtags idheads idotherrefs
5562 global linehtag linentag linedtag selectedline
5563 global canvxmax boldids boldnameids fgcolor
5564 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5566 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5567 set listed $cmitlisted($curview,$id)
5568 if {$id eq $nullid} {
5570 } elseif {$id eq $nullid2} {
5572 } elseif {$id eq $mainheadid} {
5575 set ofill [lindex $circlecolors $listed]
5577 set x [xc $row $col]
5579 set orad [expr {$linespc / 3}]
5581 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5582 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5583 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5584 } elseif {$listed == 3} {
5585 # triangle pointing left for left-side commits
5586 set t [$canv create polygon \
5587 [expr {$x - $orad}] $y \
5588 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5589 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5590 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5592 # triangle pointing right for right-side commits
5593 set t [$canv create polygon \
5594 [expr {$x + $orad - 1}] $y \
5595 [expr {$x - $orad}] [expr {$y - $orad}] \
5596 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5597 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5599 set circleitem($row) $t
5601 $canv bind $t <1> {selcanvline {} %x %y}
5602 set rmx [llength [lindex $rowidlist $row]]
5603 set olds [lindex $parentlist $row]
5605 set nextids [lindex $rowidlist [expr {$row + 1}]]
5607 set i [lsearch -exact $nextids $p]
5613 set xt [xc $row $rmx]
5614 set rowtextx($row) $xt
5615 set idpos($id) [list $x $xt $y]
5616 if {[info exists idtags($id)] || [info exists idheads($id)]
5617 || [info exists idotherrefs($id)]} {
5618 set xt [drawtags $id $x $xt $y]
5620 set headline [lindex $commitinfo($id) 0]
5621 set name [lindex $commitinfo($id) 1]
5622 set date [lindex $commitinfo($id) 2]
5623 set date [formatdate $date]
5626 set isbold [ishighlighted $id]
5629 set font mainfontbold
5631 lappend boldnameids $id
5632 set nfont mainfontbold
5635 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5636 -text $headline -font $font -tags text]
5637 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5638 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5639 -text $name -font $nfont -tags text]
5640 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5641 -text $date -font mainfont -tags text]
5642 if {$selectedline == $row} {
5645 set xr [expr {$xt + [font measure $font $headline]}]
5646 if {$xr > $canvxmax} {
5652 proc drawcmitrow {row} {
5653 global displayorder rowidlist nrows_drawn
5654 global iddrawn markingmatches
5655 global commitinfo numcommits
5656 global filehighlight fhighlights findpattern nhighlights
5657 global hlview vhighlights
5658 global highlight_related rhighlights
5660 if {$row >= $numcommits} return
5662 set id [lindex $displayorder $row]
5663 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5664 askvhighlight $row $id
5666 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5667 askfilehighlight $row $id
5669 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5670 askfindhighlight $row $id
5672 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5673 askrelhighlight $row $id
5675 if {![info exists iddrawn($id)]} {
5676 set col [lsearch -exact [lindex $rowidlist $row] $id]
5678 puts "oops, row $row id $id not in list"
5681 if {![info exists commitinfo($id)]} {
5685 drawcmittext $id $row $col
5689 if {$markingmatches} {
5690 markrowmatches $row $id
5694 proc drawcommits {row {endrow {}}} {
5695 global numcommits iddrawn displayorder curview need_redisplay
5696 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5701 if {$endrow eq {}} {
5704 if {$endrow >= $numcommits} {
5705 set endrow [expr {$numcommits - 1}]
5708 set rl1 [expr {$row - $downarrowlen - 3}]
5712 set ro1 [expr {$row - 3}]
5716 set r2 [expr {$endrow + $uparrowlen + 3}]
5717 if {$r2 > $numcommits} {
5720 for {set r $rl1} {$r < $r2} {incr r} {
5721 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5725 set rl1 [expr {$r + 1}]
5731 optimize_rows $ro1 0 $r2
5732 if {$need_redisplay || $nrows_drawn > 2000} {
5737 # make the lines join to already-drawn rows either side
5738 set r [expr {$row - 1}]
5739 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5742 set er [expr {$endrow + 1}]
5743 if {$er >= $numcommits ||
5744 ![info exists iddrawn([lindex $displayorder $er])]} {
5747 for {} {$r <= $er} {incr r} {
5748 set id [lindex $displayorder $r]
5749 set wasdrawn [info exists iddrawn($id)]
5751 if {$r == $er} break
5752 set nextid [lindex $displayorder [expr {$r + 1}]]
5753 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5754 drawparentlinks $id $r
5756 set rowids [lindex $rowidlist $r]
5757 foreach lid $rowids {
5758 if {$lid eq {}} continue
5759 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5761 # see if this is the first child of any of its parents
5762 foreach p [lindex $parentlist $r] {
5763 if {[lsearch -exact $rowids $p] < 0} {
5764 # make this line extend up to the child
5765 set lineend($p) [drawlineseg $p $r $er 0]
5769 set lineend($lid) [drawlineseg $lid $r $er 1]
5775 proc undolayout {row} {
5776 global uparrowlen mingaplen downarrowlen
5777 global rowidlist rowisopt rowfinal need_redisplay
5779 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5783 if {[llength $rowidlist] > $r} {
5785 set rowidlist [lrange $rowidlist 0 $r]
5786 set rowfinal [lrange $rowfinal 0 $r]
5787 set rowisopt [lrange $rowisopt 0 $r]
5788 set need_redisplay 1
5793 proc drawvisible {} {
5794 global canv linespc curview vrowmod selectedline targetrow targetid
5795 global need_redisplay cscroll numcommits
5797 set fs [$canv yview]
5798 set ymax [lindex [$canv cget -scrollregion] 3]
5799 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5800 set f0 [lindex $fs 0]
5801 set f1 [lindex $fs 1]
5802 set y0 [expr {int($f0 * $ymax)}]
5803 set y1 [expr {int($f1 * $ymax)}]
5805 if {[info exists targetid]} {
5806 if {[commitinview $targetid $curview]} {
5807 set r [rowofcommit $targetid]
5808 if {$r != $targetrow} {
5809 # Fix up the scrollregion and change the scrolling position
5810 # now that our target row has moved.
5811 set diff [expr {($r - $targetrow) * $linespc}]
5814 set ymax [lindex [$canv cget -scrollregion] 3]
5817 set f0 [expr {$y0 / $ymax}]
5818 set f1 [expr {$y1 / $ymax}]
5819 allcanvs yview moveto $f0
5820 $cscroll set $f0 $f1
5821 set need_redisplay 1
5828 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5829 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5830 if {$endrow >= $vrowmod($curview)} {
5831 update_arcrows $curview
5833 if {$selectedline ne {} &&
5834 $row <= $selectedline && $selectedline <= $endrow} {
5835 set targetrow $selectedline
5836 } elseif {[info exists targetid]} {
5837 set targetrow [expr {int(($row + $endrow) / 2)}]
5839 if {[info exists targetrow]} {
5840 if {$targetrow >= $numcommits} {
5841 set targetrow [expr {$numcommits - 1}]
5843 set targetid [commitonrow $targetrow]
5845 drawcommits $row $endrow
5848 proc clear_display {} {
5849 global iddrawn linesegs need_redisplay nrows_drawn
5850 global vhighlights fhighlights nhighlights rhighlights
5851 global linehtag linentag linedtag boldids boldnameids
5854 catch {unset iddrawn}
5855 catch {unset linesegs}
5856 catch {unset linehtag}
5857 catch {unset linentag}
5858 catch {unset linedtag}
5861 catch {unset vhighlights}
5862 catch {unset fhighlights}
5863 catch {unset nhighlights}
5864 catch {unset rhighlights}
5865 set need_redisplay 0
5869 proc findcrossings {id} {
5870 global rowidlist parentlist numcommits displayorder
5874 foreach {s e} [rowranges $id] {
5875 if {$e >= $numcommits} {
5876 set e [expr {$numcommits - 1}]
5878 if {$e <= $s} continue
5879 for {set row $e} {[incr row -1] >= $s} {} {
5880 set x [lsearch -exact [lindex $rowidlist $row] $id]
5882 set olds [lindex $parentlist $row]
5883 set kid [lindex $displayorder $row]
5884 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5885 if {$kidx < 0} continue
5886 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5888 set px [lsearch -exact $nextrow $p]
5889 if {$px < 0} continue
5890 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5891 if {[lsearch -exact $ccross $p] >= 0} continue
5892 if {$x == $px + ($kidx < $px? -1: 1)} {
5894 } elseif {[lsearch -exact $cross $p] < 0} {
5901 return [concat $ccross {{}} $cross]
5904 proc assigncolor {id} {
5905 global colormap colors nextcolor
5906 global parents children children curview
5908 if {[info exists colormap($id)]} return
5909 set ncolors [llength $colors]
5910 if {[info exists children($curview,$id)]} {
5911 set kids $children($curview,$id)
5915 if {[llength $kids] == 1} {
5916 set child [lindex $kids 0]
5917 if {[info exists colormap($child)]
5918 && [llength $parents($curview,$child)] == 1} {
5919 set colormap($id) $colormap($child)
5925 foreach x [findcrossings $id] {
5927 # delimiter between corner crossings and other crossings
5928 if {[llength $badcolors] >= $ncolors - 1} break
5929 set origbad $badcolors
5931 if {[info exists colormap($x)]
5932 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5933 lappend badcolors $colormap($x)
5936 if {[llength $badcolors] >= $ncolors} {
5937 set badcolors $origbad
5939 set origbad $badcolors
5940 if {[llength $badcolors] < $ncolors - 1} {
5941 foreach child $kids {
5942 if {[info exists colormap($child)]
5943 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5944 lappend badcolors $colormap($child)
5946 foreach p $parents($curview,$child) {
5947 if {[info exists colormap($p)]
5948 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5949 lappend badcolors $colormap($p)
5953 if {[llength $badcolors] >= $ncolors} {
5954 set badcolors $origbad
5957 for {set i 0} {$i <= $ncolors} {incr i} {
5958 set c [lindex $colors $nextcolor]
5959 if {[incr nextcolor] >= $ncolors} {
5962 if {[lsearch -exact $badcolors $c]} break
5964 set colormap($id) $c
5967 proc bindline {t id} {
5970 $canv bind $t <Enter> "lineenter %x %y $id"
5971 $canv bind $t <Motion> "linemotion %x %y $id"
5972 $canv bind $t <Leave> "lineleave $id"
5973 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5976 proc drawtags {id x xt y1} {
5977 global idtags idheads idotherrefs mainhead
5978 global linespc lthickness
5979 global canv rowtextx curview fgcolor bgcolor ctxbut
5984 if {[info exists idtags($id)]} {
5985 set marks $idtags($id)
5986 set ntags [llength $marks]
5988 if {[info exists idheads($id)]} {
5989 set marks [concat $marks $idheads($id)]
5990 set nheads [llength $idheads($id)]
5992 if {[info exists idotherrefs($id)]} {
5993 set marks [concat $marks $idotherrefs($id)]
5999 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6000 set yt [expr {$y1 - 0.5 * $linespc}]
6001 set yb [expr {$yt + $linespc - 1}]
6005 foreach tag $marks {
6007 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6008 set wid [font measure mainfontbold $tag]
6010 set wid [font measure mainfont $tag]
6014 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6016 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6017 -width $lthickness -fill black -tags tag.$id]
6019 foreach tag $marks x $xvals wid $wvals {
6020 set xl [expr {$x + $delta}]
6021 set xr [expr {$x + $delta + $wid + $lthickness}]
6023 if {[incr ntags -1] >= 0} {
6025 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6026 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6027 -width 1 -outline black -fill yellow -tags tag.$id]
6028 $canv bind $t <1> [list showtag $tag 1]
6029 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6031 # draw a head or other ref
6032 if {[incr nheads -1] >= 0} {
6034 if {$tag eq $mainhead} {
6035 set font mainfontbold
6040 set xl [expr {$xl - $delta/2}]
6041 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6042 -width 1 -outline black -fill $col -tags tag.$id
6043 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6044 set rwid [font measure mainfont $remoteprefix]
6045 set xi [expr {$x + 1}]
6046 set yti [expr {$yt + 1}]
6047 set xri [expr {$x + $rwid}]
6048 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6049 -width 0 -fill "#ffddaa" -tags tag.$id
6052 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6053 -font $font -tags [list tag.$id text]]
6055 $canv bind $t <1> [list showtag $tag 1]
6056 } elseif {$nheads >= 0} {
6057 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6063 proc xcoord {i level ln} {
6064 global canvx0 xspc1 xspc2
6066 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6067 if {$i > 0 && $i == $level} {
6068 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6069 } elseif {$i > $level} {
6070 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6075 proc show_status {msg} {
6079 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6080 -tags text -fill $fgcolor
6083 # Don't change the text pane cursor if it is currently the hand cursor,
6084 # showing that we are over a sha1 ID link.
6085 proc settextcursor {c} {
6086 global ctext curtextcursor
6088 if {[$ctext cget -cursor] == $curtextcursor} {
6089 $ctext config -cursor $c
6091 set curtextcursor $c
6094 proc nowbusy {what {name {}}} {
6095 global isbusy busyname statusw
6097 if {[array names isbusy] eq {}} {
6098 . config -cursor watch
6102 set busyname($what) $name
6104 $statusw conf -text $name
6108 proc notbusy {what} {
6109 global isbusy maincursor textcursor busyname statusw
6113 if {$busyname($what) ne {} &&
6114 [$statusw cget -text] eq $busyname($what)} {
6115 $statusw conf -text {}
6118 if {[array names isbusy] eq {}} {
6119 . config -cursor $maincursor
6120 settextcursor $textcursor
6124 proc findmatches {f} {
6125 global findtype findstring
6126 if {$findtype == [mc "Regexp"]} {
6127 set matches [regexp -indices -all -inline $findstring $f]
6130 if {$findtype == [mc "IgnCase"]} {
6131 set f [string tolower $f]
6132 set fs [string tolower $fs]
6136 set l [string length $fs]
6137 while {[set j [string first $fs $f $i]] >= 0} {
6138 lappend matches [list $j [expr {$j+$l-1}]]
6139 set i [expr {$j + $l}]
6145 proc dofind {{dirn 1} {wrap 1}} {
6146 global findstring findstartline findcurline selectedline numcommits
6147 global gdttype filehighlight fh_serial find_dirn findallowwrap
6149 if {[info exists find_dirn]} {
6150 if {$find_dirn == $dirn} return
6154 if {$findstring eq {} || $numcommits == 0} return
6155 if {$selectedline eq {}} {
6156 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6158 set findstartline $selectedline
6160 set findcurline $findstartline
6161 nowbusy finding [mc "Searching"]
6162 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6163 after cancel do_file_hl $fh_serial
6164 do_file_hl $fh_serial
6167 set findallowwrap $wrap
6171 proc stopfinding {} {
6172 global find_dirn findcurline fprogcoord
6174 if {[info exists find_dirn]} {
6185 global commitdata commitinfo numcommits findpattern findloc
6186 global findstartline findcurline findallowwrap
6187 global find_dirn gdttype fhighlights fprogcoord
6188 global curview varcorder vrownum varccommits vrowmod
6190 if {![info exists find_dirn]} {
6193 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6196 if {$find_dirn > 0} {
6198 if {$l >= $numcommits} {
6201 if {$l <= $findstartline} {
6202 set lim [expr {$findstartline + 1}]
6205 set moretodo $findallowwrap
6212 if {$l >= $findstartline} {
6213 set lim [expr {$findstartline - 1}]
6216 set moretodo $findallowwrap
6219 set n [expr {($lim - $l) * $find_dirn}]
6224 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6225 update_arcrows $curview
6229 set ai [bsearch $vrownum($curview) $l]
6230 set a [lindex $varcorder($curview) $ai]
6231 set arow [lindex $vrownum($curview) $ai]
6232 set ids [lindex $varccommits($curview,$a)]
6233 set arowend [expr {$arow + [llength $ids]}]
6234 if {$gdttype eq [mc "containing:"]} {
6235 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6236 if {$l < $arow || $l >= $arowend} {
6238 set a [lindex $varcorder($curview) $ai]
6239 set arow [lindex $vrownum($curview) $ai]
6240 set ids [lindex $varccommits($curview,$a)]
6241 set arowend [expr {$arow + [llength $ids]}]
6243 set id [lindex $ids [expr {$l - $arow}]]
6244 # shouldn't happen unless git log doesn't give all the commits...
6245 if {![info exists commitdata($id)] ||
6246 ![doesmatch $commitdata($id)]} {
6249 if {![info exists commitinfo($id)]} {
6252 set info $commitinfo($id)
6253 foreach f $info ty $fldtypes {
6254 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6263 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6264 if {$l < $arow || $l >= $arowend} {
6266 set a [lindex $varcorder($curview) $ai]
6267 set arow [lindex $vrownum($curview) $ai]
6268 set ids [lindex $varccommits($curview,$a)]
6269 set arowend [expr {$arow + [llength $ids]}]
6271 set id [lindex $ids [expr {$l - $arow}]]
6272 if {![info exists fhighlights($id)]} {
6273 # this sets fhighlights($id) to -1
6274 askfilehighlight $l $id
6276 if {$fhighlights($id) > 0} {
6280 if {$fhighlights($id) < 0} {
6283 set findcurline [expr {$l - $find_dirn}]
6288 if {$found || ($domore && !$moretodo)} {
6304 set findcurline [expr {$l - $find_dirn}]
6306 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6310 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6315 proc findselectline {l} {
6316 global findloc commentend ctext findcurline markingmatches gdttype
6318 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6321 if {$markingmatches &&
6322 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6323 # highlight the matches in the comments
6324 set f [$ctext get 1.0 $commentend]
6325 set matches [findmatches $f]
6326 foreach match $matches {
6327 set start [lindex $match 0]
6328 set end [expr {[lindex $match 1] + 1}]
6329 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6335 # mark the bits of a headline or author that match a find string
6336 proc markmatches {canv l str tag matches font row} {
6339 set bbox [$canv bbox $tag]
6340 set x0 [lindex $bbox 0]
6341 set y0 [lindex $bbox 1]
6342 set y1 [lindex $bbox 3]
6343 foreach match $matches {
6344 set start [lindex $match 0]
6345 set end [lindex $match 1]
6346 if {$start > $end} continue
6347 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6348 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6349 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6350 [expr {$x0+$xlen+2}] $y1 \
6351 -outline {} -tags [list match$l matches] -fill yellow]
6353 if {$row == $selectedline} {
6354 $canv raise $t secsel
6359 proc unmarkmatches {} {
6360 global markingmatches
6362 allcanvs delete matches
6363 set markingmatches 0
6367 proc selcanvline {w x y} {
6368 global canv canvy0 ctext linespc
6370 set ymax [lindex [$canv cget -scrollregion] 3]
6371 if {$ymax == {}} return
6372 set yfrac [lindex [$canv yview] 0]
6373 set y [expr {$y + $yfrac * $ymax}]
6374 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6379 set xmax [lindex [$canv cget -scrollregion] 2]
6380 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6381 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6387 proc commit_descriptor {p} {
6389 if {![info exists commitinfo($p)]} {
6393 if {[llength $commitinfo($p)] > 1} {
6394 set l [lindex $commitinfo($p) 0]
6399 # append some text to the ctext widget, and make any SHA1 ID
6400 # that we know about be a clickable link.
6401 proc appendwithlinks {text tags} {
6402 global ctext linknum curview
6404 set start [$ctext index "end - 1c"]
6405 $ctext insert end $text $tags
6406 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6410 set linkid [string range $text $s $e]
6412 $ctext tag delete link$linknum
6413 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6414 setlink $linkid link$linknum
6419 proc setlink {id lk} {
6420 global curview ctext pendinglinks
6423 if {[string length $id] < 40} {
6424 set matches [longid $id]
6425 if {[llength $matches] > 0} {
6426 if {[llength $matches] > 1} return
6428 set id [lindex $matches 0]
6431 set known [commitinview $id $curview]
6434 $ctext tag conf $lk -foreground blue -underline 1
6435 $ctext tag bind $lk <1> [list selbyid $id]
6436 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6437 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6439 lappend pendinglinks($id) $lk
6440 interestedin $id {makelink %P}
6444 proc makelink {id} {
6447 if {![info exists pendinglinks($id)]} return
6448 foreach lk $pendinglinks($id) {
6451 unset pendinglinks($id)
6454 proc linkcursor {w inc} {
6455 global linkentercount curtextcursor
6457 if {[incr linkentercount $inc] > 0} {
6458 $w configure -cursor hand2
6460 $w configure -cursor $curtextcursor
6461 if {$linkentercount < 0} {
6462 set linkentercount 0
6467 proc viewnextline {dir} {
6471 set ymax [lindex [$canv cget -scrollregion] 3]
6472 set wnow [$canv yview]
6473 set wtop [expr {[lindex $wnow 0] * $ymax}]
6474 set newtop [expr {$wtop + $dir * $linespc}]
6477 } elseif {$newtop > $ymax} {
6480 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6483 # add a list of tag or branch names at position pos
6484 # returns the number of names inserted
6485 proc appendrefs {pos ids var} {
6486 global ctext linknum curview $var maxrefs
6488 if {[catch {$ctext index $pos}]} {
6491 $ctext conf -state normal
6492 $ctext delete $pos "$pos lineend"
6495 foreach tag [set $var\($id\)] {
6496 lappend tags [list $tag $id]
6499 if {[llength $tags] > $maxrefs} {
6500 $ctext insert $pos "many ([llength $tags])"
6502 set tags [lsort -index 0 -decreasing $tags]
6505 set id [lindex $ti 1]
6508 $ctext tag delete $lk
6509 $ctext insert $pos $sep
6510 $ctext insert $pos [lindex $ti 0] $lk
6515 $ctext conf -state disabled
6516 return [llength $tags]
6519 # called when we have finished computing the nearby tags
6520 proc dispneartags {delay} {
6521 global selectedline currentid showneartags tagphase
6523 if {$selectedline eq {} || !$showneartags} return
6524 after cancel dispnexttag
6526 after 200 dispnexttag
6529 after idle dispnexttag
6534 proc dispnexttag {} {
6535 global selectedline currentid showneartags tagphase ctext
6537 if {$selectedline eq {} || !$showneartags} return
6538 switch -- $tagphase {
6540 set dtags [desctags $currentid]
6542 appendrefs precedes $dtags idtags
6546 set atags [anctags $currentid]
6548 appendrefs follows $atags idtags
6552 set dheads [descheads $currentid]
6553 if {$dheads ne {}} {
6554 if {[appendrefs branch $dheads idheads] > 1
6555 && [$ctext get "branch -3c"] eq "h"} {
6556 # turn "Branch" into "Branches"
6557 $ctext conf -state normal
6558 $ctext insert "branch -2c" "es"
6559 $ctext conf -state disabled
6564 if {[incr tagphase] <= 2} {
6565 after idle dispnexttag
6569 proc make_secsel {id} {
6570 global linehtag linentag linedtag canv canv2 canv3
6572 if {![info exists linehtag($id)]} return
6574 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6575 -tags secsel -fill [$canv cget -selectbackground]]
6577 $canv2 delete secsel
6578 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6579 -tags secsel -fill [$canv2 cget -selectbackground]]
6581 $canv3 delete secsel
6582 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6583 -tags secsel -fill [$canv3 cget -selectbackground]]
6587 proc selectline {l isnew {desired_loc {}}} {
6588 global canv ctext commitinfo selectedline
6589 global canvy0 linespc parents children curview
6590 global currentid sha1entry
6591 global commentend idtags linknum
6592 global mergemax numcommits pending_select
6593 global cmitmode showneartags allcommits
6594 global targetrow targetid lastscrollrows
6595 global autoselect jump_to_here
6597 catch {unset pending_select}
6602 if {$l < 0 || $l >= $numcommits} return
6603 set id [commitonrow $l]
6608 if {$lastscrollrows < $numcommits} {
6612 set y [expr {$canvy0 + $l * $linespc}]
6613 set ymax [lindex [$canv cget -scrollregion] 3]
6614 set ytop [expr {$y - $linespc - 1}]
6615 set ybot [expr {$y + $linespc + 1}]
6616 set wnow [$canv yview]
6617 set wtop [expr {[lindex $wnow 0] * $ymax}]
6618 set wbot [expr {[lindex $wnow 1] * $ymax}]
6619 set wh [expr {$wbot - $wtop}]
6621 if {$ytop < $wtop} {
6622 if {$ybot < $wtop} {
6623 set newtop [expr {$y - $wh / 2.0}]
6626 if {$newtop > $wtop - $linespc} {
6627 set newtop [expr {$wtop - $linespc}]
6630 } elseif {$ybot > $wbot} {
6631 if {$ytop > $wbot} {
6632 set newtop [expr {$y - $wh / 2.0}]
6634 set newtop [expr {$ybot - $wh}]
6635 if {$newtop < $wtop + $linespc} {
6636 set newtop [expr {$wtop + $linespc}]
6640 if {$newtop != $wtop} {
6644 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6651 addtohistory [list selbyid $id]
6654 $sha1entry delete 0 end
6655 $sha1entry insert 0 $id
6657 $sha1entry selection from 0
6658 $sha1entry selection to end
6662 $ctext conf -state normal
6665 if {![info exists commitinfo($id)]} {
6668 set info $commitinfo($id)
6669 set date [formatdate [lindex $info 2]]
6670 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6671 set date [formatdate [lindex $info 4]]
6672 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6673 if {[info exists idtags($id)]} {
6674 $ctext insert end [mc "Tags:"]
6675 foreach tag $idtags($id) {
6676 $ctext insert end " $tag"
6678 $ctext insert end "\n"
6682 set olds $parents($curview,$id)
6683 if {[llength $olds] > 1} {
6686 if {$np >= $mergemax} {
6691 $ctext insert end "[mc "Parent"]: " $tag
6692 appendwithlinks [commit_descriptor $p] {}
6697 append headers "[mc "Parent"]: [commit_descriptor $p]"
6701 foreach c $children($curview,$id) {
6702 append headers "[mc "Child"]: [commit_descriptor $c]"
6705 # make anything that looks like a SHA1 ID be a clickable link
6706 appendwithlinks $headers {}
6707 if {$showneartags} {
6708 if {![info exists allcommits]} {
6711 $ctext insert end "[mc "Branch"]: "
6712 $ctext mark set branch "end -1c"
6713 $ctext mark gravity branch left
6714 $ctext insert end "\n[mc "Follows"]: "
6715 $ctext mark set follows "end -1c"
6716 $ctext mark gravity follows left
6717 $ctext insert end "\n[mc "Precedes"]: "
6718 $ctext mark set precedes "end -1c"
6719 $ctext mark gravity precedes left
6720 $ctext insert end "\n"
6723 $ctext insert end "\n"
6724 set comment [lindex $info 5]
6725 if {[string first "\r" $comment] >= 0} {
6726 set comment [string map {"\r" "\n "} $comment]
6728 appendwithlinks $comment {comment}
6730 $ctext tag remove found 1.0 end
6731 $ctext conf -state disabled
6732 set commentend [$ctext index "end - 1c"]
6734 set jump_to_here $desired_loc
6735 init_flist [mc "Comments"]
6736 if {$cmitmode eq "tree"} {
6738 } elseif {[llength $olds] <= 1} {
6745 proc selfirstline {} {
6750 proc sellastline {} {
6753 set l [expr {$numcommits - 1}]
6757 proc selnextline {dir} {
6760 if {$selectedline eq {}} return
6761 set l [expr {$selectedline + $dir}]
6766 proc selnextpage {dir} {
6767 global canv linespc selectedline numcommits
6769 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6773 allcanvs yview scroll [expr {$dir * $lpp}] units
6775 if {$selectedline eq {}} return
6776 set l [expr {$selectedline + $dir * $lpp}]
6779 } elseif {$l >= $numcommits} {
6780 set l [expr $numcommits - 1]
6786 proc unselectline {} {
6787 global selectedline currentid
6790 catch {unset currentid}
6791 allcanvs delete secsel
6795 proc reselectline {} {
6798 if {$selectedline ne {}} {
6799 selectline $selectedline 0
6803 proc addtohistory {cmd} {
6804 global history historyindex curview
6806 set elt [list $curview $cmd]
6807 if {$historyindex > 0
6808 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6812 if {$historyindex < [llength $history]} {
6813 set history [lreplace $history $historyindex end $elt]
6815 lappend history $elt
6818 if {$historyindex > 1} {
6819 .tf.bar.leftbut conf -state normal
6821 .tf.bar.leftbut conf -state disabled
6823 .tf.bar.rightbut conf -state disabled
6829 set view [lindex $elt 0]
6830 set cmd [lindex $elt 1]
6831 if {$curview != $view} {
6838 global history historyindex
6841 if {$historyindex > 1} {
6842 incr historyindex -1
6843 godo [lindex $history [expr {$historyindex - 1}]]
6844 .tf.bar.rightbut conf -state normal
6846 if {$historyindex <= 1} {
6847 .tf.bar.leftbut conf -state disabled
6852 global history historyindex
6855 if {$historyindex < [llength $history]} {
6856 set cmd [lindex $history $historyindex]
6859 .tf.bar.leftbut conf -state normal
6861 if {$historyindex >= [llength $history]} {
6862 .tf.bar.rightbut conf -state disabled
6867 global treefilelist treeidlist diffids diffmergeid treepending
6868 global nullid nullid2
6871 catch {unset diffmergeid}
6872 if {![info exists treefilelist($id)]} {
6873 if {![info exists treepending]} {
6874 if {$id eq $nullid} {
6875 set cmd [list | git ls-files]
6876 } elseif {$id eq $nullid2} {
6877 set cmd [list | git ls-files --stage -t]
6879 set cmd [list | git ls-tree -r $id]
6881 if {[catch {set gtf [open $cmd r]}]} {
6885 set treefilelist($id) {}
6886 set treeidlist($id) {}
6887 fconfigure $gtf -blocking 0 -encoding binary
6888 filerun $gtf [list gettreeline $gtf $id]
6895 proc gettreeline {gtf id} {
6896 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6899 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6900 if {$diffids eq $nullid} {
6903 set i [string first "\t" $line]
6904 if {$i < 0} continue
6905 set fname [string range $line [expr {$i+1}] end]
6906 set line [string range $line 0 [expr {$i-1}]]
6907 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6908 set sha1 [lindex $line 2]
6909 lappend treeidlist($id) $sha1
6911 if {[string index $fname 0] eq "\""} {
6912 set fname [lindex $fname 0]
6914 set fname [encoding convertfrom $fname]
6915 lappend treefilelist($id) $fname
6918 return [expr {$nl >= 1000? 2: 1}]
6922 if {$cmitmode ne "tree"} {
6923 if {![info exists diffmergeid]} {
6924 gettreediffs $diffids
6926 } elseif {$id ne $diffids} {
6935 global treefilelist treeidlist diffids nullid nullid2
6936 global ctext_file_names ctext_file_lines
6937 global ctext commentend
6939 set i [lsearch -exact $treefilelist($diffids) $f]
6941 puts "oops, $f not in list for id $diffids"
6944 if {$diffids eq $nullid} {
6945 if {[catch {set bf [open $f r]} err]} {
6946 puts "oops, can't read $f: $err"
6950 set blob [lindex $treeidlist($diffids) $i]
6951 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6952 puts "oops, error reading blob $blob: $err"
6956 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6957 filerun $bf [list getblobline $bf $diffids]
6958 $ctext config -state normal
6959 clear_ctext $commentend
6960 lappend ctext_file_names $f
6961 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6962 $ctext insert end "\n"
6963 $ctext insert end "$f\n" filesep
6964 $ctext config -state disabled
6965 $ctext yview $commentend
6969 proc getblobline {bf id} {
6970 global diffids cmitmode ctext
6972 if {$id ne $diffids || $cmitmode ne "tree"} {
6976 $ctext config -state normal
6978 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6979 $ctext insert end "$line\n"
6982 global jump_to_here ctext_file_names commentend
6984 # delete last newline
6985 $ctext delete "end - 2c" "end - 1c"
6987 if {$jump_to_here ne {} &&
6988 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6989 set lnum [expr {[lindex $jump_to_here 1] +
6990 [lindex [split $commentend .] 0]}]
6991 mark_ctext_line $lnum
6995 $ctext config -state disabled
6996 return [expr {$nl >= 1000? 2: 1}]
6999 proc mark_ctext_line {lnum} {
7000 global ctext markbgcolor
7002 $ctext tag delete omark
7003 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7004 $ctext tag conf omark -background $markbgcolor
7008 proc mergediff {id} {
7010 global diffids treediffs
7011 global parents curview
7015 set treediffs($id) {}
7016 set np [llength $parents($curview,$id)]
7021 proc startdiff {ids} {
7022 global treediffs diffids treepending diffmergeid nullid nullid2
7026 catch {unset diffmergeid}
7027 if {![info exists treediffs($ids)] ||
7028 [lsearch -exact $ids $nullid] >= 0 ||
7029 [lsearch -exact $ids $nullid2] >= 0} {
7030 if {![info exists treepending]} {
7038 proc path_filter {filter name} {
7040 set l [string length $p]
7041 if {[string index $p end] eq "/"} {
7042 if {[string compare -length $l $p $name] == 0} {
7046 if {[string compare -length $l $p $name] == 0 &&
7047 ([string length $name] == $l ||
7048 [string index $name $l] eq "/")} {
7056 proc addtocflist {ids} {
7059 add_flist $treediffs($ids)
7063 proc diffcmd {ids flags} {
7064 global nullid nullid2
7066 set i [lsearch -exact $ids $nullid]
7067 set j [lsearch -exact $ids $nullid2]
7069 if {[llength $ids] > 1 && $j < 0} {
7070 # comparing working directory with some specific revision
7071 set cmd [concat | git diff-index $flags]
7073 lappend cmd -R [lindex $ids 1]
7075 lappend cmd [lindex $ids 0]
7078 # comparing working directory with index
7079 set cmd [concat | git diff-files $flags]
7084 } elseif {$j >= 0} {
7085 set cmd [concat | git diff-index --cached $flags]
7086 if {[llength $ids] > 1} {
7087 # comparing index with specific revision
7089 lappend cmd -R [lindex $ids 1]
7091 lappend cmd [lindex $ids 0]
7094 # comparing index with HEAD
7098 set cmd [concat | git diff-tree -r $flags $ids]
7103 proc gettreediffs {ids} {
7104 global treediff treepending
7106 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7108 set treepending $ids
7110 fconfigure $gdtf -blocking 0 -encoding binary
7111 filerun $gdtf [list gettreediffline $gdtf $ids]
7114 proc gettreediffline {gdtf ids} {
7115 global treediff treediffs treepending diffids diffmergeid
7116 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7121 if {$perfile_attrs} {
7122 # cache_gitattr is slow, and even slower on win32 where we
7123 # have to invoke it for only about 30 paths at a time
7125 if {[tk windowingsystem] == "win32"} {
7129 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7130 set i [string first "\t" $line]
7132 set file [string range $line [expr {$i+1}] end]
7133 if {[string index $file 0] eq "\""} {
7134 set file [lindex $file 0]
7136 set file [encoding convertfrom $file]
7137 if {$file ne [lindex $treediff end]} {
7138 lappend treediff $file
7139 lappend sublist $file
7143 if {$perfile_attrs} {
7144 cache_gitattr encoding $sublist
7147 return [expr {$nr >= $max? 2: 1}]
7150 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7152 foreach f $treediff {
7153 if {[path_filter $vfilelimit($curview) $f]} {
7157 set treediffs($ids) $flist
7159 set treediffs($ids) $treediff
7162 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7164 } elseif {$ids != $diffids} {
7165 if {![info exists diffmergeid]} {
7166 gettreediffs $diffids
7174 # empty string or positive integer
7175 proc diffcontextvalidate {v} {
7176 return [regexp {^(|[1-9][0-9]*)$} $v]
7179 proc diffcontextchange {n1 n2 op} {
7180 global diffcontextstring diffcontext
7182 if {[string is integer -strict $diffcontextstring]} {
7183 if {$diffcontextstring > 0} {
7184 set diffcontext $diffcontextstring
7190 proc changeignorespace {} {
7194 proc getblobdiffs {ids} {
7195 global blobdifffd diffids env
7196 global diffinhdr treediffs
7199 global limitdiffs vfilelimit curview
7200 global diffencoding targetline diffnparents
7202 set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7206 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7207 set cmd [concat $cmd -- $vfilelimit($curview)]
7209 if {[catch {set bdf [open $cmd r]} err]} {
7210 error_popup [mc "Error getting diffs: %s" $err]
7216 set diffencoding [get_path_encoding {}]
7217 fconfigure $bdf -blocking 0 -encoding binary
7218 set blobdifffd($ids) $bdf
7219 filerun $bdf [list getblobdiffline $bdf $diffids]
7222 proc setinlist {var i val} {
7225 while {[llength [set $var]] < $i} {
7228 if {[llength [set $var]] == $i} {
7235 proc makediffhdr {fname ids} {
7236 global ctext curdiffstart treediffs diffencoding
7237 global ctext_file_names jump_to_here targetline diffline
7239 set fname [encoding convertfrom $fname]
7240 set diffencoding [get_path_encoding $fname]
7241 set i [lsearch -exact $treediffs($ids) $fname]
7243 setinlist difffilestart $i $curdiffstart
7245 lset ctext_file_names end $fname
7246 set l [expr {(78 - [string length $fname]) / 2}]
7247 set pad [string range "----------------------------------------" 1 $l]
7248 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7250 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7251 set targetline [lindex $jump_to_here 1]
7256 proc getblobdiffline {bdf ids} {
7257 global diffids blobdifffd ctext curdiffstart
7258 global diffnexthead diffnextnote difffilestart
7259 global ctext_file_names ctext_file_lines
7260 global diffinhdr treediffs mergemax diffnparents
7261 global diffencoding jump_to_here targetline diffline
7264 $ctext conf -state normal
7265 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7266 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7270 if {![string compare -length 5 "diff " $line]} {
7271 if {![regexp {^diff (--cc|--git) } $line m type]} {
7272 set line [encoding convertfrom $line]
7273 $ctext insert end "$line\n" hunksep
7276 # start of a new file
7278 $ctext insert end "\n"
7279 set curdiffstart [$ctext index "end - 1c"]
7280 lappend ctext_file_names ""
7281 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7282 $ctext insert end "\n" filesep
7284 if {$type eq "--cc"} {
7285 # start of a new file in a merge diff
7286 set fname [string range $line 10 end]
7287 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7288 lappend treediffs($ids) $fname
7289 add_flist [list $fname]
7293 set line [string range $line 11 end]
7294 # If the name hasn't changed the length will be odd,
7295 # the middle char will be a space, and the two bits either
7296 # side will be a/name and b/name, or "a/name" and "b/name".
7297 # If the name has changed we'll get "rename from" and
7298 # "rename to" or "copy from" and "copy to" lines following
7299 # this, and we'll use them to get the filenames.
7300 # This complexity is necessary because spaces in the
7301 # filename(s) don't get escaped.
7302 set l [string length $line]
7303 set i [expr {$l / 2}]
7304 if {!(($l & 1) && [string index $line $i] eq " " &&
7305 [string range $line 2 [expr {$i - 1}]] eq \
7306 [string range $line [expr {$i + 3}] end])} {
7309 # unescape if quoted and chop off the a/ from the front
7310 if {[string index $line 0] eq "\""} {
7311 set fname [string range [lindex $line 0] 2 end]
7313 set fname [string range $line 2 [expr {$i - 1}]]
7316 makediffhdr $fname $ids
7318 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7319 set fname [encoding convertfrom [string range $line 16 end]]
7320 $ctext insert end "\n"
7321 set curdiffstart [$ctext index "end - 1c"]
7322 lappend ctext_file_names $fname
7323 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7324 $ctext insert end "$line\n" filesep
7325 set i [lsearch -exact $treediffs($ids) $fname]
7327 setinlist difffilestart $i $curdiffstart
7330 } elseif {![string compare -length 2 "@@" $line]} {
7331 regexp {^@@+} $line ats
7332 set line [encoding convertfrom $diffencoding $line]
7333 $ctext insert end "$line\n" hunksep
7334 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7337 set diffnparents [expr {[string length $ats] - 1}]
7340 } elseif {$diffinhdr} {
7341 if {![string compare -length 12 "rename from " $line]} {
7342 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7343 if {[string index $fname 0] eq "\""} {
7344 set fname [lindex $fname 0]
7346 set fname [encoding convertfrom $fname]
7347 set i [lsearch -exact $treediffs($ids) $fname]
7349 setinlist difffilestart $i $curdiffstart
7351 } elseif {![string compare -length 10 $line "rename to "] ||
7352 ![string compare -length 8 $line "copy to "]} {
7353 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7354 if {[string index $fname 0] eq "\""} {
7355 set fname [lindex $fname 0]
7357 makediffhdr $fname $ids
7358 } elseif {[string compare -length 3 $line "---"] == 0} {
7361 } elseif {[string compare -length 3 $line "+++"] == 0} {
7365 $ctext insert end "$line\n" filesep
7368 set line [encoding convertfrom $diffencoding $line]
7369 # parse the prefix - one ' ', '-' or '+' for each parent
7370 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7371 set tag [expr {$diffnparents > 1? "m": "d"}]
7372 if {[string trim $prefix " -+"] eq {}} {
7373 # prefix only has " ", "-" and "+" in it: normal diff line
7374 set num [string first "-" $prefix]
7376 # removed line, first parent with line is $num
7377 if {$num >= $mergemax} {
7380 $ctext insert end "$line\n" $tag$num
7383 if {[string first "+" $prefix] >= 0} {
7385 lappend tags ${tag}result
7386 if {$diffnparents > 1} {
7387 set num [string first " " $prefix]
7389 if {$num >= $mergemax} {
7396 if {$targetline ne {}} {
7397 if {$diffline == $targetline} {
7398 set seehere [$ctext index "end - 1 chars"]
7404 $ctext insert end "$line\n" $tags
7407 # "\ No newline at end of file",
7408 # or something else we don't recognize
7409 $ctext insert end "$line\n" hunksep
7413 if {[info exists seehere]} {
7414 mark_ctext_line [lindex [split $seehere .] 0]
7416 $ctext conf -state disabled
7421 return [expr {$nr >= 1000? 2: 1}]
7424 proc changediffdisp {} {
7425 global ctext diffelide
7427 $ctext tag conf d0 -elide [lindex $diffelide 0]
7428 $ctext tag conf dresult -elide [lindex $diffelide 1]
7431 proc highlightfile {loc cline} {
7432 global ctext cflist cflist_top
7435 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7436 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7437 $cflist see $cline.0
7438 set cflist_top $cline
7442 global difffilestart ctext cmitmode
7444 if {$cmitmode eq "tree"} return
7447 set here [$ctext index @0,0]
7448 foreach loc $difffilestart {
7449 if {[$ctext compare $loc >= $here]} {
7450 highlightfile $prev $prevline
7456 highlightfile $prev $prevline
7460 global difffilestart ctext cmitmode
7462 if {$cmitmode eq "tree"} return
7463 set here [$ctext index @0,0]
7465 foreach loc $difffilestart {
7467 if {[$ctext compare $loc > $here]} {
7468 highlightfile $loc $line
7474 proc clear_ctext {{first 1.0}} {
7475 global ctext smarktop smarkbot
7476 global ctext_file_names ctext_file_lines
7479 set l [lindex [split $first .] 0]
7480 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7483 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7486 $ctext delete $first end
7487 if {$first eq "1.0"} {
7488 catch {unset pendinglinks}
7490 set ctext_file_names {}
7491 set ctext_file_lines {}
7494 proc settabs {{firstab {}}} {
7495 global firsttabstop tabstop ctext have_tk85
7497 if {$firstab ne {} && $have_tk85} {
7498 set firsttabstop $firstab
7500 set w [font measure textfont "0"]
7501 if {$firsttabstop != 0} {
7502 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7503 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7504 } elseif {$have_tk85 || $tabstop != 8} {
7505 $ctext conf -tabs [expr {$tabstop * $w}]
7507 $ctext conf -tabs {}
7511 proc incrsearch {name ix op} {
7512 global ctext searchstring searchdirn
7514 $ctext tag remove found 1.0 end
7515 if {[catch {$ctext index anchor}]} {
7516 # no anchor set, use start of selection, or of visible area
7517 set sel [$ctext tag ranges sel]
7519 $ctext mark set anchor [lindex $sel 0]
7520 } elseif {$searchdirn eq "-forwards"} {
7521 $ctext mark set anchor @0,0
7523 $ctext mark set anchor @0,[winfo height $ctext]
7526 if {$searchstring ne {}} {
7527 set here [$ctext search $searchdirn -- $searchstring anchor]
7536 global sstring ctext searchstring searchdirn
7539 $sstring icursor end
7540 set searchdirn -forwards
7541 if {$searchstring ne {}} {
7542 set sel [$ctext tag ranges sel]
7544 set start "[lindex $sel 0] + 1c"
7545 } elseif {[catch {set start [$ctext index anchor]}]} {
7548 set match [$ctext search -count mlen -- $searchstring $start]
7549 $ctext tag remove sel 1.0 end
7555 set mend "$match + $mlen c"
7556 $ctext tag add sel $match $mend
7557 $ctext mark unset anchor
7561 proc dosearchback {} {
7562 global sstring ctext searchstring searchdirn
7565 $sstring icursor end
7566 set searchdirn -backwards
7567 if {$searchstring ne {}} {
7568 set sel [$ctext tag ranges sel]
7570 set start [lindex $sel 0]
7571 } elseif {[catch {set start [$ctext index anchor]}]} {
7572 set start @0,[winfo height $ctext]
7574 set match [$ctext search -backwards -count ml -- $searchstring $start]
7575 $ctext tag remove sel 1.0 end
7581 set mend "$match + $ml c"
7582 $ctext tag add sel $match $mend
7583 $ctext mark unset anchor
7587 proc searchmark {first last} {
7588 global ctext searchstring
7592 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7593 if {$match eq {}} break
7594 set mend "$match + $mlen c"
7595 $ctext tag add found $match $mend
7599 proc searchmarkvisible {doall} {
7600 global ctext smarktop smarkbot
7602 set topline [lindex [split [$ctext index @0,0] .] 0]
7603 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7604 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7605 # no overlap with previous
7606 searchmark $topline $botline
7607 set smarktop $topline
7608 set smarkbot $botline
7610 if {$topline < $smarktop} {
7611 searchmark $topline [expr {$smarktop-1}]
7612 set smarktop $topline
7614 if {$botline > $smarkbot} {
7615 searchmark [expr {$smarkbot+1}] $botline
7616 set smarkbot $botline
7621 proc scrolltext {f0 f1} {
7624 .bleft.bottom.sb set $f0 $f1
7625 if {$searchstring ne {}} {
7631 global linespc charspc canvx0 canvy0
7632 global xspc1 xspc2 lthickness
7634 set linespc [font metrics mainfont -linespace]
7635 set charspc [font measure mainfont "m"]
7636 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7637 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7638 set lthickness [expr {int($linespc / 9) + 1}]
7639 set xspc1(0) $linespc
7647 set ymax [lindex [$canv cget -scrollregion] 3]
7648 if {$ymax eq {} || $ymax == 0} return
7649 set span [$canv yview]
7652 allcanvs yview moveto [lindex $span 0]
7654 if {$selectedline ne {}} {
7655 selectline $selectedline 0
7656 allcanvs yview moveto [lindex $span 0]
7660 proc parsefont {f n} {
7663 set fontattr($f,family) [lindex $n 0]
7665 if {$s eq {} || $s == 0} {
7668 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7670 set fontattr($f,size) $s
7671 set fontattr($f,weight) normal
7672 set fontattr($f,slant) roman
7673 foreach style [lrange $n 2 end] {
7676 "bold" {set fontattr($f,weight) $style}
7678 "italic" {set fontattr($f,slant) $style}
7683 proc fontflags {f {isbold 0}} {
7686 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7687 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7688 -slant $fontattr($f,slant)]
7694 set n [list $fontattr($f,family) $fontattr($f,size)]
7695 if {$fontattr($f,weight) eq "bold"} {
7698 if {$fontattr($f,slant) eq "italic"} {
7704 proc incrfont {inc} {
7705 global mainfont textfont ctext canv cflist showrefstop
7706 global stopped entries fontattr
7709 set s $fontattr(mainfont,size)
7714 set fontattr(mainfont,size) $s
7715 font config mainfont -size $s
7716 font config mainfontbold -size $s
7717 set mainfont [fontname mainfont]
7718 set s $fontattr(textfont,size)
7723 set fontattr(textfont,size) $s
7724 font config textfont -size $s
7725 font config textfontbold -size $s
7726 set textfont [fontname textfont]
7733 global sha1entry sha1string
7734 if {[string length $sha1string] == 40} {
7735 $sha1entry delete 0 end
7739 proc sha1change {n1 n2 op} {
7740 global sha1string currentid sha1but
7741 if {$sha1string == {}
7742 || ([info exists currentid] && $sha1string == $currentid)} {
7747 if {[$sha1but cget -state] == $state} return
7748 if {$state == "normal"} {
7749 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7751 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7755 proc gotocommit {} {
7756 global sha1string tagids headids curview varcid
7758 if {$sha1string == {}
7759 || ([info exists currentid] && $sha1string == $currentid)} return
7760 if {[info exists tagids($sha1string)]} {
7761 set id $tagids($sha1string)
7762 } elseif {[info exists headids($sha1string)]} {
7763 set id $headids($sha1string)
7765 set id [string tolower $sha1string]
7766 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7767 set matches [longid $id]
7768 if {$matches ne {}} {
7769 if {[llength $matches] > 1} {
7770 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7773 set id [lindex $matches 0]
7777 if {[commitinview $id $curview]} {
7778 selectline [rowofcommit $id] 1
7781 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7782 set msg [mc "SHA1 id %s is not known" $sha1string]
7784 set msg [mc "Tag/Head %s is not known" $sha1string]
7789 proc lineenter {x y id} {
7790 global hoverx hovery hoverid hovertimer
7791 global commitinfo canv
7793 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7797 if {[info exists hovertimer]} {
7798 after cancel $hovertimer
7800 set hovertimer [after 500 linehover]
7804 proc linemotion {x y id} {
7805 global hoverx hovery hoverid hovertimer
7807 if {[info exists hoverid] && $id == $hoverid} {
7810 if {[info exists hovertimer]} {
7811 after cancel $hovertimer
7813 set hovertimer [after 500 linehover]
7817 proc lineleave {id} {
7818 global hoverid hovertimer canv
7820 if {[info exists hoverid] && $id == $hoverid} {
7822 if {[info exists hovertimer]} {
7823 after cancel $hovertimer
7831 global hoverx hovery hoverid hovertimer
7832 global canv linespc lthickness
7835 set text [lindex $commitinfo($hoverid) 0]
7836 set ymax [lindex [$canv cget -scrollregion] 3]
7837 if {$ymax == {}} return
7838 set yfrac [lindex [$canv yview] 0]
7839 set x [expr {$hoverx + 2 * $linespc}]
7840 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7841 set x0 [expr {$x - 2 * $lthickness}]
7842 set y0 [expr {$y - 2 * $lthickness}]
7843 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7844 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7845 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7846 -fill \#ffff80 -outline black -width 1 -tags hover]
7848 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7853 proc clickisonarrow {id y} {
7856 set ranges [rowranges $id]
7857 set thresh [expr {2 * $lthickness + 6}]
7858 set n [expr {[llength $ranges] - 1}]
7859 for {set i 1} {$i < $n} {incr i} {
7860 set row [lindex $ranges $i]
7861 if {abs([yc $row] - $y) < $thresh} {
7868 proc arrowjump {id n y} {
7871 # 1 <-> 2, 3 <-> 4, etc...
7872 set n [expr {(($n - 1) ^ 1) + 1}]
7873 set row [lindex [rowranges $id] $n]
7875 set ymax [lindex [$canv cget -scrollregion] 3]
7876 if {$ymax eq {} || $ymax <= 0} return
7877 set view [$canv yview]
7878 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7879 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7883 allcanvs yview moveto $yfrac
7886 proc lineclick {x y id isnew} {
7887 global ctext commitinfo children canv thickerline curview
7889 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7894 # draw this line thicker than normal
7898 set ymax [lindex [$canv cget -scrollregion] 3]
7899 if {$ymax eq {}} return
7900 set yfrac [lindex [$canv yview] 0]
7901 set y [expr {$y + $yfrac * $ymax}]
7903 set dirn [clickisonarrow $id $y]
7905 arrowjump $id $dirn $y
7910 addtohistory [list lineclick $x $y $id 0]
7912 # fill the details pane with info about this line
7913 $ctext conf -state normal
7916 $ctext insert end "[mc "Parent"]:\t"
7917 $ctext insert end $id link0
7919 set info $commitinfo($id)
7920 $ctext insert end "\n\t[lindex $info 0]\n"
7921 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7922 set date [formatdate [lindex $info 2]]
7923 $ctext insert end "\t[mc "Date"]:\t$date\n"
7924 set kids $children($curview,$id)
7926 $ctext insert end "\n[mc "Children"]:"
7928 foreach child $kids {
7930 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7931 set info $commitinfo($child)
7932 $ctext insert end "\n\t"
7933 $ctext insert end $child link$i
7934 setlink $child link$i
7935 $ctext insert end "\n\t[lindex $info 0]"
7936 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7937 set date [formatdate [lindex $info 2]]
7938 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7941 $ctext conf -state disabled
7945 proc normalline {} {
7947 if {[info exists thickerline]} {
7956 if {[commitinview $id $curview]} {
7957 selectline [rowofcommit $id] 1
7963 if {![info exists startmstime]} {
7964 set startmstime [clock clicks -milliseconds]
7966 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7969 proc rowmenu {x y id} {
7970 global rowctxmenu selectedline rowmenuid curview
7971 global nullid nullid2 fakerowmenu mainhead
7975 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7980 if {$id ne $nullid && $id ne $nullid2} {
7981 set menu $rowctxmenu
7982 if {$mainhead ne {}} {
7983 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
7985 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7988 set menu $fakerowmenu
7990 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7991 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7992 $menu entryconfigure [mca "Make patch"] -state $state
7993 tk_popup $menu $x $y
7996 proc diffvssel {dirn} {
7997 global rowmenuid selectedline
7999 if {$selectedline eq {}} return
8001 set oldid [commitonrow $selectedline]
8002 set newid $rowmenuid
8004 set oldid $rowmenuid
8005 set newid [commitonrow $selectedline]
8007 addtohistory [list doseldiff $oldid $newid]
8008 doseldiff $oldid $newid
8011 proc doseldiff {oldid newid} {
8015 $ctext conf -state normal
8017 init_flist [mc "Top"]
8018 $ctext insert end "[mc "From"] "
8019 $ctext insert end $oldid link0
8020 setlink $oldid link0
8021 $ctext insert end "\n "
8022 $ctext insert end [lindex $commitinfo($oldid) 0]
8023 $ctext insert end "\n\n[mc "To"] "
8024 $ctext insert end $newid link1
8025 setlink $newid link1
8026 $ctext insert end "\n "
8027 $ctext insert end [lindex $commitinfo($newid) 0]
8028 $ctext insert end "\n"
8029 $ctext conf -state disabled
8030 $ctext tag remove found 1.0 end
8031 startdiff [list $oldid $newid]
8035 global rowmenuid currentid commitinfo patchtop patchnum
8037 if {![info exists currentid]} return
8038 set oldid $currentid
8039 set oldhead [lindex $commitinfo($oldid) 0]
8040 set newid $rowmenuid
8041 set newhead [lindex $commitinfo($newid) 0]
8044 catch {destroy $top}
8046 make_transient $top .
8047 label $top.title -text [mc "Generate patch"]
8048 grid $top.title - -pady 10
8049 label $top.from -text [mc "From:"]
8050 entry $top.fromsha1 -width 40 -relief flat
8051 $top.fromsha1 insert 0 $oldid
8052 $top.fromsha1 conf -state readonly
8053 grid $top.from $top.fromsha1 -sticky w
8054 entry $top.fromhead -width 60 -relief flat
8055 $top.fromhead insert 0 $oldhead
8056 $top.fromhead conf -state readonly
8057 grid x $top.fromhead -sticky w
8058 label $top.to -text [mc "To:"]
8059 entry $top.tosha1 -width 40 -relief flat
8060 $top.tosha1 insert 0 $newid
8061 $top.tosha1 conf -state readonly
8062 grid $top.to $top.tosha1 -sticky w
8063 entry $top.tohead -width 60 -relief flat
8064 $top.tohead insert 0 $newhead
8065 $top.tohead conf -state readonly
8066 grid x $top.tohead -sticky w
8067 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8068 grid $top.rev x -pady 10
8069 label $top.flab -text [mc "Output file:"]
8070 entry $top.fname -width 60
8071 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8073 grid $top.flab $top.fname -sticky w
8075 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8076 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8077 bind $top <Key-Return> mkpatchgo
8078 bind $top <Key-Escape> mkpatchcan
8079 grid $top.buts.gen $top.buts.can
8080 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8081 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8082 grid $top.buts - -pady 10 -sticky ew
8086 proc mkpatchrev {} {
8089 set oldid [$patchtop.fromsha1 get]
8090 set oldhead [$patchtop.fromhead get]
8091 set newid [$patchtop.tosha1 get]
8092 set newhead [$patchtop.tohead get]
8093 foreach e [list fromsha1 fromhead tosha1 tohead] \
8094 v [list $newid $newhead $oldid $oldhead] {
8095 $patchtop.$e conf -state normal
8096 $patchtop.$e delete 0 end
8097 $patchtop.$e insert 0 $v
8098 $patchtop.$e conf -state readonly
8103 global patchtop nullid nullid2
8105 set oldid [$patchtop.fromsha1 get]
8106 set newid [$patchtop.tosha1 get]
8107 set fname [$patchtop.fname get]
8108 set cmd [diffcmd [list $oldid $newid] -p]
8109 # trim off the initial "|"
8110 set cmd [lrange $cmd 1 end]
8111 lappend cmd >$fname &
8112 if {[catch {eval exec $cmd} err]} {
8113 error_popup "[mc "Error creating patch:"] $err" $patchtop
8115 catch {destroy $patchtop}
8119 proc mkpatchcan {} {
8122 catch {destroy $patchtop}
8127 global rowmenuid mktagtop commitinfo
8131 catch {destroy $top}
8133 make_transient $top .
8134 label $top.title -text [mc "Create tag"]
8135 grid $top.title - -pady 10
8136 label $top.id -text [mc "ID:"]
8137 entry $top.sha1 -width 40 -relief flat
8138 $top.sha1 insert 0 $rowmenuid
8139 $top.sha1 conf -state readonly
8140 grid $top.id $top.sha1 -sticky w
8141 entry $top.head -width 60 -relief flat
8142 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8143 $top.head conf -state readonly
8144 grid x $top.head -sticky w
8145 label $top.tlab -text [mc "Tag name:"]
8146 entry $top.tag -width 60
8147 grid $top.tlab $top.tag -sticky w
8149 button $top.buts.gen -text [mc "Create"] -command mktaggo
8150 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8151 bind $top <Key-Return> mktaggo
8152 bind $top <Key-Escape> mktagcan
8153 grid $top.buts.gen $top.buts.can
8154 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8155 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8156 grid $top.buts - -pady 10 -sticky ew
8161 global mktagtop env tagids idtags
8163 set id [$mktagtop.sha1 get]
8164 set tag [$mktagtop.tag get]
8166 error_popup [mc "No tag name specified"] $mktagtop
8169 if {[info exists tagids($tag)]} {
8170 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8174 exec git tag $tag $id
8176 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8180 set tagids($tag) $id
8181 lappend idtags($id) $tag
8189 proc redrawtags {id} {
8190 global canv linehtag idpos currentid curview cmitlisted
8191 global canvxmax iddrawn circleitem mainheadid circlecolors
8193 if {![commitinview $id $curview]} return
8194 if {![info exists iddrawn($id)]} return
8195 set row [rowofcommit $id]
8196 if {$id eq $mainheadid} {
8199 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8201 $canv itemconf $circleitem($row) -fill $ofill
8202 $canv delete tag.$id
8203 set xt [eval drawtags $id $idpos($id)]
8204 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8205 set text [$canv itemcget $linehtag($id) -text]
8206 set font [$canv itemcget $linehtag($id) -font]
8207 set xr [expr {$xt + [font measure $font $text]}]
8208 if {$xr > $canvxmax} {
8212 if {[info exists currentid] && $currentid == $id} {
8220 catch {destroy $mktagtop}
8225 if {![domktag]} return
8229 proc writecommit {} {
8230 global rowmenuid wrcomtop commitinfo wrcomcmd
8232 set top .writecommit
8234 catch {destroy $top}
8236 make_transient $top .
8237 label $top.title -text [mc "Write commit to file"]
8238 grid $top.title - -pady 10
8239 label $top.id -text [mc "ID:"]
8240 entry $top.sha1 -width 40 -relief flat
8241 $top.sha1 insert 0 $rowmenuid
8242 $top.sha1 conf -state readonly
8243 grid $top.id $top.sha1 -sticky w
8244 entry $top.head -width 60 -relief flat
8245 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8246 $top.head conf -state readonly
8247 grid x $top.head -sticky w
8248 label $top.clab -text [mc "Command:"]
8249 entry $top.cmd -width 60 -textvariable wrcomcmd
8250 grid $top.clab $top.cmd -sticky w -pady 10
8251 label $top.flab -text [mc "Output file:"]
8252 entry $top.fname -width 60
8253 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8254 grid $top.flab $top.fname -sticky w
8256 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8257 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8258 bind $top <Key-Return> wrcomgo
8259 bind $top <Key-Escape> wrcomcan
8260 grid $top.buts.gen $top.buts.can
8261 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8262 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8263 grid $top.buts - -pady 10 -sticky ew
8270 set id [$wrcomtop.sha1 get]
8271 set cmd "echo $id | [$wrcomtop.cmd get]"
8272 set fname [$wrcomtop.fname get]
8273 if {[catch {exec sh -c $cmd >$fname &} err]} {
8274 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8276 catch {destroy $wrcomtop}
8283 catch {destroy $wrcomtop}
8288 global rowmenuid mkbrtop
8291 catch {destroy $top}
8293 make_transient $top .
8294 label $top.title -text [mc "Create new branch"]
8295 grid $top.title - -pady 10
8296 label $top.id -text [mc "ID:"]
8297 entry $top.sha1 -width 40 -relief flat
8298 $top.sha1 insert 0 $rowmenuid
8299 $top.sha1 conf -state readonly
8300 grid $top.id $top.sha1 -sticky w
8301 label $top.nlab -text [mc "Name:"]
8302 entry $top.name -width 40
8303 grid $top.nlab $top.name -sticky w
8305 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8306 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8307 bind $top <Key-Return> [list mkbrgo $top]
8308 bind $top <Key-Escape> "catch {destroy $top}"
8309 grid $top.buts.go $top.buts.can
8310 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8311 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8312 grid $top.buts - -pady 10 -sticky ew
8317 global headids idheads
8319 set name [$top.name get]
8320 set id [$top.sha1 get]
8324 error_popup [mc "Please specify a name for the new branch"] $top
8327 if {[info exists headids($name)]} {
8328 if {![confirm_popup [mc \
8329 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8332 set old_id $headids($name)
8335 catch {destroy $top}
8336 lappend cmdargs $name $id
8340 eval exec git branch $cmdargs
8346 if {$old_id ne {}} {
8352 set headids($name) $id
8353 lappend idheads($id) $name
8362 proc exec_citool {tool_args {baseid {}}} {
8363 global commitinfo env
8365 set save_env [array get env GIT_AUTHOR_*]
8367 if {$baseid ne {}} {
8368 if {![info exists commitinfo($baseid)]} {
8371 set author [lindex $commitinfo($baseid) 1]
8372 set date [lindex $commitinfo($baseid) 2]
8373 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8374 $author author name email]
8376 set env(GIT_AUTHOR_NAME) $name
8377 set env(GIT_AUTHOR_EMAIL) $email
8378 set env(GIT_AUTHOR_DATE) $date
8382 eval exec git citool $tool_args &
8384 array unset env GIT_AUTHOR_*
8385 array set env $save_env
8388 proc cherrypick {} {
8389 global rowmenuid curview
8390 global mainhead mainheadid
8392 set oldhead [exec git rev-parse HEAD]
8393 set dheads [descheads $rowmenuid]
8394 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8395 set ok [confirm_popup [mc "Commit %s is already\
8396 included in branch %s -- really re-apply it?" \
8397 [string range $rowmenuid 0 7] $mainhead]]
8400 nowbusy cherrypick [mc "Cherry-picking"]
8402 # Unfortunately git-cherry-pick writes stuff to stderr even when
8403 # no error occurs, and exec takes that as an indication of error...
8404 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8407 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8409 error_popup [mc "Cherry-pick failed because of local changes\
8410 to file '%s'.\nPlease commit, reset or stash\
8411 your changes and try again." $fname]
8412 } elseif {[regexp -line \
8413 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8415 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8416 conflict.\nDo you wish to run git citool to\
8418 # Force citool to read MERGE_MSG
8419 file delete [file join [gitdir] "GITGUI_MSG"]
8420 exec_citool {} $rowmenuid
8428 set newhead [exec git rev-parse HEAD]
8429 if {$newhead eq $oldhead} {
8431 error_popup [mc "No changes committed"]
8434 addnewchild $newhead $oldhead
8435 if {[commitinview $oldhead $curview]} {
8436 # XXX this isn't right if we have a path limit...
8437 insertrow $newhead $oldhead $curview
8438 if {$mainhead ne {}} {
8439 movehead $newhead $mainhead
8440 movedhead $newhead $mainhead
8442 set mainheadid $newhead
8451 global mainhead rowmenuid confirm_ok resettype
8454 set w ".confirmreset"
8457 wm title $w [mc "Confirm reset"]
8458 message $w.m -text \
8459 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8460 -justify center -aspect 1000
8461 pack $w.m -side top -fill x -padx 20 -pady 20
8462 frame $w.f -relief sunken -border 2
8463 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8464 grid $w.f.rt -sticky w
8466 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8467 -text [mc "Soft: Leave working tree and index untouched"]
8468 grid $w.f.soft -sticky w
8469 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8470 -text [mc "Mixed: Leave working tree untouched, reset index"]
8471 grid $w.f.mixed -sticky w
8472 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8473 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8474 grid $w.f.hard -sticky w
8475 pack $w.f -side top -fill x
8476 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8477 pack $w.ok -side left -fill x -padx 20 -pady 20
8478 button $w.cancel -text [mc Cancel] -command "destroy $w"
8479 bind $w <Key-Escape> [list destroy $w]
8480 pack $w.cancel -side right -fill x -padx 20 -pady 20
8481 bind $w <Visibility> "grab $w; focus $w"
8483 if {!$confirm_ok} return
8484 if {[catch {set fd [open \
8485 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8489 filerun $fd [list readresetstat $fd]
8490 nowbusy reset [mc "Resetting"]
8495 proc readresetstat {fd} {
8496 global mainhead mainheadid showlocalchanges rprogcoord
8498 if {[gets $fd line] >= 0} {
8499 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8500 set rprogcoord [expr {1.0 * $m / $n}]
8508 if {[catch {close $fd} err]} {
8511 set oldhead $mainheadid
8512 set newhead [exec git rev-parse HEAD]
8513 if {$newhead ne $oldhead} {
8514 movehead $newhead $mainhead
8515 movedhead $newhead $mainhead
8516 set mainheadid $newhead
8520 if {$showlocalchanges} {
8526 # context menu for a head
8527 proc headmenu {x y id head} {
8528 global headmenuid headmenuhead headctxmenu mainhead
8532 set headmenuhead $head
8534 if {$head eq $mainhead} {
8537 $headctxmenu entryconfigure 0 -state $state
8538 $headctxmenu entryconfigure 1 -state $state
8539 tk_popup $headctxmenu $x $y
8543 global headmenuid headmenuhead headids
8544 global showlocalchanges
8546 # check the tree is clean first??
8547 nowbusy checkout [mc "Checking out"]
8551 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8555 if {$showlocalchanges} {
8559 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8563 proc readcheckoutstat {fd newhead newheadid} {
8564 global mainhead mainheadid headids showlocalchanges progresscoords
8565 global viewmainheadid curview
8567 if {[gets $fd line] >= 0} {
8568 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8569 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8574 set progresscoords {0 0}
8577 if {[catch {close $fd} err]} {
8580 set oldmainid $mainheadid
8581 set mainhead $newhead
8582 set mainheadid $newheadid
8583 set viewmainheadid($curview) $newheadid
8584 redrawtags $oldmainid
8585 redrawtags $newheadid
8587 if {$showlocalchanges} {
8593 global headmenuid headmenuhead mainhead
8596 set head $headmenuhead
8598 # this check shouldn't be needed any more...
8599 if {$head eq $mainhead} {
8600 error_popup [mc "Cannot delete the currently checked-out branch"]
8603 set dheads [descheads $id]
8604 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8605 # the stuff on this branch isn't on any other branch
8606 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8607 branch.\nReally delete branch %s?" $head $head]]} return
8611 if {[catch {exec git branch -D $head} err]} {
8616 removehead $id $head
8617 removedhead $id $head
8624 # Display a list of tags and heads
8626 global showrefstop bgcolor fgcolor selectbgcolor
8627 global bglist fglist reflistfilter reflist maincursor
8630 set showrefstop $top
8631 if {[winfo exists $top]} {
8637 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8638 make_transient $top .
8639 text $top.list -background $bgcolor -foreground $fgcolor \
8640 -selectbackground $selectbgcolor -font mainfont \
8641 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8642 -width 30 -height 20 -cursor $maincursor \
8643 -spacing1 1 -spacing3 1 -state disabled
8644 $top.list tag configure highlight -background $selectbgcolor
8645 lappend bglist $top.list
8646 lappend fglist $top.list
8647 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8648 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8649 grid $top.list $top.ysb -sticky nsew
8650 grid $top.xsb x -sticky ew
8652 label $top.f.l -text "[mc "Filter"]: "
8653 entry $top.f.e -width 20 -textvariable reflistfilter
8654 set reflistfilter "*"
8655 trace add variable reflistfilter write reflistfilter_change
8656 pack $top.f.e -side right -fill x -expand 1
8657 pack $top.f.l -side left
8658 grid $top.f - -sticky ew -pady 2
8659 button $top.close -command [list destroy $top] -text [mc "Close"]
8660 bind $top <Key-Escape> [list destroy $top]
8662 grid columnconfigure $top 0 -weight 1
8663 grid rowconfigure $top 0 -weight 1
8664 bind $top.list <1> {break}
8665 bind $top.list <B1-Motion> {break}
8666 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8671 proc sel_reflist {w x y} {
8672 global showrefstop reflist headids tagids otherrefids
8674 if {![winfo exists $showrefstop]} return
8675 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8676 set ref [lindex $reflist [expr {$l-1}]]
8677 set n [lindex $ref 0]
8678 switch -- [lindex $ref 1] {
8679 "H" {selbyid $headids($n)}
8680 "T" {selbyid $tagids($n)}
8681 "o" {selbyid $otherrefids($n)}
8683 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8686 proc unsel_reflist {} {
8689 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8690 $showrefstop.list tag remove highlight 0.0 end
8693 proc reflistfilter_change {n1 n2 op} {
8694 global reflistfilter
8696 after cancel refill_reflist
8697 after 200 refill_reflist
8700 proc refill_reflist {} {
8701 global reflist reflistfilter showrefstop headids tagids otherrefids
8704 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8706 foreach n [array names headids] {
8707 if {[string match $reflistfilter $n]} {
8708 if {[commitinview $headids($n) $curview]} {
8709 lappend refs [list $n H]
8711 interestedin $headids($n) {run refill_reflist}
8715 foreach n [array names tagids] {
8716 if {[string match $reflistfilter $n]} {
8717 if {[commitinview $tagids($n) $curview]} {
8718 lappend refs [list $n T]
8720 interestedin $tagids($n) {run refill_reflist}
8724 foreach n [array names otherrefids] {
8725 if {[string match $reflistfilter $n]} {
8726 if {[commitinview $otherrefids($n) $curview]} {
8727 lappend refs [list $n o]
8729 interestedin $otherrefids($n) {run refill_reflist}
8733 set refs [lsort -index 0 $refs]
8734 if {$refs eq $reflist} return
8736 # Update the contents of $showrefstop.list according to the
8737 # differences between $reflist (old) and $refs (new)
8738 $showrefstop.list conf -state normal
8739 $showrefstop.list insert end "\n"
8742 while {$i < [llength $reflist] || $j < [llength $refs]} {
8743 if {$i < [llength $reflist]} {
8744 if {$j < [llength $refs]} {
8745 set cmp [string compare [lindex $reflist $i 0] \
8746 [lindex $refs $j 0]]
8748 set cmp [string compare [lindex $reflist $i 1] \
8749 [lindex $refs $j 1]]
8759 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8767 set l [expr {$j + 1}]
8768 $showrefstop.list image create $l.0 -align baseline \
8769 -image reficon-[lindex $refs $j 1] -padx 2
8770 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8776 # delete last newline
8777 $showrefstop.list delete end-2c end-1c
8778 $showrefstop.list conf -state disabled
8781 # Stuff for finding nearby tags
8782 proc getallcommits {} {
8783 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8784 global idheads idtags idotherrefs allparents tagobjid
8786 if {![info exists allcommits]} {
8792 set allccache [file join [gitdir] "gitk.cache"]
8794 set f [open $allccache r]
8803 set cmd [list | git rev-list --parents]
8804 set allcupdate [expr {$seeds ne {}}]
8808 set refs [concat [array names idheads] [array names idtags] \
8809 [array names idotherrefs]]
8812 foreach name [array names tagobjid] {
8813 lappend tagobjs $tagobjid($name)
8815 foreach id [lsort -unique $refs] {
8816 if {![info exists allparents($id)] &&
8817 [lsearch -exact $tagobjs $id] < 0} {
8828 set fd [open [concat $cmd $ids] r]
8829 fconfigure $fd -blocking 0
8832 filerun $fd [list getallclines $fd]
8838 # Since most commits have 1 parent and 1 child, we group strings of
8839 # such commits into "arcs" joining branch/merge points (BMPs), which
8840 # are commits that either don't have 1 parent or don't have 1 child.
8842 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8843 # arcout(id) - outgoing arcs for BMP
8844 # arcids(a) - list of IDs on arc including end but not start
8845 # arcstart(a) - BMP ID at start of arc
8846 # arcend(a) - BMP ID at end of arc
8847 # growing(a) - arc a is still growing
8848 # arctags(a) - IDs out of arcids (excluding end) that have tags
8849 # archeads(a) - IDs out of arcids (excluding end) that have heads
8850 # The start of an arc is at the descendent end, so "incoming" means
8851 # coming from descendents, and "outgoing" means going towards ancestors.
8853 proc getallclines {fd} {
8854 global allparents allchildren idtags idheads nextarc
8855 global arcnos arcids arctags arcout arcend arcstart archeads growing
8856 global seeds allcommits cachedarcs allcupdate
8859 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8860 set id [lindex $line 0]
8861 if {[info exists allparents($id)]} {
8866 set olds [lrange $line 1 end]
8867 set allparents($id) $olds
8868 if {![info exists allchildren($id)]} {
8869 set allchildren($id) {}
8874 if {[llength $olds] == 1 && [llength $a] == 1} {
8875 lappend arcids($a) $id
8876 if {[info exists idtags($id)]} {
8877 lappend arctags($a) $id
8879 if {[info exists idheads($id)]} {
8880 lappend archeads($a) $id
8882 if {[info exists allparents($olds)]} {
8883 # seen parent already
8884 if {![info exists arcout($olds)]} {
8887 lappend arcids($a) $olds
8888 set arcend($a) $olds
8891 lappend allchildren($olds) $id
8892 lappend arcnos($olds) $a
8896 foreach a $arcnos($id) {
8897 lappend arcids($a) $id
8904 lappend allchildren($p) $id
8905 set a [incr nextarc]
8906 set arcstart($a) $id
8913 if {[info exists allparents($p)]} {
8914 # seen it already, may need to make a new branch
8915 if {![info exists arcout($p)]} {
8918 lappend arcids($a) $p
8922 lappend arcnos($p) $a
8927 global cached_dheads cached_dtags cached_atags
8928 catch {unset cached_dheads}
8929 catch {unset cached_dtags}
8930 catch {unset cached_atags}
8933 return [expr {$nid >= 1000? 2: 1}]
8937 fconfigure $fd -blocking 1
8940 # got an error reading the list of commits
8941 # if we were updating, try rereading the whole thing again
8947 error_popup "[mc "Error reading commit topology information;\
8948 branch and preceding/following tag information\
8949 will be incomplete."]\n($err)"
8952 if {[incr allcommits -1] == 0} {
8962 proc recalcarc {a} {
8963 global arctags archeads arcids idtags idheads
8967 foreach id [lrange $arcids($a) 0 end-1] {
8968 if {[info exists idtags($id)]} {
8971 if {[info exists idheads($id)]} {
8976 set archeads($a) $ah
8980 global arcnos arcids nextarc arctags archeads idtags idheads
8981 global arcstart arcend arcout allparents growing
8984 if {[llength $a] != 1} {
8985 puts "oops splitarc called but [llength $a] arcs already"
8989 set i [lsearch -exact $arcids($a) $p]
8991 puts "oops splitarc $p not in arc $a"
8994 set na [incr nextarc]
8995 if {[info exists arcend($a)]} {
8996 set arcend($na) $arcend($a)
8998 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8999 set j [lsearch -exact $arcnos($l) $a]
9000 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9002 set tail [lrange $arcids($a) [expr {$i+1}] end]
9003 set arcids($a) [lrange $arcids($a) 0 $i]
9005 set arcstart($na) $p
9007 set arcids($na) $tail
9008 if {[info exists growing($a)]} {
9014 if {[llength $arcnos($id)] == 1} {
9017 set j [lsearch -exact $arcnos($id) $a]
9018 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9022 # reconstruct tags and heads lists
9023 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9028 set archeads($na) {}
9032 # Update things for a new commit added that is a child of one
9033 # existing commit. Used when cherry-picking.
9034 proc addnewchild {id p} {
9035 global allparents allchildren idtags nextarc
9036 global arcnos arcids arctags arcout arcend arcstart archeads growing
9037 global seeds allcommits
9039 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9040 set allparents($id) [list $p]
9041 set allchildren($id) {}
9044 lappend allchildren($p) $id
9045 set a [incr nextarc]
9046 set arcstart($a) $id
9049 set arcids($a) [list $p]
9051 if {![info exists arcout($p)]} {
9054 lappend arcnos($p) $a
9055 set arcout($id) [list $a]
9058 # This implements a cache for the topology information.
9059 # The cache saves, for each arc, the start and end of the arc,
9060 # the ids on the arc, and the outgoing arcs from the end.
9061 proc readcache {f} {
9062 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9063 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9068 if {$lim - $a > 500} {
9069 set lim [expr {$a + 500}]
9073 # finish reading the cache and setting up arctags, etc.
9075 if {$line ne "1"} {error "bad final version"}
9077 foreach id [array names idtags] {
9078 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9079 [llength $allparents($id)] == 1} {
9080 set a [lindex $arcnos($id) 0]
9081 if {$arctags($a) eq {}} {
9086 foreach id [array names idheads] {
9087 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9088 [llength $allparents($id)] == 1} {
9089 set a [lindex $arcnos($id) 0]
9090 if {$archeads($a) eq {}} {
9095 foreach id [lsort -unique $possible_seeds] {
9096 if {$arcnos($id) eq {}} {
9102 while {[incr a] <= $lim} {
9104 if {[llength $line] != 3} {error "bad line"}
9105 set s [lindex $line 0]
9107 lappend arcout($s) $a
9108 if {![info exists arcnos($s)]} {
9109 lappend possible_seeds $s
9112 set e [lindex $line 1]
9117 if {![info exists arcout($e)]} {
9121 set arcids($a) [lindex $line 2]
9122 foreach id $arcids($a) {
9123 lappend allparents($s) $id
9125 lappend arcnos($id) $a
9127 if {![info exists allparents($s)]} {
9128 set allparents($s) {}
9133 set nextarc [expr {$a - 1}]
9146 global nextarc cachedarcs possible_seeds
9150 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9151 # make sure it's an integer
9152 set cachedarcs [expr {int([lindex $line 1])}]
9153 if {$cachedarcs < 0} {error "bad number of arcs"}
9155 set possible_seeds {}
9163 proc dropcache {err} {
9164 global allcwait nextarc cachedarcs seeds
9166 #puts "dropping cache ($err)"
9167 foreach v {arcnos arcout arcids arcstart arcend growing \
9168 arctags archeads allparents allchildren} {
9179 proc writecache {f} {
9180 global cachearc cachedarcs allccache
9181 global arcstart arcend arcnos arcids arcout
9185 if {$lim - $a > 1000} {
9186 set lim [expr {$a + 1000}]
9189 while {[incr a] <= $lim} {
9190 if {[info exists arcend($a)]} {
9191 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9193 puts $f [list $arcstart($a) {} $arcids($a)]
9198 catch {file delete $allccache}
9199 #puts "writing cache failed ($err)"
9202 set cachearc [expr {$a - 1}]
9203 if {$a > $cachedarcs} {
9212 global nextarc cachedarcs cachearc allccache
9214 if {$nextarc == $cachedarcs} return
9216 set cachedarcs $nextarc
9218 set f [open $allccache w]
9219 puts $f [list 1 $cachedarcs]
9224 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9225 # or 0 if neither is true.
9226 proc anc_or_desc {a b} {
9227 global arcout arcstart arcend arcnos cached_isanc
9229 if {$arcnos($a) eq $arcnos($b)} {
9230 # Both are on the same arc(s); either both are the same BMP,
9231 # or if one is not a BMP, the other is also not a BMP or is
9232 # the BMP at end of the arc (and it only has 1 incoming arc).
9233 # Or both can be BMPs with no incoming arcs.
9234 if {$a eq $b || $arcnos($a) eq {}} {
9237 # assert {[llength $arcnos($a)] == 1}
9238 set arc [lindex $arcnos($a) 0]
9239 set i [lsearch -exact $arcids($arc) $a]
9240 set j [lsearch -exact $arcids($arc) $b]
9241 if {$i < 0 || $i > $j} {
9248 if {![info exists arcout($a)]} {
9249 set arc [lindex $arcnos($a) 0]
9250 if {[info exists arcend($arc)]} {
9251 set aend $arcend($arc)
9255 set a $arcstart($arc)
9259 if {![info exists arcout($b)]} {
9260 set arc [lindex $arcnos($b) 0]
9261 if {[info exists arcend($arc)]} {
9262 set bend $arcend($arc)
9266 set b $arcstart($arc)
9276 if {[info exists cached_isanc($a,$bend)]} {
9277 if {$cached_isanc($a,$bend)} {
9281 if {[info exists cached_isanc($b,$aend)]} {
9282 if {$cached_isanc($b,$aend)} {
9285 if {[info exists cached_isanc($a,$bend)]} {
9290 set todo [list $a $b]
9293 for {set i 0} {$i < [llength $todo]} {incr i} {
9294 set x [lindex $todo $i]
9295 if {$anc($x) eq {}} {
9298 foreach arc $arcnos($x) {
9299 set xd $arcstart($arc)
9301 set cached_isanc($a,$bend) 1
9302 set cached_isanc($b,$aend) 0
9304 } elseif {$xd eq $aend} {
9305 set cached_isanc($b,$aend) 1
9306 set cached_isanc($a,$bend) 0
9309 if {![info exists anc($xd)]} {
9310 set anc($xd) $anc($x)
9312 } elseif {$anc($xd) ne $anc($x)} {
9317 set cached_isanc($a,$bend) 0
9318 set cached_isanc($b,$aend) 0
9322 # This identifies whether $desc has an ancestor that is
9323 # a growing tip of the graph and which is not an ancestor of $anc
9324 # and returns 0 if so and 1 if not.
9325 # If we subsequently discover a tag on such a growing tip, and that
9326 # turns out to be a descendent of $anc (which it could, since we
9327 # don't necessarily see children before parents), then $desc
9328 # isn't a good choice to display as a descendent tag of
9329 # $anc (since it is the descendent of another tag which is
9330 # a descendent of $anc). Similarly, $anc isn't a good choice to
9331 # display as a ancestor tag of $desc.
9333 proc is_certain {desc anc} {
9334 global arcnos arcout arcstart arcend growing problems
9337 if {[llength $arcnos($anc)] == 1} {
9338 # tags on the same arc are certain
9339 if {$arcnos($desc) eq $arcnos($anc)} {
9342 if {![info exists arcout($anc)]} {
9343 # if $anc is partway along an arc, use the start of the arc instead
9344 set a [lindex $arcnos($anc) 0]
9345 set anc $arcstart($a)
9348 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9351 set a [lindex $arcnos($desc) 0]
9357 set anclist [list $x]
9361 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9362 set x [lindex $anclist $i]
9367 foreach a $arcout($x) {
9368 if {[info exists growing($a)]} {
9369 if {![info exists growanc($x)] && $dl($x)} {
9375 if {[info exists dl($y)]} {
9379 if {![info exists done($y)]} {
9382 if {[info exists growanc($x)]} {
9386 for {set k 0} {$k < [llength $xl]} {incr k} {
9387 set z [lindex $xl $k]
9388 foreach c $arcout($z) {
9389 if {[info exists arcend($c)]} {
9391 if {[info exists dl($v)] && $dl($v)} {
9393 if {![info exists done($v)]} {
9396 if {[info exists growanc($v)]} {
9406 } elseif {$y eq $anc || !$dl($x)} {
9417 foreach x [array names growanc] {
9426 proc validate_arctags {a} {
9427 global arctags idtags
9431 foreach id $arctags($a) {
9433 if {![info exists idtags($id)]} {
9434 set na [lreplace $na $i $i]
9441 proc validate_archeads {a} {
9442 global archeads idheads
9445 set na $archeads($a)
9446 foreach id $archeads($a) {
9448 if {![info exists idheads($id)]} {
9449 set na [lreplace $na $i $i]
9453 set archeads($a) $na
9456 # Return the list of IDs that have tags that are descendents of id,
9457 # ignoring IDs that are descendents of IDs already reported.
9458 proc desctags {id} {
9459 global arcnos arcstart arcids arctags idtags allparents
9460 global growing cached_dtags
9462 if {![info exists allparents($id)]} {
9465 set t1 [clock clicks -milliseconds]
9467 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9468 # part-way along an arc; check that arc first
9469 set a [lindex $arcnos($id) 0]
9470 if {$arctags($a) ne {}} {
9472 set i [lsearch -exact $arcids($a) $id]
9474 foreach t $arctags($a) {
9475 set j [lsearch -exact $arcids($a) $t]
9483 set id $arcstart($a)
9484 if {[info exists idtags($id)]} {
9488 if {[info exists cached_dtags($id)]} {
9489 return $cached_dtags($id)
9496 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9497 set id [lindex $todo $i]
9499 set ta [info exists hastaggedancestor($id)]
9503 # ignore tags on starting node
9504 if {!$ta && $i > 0} {
9505 if {[info exists idtags($id)]} {
9508 } elseif {[info exists cached_dtags($id)]} {
9509 set tagloc($id) $cached_dtags($id)
9513 foreach a $arcnos($id) {
9515 if {!$ta && $arctags($a) ne {}} {
9517 if {$arctags($a) ne {}} {
9518 lappend tagloc($id) [lindex $arctags($a) end]
9521 if {$ta || $arctags($a) ne {}} {
9522 set tomark [list $d]
9523 for {set j 0} {$j < [llength $tomark]} {incr j} {
9524 set dd [lindex $tomark $j]
9525 if {![info exists hastaggedancestor($dd)]} {
9526 if {[info exists done($dd)]} {
9527 foreach b $arcnos($dd) {
9528 lappend tomark $arcstart($b)
9530 if {[info exists tagloc($dd)]} {
9533 } elseif {[info exists queued($dd)]} {
9536 set hastaggedancestor($dd) 1
9540 if {![info exists queued($d)]} {
9543 if {![info exists hastaggedancestor($d)]} {
9550 foreach id [array names tagloc] {
9551 if {![info exists hastaggedancestor($id)]} {
9552 foreach t $tagloc($id) {
9553 if {[lsearch -exact $tags $t] < 0} {
9559 set t2 [clock clicks -milliseconds]
9562 # remove tags that are descendents of other tags
9563 for {set i 0} {$i < [llength $tags]} {incr i} {
9564 set a [lindex $tags $i]
9565 for {set j 0} {$j < $i} {incr j} {
9566 set b [lindex $tags $j]
9567 set r [anc_or_desc $a $b]
9569 set tags [lreplace $tags $j $j]
9572 } elseif {$r == -1} {
9573 set tags [lreplace $tags $i $i]
9580 if {[array names growing] ne {}} {
9581 # graph isn't finished, need to check if any tag could get
9582 # eclipsed by another tag coming later. Simply ignore any
9583 # tags that could later get eclipsed.
9586 if {[is_certain $t $origid]} {
9590 if {$tags eq $ctags} {
9591 set cached_dtags($origid) $tags
9596 set cached_dtags($origid) $tags
9598 set t3 [clock clicks -milliseconds]
9599 if {0 && $t3 - $t1 >= 100} {
9600 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9601 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9607 global arcnos arcids arcout arcend arctags idtags allparents
9608 global growing cached_atags
9610 if {![info exists allparents($id)]} {
9613 set t1 [clock clicks -milliseconds]
9615 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9616 # part-way along an arc; check that arc first
9617 set a [lindex $arcnos($id) 0]
9618 if {$arctags($a) ne {}} {
9620 set i [lsearch -exact $arcids($a) $id]
9621 foreach t $arctags($a) {
9622 set j [lsearch -exact $arcids($a) $t]
9628 if {![info exists arcend($a)]} {
9632 if {[info exists idtags($id)]} {
9636 if {[info exists cached_atags($id)]} {
9637 return $cached_atags($id)
9645 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9646 set id [lindex $todo $i]
9648 set td [info exists hastaggeddescendent($id)]
9652 # ignore tags on starting node
9653 if {!$td && $i > 0} {
9654 if {[info exists idtags($id)]} {
9657 } elseif {[info exists cached_atags($id)]} {
9658 set tagloc($id) $cached_atags($id)
9662 foreach a $arcout($id) {
9663 if {!$td && $arctags($a) ne {}} {
9665 if {$arctags($a) ne {}} {
9666 lappend tagloc($id) [lindex $arctags($a) 0]
9669 if {![info exists arcend($a)]} continue
9671 if {$td || $arctags($a) ne {}} {
9672 set tomark [list $d]
9673 for {set j 0} {$j < [llength $tomark]} {incr j} {
9674 set dd [lindex $tomark $j]
9675 if {![info exists hastaggeddescendent($dd)]} {
9676 if {[info exists done($dd)]} {
9677 foreach b $arcout($dd) {
9678 if {[info exists arcend($b)]} {
9679 lappend tomark $arcend($b)
9682 if {[info exists tagloc($dd)]} {
9685 } elseif {[info exists queued($dd)]} {
9688 set hastaggeddescendent($dd) 1
9692 if {![info exists queued($d)]} {
9695 if {![info exists hastaggeddescendent($d)]} {
9701 set t2 [clock clicks -milliseconds]
9704 foreach id [array names tagloc] {
9705 if {![info exists hastaggeddescendent($id)]} {
9706 foreach t $tagloc($id) {
9707 if {[lsearch -exact $tags $t] < 0} {
9714 # remove tags that are ancestors of other tags
9715 for {set i 0} {$i < [llength $tags]} {incr i} {
9716 set a [lindex $tags $i]
9717 for {set j 0} {$j < $i} {incr j} {
9718 set b [lindex $tags $j]
9719 set r [anc_or_desc $a $b]
9721 set tags [lreplace $tags $j $j]
9724 } elseif {$r == 1} {
9725 set tags [lreplace $tags $i $i]
9732 if {[array names growing] ne {}} {
9733 # graph isn't finished, need to check if any tag could get
9734 # eclipsed by another tag coming later. Simply ignore any
9735 # tags that could later get eclipsed.
9738 if {[is_certain $origid $t]} {
9742 if {$tags eq $ctags} {
9743 set cached_atags($origid) $tags
9748 set cached_atags($origid) $tags
9750 set t3 [clock clicks -milliseconds]
9751 if {0 && $t3 - $t1 >= 100} {
9752 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9753 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9758 # Return the list of IDs that have heads that are descendents of id,
9759 # including id itself if it has a head.
9760 proc descheads {id} {
9761 global arcnos arcstart arcids archeads idheads cached_dheads
9764 if {![info exists allparents($id)]} {
9768 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9769 # part-way along an arc; check it first
9770 set a [lindex $arcnos($id) 0]
9771 if {$archeads($a) ne {}} {
9772 validate_archeads $a
9773 set i [lsearch -exact $arcids($a) $id]
9774 foreach t $archeads($a) {
9775 set j [lsearch -exact $arcids($a) $t]
9780 set id $arcstart($a)
9786 for {set i 0} {$i < [llength $todo]} {incr i} {
9787 set id [lindex $todo $i]
9788 if {[info exists cached_dheads($id)]} {
9789 set ret [concat $ret $cached_dheads($id)]
9791 if {[info exists idheads($id)]} {
9794 foreach a $arcnos($id) {
9795 if {$archeads($a) ne {}} {
9796 validate_archeads $a
9797 if {$archeads($a) ne {}} {
9798 set ret [concat $ret $archeads($a)]
9802 if {![info exists seen($d)]} {
9809 set ret [lsort -unique $ret]
9810 set cached_dheads($origid) $ret
9811 return [concat $ret $aret]
9814 proc addedtag {id} {
9815 global arcnos arcout cached_dtags cached_atags
9817 if {![info exists arcnos($id)]} return
9818 if {![info exists arcout($id)]} {
9819 recalcarc [lindex $arcnos($id) 0]
9821 catch {unset cached_dtags}
9822 catch {unset cached_atags}
9825 proc addedhead {hid head} {
9826 global arcnos arcout cached_dheads
9828 if {![info exists arcnos($hid)]} return
9829 if {![info exists arcout($hid)]} {
9830 recalcarc [lindex $arcnos($hid) 0]
9832 catch {unset cached_dheads}
9835 proc removedhead {hid head} {
9836 global cached_dheads
9838 catch {unset cached_dheads}
9841 proc movedhead {hid head} {
9842 global arcnos arcout cached_dheads
9844 if {![info exists arcnos($hid)]} return
9845 if {![info exists arcout($hid)]} {
9846 recalcarc [lindex $arcnos($hid) 0]
9848 catch {unset cached_dheads}
9851 proc changedrefs {} {
9852 global cached_dheads cached_dtags cached_atags
9853 global arctags archeads arcnos arcout idheads idtags
9855 foreach id [concat [array names idheads] [array names idtags]] {
9856 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9857 set a [lindex $arcnos($id) 0]
9858 if {![info exists donearc($a)]} {
9864 catch {unset cached_dtags}
9865 catch {unset cached_atags}
9866 catch {unset cached_dheads}
9869 proc rereadrefs {} {
9870 global idtags idheads idotherrefs mainheadid
9872 set refids [concat [array names idtags] \
9873 [array names idheads] [array names idotherrefs]]
9874 foreach id $refids {
9875 if {![info exists ref($id)]} {
9876 set ref($id) [listrefs $id]
9879 set oldmainhead $mainheadid
9882 set refids [lsort -unique [concat $refids [array names idtags] \
9883 [array names idheads] [array names idotherrefs]]]
9884 foreach id $refids {
9885 set v [listrefs $id]
9886 if {![info exists ref($id)] || $ref($id) != $v} {
9890 if {$oldmainhead ne $mainheadid} {
9891 redrawtags $oldmainhead
9892 redrawtags $mainheadid
9897 proc listrefs {id} {
9898 global idtags idheads idotherrefs
9901 if {[info exists idtags($id)]} {
9905 if {[info exists idheads($id)]} {
9909 if {[info exists idotherrefs($id)]} {
9910 set z $idotherrefs($id)
9912 return [list $x $y $z]
9915 proc showtag {tag isnew} {
9916 global ctext tagcontents tagids linknum tagobjid
9919 addtohistory [list showtag $tag 0]
9921 $ctext conf -state normal
9925 if {![info exists tagcontents($tag)]} {
9927 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9930 if {[info exists tagcontents($tag)]} {
9931 set text $tagcontents($tag)
9933 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9935 appendwithlinks $text {}
9936 $ctext conf -state disabled
9948 if {[info exists gitktmpdir]} {
9949 catch {file delete -force $gitktmpdir}
9953 proc mkfontdisp {font top which} {
9954 global fontattr fontpref $font
9956 set fontpref($font) [set $font]
9957 button $top.${font}but -text $which -font optionfont \
9958 -command [list choosefont $font $which]
9959 label $top.$font -relief flat -font $font \
9960 -text $fontattr($font,family) -justify left
9961 grid x $top.${font}but $top.$font -sticky w
9964 proc choosefont {font which} {
9965 global fontparam fontlist fonttop fontattr
9968 set fontparam(which) $which
9969 set fontparam(font) $font
9970 set fontparam(family) [font actual $font -family]
9971 set fontparam(size) $fontattr($font,size)
9972 set fontparam(weight) $fontattr($font,weight)
9973 set fontparam(slant) $fontattr($font,slant)
9976 if {![winfo exists $top]} {
9978 eval font config sample [font actual $font]
9980 make_transient $top $prefstop
9981 wm title $top [mc "Gitk font chooser"]
9982 label $top.l -textvariable fontparam(which)
9983 pack $top.l -side top
9984 set fontlist [lsort [font families]]
9986 listbox $top.f.fam -listvariable fontlist \
9987 -yscrollcommand [list $top.f.sb set]
9988 bind $top.f.fam <<ListboxSelect>> selfontfam
9989 scrollbar $top.f.sb -command [list $top.f.fam yview]
9990 pack $top.f.sb -side right -fill y
9991 pack $top.f.fam -side left -fill both -expand 1
9992 pack $top.f -side top -fill both -expand 1
9994 spinbox $top.g.size -from 4 -to 40 -width 4 \
9995 -textvariable fontparam(size) \
9996 -validatecommand {string is integer -strict %s}
9997 checkbutton $top.g.bold -padx 5 \
9998 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9999 -variable fontparam(weight) -onvalue bold -offvalue normal
10000 checkbutton $top.g.ital -padx 5 \
10001 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10002 -variable fontparam(slant) -onvalue italic -offvalue roman
10003 pack $top.g.size $top.g.bold $top.g.ital -side left
10004 pack $top.g -side top
10005 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10007 $top.c create text 100 25 -anchor center -text $which -font sample \
10008 -fill black -tags text
10009 bind $top.c <Configure> [list centertext $top.c]
10010 pack $top.c -side top -fill x
10012 button $top.buts.ok -text [mc "OK"] -command fontok -default active
10013 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10014 bind $top <Key-Return> fontok
10015 bind $top <Key-Escape> fontcan
10016 grid $top.buts.ok $top.buts.can
10017 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10018 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10019 pack $top.buts -side bottom -fill x
10020 trace add variable fontparam write chg_fontparam
10023 $top.c itemconf text -text $which
10025 set i [lsearch -exact $fontlist $fontparam(family)]
10027 $top.f.fam selection set $i
10032 proc centertext {w} {
10033 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10037 global fontparam fontpref prefstop
10039 set f $fontparam(font)
10040 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10041 if {$fontparam(weight) eq "bold"} {
10042 lappend fontpref($f) "bold"
10044 if {$fontparam(slant) eq "italic"} {
10045 lappend fontpref($f) "italic"
10048 $w conf -text $fontparam(family) -font $fontpref($f)
10054 global fonttop fontparam
10056 if {[info exists fonttop]} {
10057 catch {destroy $fonttop}
10058 catch {font delete sample}
10064 proc selfontfam {} {
10065 global fonttop fontparam
10067 set i [$fonttop.f.fam curselection]
10069 set fontparam(family) [$fonttop.f.fam get $i]
10073 proc chg_fontparam {v sub op} {
10076 font config sample -$sub $fontparam($sub)
10080 global maxwidth maxgraphpct
10081 global oldprefs prefstop showneartags showlocalchanges
10082 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10083 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10087 if {[winfo exists $top]} {
10091 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10092 limitdiffs tabstop perfile_attrs} {
10093 set oldprefs($v) [set $v]
10096 wm title $top [mc "Gitk preferences"]
10097 make_transient $top .
10098 label $top.ldisp -text [mc "Commit list display options"]
10099 grid $top.ldisp - -sticky w -pady 10
10100 label $top.spacer -text " "
10101 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10103 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10104 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10105 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10107 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10108 grid x $top.maxpctl $top.maxpct -sticky w
10109 checkbutton $top.showlocal -text [mc "Show local changes"] \
10110 -font optionfont -variable showlocalchanges
10111 grid x $top.showlocal -sticky w
10112 checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10113 -font optionfont -variable autoselect
10114 grid x $top.autoselect -sticky w
10116 label $top.ddisp -text [mc "Diff display options"]
10117 grid $top.ddisp - -sticky w -pady 10
10118 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10119 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10120 grid x $top.tabstopl $top.tabstop -sticky w
10121 checkbutton $top.ntag -text [mc "Display nearby tags"] \
10122 -font optionfont -variable showneartags
10123 grid x $top.ntag -sticky w
10124 checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10125 -font optionfont -variable limitdiffs
10126 grid x $top.ldiff -sticky w
10127 checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10128 -font optionfont -variable perfile_attrs
10129 grid x $top.lattr -sticky w
10131 entry $top.extdifft -textvariable extdifftool
10132 frame $top.extdifff
10133 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10135 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10136 -command choose_extdiff
10137 pack $top.extdifff.l $top.extdifff.b -side left
10138 grid x $top.extdifff $top.extdifft -sticky w
10140 label $top.cdisp -text [mc "Colors: press to choose"]
10141 grid $top.cdisp - -sticky w -pady 10
10142 label $top.bg -padx 40 -relief sunk -background $bgcolor
10143 button $top.bgbut -text [mc "Background"] -font optionfont \
10144 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10145 grid x $top.bgbut $top.bg -sticky w
10146 label $top.fg -padx 40 -relief sunk -background $fgcolor
10147 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10148 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10149 grid x $top.fgbut $top.fg -sticky w
10150 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10151 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10152 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10153 [list $ctext tag conf d0 -foreground]]
10154 grid x $top.diffoldbut $top.diffold -sticky w
10155 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10156 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10157 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10158 [list $ctext tag conf dresult -foreground]]
10159 grid x $top.diffnewbut $top.diffnew -sticky w
10160 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10161 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10162 -command [list choosecolor diffcolors 2 $top.hunksep \
10163 [mc "diff hunk header"] \
10164 [list $ctext tag conf hunksep -foreground]]
10165 grid x $top.hunksepbut $top.hunksep -sticky w
10166 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10167 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10168 -command [list choosecolor markbgcolor {} $top.markbgsep \
10169 [mc "marked line background"] \
10170 [list $ctext tag conf omark -background]]
10171 grid x $top.markbgbut $top.markbgsep -sticky w
10172 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10173 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10174 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10175 grid x $top.selbgbut $top.selbgsep -sticky w
10177 label $top.cfont -text [mc "Fonts: press to choose"]
10178 grid $top.cfont - -sticky w -pady 10
10179 mkfontdisp mainfont $top [mc "Main font"]
10180 mkfontdisp textfont $top [mc "Diff display font"]
10181 mkfontdisp uifont $top [mc "User interface font"]
10184 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10185 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10186 bind $top <Key-Return> prefsok
10187 bind $top <Key-Escape> prefscan
10188 grid $top.buts.ok $top.buts.can
10189 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10190 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10191 grid $top.buts - - -pady 10 -sticky ew
10192 bind $top <Visibility> "focus $top.buts.ok"
10195 proc choose_extdiff {} {
10198 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10200 set extdifftool $prog
10204 proc choosecolor {v vi w x cmd} {
10207 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10208 -title [mc "Gitk: choose color for %s" $x]]
10209 if {$c eq {}} return
10210 $w conf -background $c
10215 proc setselbg {c} {
10216 global bglist cflist
10217 foreach w $bglist {
10218 $w configure -selectbackground $c
10220 $cflist tag configure highlight \
10221 -background [$cflist cget -selectbackground]
10222 allcanvs itemconf secsel -fill $c
10228 foreach w $bglist {
10229 $w conf -background $c
10236 foreach w $fglist {
10237 $w conf -foreground $c
10239 allcanvs itemconf text -fill $c
10240 $canv itemconf circle -outline $c
10244 global oldprefs prefstop
10246 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10247 limitdiffs tabstop perfile_attrs} {
10249 set $v $oldprefs($v)
10251 catch {destroy $prefstop}
10257 global maxwidth maxgraphpct
10258 global oldprefs prefstop showneartags showlocalchanges
10259 global fontpref mainfont textfont uifont
10260 global limitdiffs treediffs perfile_attrs
10262 catch {destroy $prefstop}
10266 if {$mainfont ne $fontpref(mainfont)} {
10267 set mainfont $fontpref(mainfont)
10268 parsefont mainfont $mainfont
10269 eval font configure mainfont [fontflags mainfont]
10270 eval font configure mainfontbold [fontflags mainfont 1]
10274 if {$textfont ne $fontpref(textfont)} {
10275 set textfont $fontpref(textfont)
10276 parsefont textfont $textfont
10277 eval font configure textfont [fontflags textfont]
10278 eval font configure textfontbold [fontflags textfont 1]
10280 if {$uifont ne $fontpref(uifont)} {
10281 set uifont $fontpref(uifont)
10282 parsefont uifont $uifont
10283 eval font configure uifont [fontflags uifont]
10286 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10287 if {$showlocalchanges} {
10293 if {$limitdiffs != $oldprefs(limitdiffs) ||
10294 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10295 # treediffs elements are limited by path;
10296 # won't have encodings cached if perfile_attrs was just turned on
10297 catch {unset treediffs}
10299 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10300 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10302 } elseif {$showneartags != $oldprefs(showneartags) ||
10303 $limitdiffs != $oldprefs(limitdiffs)} {
10308 proc formatdate {d} {
10309 global datetimeformat
10311 set d [clock format $d -format $datetimeformat]
10316 # This list of encoding names and aliases is distilled from
10317 # http://www.iana.org/assignments/character-sets.
10318 # Not all of them are supported by Tcl.
10319 set encoding_aliases {
10320 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10321 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10322 { ISO-10646-UTF-1 csISO10646UTF1 }
10323 { ISO_646.basic:1983 ref csISO646basic1983 }
10324 { INVARIANT csINVARIANT }
10325 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10326 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10327 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10328 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10329 { NATS-DANO iso-ir-9-1 csNATSDANO }
10330 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10331 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10332 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10333 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10334 { ISO-2022-KR csISO2022KR }
10336 { ISO-2022-JP csISO2022JP }
10337 { ISO-2022-JP-2 csISO2022JP2 }
10338 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10339 csISO13JISC6220jp }
10340 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10341 { IT iso-ir-15 ISO646-IT csISO15Italian }
10342 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10343 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10344 { greek7-old iso-ir-18 csISO18Greek7Old }
10345 { latin-greek iso-ir-19 csISO19LatinGreek }
10346 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10347 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10348 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10349 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10350 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10351 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10352 { INIS iso-ir-49 csISO49INIS }
10353 { INIS-8 iso-ir-50 csISO50INIS8 }
10354 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10355 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10356 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10357 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10358 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10359 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10360 csISO60Norwegian1 }
10361 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10362 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10363 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10364 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10365 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10366 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10367 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10368 { greek7 iso-ir-88 csISO88Greek7 }
10369 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10370 { iso-ir-90 csISO90 }
10371 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10372 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10373 csISO92JISC62991984b }
10374 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10375 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10376 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10377 csISO95JIS62291984handadd }
10378 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10379 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10380 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10381 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10382 CP819 csISOLatin1 }
10383 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10384 { T.61-7bit iso-ir-102 csISO102T617bit }
10385 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10386 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10387 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10388 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10389 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10390 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10391 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10392 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10393 arabic csISOLatinArabic }
10394 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10395 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10396 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10397 greek greek8 csISOLatinGreek }
10398 { T.101-G2 iso-ir-128 csISO128T101G2 }
10399 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10401 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10402 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10403 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10404 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10405 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10406 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10407 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10408 csISOLatinCyrillic }
10409 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10410 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10411 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10412 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10413 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10414 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10415 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10416 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10417 { ISO_10367-box iso-ir-155 csISO10367Box }
10418 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10419 { latin-lap lap iso-ir-158 csISO158Lap }
10420 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10421 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10424 { JIS_X0201 X0201 csHalfWidthKatakana }
10425 { KSC5636 ISO646-KR csKSC5636 }
10426 { ISO-10646-UCS-2 csUnicode }
10427 { ISO-10646-UCS-4 csUCS4 }
10428 { DEC-MCS dec csDECMCS }
10429 { hp-roman8 roman8 r8 csHPRoman8 }
10430 { macintosh mac csMacintosh }
10431 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10433 { IBM038 EBCDIC-INT cp038 csIBM038 }
10434 { IBM273 CP273 csIBM273 }
10435 { IBM274 EBCDIC-BE CP274 csIBM274 }
10436 { IBM275 EBCDIC-BR cp275 csIBM275 }
10437 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10438 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10439 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10440 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10441 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10442 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10443 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10444 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10445 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10446 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10447 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10448 { IBM437 cp437 437 csPC8CodePage437 }
10449 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10450 { IBM775 cp775 csPC775Baltic }
10451 { IBM850 cp850 850 csPC850Multilingual }
10452 { IBM851 cp851 851 csIBM851 }
10453 { IBM852 cp852 852 csPCp852 }
10454 { IBM855 cp855 855 csIBM855 }
10455 { IBM857 cp857 857 csIBM857 }
10456 { IBM860 cp860 860 csIBM860 }
10457 { IBM861 cp861 861 cp-is csIBM861 }
10458 { IBM862 cp862 862 csPC862LatinHebrew }
10459 { IBM863 cp863 863 csIBM863 }
10460 { IBM864 cp864 csIBM864 }
10461 { IBM865 cp865 865 csIBM865 }
10462 { IBM866 cp866 866 csIBM866 }
10463 { IBM868 CP868 cp-ar csIBM868 }
10464 { IBM869 cp869 869 cp-gr csIBM869 }
10465 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10466 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10467 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10468 { IBM891 cp891 csIBM891 }
10469 { IBM903 cp903 csIBM903 }
10470 { IBM904 cp904 904 csIBBM904 }
10471 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10472 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10473 { IBM1026 CP1026 csIBM1026 }
10474 { EBCDIC-AT-DE csIBMEBCDICATDE }
10475 { EBCDIC-AT-DE-A csEBCDICATDEA }
10476 { EBCDIC-CA-FR csEBCDICCAFR }
10477 { EBCDIC-DK-NO csEBCDICDKNO }
10478 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10479 { EBCDIC-FI-SE csEBCDICFISE }
10480 { EBCDIC-FI-SE-A csEBCDICFISEA }
10481 { EBCDIC-FR csEBCDICFR }
10482 { EBCDIC-IT csEBCDICIT }
10483 { EBCDIC-PT csEBCDICPT }
10484 { EBCDIC-ES csEBCDICES }
10485 { EBCDIC-ES-A csEBCDICESA }
10486 { EBCDIC-ES-S csEBCDICESS }
10487 { EBCDIC-UK csEBCDICUK }
10488 { EBCDIC-US csEBCDICUS }
10489 { UNKNOWN-8BIT csUnknown8BiT }
10490 { MNEMONIC csMnemonic }
10492 { VISCII csVISCII }
10495 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10496 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10497 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10498 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10499 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10500 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10501 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10502 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10503 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10504 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10505 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10506 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10507 { IBM1047 IBM-1047 }
10508 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10509 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10510 { UNICODE-1-1 csUnicode11 }
10511 { CESU-8 csCESU-8 }
10512 { BOCU-1 csBOCU-1 }
10513 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10514 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10516 { ISO-8859-15 ISO_8859-15 Latin-9 }
10517 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10518 { GBK CP936 MS936 windows-936 }
10519 { JIS_Encoding csJISEncoding }
10520 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10521 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10523 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10524 { ISO-10646-UCS-Basic csUnicodeASCII }
10525 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10526 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10527 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10528 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10529 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10530 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10531 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10532 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10533 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10534 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10535 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10536 { Ventura-US csVenturaUS }
10537 { Ventura-International csVenturaInternational }
10538 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10539 { PC8-Turkish csPC8Turkish }
10540 { IBM-Symbols csIBMSymbols }
10541 { IBM-Thai csIBMThai }
10542 { HP-Legal csHPLegal }
10543 { HP-Pi-font csHPPiFont }
10544 { HP-Math8 csHPMath8 }
10545 { Adobe-Symbol-Encoding csHPPSMath }
10546 { HP-DeskTop csHPDesktop }
10547 { Ventura-Math csVenturaMath }
10548 { Microsoft-Publishing csMicrosoftPublishing }
10549 { Windows-31J csWindows31J }
10550 { GB2312 csGB2312 }
10554 proc tcl_encoding {enc} {
10555 global encoding_aliases tcl_encoding_cache
10556 if {[info exists tcl_encoding_cache($enc)]} {
10557 return $tcl_encoding_cache($enc)
10559 set names [encoding names]
10560 set lcnames [string tolower $names]
10561 set enc [string tolower $enc]
10562 set i [lsearch -exact $lcnames $enc]
10564 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10565 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10566 set i [lsearch -exact $lcnames $encx]
10570 foreach l $encoding_aliases {
10571 set ll [string tolower $l]
10572 if {[lsearch -exact $ll $enc] < 0} continue
10573 # look through the aliases for one that tcl knows about
10575 set i [lsearch -exact $lcnames $e]
10577 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10578 set i [lsearch -exact $lcnames $ex]
10588 set tclenc [lindex $names $i]
10590 set tcl_encoding_cache($enc) $tclenc
10594 proc gitattr {path attr default} {
10595 global path_attr_cache
10596 if {[info exists path_attr_cache($attr,$path)]} {
10597 set r $path_attr_cache($attr,$path)
10599 set r "unspecified"
10600 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10601 regexp "(.*): encoding: (.*)" $line m f r
10603 set path_attr_cache($attr,$path) $r
10605 if {$r eq "unspecified"} {
10611 proc cache_gitattr {attr pathlist} {
10612 global path_attr_cache
10614 foreach path $pathlist {
10615 if {![info exists path_attr_cache($attr,$path)]} {
10616 lappend newlist $path
10620 if {[tk windowingsystem] == "win32"} {
10621 # windows has a 32k limit on the arguments to a command...
10624 while {$newlist ne {}} {
10625 set head [lrange $newlist 0 [expr {$lim - 1}]]
10626 set newlist [lrange $newlist $lim end]
10627 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10628 foreach row [split $rlist "\n"] {
10629 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10630 if {[string index $path 0] eq "\""} {
10631 set path [encoding convertfrom [lindex $path 0]]
10633 set path_attr_cache($attr,$path) $value
10640 proc get_path_encoding {path} {
10641 global gui_encoding perfile_attrs
10642 set tcl_enc $gui_encoding
10643 if {$path ne {} && $perfile_attrs} {
10644 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10652 # First check that Tcl/Tk is recent enough
10653 if {[catch {package require Tk 8.4} err]} {
10654 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10655 Gitk requires at least Tcl/Tk 8.4."]
10660 set wrcomcmd "git diff-tree --stdin -p --pretty"
10664 set gitencoding [exec git config --get i18n.commitencoding]
10667 set gitencoding [exec git config --get i18n.logoutputencoding]
10669 if {$gitencoding == ""} {
10670 set gitencoding "utf-8"
10672 set tclencoding [tcl_encoding $gitencoding]
10673 if {$tclencoding == {}} {
10674 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10677 set gui_encoding [encoding system]
10679 set enc [exec git config --get gui.encoding]
10681 set tclenc [tcl_encoding $enc]
10682 if {$tclenc ne {}} {
10683 set gui_encoding $tclenc
10685 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10690 set mainfont {Helvetica 9}
10691 set textfont {Courier 9}
10692 set uifont {Helvetica 9 bold}
10694 set findmergefiles 0
10702 set cmitmode "patch"
10703 set wrapcomment "none"
10707 set showlocalchanges 1
10709 set datetimeformat "%Y-%m-%d %H:%M:%S"
10711 set perfile_attrs 0
10713 set extdifftool "meld"
10715 set colors {green red blue magenta darkgrey brown orange}
10718 set diffcolors {red "#00a000" blue}
10721 set selectbgcolor gray85
10722 set markbgcolor "#e0e0ff"
10724 set circlecolors {white blue gray blue blue}
10726 # button for popping up context menus
10727 if {[tk windowingsystem] eq "aqua"} {
10728 set ctxbut <Button-2>
10730 set ctxbut <Button-3>
10733 ## For msgcat loading, first locate the installation location.
10734 if { [info exists ::env(GITK_MSGSDIR)] } {
10735 ## Msgsdir was manually set in the environment.
10736 set gitk_msgsdir $::env(GITK_MSGSDIR)
10738 ## Let's guess the prefix from argv0.
10739 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10740 set gitk_libdir [file join $gitk_prefix share gitk lib]
10741 set gitk_msgsdir [file join $gitk_libdir msgs]
10745 ## Internationalization (i18n) through msgcat and gettext. See
10746 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10747 package require msgcat
10748 namespace import ::msgcat::mc
10749 ## And eventually load the actual message catalog
10750 ::msgcat::mcload $gitk_msgsdir
10752 catch {source ~/.gitk}
10754 font create optionfont -family sans-serif -size -12
10756 parsefont mainfont $mainfont
10757 eval font create mainfont [fontflags mainfont]
10758 eval font create mainfontbold [fontflags mainfont 1]
10760 parsefont textfont $textfont
10761 eval font create textfont [fontflags textfont]
10762 eval font create textfontbold [fontflags textfont 1]
10764 parsefont uifont $uifont
10765 eval font create uifont [fontflags uifont]
10769 # check that we can find a .git directory somewhere...
10770 if {[catch {set gitdir [gitdir]}]} {
10771 show_error {} . [mc "Cannot find a git repository here."]
10774 if {![file isdirectory $gitdir]} {
10775 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10780 set selectheadid {}
10783 set cmdline_files {}
10785 set revtreeargscmd {}
10786 foreach arg $argv {
10787 switch -glob -- $arg {
10790 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10793 "--select-commit=*" {
10794 set selecthead [string range $arg 16 end]
10797 set revtreeargscmd [string range $arg 10 end]
10800 lappend revtreeargs $arg
10806 if {$selecthead eq "HEAD"} {
10810 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10811 # no -- on command line, but some arguments (other than --argscmd)
10813 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10814 set cmdline_files [split $f "\n"]
10815 set n [llength $cmdline_files]
10816 set revtreeargs [lrange $revtreeargs 0 end-$n]
10817 # Unfortunately git rev-parse doesn't produce an error when
10818 # something is both a revision and a filename. To be consistent
10819 # with git log and git rev-list, check revtreeargs for filenames.
10820 foreach arg $revtreeargs {
10821 if {[file exists $arg]} {
10822 show_error {} . [mc "Ambiguous argument '%s': both revision\
10823 and filename" $arg]
10828 # unfortunately we get both stdout and stderr in $err,
10829 # so look for "fatal:".
10830 set i [string first "fatal:" $err]
10832 set err [string range $err [expr {$i + 6}] end]
10834 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10839 set nullid "0000000000000000000000000000000000000000"
10840 set nullid2 "0000000000000000000000000000000000000001"
10841 set nullfile "/dev/null"
10843 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10850 set highlight_paths {}
10852 set searchdirn -forwards
10855 set diffelide {0 0}
10856 set markingmatches 0
10857 set linkentercount 0
10858 set need_redisplay 0
10865 set selectedhlview [mc "None"]
10866 set highlight_related [mc "None"]
10867 set highlight_files {}
10868 set viewfiles(0) {}
10871 set viewargscmd(0) {}
10873 set selectedline {}
10881 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10884 # wait for the window to become visible
10885 tkwait visibility .
10886 wm title . "[file tail $argv0]: [file tail [pwd]]"
10889 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10890 # create a view for the files/dirs specified on the command line
10894 set viewname(1) [mc "Command line"]
10895 set viewfiles(1) $cmdline_files
10896 set viewargs(1) $revtreeargs
10897 set viewargscmd(1) $revtreeargscmd
10901 .bar.view entryconf [mca "Edit view..."] -state normal
10902 .bar.view entryconf [mca "Delete view"] -state normal
10905 if {[info exists permviews]} {
10906 foreach v $permviews {
10909 set viewname($n) [lindex $v 0]
10910 set viewfiles($n) [lindex $v 1]
10911 set viewargs($n) [lindex $v 2]
10912 set viewargscmd($n) [lindex $v 3]
10918 if {[tk windowingsystem] eq "win32"} {