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.
14 if {[info exists env(GIT_DIR)]} {
17 return [exec git rev-parse --git-dir]
21 # A simple scheduler for compute-intensive stuff.
22 # The aim is to make sure that event handlers for GUI actions can
23 # run at least every 50-100 ms. Unfortunately fileevent handlers are
24 # run before X event handlers, so reading from a fast source can
25 # make the GUI completely unresponsive.
27 global isonrunq runq currunq
30 if {[info exists isonrunq($script)]} return
31 if {$runq eq {} && ![info exists currunq]} {
34 lappend runq [list {} $script]
35 set isonrunq($script) 1
38 proc filerun {fd script} {
39 fileevent $fd readable [list filereadable $fd $script]
42 proc filereadable {fd script} {
45 fileevent $fd readable {}
46 if {$runq eq {} && ![info exists currunq]} {
49 lappend runq [list $fd $script]
55 for {set i 0} {$i < [llength $runq]} {} {
56 if {[lindex $runq $i 0] eq $fd} {
57 set runq [lreplace $runq $i $i]
65 global isonrunq runq currunq
67 set tstart [clock clicks -milliseconds]
69 while {[llength $runq] > 0} {
70 set fd [lindex $runq 0 0]
71 set script [lindex $runq 0 1]
72 set currunq [lindex $runq 0]
73 set runq [lrange $runq 1 end]
74 set repeat [eval $script]
76 set t1 [clock clicks -milliseconds]
77 set t [expr {$t1 - $t0}]
78 if {$repeat ne {} && $repeat} {
79 if {$fd eq {} || $repeat == 2} {
80 # script returns 1 if it wants to be readded
81 # file readers return 2 if they could do more straight away
82 lappend runq [list $fd $script]
84 fileevent $fd readable [list filereadable $fd $script]
86 } elseif {$fd eq {}} {
87 unset isonrunq($script)
90 if {$t1 - $tstart >= 80} break
97 proc reg_instance {fd} {
98 global commfd leftover loginstance
100 set i [incr loginstance]
106 proc unmerged_files {files} {
109 # find the list of unmerged files
113 set fd [open "| git ls-files -u" r]
115 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
118 while {[gets $fd line] >= 0} {
119 set i [string first "\t" $line]
121 set fname [string range $line [expr {$i+1}] end]
122 if {[lsearch -exact $mlist $fname] >= 0} continue
124 if {$files eq {} || [path_filter $files $fname]} {
132 proc parseviewargs {n arglist} {
133 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
141 set origargs $arglist
145 foreach arg $arglist {
152 switch -glob -- $arg {
156 # remove from origargs in case we hit an unknown option
157 set origargs [lreplace $origargs $i $i]
161 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165 "--ignore-space-change" - "-U*" - "--unified=*" {
166 # These request or affect diff output, which we don't want.
167 # Some could be used to set our defaults for diff display.
168 lappend diffargs $arg
170 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171 "--name-only" - "--name-status" - "--color" - "--color-words" -
172 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176 "--objects" - "--objects-edge" - "--reverse" {
177 # These cause our parsing of git log's output to fail, or else
178 # they're options we want to set ourselves, so ignore them.
180 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
181 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
182 "--full-history" - "--dense" - "--sparse" -
183 "--follow" - "--left-right" - "--encoding=*" {
184 # These are harmless, and some are even useful
187 "--diff-filter=*" - "--no-merges" - "--unpacked" -
188 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
189 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
190 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
191 "--remove-empty" - "--first-parent" - "--cherry-pick" -
192 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
193 "--simplify-by-decoration" {
194 # These mean that we get a subset of the commits
199 # This appears to be the only one that has a value as a
200 # separate word following it
210 # git rev-parse doesn't understand --merge
211 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
214 # Other flag arguments including -<n>
215 if {[string is digit -strict [string range $arg 1 end]]} {
218 # a flag argument that we don't recognize;
219 # that means we can't optimize
225 # Non-flag arguments specify commits or ranges of commits
226 if {[string match "*...*" $arg]} {
227 lappend revargs --gitk-symmetric-diff-marker
233 set vdflags($n) $diffargs
234 set vflags($n) $glflags
235 set vrevs($n) $revargs
236 set vfiltered($n) $filtered
237 set vorigargs($n) $origargs
241 proc parseviewrevs {view revs} {
242 global vposids vnegids
247 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
248 # we get stdout followed by stderr in $err
249 # for an unknown rev, git rev-parse echoes it and then errors out
250 set errlines [split $err "\n"]
252 for {set l 0} {$l < [llength $errlines]} {incr l} {
253 set line [lindex $errlines $l]
254 if {!([string length $line] == 40 && [string is xdigit $line])} {
255 if {[string match "fatal:*" $line]} {
256 if {[string match "fatal: ambiguous argument*" $line]
258 if {[llength $badrev] == 1} {
259 set err "unknown revision $badrev"
261 set err "unknown revisions: [join $badrev ", "]"
264 set err [join [lrange $errlines $l end] "\n"]
271 error_popup "[mc "Error parsing revisions:"] $err"
278 foreach id [split $ids "\n"] {
279 if {$id eq "--gitk-symmetric-diff-marker"} {
281 } elseif {[string match "^*" $id]} {
288 lappend neg [string range $id 1 end]
293 lset ret end $id...[lindex $ret end]
299 set vposids($view) $pos
300 set vnegids($view) $neg
304 # Start off a git log process and arrange to read its output
305 proc start_rev_list {view} {
306 global startmsecs commitidx viewcomplete curview
308 global viewargs viewargscmd viewfiles vfilelimit
309 global showlocalchanges
310 global viewactive viewinstances vmergeonly
311 global mainheadid viewmainheadid viewmainheadid_orig
312 global vcanopt vflags vrevs vorigargs
314 set startmsecs [clock clicks -milliseconds]
315 set commitidx($view) 0
316 # these are set this way for the error exits
317 set viewcomplete($view) 1
318 set viewactive($view) 0
321 set args $viewargs($view)
322 if {$viewargscmd($view) ne {}} {
324 set str [exec sh -c $viewargscmd($view)]
326 error_popup "[mc "Error executing --argscmd command:"] $err"
329 set args [concat $args [split $str "\n"]]
331 set vcanopt($view) [parseviewargs $view $args]
333 set files $viewfiles($view)
334 if {$vmergeonly($view)} {
335 set files [unmerged_files $files]
338 if {$nr_unmerged == 0} {
339 error_popup [mc "No files selected: --merge specified but\
340 no files are unmerged."]
342 error_popup [mc "No files selected: --merge specified but\
343 no unmerged files are within file limit."]
348 set vfilelimit($view) $files
350 if {$vcanopt($view)} {
351 set revs [parseviewrevs $view $vrevs($view)]
355 set args [concat $vflags($view) $revs]
357 set args $vorigargs($view)
361 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
362 --boundary $args "--" $files] r]
364 error_popup "[mc "Error executing git log:"] $err"
367 set i [reg_instance $fd]
368 set viewinstances($view) [list $i]
369 set viewmainheadid($view) $mainheadid
370 set viewmainheadid_orig($view) $mainheadid
371 if {$files ne {} && $mainheadid ne {}} {
372 get_viewmainhead $view
374 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
375 interestedin $viewmainheadid($view) dodiffindex
377 fconfigure $fd -blocking 0 -translation lf -eofchar {}
378 if {$tclencoding != {}} {
379 fconfigure $fd -encoding $tclencoding
381 filerun $fd [list getcommitlines $fd $i $view 0]
382 nowbusy $view [mc "Reading"]
383 set viewcomplete($view) 0
384 set viewactive($view) 1
388 proc stop_instance {inst} {
389 global commfd leftover
391 set fd $commfd($inst)
395 if {$::tcl_platform(platform) eq {windows}} {
404 unset leftover($inst)
407 proc stop_backends {} {
410 foreach inst [array names commfd] {
415 proc stop_rev_list {view} {
418 foreach inst $viewinstances($view) {
421 set viewinstances($view) {}
424 proc reset_pending_select {selid} {
425 global pending_select mainheadid selectheadid
428 set pending_select $selid
429 } elseif {$selectheadid ne {}} {
430 set pending_select $selectheadid
432 set pending_select $mainheadid
436 proc getcommits {selid} {
437 global canv curview need_redisplay viewactive
440 if {[start_rev_list $curview]} {
441 reset_pending_select $selid
442 show_status [mc "Reading commits..."]
445 show_status [mc "No commits selected"]
449 proc updatecommits {} {
450 global curview vcanopt vorigargs vfilelimit viewinstances
451 global viewactive viewcomplete tclencoding
452 global startmsecs showneartags showlocalchanges
453 global mainheadid viewmainheadid viewmainheadid_orig pending_select
455 global varcid vposids vnegids vflags vrevs
457 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
460 if {$mainheadid ne $viewmainheadid_orig($view)} {
461 if {$showlocalchanges} {
464 set viewmainheadid($view) $mainheadid
465 set viewmainheadid_orig($view) $mainheadid
466 if {$vfilelimit($view) ne {}} {
467 get_viewmainhead $view
470 if {$showlocalchanges} {
473 if {$vcanopt($view)} {
474 set oldpos $vposids($view)
475 set oldneg $vnegids($view)
476 set revs [parseviewrevs $view $vrevs($view)]
480 # note: getting the delta when negative refs change is hard,
481 # and could require multiple git log invocations, so in that
482 # case we ask git log for all the commits (not just the delta)
483 if {$oldneg eq $vnegids($view)} {
486 # take out positive refs that we asked for before or
487 # that we have already seen
489 if {[string length $rev] == 40} {
490 if {[lsearch -exact $oldpos $rev] < 0
491 && ![info exists varcid($view,$rev)]} {
496 lappend $newrevs $rev
499 if {$npos == 0} return
501 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
503 set args [concat $vflags($view) $revs --not $oldpos]
505 set args $vorigargs($view)
508 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
509 --boundary $args "--" $vfilelimit($view)] r]
511 error_popup "[mc "Error executing git log:"] $err"
514 if {$viewactive($view) == 0} {
515 set startmsecs [clock clicks -milliseconds]
517 set i [reg_instance $fd]
518 lappend viewinstances($view) $i
519 fconfigure $fd -blocking 0 -translation lf -eofchar {}
520 if {$tclencoding != {}} {
521 fconfigure $fd -encoding $tclencoding
523 filerun $fd [list getcommitlines $fd $i $view 1]
524 incr viewactive($view)
525 set viewcomplete($view) 0
526 reset_pending_select {}
527 nowbusy $view [mc "Reading"]
533 proc reloadcommits {} {
534 global curview viewcomplete selectedline currentid thickerline
535 global showneartags treediffs commitinterest cached_commitrow
539 if {$selectedline ne {}} {
543 if {!$viewcomplete($curview)} {
544 stop_rev_list $curview
548 catch {unset currentid}
549 catch {unset thickerline}
550 catch {unset treediffs}
557 catch {unset commitinterest}
558 catch {unset cached_commitrow}
559 catch {unset targetid}
565 # This makes a string representation of a positive integer which
566 # sorts as a string in numerical order
569 return [format "%x" $n]
570 } elseif {$n < 256} {
571 return [format "x%.2x" $n]
572 } elseif {$n < 65536} {
573 return [format "y%.4x" $n]
575 return [format "z%.8x" $n]
578 # Procedures used in reordering commits from git log (without
579 # --topo-order) into the order for display.
581 proc varcinit {view} {
582 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
583 global vtokmod varcmod vrowmod varcix vlastins
585 set varcstart($view) {{}}
586 set vupptr($view) {0}
587 set vdownptr($view) {0}
588 set vleftptr($view) {0}
589 set vbackptr($view) {0}
590 set varctok($view) {{}}
591 set varcrow($view) {{}}
592 set vtokmod($view) {}
595 set varcix($view) {{}}
596 set vlastins($view) {0}
599 proc resetvarcs {view} {
600 global varcid varccommits parents children vseedcount ordertok
602 foreach vid [array names varcid $view,*] {
607 # some commits might have children but haven't been seen yet
608 foreach vid [array names children $view,*] {
611 foreach va [array names varccommits $view,*] {
612 unset varccommits($va)
614 foreach vd [array names vseedcount $view,*] {
615 unset vseedcount($vd)
617 catch {unset ordertok}
620 # returns a list of the commits with no children
622 global vdownptr vleftptr varcstart
625 set a [lindex $vdownptr($v) 0]
627 lappend ret [lindex $varcstart($v) $a]
628 set a [lindex $vleftptr($v) $a]
633 proc newvarc {view id} {
634 global varcid varctok parents children vdatemode
635 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
636 global commitdata commitinfo vseedcount varccommits vlastins
638 set a [llength $varctok($view)]
640 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
641 if {![info exists commitinfo($id)]} {
642 parsecommit $id $commitdata($id) 1
644 set cdate [lindex $commitinfo($id) 4]
645 if {![string is integer -strict $cdate]} {
648 if {![info exists vseedcount($view,$cdate)]} {
649 set vseedcount($view,$cdate) -1
651 set c [incr vseedcount($view,$cdate)]
652 set cdate [expr {$cdate ^ 0xffffffff}]
653 set tok "s[strrep $cdate][strrep $c]"
658 if {[llength $children($vid)] > 0} {
659 set kid [lindex $children($vid) end]
660 set k $varcid($view,$kid)
661 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
664 set tok [lindex $varctok($view) $k]
668 set i [lsearch -exact $parents($view,$ki) $id]
669 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
670 append tok [strrep $j]
672 set c [lindex $vlastins($view) $ka]
673 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
675 set b [lindex $vdownptr($view) $ka]
677 set b [lindex $vleftptr($view) $c]
679 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
681 set b [lindex $vleftptr($view) $c]
684 lset vdownptr($view) $ka $a
685 lappend vbackptr($view) 0
687 lset vleftptr($view) $c $a
688 lappend vbackptr($view) $c
690 lset vlastins($view) $ka $a
691 lappend vupptr($view) $ka
692 lappend vleftptr($view) $b
694 lset vbackptr($view) $b $a
696 lappend varctok($view) $tok
697 lappend varcstart($view) $id
698 lappend vdownptr($view) 0
699 lappend varcrow($view) {}
700 lappend varcix($view) {}
701 set varccommits($view,$a) {}
702 lappend vlastins($view) 0
706 proc splitvarc {p v} {
707 global varcid varcstart varccommits varctok vtokmod
708 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
710 set oa $varcid($v,$p)
711 set otok [lindex $varctok($v) $oa]
712 set ac $varccommits($v,$oa)
713 set i [lsearch -exact $varccommits($v,$oa) $p]
715 set na [llength $varctok($v)]
716 # "%" sorts before "0"...
717 set tok "$otok%[strrep $i]"
718 lappend varctok($v) $tok
719 lappend varcrow($v) {}
720 lappend varcix($v) {}
721 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
722 set varccommits($v,$na) [lrange $ac $i end]
723 lappend varcstart($v) $p
724 foreach id $varccommits($v,$na) {
725 set varcid($v,$id) $na
727 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
728 lappend vlastins($v) [lindex $vlastins($v) $oa]
729 lset vdownptr($v) $oa $na
730 lset vlastins($v) $oa 0
731 lappend vupptr($v) $oa
732 lappend vleftptr($v) 0
733 lappend vbackptr($v) 0
734 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
735 lset vupptr($v) $b $na
737 if {[string compare $otok $vtokmod($v)] <= 0} {
742 proc renumbervarc {a v} {
743 global parents children varctok varcstart varccommits
744 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
746 set t1 [clock clicks -milliseconds]
752 if {[info exists isrelated($a)]} {
754 set id [lindex $varccommits($v,$a) end]
755 foreach p $parents($v,$id) {
756 if {[info exists varcid($v,$p)]} {
757 set isrelated($varcid($v,$p)) 1
762 set b [lindex $vdownptr($v) $a]
765 set b [lindex $vleftptr($v) $a]
767 set a [lindex $vupptr($v) $a]
773 if {![info exists kidchanged($a)]} continue
774 set id [lindex $varcstart($v) $a]
775 if {[llength $children($v,$id)] > 1} {
776 set children($v,$id) [lsort -command [list vtokcmp $v] \
779 set oldtok [lindex $varctok($v) $a]
780 if {!$vdatemode($v)} {
786 set kid [last_real_child $v,$id]
788 set k $varcid($v,$kid)
789 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
792 set tok [lindex $varctok($v) $k]
796 set i [lsearch -exact $parents($v,$ki) $id]
797 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
798 append tok [strrep $j]
800 if {$tok eq $oldtok} {
803 set id [lindex $varccommits($v,$a) end]
804 foreach p $parents($v,$id) {
805 if {[info exists varcid($v,$p)]} {
806 set kidchanged($varcid($v,$p)) 1
811 lset varctok($v) $a $tok
812 set b [lindex $vupptr($v) $a]
814 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
817 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
820 set c [lindex $vbackptr($v) $a]
821 set d [lindex $vleftptr($v) $a]
823 lset vdownptr($v) $b $d
825 lset vleftptr($v) $c $d
828 lset vbackptr($v) $d $c
830 if {[lindex $vlastins($v) $b] == $a} {
831 lset vlastins($v) $b $c
833 lset vupptr($v) $a $ka
834 set c [lindex $vlastins($v) $ka]
836 [string compare $tok [lindex $varctok($v) $c]] < 0} {
838 set b [lindex $vdownptr($v) $ka]
840 set b [lindex $vleftptr($v) $c]
843 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
845 set b [lindex $vleftptr($v) $c]
848 lset vdownptr($v) $ka $a
849 lset vbackptr($v) $a 0
851 lset vleftptr($v) $c $a
852 lset vbackptr($v) $a $c
854 lset vleftptr($v) $a $b
856 lset vbackptr($v) $b $a
858 lset vlastins($v) $ka $a
861 foreach id [array names sortkids] {
862 if {[llength $children($v,$id)] > 1} {
863 set children($v,$id) [lsort -command [list vtokcmp $v] \
867 set t2 [clock clicks -milliseconds]
868 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
871 # Fix up the graph after we have found out that in view $v,
872 # $p (a commit that we have already seen) is actually the parent
873 # of the last commit in arc $a.
874 proc fix_reversal {p a v} {
875 global varcid varcstart varctok vupptr
877 set pa $varcid($v,$p)
878 if {$p ne [lindex $varcstart($v) $pa]} {
880 set pa $varcid($v,$p)
882 # seeds always need to be renumbered
883 if {[lindex $vupptr($v) $pa] == 0 ||
884 [string compare [lindex $varctok($v) $a] \
885 [lindex $varctok($v) $pa]] > 0} {
890 proc insertrow {id p v} {
891 global cmitlisted children parents varcid varctok vtokmod
892 global varccommits ordertok commitidx numcommits curview
893 global targetid targetrow
897 set cmitlisted($vid) 1
898 set children($vid) {}
899 set parents($vid) [list $p]
900 set a [newvarc $v $id]
902 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
905 lappend varccommits($v,$a) $id
907 if {[llength [lappend children($vp) $id]] > 1} {
908 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
909 catch {unset ordertok}
911 fix_reversal $p $a $v
913 if {$v == $curview} {
914 set numcommits $commitidx($v)
916 if {[info exists targetid]} {
917 if {![comes_before $targetid $p]} {
924 proc insertfakerow {id p} {
925 global varcid varccommits parents children cmitlisted
926 global commitidx varctok vtokmod targetid targetrow curview numcommits
930 set i [lsearch -exact $varccommits($v,$a) $p]
932 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
935 set children($v,$id) {}
936 set parents($v,$id) [list $p]
937 set varcid($v,$id) $a
938 lappend children($v,$p) $id
939 set cmitlisted($v,$id) 1
940 set numcommits [incr commitidx($v)]
941 # note we deliberately don't update varcstart($v) even if $i == 0
942 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
944 if {[info exists targetid]} {
945 if {![comes_before $targetid $p]} {
953 proc removefakerow {id} {
954 global varcid varccommits parents children commitidx
955 global varctok vtokmod cmitlisted currentid selectedline
956 global targetid curview numcommits
959 if {[llength $parents($v,$id)] != 1} {
960 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
963 set p [lindex $parents($v,$id) 0]
964 set a $varcid($v,$id)
965 set i [lsearch -exact $varccommits($v,$a) $id]
967 puts "oops: removefakerow can't find [shortids $id] on arc $a"
971 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
972 unset parents($v,$id)
973 unset children($v,$id)
974 unset cmitlisted($v,$id)
975 set numcommits [incr commitidx($v) -1]
976 set j [lsearch -exact $children($v,$p) $id]
978 set children($v,$p) [lreplace $children($v,$p) $j $j]
981 if {[info exist currentid] && $id eq $currentid} {
985 if {[info exists targetid] && $targetid eq $id} {
992 proc first_real_child {vp} {
993 global children nullid nullid2
995 foreach id $children($vp) {
996 if {$id ne $nullid && $id ne $nullid2} {
1003 proc last_real_child {vp} {
1004 global children nullid nullid2
1006 set kids $children($vp)
1007 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1008 set id [lindex $kids $i]
1009 if {$id ne $nullid && $id ne $nullid2} {
1016 proc vtokcmp {v a b} {
1017 global varctok varcid
1019 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1020 [lindex $varctok($v) $varcid($v,$b)]]
1023 # This assumes that if lim is not given, the caller has checked that
1024 # arc a's token is less than $vtokmod($v)
1025 proc modify_arc {v a {lim {}}} {
1026 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1029 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1032 set r [lindex $varcrow($v) $a]
1033 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1036 set vtokmod($v) [lindex $varctok($v) $a]
1038 if {$v == $curview} {
1039 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1040 set a [lindex $vupptr($v) $a]
1046 set lim [llength $varccommits($v,$a)]
1048 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1055 proc update_arcrows {v} {
1056 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1057 global varcid vrownum varcorder varcix varccommits
1058 global vupptr vdownptr vleftptr varctok
1059 global displayorder parentlist curview cached_commitrow
1061 if {$vrowmod($v) == $commitidx($v)} return
1062 if {$v == $curview} {
1063 if {[llength $displayorder] > $vrowmod($v)} {
1064 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1065 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1067 catch {unset cached_commitrow}
1069 set narctot [expr {[llength $varctok($v)] - 1}]
1071 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1072 # go up the tree until we find something that has a row number,
1073 # or we get to a seed
1074 set a [lindex $vupptr($v) $a]
1077 set a [lindex $vdownptr($v) 0]
1080 set varcorder($v) [list $a]
1081 lset varcix($v) $a 0
1082 lset varcrow($v) $a 0
1086 set arcn [lindex $varcix($v) $a]
1087 if {[llength $vrownum($v)] > $arcn + 1} {
1088 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1089 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1091 set row [lindex $varcrow($v) $a]
1095 incr row [llength $varccommits($v,$a)]
1096 # go down if possible
1097 set b [lindex $vdownptr($v) $a]
1099 # if not, go left, or go up until we can go left
1101 set b [lindex $vleftptr($v) $a]
1103 set a [lindex $vupptr($v) $a]
1109 lappend vrownum($v) $row
1110 lappend varcorder($v) $a
1111 lset varcix($v) $a $arcn
1112 lset varcrow($v) $a $row
1114 set vtokmod($v) [lindex $varctok($v) $p]
1116 set vrowmod($v) $row
1117 if {[info exists currentid]} {
1118 set selectedline [rowofcommit $currentid]
1122 # Test whether view $v contains commit $id
1123 proc commitinview {id v} {
1126 return [info exists varcid($v,$id)]
1129 # Return the row number for commit $id in the current view
1130 proc rowofcommit {id} {
1131 global varcid varccommits varcrow curview cached_commitrow
1132 global varctok vtokmod
1135 if {![info exists varcid($v,$id)]} {
1136 puts "oops rowofcommit no arc for [shortids $id]"
1139 set a $varcid($v,$id)
1140 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1143 if {[info exists cached_commitrow($id)]} {
1144 return $cached_commitrow($id)
1146 set i [lsearch -exact $varccommits($v,$a) $id]
1148 puts "oops didn't find commit [shortids $id] in arc $a"
1151 incr i [lindex $varcrow($v) $a]
1152 set cached_commitrow($id) $i
1156 # Returns 1 if a is on an earlier row than b, otherwise 0
1157 proc comes_before {a b} {
1158 global varcid varctok curview
1161 if {$a eq $b || ![info exists varcid($v,$a)] || \
1162 ![info exists varcid($v,$b)]} {
1165 if {$varcid($v,$a) != $varcid($v,$b)} {
1166 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1167 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1169 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1172 proc bsearch {l elt} {
1173 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1178 while {$hi - $lo > 1} {
1179 set mid [expr {int(($lo + $hi) / 2)}]
1180 set t [lindex $l $mid]
1183 } elseif {$elt > $t} {
1192 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1193 proc make_disporder {start end} {
1194 global vrownum curview commitidx displayorder parentlist
1195 global varccommits varcorder parents vrowmod varcrow
1196 global d_valid_start d_valid_end
1198 if {$end > $vrowmod($curview)} {
1199 update_arcrows $curview
1201 set ai [bsearch $vrownum($curview) $start]
1202 set start [lindex $vrownum($curview) $ai]
1203 set narc [llength $vrownum($curview)]
1204 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1205 set a [lindex $varcorder($curview) $ai]
1206 set l [llength $displayorder]
1207 set al [llength $varccommits($curview,$a)]
1208 if {$l < $r + $al} {
1210 set pad [ntimes [expr {$r - $l}] {}]
1211 set displayorder [concat $displayorder $pad]
1212 set parentlist [concat $parentlist $pad]
1213 } elseif {$l > $r} {
1214 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1215 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1217 foreach id $varccommits($curview,$a) {
1218 lappend displayorder $id
1219 lappend parentlist $parents($curview,$id)
1221 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1223 foreach id $varccommits($curview,$a) {
1224 lset displayorder $i $id
1225 lset parentlist $i $parents($curview,$id)
1233 proc commitonrow {row} {
1236 set id [lindex $displayorder $row]
1238 make_disporder $row [expr {$row + 1}]
1239 set id [lindex $displayorder $row]
1244 proc closevarcs {v} {
1245 global varctok varccommits varcid parents children
1246 global cmitlisted commitidx vtokmod
1248 set missing_parents 0
1250 set narcs [llength $varctok($v)]
1251 for {set a 1} {$a < $narcs} {incr a} {
1252 set id [lindex $varccommits($v,$a) end]
1253 foreach p $parents($v,$id) {
1254 if {[info exists varcid($v,$p)]} continue
1255 # add p as a new commit
1256 incr missing_parents
1257 set cmitlisted($v,$p) 0
1258 set parents($v,$p) {}
1259 if {[llength $children($v,$p)] == 1 &&
1260 [llength $parents($v,$id)] == 1} {
1263 set b [newvarc $v $p]
1265 set varcid($v,$p) $b
1266 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1269 lappend varccommits($v,$b) $p
1271 set scripts [check_interest $p $scripts]
1274 if {$missing_parents > 0} {
1275 foreach s $scripts {
1281 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1282 # Assumes we already have an arc for $rwid.
1283 proc rewrite_commit {v id rwid} {
1284 global children parents varcid varctok vtokmod varccommits
1286 foreach ch $children($v,$id) {
1287 # make $rwid be $ch's parent in place of $id
1288 set i [lsearch -exact $parents($v,$ch) $id]
1290 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1292 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1293 # add $ch to $rwid's children and sort the list if necessary
1294 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1295 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1296 $children($v,$rwid)]
1298 # fix the graph after joining $id to $rwid
1299 set a $varcid($v,$ch)
1300 fix_reversal $rwid $a $v
1301 # parentlist is wrong for the last element of arc $a
1302 # even if displayorder is right, hence the 3rd arg here
1303 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1307 # Mechanism for registering a command to be executed when we come
1308 # across a particular commit. To handle the case when only the
1309 # prefix of the commit is known, the commitinterest array is now
1310 # indexed by the first 4 characters of the ID. Each element is a
1311 # list of id, cmd pairs.
1312 proc interestedin {id cmd} {
1313 global commitinterest
1315 lappend commitinterest([string range $id 0 3]) $id $cmd
1318 proc check_interest {id scripts} {
1319 global commitinterest
1321 set prefix [string range $id 0 3]
1322 if {[info exists commitinterest($prefix)]} {
1324 foreach {i script} $commitinterest($prefix) {
1325 if {[string match "$i*" $id]} {
1326 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1328 lappend newlist $i $script
1331 if {$newlist ne {}} {
1332 set commitinterest($prefix) $newlist
1334 unset commitinterest($prefix)
1340 proc getcommitlines {fd inst view updating} {
1341 global cmitlisted leftover
1342 global commitidx commitdata vdatemode
1343 global parents children curview hlview
1344 global idpending ordertok
1345 global varccommits varcid varctok vtokmod vfilelimit
1347 set stuff [read $fd 500000]
1348 # git log doesn't terminate the last commit with a null...
1349 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1356 global commfd viewcomplete viewactive viewname
1357 global viewinstances
1359 set i [lsearch -exact $viewinstances($view) $inst]
1361 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1363 # set it blocking so we wait for the process to terminate
1364 fconfigure $fd -blocking 1
1365 if {[catch {close $fd} err]} {
1367 if {$view != $curview} {
1368 set fv " for the \"$viewname($view)\" view"
1370 if {[string range $err 0 4] == "usage"} {
1371 set err "Gitk: error reading commits$fv:\
1372 bad arguments to git log."
1373 if {$viewname($view) eq "Command line"} {
1375 " (Note: arguments to gitk are passed to git log\
1376 to allow selection of commits to be displayed.)"
1379 set err "Error reading commits$fv: $err"
1383 if {[incr viewactive($view) -1] <= 0} {
1384 set viewcomplete($view) 1
1385 # Check if we have seen any ids listed as parents that haven't
1386 # appeared in the list
1390 if {$view == $curview} {
1399 set i [string first "\0" $stuff $start]
1401 append leftover($inst) [string range $stuff $start end]
1405 set cmit $leftover($inst)
1406 append cmit [string range $stuff 0 [expr {$i - 1}]]
1407 set leftover($inst) {}
1409 set cmit [string range $stuff $start [expr {$i - 1}]]
1411 set start [expr {$i + 1}]
1412 set j [string first "\n" $cmit]
1415 if {$j >= 0 && [string match "commit *" $cmit]} {
1416 set ids [string range $cmit 7 [expr {$j - 1}]]
1417 if {[string match {[-^<>]*} $ids]} {
1418 switch -- [string index $ids 0] {
1424 set ids [string range $ids 1 end]
1428 if {[string length $id] != 40} {
1436 if {[string length $shortcmit] > 80} {
1437 set shortcmit "[string range $shortcmit 0 80]..."
1439 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1442 set id [lindex $ids 0]
1445 if {!$listed && $updating && ![info exists varcid($vid)] &&
1446 $vfilelimit($view) ne {}} {
1447 # git log doesn't rewrite parents for unlisted commits
1448 # when doing path limiting, so work around that here
1449 # by working out the rewritten parent with git rev-list
1450 # and if we already know about it, using the rewritten
1451 # parent as a substitute parent for $id's children.
1453 set rwid [exec git rev-list --first-parent --max-count=1 \
1454 $id -- $vfilelimit($view)]
1456 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1457 # use $rwid in place of $id
1458 rewrite_commit $view $id $rwid
1465 if {[info exists varcid($vid)]} {
1466 if {$cmitlisted($vid) || !$listed} continue
1470 set olds [lrange $ids 1 end]
1474 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1475 set cmitlisted($vid) $listed
1476 set parents($vid) $olds
1477 if {![info exists children($vid)]} {
1478 set children($vid) {}
1479 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1480 set k [lindex $children($vid) 0]
1481 if {[llength $parents($view,$k)] == 1 &&
1482 (!$vdatemode($view) ||
1483 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1484 set a $varcid($view,$k)
1489 set a [newvarc $view $id]
1491 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1494 if {![info exists varcid($vid)]} {
1496 lappend varccommits($view,$a) $id
1497 incr commitidx($view)
1502 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1504 if {[llength [lappend children($vp) $id]] > 1 &&
1505 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1506 set children($vp) [lsort -command [list vtokcmp $view] \
1508 catch {unset ordertok}
1510 if {[info exists varcid($view,$p)]} {
1511 fix_reversal $p $a $view
1517 set scripts [check_interest $id $scripts]
1521 global numcommits hlview
1523 if {$view == $curview} {
1524 set numcommits $commitidx($view)
1527 if {[info exists hlview] && $view == $hlview} {
1528 # we never actually get here...
1531 foreach s $scripts {
1538 proc chewcommits {} {
1539 global curview hlview viewcomplete
1540 global pending_select
1543 if {$viewcomplete($curview)} {
1544 global commitidx varctok
1545 global numcommits startmsecs
1547 if {[info exists pending_select]} {
1549 reset_pending_select {}
1551 if {[commitinview $pending_select $curview]} {
1552 selectline [rowofcommit $pending_select] 1
1554 set row [first_real_row]
1558 if {$commitidx($curview) > 0} {
1559 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1560 #puts "overall $ms ms for $numcommits commits"
1561 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1563 show_status [mc "No commits selected"]
1570 proc do_readcommit {id} {
1573 # Invoke git-log to handle automatic encoding conversion
1574 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1575 # Read the results using i18n.logoutputencoding
1576 fconfigure $fd -translation lf -eofchar {}
1577 if {$tclencoding != {}} {
1578 fconfigure $fd -encoding $tclencoding
1580 set contents [read $fd]
1582 # Remove the heading line
1583 regsub {^commit [0-9a-f]+\n} $contents {} contents
1588 proc readcommit {id} {
1589 if {[catch {set contents [do_readcommit $id]}]} return
1590 parsecommit $id $contents 1
1593 proc parsecommit {id contents listed} {
1594 global commitinfo cdate
1603 set hdrend [string first "\n\n" $contents]
1605 # should never happen...
1606 set hdrend [string length $contents]
1608 set header [string range $contents 0 [expr {$hdrend - 1}]]
1609 set comment [string range $contents [expr {$hdrend + 2}] end]
1610 foreach line [split $header "\n"] {
1611 set line [split $line " "]
1612 set tag [lindex $line 0]
1613 if {$tag == "author"} {
1614 set audate [lindex $line end-1]
1615 set auname [join [lrange $line 1 end-2] " "]
1616 } elseif {$tag == "committer"} {
1617 set comdate [lindex $line end-1]
1618 set comname [join [lrange $line 1 end-2] " "]
1622 # take the first non-blank line of the comment as the headline
1623 set headline [string trimleft $comment]
1624 set i [string first "\n" $headline]
1626 set headline [string range $headline 0 $i]
1628 set headline [string trimright $headline]
1629 set i [string first "\r" $headline]
1631 set headline [string trimright [string range $headline 0 $i]]
1634 # git log indents the comment by 4 spaces;
1635 # if we got this via git cat-file, add the indentation
1637 foreach line [split $comment "\n"] {
1638 append newcomment " "
1639 append newcomment $line
1640 append newcomment "\n"
1642 set comment $newcomment
1644 if {$comdate != {}} {
1645 set cdate($id) $comdate
1647 set commitinfo($id) [list $headline $auname $audate \
1648 $comname $comdate $comment]
1651 proc getcommit {id} {
1652 global commitdata commitinfo
1654 if {[info exists commitdata($id)]} {
1655 parsecommit $id $commitdata($id) 1
1658 if {![info exists commitinfo($id)]} {
1659 set commitinfo($id) [list [mc "No commit information available"]]
1665 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1666 # and are present in the current view.
1667 # This is fairly slow...
1668 proc longid {prefix} {
1669 global varcid curview
1672 foreach match [array names varcid "$curview,$prefix*"] {
1673 lappend ids [lindex [split $match ","] 1]
1679 global tagids idtags headids idheads tagobjid
1680 global otherrefids idotherrefs mainhead mainheadid
1681 global selecthead selectheadid
1684 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1687 set refd [open [list | git show-ref -d] r]
1688 while {[gets $refd line] >= 0} {
1689 if {[string index $line 40] ne " "} continue
1690 set id [string range $line 0 39]
1691 set ref [string range $line 41 end]
1692 if {![string match "refs/*" $ref]} continue
1693 set name [string range $ref 5 end]
1694 if {[string match "remotes/*" $name]} {
1695 if {![string match "*/HEAD" $name] && !$hideremotes} {
1696 set headids($name) $id
1697 lappend idheads($id) $name
1699 } elseif {[string match "heads/*" $name]} {
1700 set name [string range $name 6 end]
1701 set headids($name) $id
1702 lappend idheads($id) $name
1703 } elseif {[string match "tags/*" $name]} {
1704 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1705 # which is what we want since the former is the commit ID
1706 set name [string range $name 5 end]
1707 if {[string match "*^{}" $name]} {
1708 set name [string range $name 0 end-3]
1710 set tagobjid($name) $id
1712 set tagids($name) $id
1713 lappend idtags($id) $name
1715 set otherrefids($name) $id
1716 lappend idotherrefs($id) $name
1723 set mainheadid [exec git rev-parse HEAD]
1724 set thehead [exec git symbolic-ref HEAD]
1725 if {[string match "refs/heads/*" $thehead]} {
1726 set mainhead [string range $thehead 11 end]
1730 if {$selecthead ne {}} {
1732 set selectheadid [exec git rev-parse --verify $selecthead]
1737 # skip over fake commits
1738 proc first_real_row {} {
1739 global nullid nullid2 numcommits
1741 for {set row 0} {$row < $numcommits} {incr row} {
1742 set id [commitonrow $row]
1743 if {$id ne $nullid && $id ne $nullid2} {
1750 # update things for a head moved to a child of its previous location
1751 proc movehead {id name} {
1752 global headids idheads
1754 removehead $headids($name) $name
1755 set headids($name) $id
1756 lappend idheads($id) $name
1759 # update things when a head has been removed
1760 proc removehead {id name} {
1761 global headids idheads
1763 if {$idheads($id) eq $name} {
1766 set i [lsearch -exact $idheads($id) $name]
1768 set idheads($id) [lreplace $idheads($id) $i $i]
1771 unset headids($name)
1774 proc ttk_toplevel {w args} {
1776 eval [linsert $args 0 ::toplevel $w]
1778 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1783 proc make_transient {window origin} {
1786 # In MacOS Tk 8.4 transient appears to work by setting
1787 # overrideredirect, which is utterly useless, since the
1788 # windows get no border, and are not even kept above
1790 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1792 wm transient $window $origin
1794 # Windows fails to place transient windows normally, so
1795 # schedule a callback to center them on the parent.
1796 if {[tk windowingsystem] eq {win32}} {
1797 after idle [list tk::PlaceWindow $window widget $origin]
1801 proc show_error {w top msg} {
1803 if {![info exists NS]} {set NS ""}
1804 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1805 message $w.m -text $msg -justify center -aspect 400
1806 pack $w.m -side top -fill x -padx 20 -pady 20
1807 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1808 pack $w.ok -side bottom -fill x
1809 bind $top <Visibility> "grab $top; focus $top"
1810 bind $top <Key-Return> "destroy $top"
1811 bind $top <Key-space> "destroy $top"
1812 bind $top <Key-Escape> "destroy $top"
1816 proc error_popup {msg {owner .}} {
1817 if {[tk windowingsystem] eq "win32"} {
1818 tk_messageBox -icon error -type ok -title [wm title .] \
1819 -parent $owner -message $msg
1823 make_transient $w $owner
1824 show_error $w $w $msg
1828 proc confirm_popup {msg {owner .}} {
1829 global confirm_ok NS
1833 make_transient $w $owner
1834 message $w.m -text $msg -justify center -aspect 400
1835 pack $w.m -side top -fill x -padx 20 -pady 20
1836 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1837 pack $w.ok -side left -fill x
1838 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1839 pack $w.cancel -side right -fill x
1840 bind $w <Visibility> "grab $w; focus $w"
1841 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1842 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1843 bind $w <Key-Escape> "destroy $w"
1844 tk::PlaceWindow $w widget $owner
1849 proc setoptions {} {
1850 if {[tk windowingsystem] ne "win32"} {
1851 option add *Panedwindow.showHandle 1 startupFile
1852 option add *Panedwindow.sashRelief raised startupFile
1853 if {[tk windowingsystem] ne "aqua"} {
1854 option add *Menu.font uifont startupFile
1857 option add *Menu.TearOff 0 startupFile
1859 option add *Button.font uifont startupFile
1860 option add *Checkbutton.font uifont startupFile
1861 option add *Radiobutton.font uifont startupFile
1862 option add *Menubutton.font uifont startupFile
1863 option add *Label.font uifont startupFile
1864 option add *Message.font uifont startupFile
1865 option add *Entry.font uifont startupFile
1866 option add *Labelframe.font uifont startupFile
1869 # Make a menu and submenus.
1870 # m is the window name for the menu, items is the list of menu items to add.
1871 # Each item is a list {mc label type description options...}
1872 # mc is ignored; it's so we can put mc there to alert xgettext
1873 # label is the string that appears in the menu
1874 # type is cascade, command or radiobutton (should add checkbutton)
1875 # description depends on type; it's the sublist for cascade, the
1876 # command to invoke for command, or {variable value} for radiobutton
1877 proc makemenu {m items} {
1879 if {[tk windowingsystem] eq {aqua}} {
1885 set name [mc [lindex $i 1]]
1886 set type [lindex $i 2]
1887 set thing [lindex $i 3]
1888 set params [list $type]
1890 set u [string first "&" [string map {&& x} $name]]
1891 lappend params -label [string map {&& & & {}} $name]
1893 lappend params -underline $u
1898 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1899 lappend params -menu $m.$submenu
1902 lappend params -command $thing
1905 lappend params -variable [lindex $thing 0] \
1906 -value [lindex $thing 1]
1909 set tail [lrange $i 4 end]
1910 regsub -all {\yMeta1\y} $tail $Meta1 tail
1911 eval $m add $params $tail
1912 if {$type eq "cascade"} {
1913 makemenu $m.$submenu $thing
1918 # translate string and remove ampersands
1920 return [string map {&& & & {}} [mc $str]]
1923 proc makedroplist {w varname args} {
1927 foreach label $args {
1928 set cx [string length $label]
1929 if {$cx > $width} {set width $cx}
1931 set gm [ttk::combobox $w -width $width -state readonly\
1932 -textvariable $varname -values $args]
1934 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
1939 proc makewindow {} {
1940 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1942 global findtype findtypemenu findloc findstring fstring geometry
1943 global entries sha1entry sha1string sha1but
1944 global diffcontextstring diffcontext
1946 global maincursor textcursor curtextcursor
1947 global rowctxmenu fakerowmenu mergemax wrapcomment
1948 global highlight_files gdttype
1949 global searchstring sstring
1950 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1951 global headctxmenu progresscanv progressitem progresscoords statusw
1952 global fprogitem fprogcoord lastprogupdate progupdatepending
1953 global rprogitem rprogcoord rownumsel numcommits
1954 global have_tk85 use_ttk NS
1956 # The "mc" arguments here are purely so that xgettext
1957 # sees the following string as needing to be translated
1960 {mc "Update" command updatecommits -accelerator F5}
1961 {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1962 {mc "Reread references" command rereadrefs}
1963 {mc "List references" command showrefs -accelerator F2}
1965 {mc "Start git gui" command {exec git gui &}}
1967 {mc "Quit" command doquit -accelerator Meta1-Q}
1971 {mc "Preferences" command doprefs}
1975 {mc "New view..." command {newview 0} -accelerator Shift-F4}
1976 {mc "Edit view..." command editview -state disabled -accelerator F4}
1977 {mc "Delete view" command delview -state disabled}
1979 {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1981 if {[tk windowingsystem] ne "aqua"} {
1984 {mc "About gitk" command about}
1985 {mc "Key bindings" command keys}
1987 set bar [list $file $edit $view $help]
1989 proc ::tk::mac::ShowPreferences {} {doprefs}
1990 proc ::tk::mac::Quit {} {doquit}
1991 lset file end [lreplace [lindex $file end] end-1 end]
1993 xx "Apple" cascade {
1994 {mc "About gitk" command about}
1999 {mc "Key bindings" command keys}
2001 set bar [list $apple $file $view $help]
2004 . configure -menu .bar
2007 # cover the non-themed toplevel with a themed frame.
2008 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2011 # the gui has upper and lower half, parts of a paned window.
2012 ${NS}::panedwindow .ctop -orient vertical
2014 # possibly use assumed geometry
2015 if {![info exists geometry(pwsash0)]} {
2016 set geometry(topheight) [expr {15 * $linespc}]
2017 set geometry(topwidth) [expr {80 * $charspc}]
2018 set geometry(botheight) [expr {15 * $linespc}]
2019 set geometry(botwidth) [expr {50 * $charspc}]
2020 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2021 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2024 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2025 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2026 ${NS}::frame .tf.histframe
2027 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2029 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2032 # create three canvases
2033 set cscroll .tf.histframe.csb
2034 set canv .tf.histframe.pwclist.canv
2036 -selectbackground $selectbgcolor \
2037 -background $bgcolor -bd 0 \
2038 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2039 .tf.histframe.pwclist add $canv
2040 set canv2 .tf.histframe.pwclist.canv2
2042 -selectbackground $selectbgcolor \
2043 -background $bgcolor -bd 0 -yscrollincr $linespc
2044 .tf.histframe.pwclist add $canv2
2045 set canv3 .tf.histframe.pwclist.canv3
2047 -selectbackground $selectbgcolor \
2048 -background $bgcolor -bd 0 -yscrollincr $linespc
2049 .tf.histframe.pwclist add $canv3
2051 bind .tf.histframe.pwclist <Map> {
2053 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2054 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2057 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2058 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2061 # a scroll bar to rule them
2062 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2063 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2064 pack $cscroll -side right -fill y
2065 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2066 lappend bglist $canv $canv2 $canv3
2067 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2069 # we have two button bars at bottom of top frame. Bar 1
2070 ${NS}::frame .tf.bar
2071 ${NS}::frame .tf.lbar -height 15
2073 set sha1entry .tf.bar.sha1
2074 set entries $sha1entry
2075 set sha1but .tf.bar.sha1label
2076 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
2077 -command gotocommit -width 8
2078 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2079 pack .tf.bar.sha1label -side left
2080 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2081 trace add variable sha1string write sha1change
2082 pack $sha1entry -side left -pady 2
2084 image create bitmap bm-left -data {
2085 #define left_width 16
2086 #define left_height 16
2087 static unsigned char left_bits[] = {
2088 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2089 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2090 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2092 image create bitmap bm-right -data {
2093 #define right_width 16
2094 #define right_height 16
2095 static unsigned char right_bits[] = {
2096 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2097 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2098 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2100 ${NS}::button .tf.bar.leftbut -image bm-left -command goback \
2101 -state disabled -width 26
2102 pack .tf.bar.leftbut -side left -fill y
2103 ${NS}::button .tf.bar.rightbut -image bm-right -command goforw \
2104 -state disabled -width 26
2105 pack .tf.bar.rightbut -side left -fill y
2107 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2109 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2110 -relief sunken -anchor e
2111 ${NS}::label .tf.bar.rowlabel2 -text "/"
2112 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2113 -relief sunken -anchor e
2114 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2117 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2120 trace add variable selectedline write selectedline_change
2122 # Status label and progress bar
2123 set statusw .tf.bar.status
2124 ${NS}::label $statusw -width 15 -relief sunken
2125 pack $statusw -side left -padx 5
2127 set progresscanv [ttk::progressbar .tf.bar.progress]
2129 set h [expr {[font metrics uifont -linespace] + 2}]
2130 set progresscanv .tf.bar.progress
2131 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2132 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2133 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2134 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2136 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2137 set progresscoords {0 0}
2140 bind $progresscanv <Configure> adjustprogress
2141 set lastprogupdate [clock clicks -milliseconds]
2142 set progupdatepending 0
2144 # build up the bottom bar of upper window
2145 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2146 ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2147 ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2148 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2149 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2151 set gdttype [mc "containing:"]
2152 set gm [makedroplist .tf.lbar.gdttype gdttype \
2153 [mc "containing:"] \
2154 [mc "touching paths:"] \
2155 [mc "adding/removing string:"]]
2156 trace add variable gdttype write gdttype_change
2157 pack .tf.lbar.gdttype -side left -fill y
2160 set fstring .tf.lbar.findstring
2161 lappend entries $fstring
2162 ${NS}::entry $fstring -width 30 -font textfont -textvariable findstring
2163 trace add variable findstring write find_change
2164 set findtype [mc "Exact"]
2165 set findtypemenu [makedroplist .tf.lbar.findtype \
2166 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2167 trace add variable findtype write findcom_change
2168 set findloc [mc "All fields"]
2169 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2170 [mc "Comments"] [mc "Author"] [mc "Committer"]
2171 trace add variable findloc write find_change
2172 pack .tf.lbar.findloc -side right
2173 pack .tf.lbar.findtype -side right
2174 pack $fstring -side left -expand 1 -fill x
2176 # Finish putting the upper half of the viewer together
2177 pack .tf.lbar -in .tf -side bottom -fill x
2178 pack .tf.bar -in .tf -side bottom -fill x
2179 pack .tf.histframe -fill both -side top -expand 1
2182 .ctop paneconfigure .tf -height $geometry(topheight)
2183 .ctop paneconfigure .tf -width $geometry(topwidth)
2186 # now build up the bottom
2187 ${NS}::panedwindow .pwbottom -orient horizontal
2189 # lower left, a text box over search bar, scroll bar to the right
2190 # if we know window height, then that will set the lower text height, otherwise
2191 # we set lower text height which will drive window height
2192 if {[info exists geometry(main)]} {
2193 ${NS}::frame .bleft -width $geometry(botwidth)
2195 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2197 ${NS}::frame .bleft.top
2198 ${NS}::frame .bleft.mid
2199 ${NS}::frame .bleft.bottom
2201 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2202 pack .bleft.top.search -side left -padx 5
2203 set sstring .bleft.top.sstring
2205 ${NS}::entry $sstring -width 20 -font textfont -textvariable searchstring
2206 lappend entries $sstring
2207 trace add variable searchstring write incrsearch
2208 pack $sstring -side left -expand 1 -fill x
2209 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2210 -command changediffdisp -variable diffelide -value {0 0}
2211 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2212 -command changediffdisp -variable diffelide -value {0 1}
2213 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2214 -command changediffdisp -variable diffelide -value {1 0}
2215 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2216 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2217 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2218 -from 0 -increment 1 -to 10000000 \
2219 -validate all -validatecommand "diffcontextvalidate %P" \
2220 -textvariable diffcontextstring
2221 .bleft.mid.diffcontext set $diffcontext
2222 trace add variable diffcontextstring write diffcontextchange
2223 lappend entries .bleft.mid.diffcontext
2224 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2225 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2226 -command changeignorespace -variable ignorespace
2227 pack .bleft.mid.ignspace -side left -padx 5
2228 set ctext .bleft.bottom.ctext
2229 text $ctext -background $bgcolor -foreground $fgcolor \
2230 -state disabled -font textfont \
2231 -yscrollcommand scrolltext -wrap none \
2232 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2234 $ctext conf -tabstyle wordprocessor
2236 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2237 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2238 pack .bleft.top -side top -fill x
2239 pack .bleft.mid -side top -fill x
2240 grid $ctext .bleft.bottom.sb -sticky nsew
2241 grid .bleft.bottom.sbhorizontal -sticky ew
2242 grid columnconfigure .bleft.bottom 0 -weight 1
2243 grid rowconfigure .bleft.bottom 0 -weight 1
2244 grid rowconfigure .bleft.bottom 1 -weight 0
2245 pack .bleft.bottom -side top -fill both -expand 1
2246 lappend bglist $ctext
2247 lappend fglist $ctext
2249 $ctext tag conf comment -wrap $wrapcomment
2250 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2251 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2252 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2253 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2254 $ctext tag conf m0 -fore red
2255 $ctext tag conf m1 -fore blue
2256 $ctext tag conf m2 -fore green
2257 $ctext tag conf m3 -fore purple
2258 $ctext tag conf m4 -fore brown
2259 $ctext tag conf m5 -fore "#009090"
2260 $ctext tag conf m6 -fore magenta
2261 $ctext tag conf m7 -fore "#808000"
2262 $ctext tag conf m8 -fore "#009000"
2263 $ctext tag conf m9 -fore "#ff0080"
2264 $ctext tag conf m10 -fore cyan
2265 $ctext tag conf m11 -fore "#b07070"
2266 $ctext tag conf m12 -fore "#70b0f0"
2267 $ctext tag conf m13 -fore "#70f0b0"
2268 $ctext tag conf m14 -fore "#f0b070"
2269 $ctext tag conf m15 -fore "#ff70b0"
2270 $ctext tag conf mmax -fore darkgrey
2272 $ctext tag conf mresult -font textfontbold
2273 $ctext tag conf msep -font textfontbold
2274 $ctext tag conf found -back yellow
2276 .pwbottom add .bleft
2278 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2282 ${NS}::frame .bright
2283 ${NS}::frame .bright.mode
2284 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2285 -command reselectline -variable cmitmode -value "patch"
2286 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2287 -command reselectline -variable cmitmode -value "tree"
2288 grid .bright.mode.patch .bright.mode.tree -sticky ew
2289 pack .bright.mode -side top -fill x
2290 set cflist .bright.cfiles
2291 set indent [font measure mainfont "nn"]
2293 -selectbackground $selectbgcolor \
2294 -background $bgcolor -foreground $fgcolor \
2296 -tabs [list $indent [expr {2 * $indent}]] \
2297 -yscrollcommand ".bright.sb set" \
2298 -cursor [. cget -cursor] \
2299 -spacing1 1 -spacing3 1
2300 lappend bglist $cflist
2301 lappend fglist $cflist
2302 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2303 pack .bright.sb -side right -fill y
2304 pack $cflist -side left -fill both -expand 1
2305 $cflist tag configure highlight \
2306 -background [$cflist cget -selectbackground]
2307 $cflist tag configure bold -font mainfontbold
2309 .pwbottom add .bright
2312 # restore window width & height if known
2313 if {[info exists geometry(main)]} {
2314 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2315 if {$w > [winfo screenwidth .]} {
2316 set w [winfo screenwidth .]
2318 if {$h > [winfo screenheight .]} {
2319 set h [winfo screenheight .]
2321 wm geometry . "${w}x$h"
2325 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2326 wm state . $geometry(state)
2329 if {[tk windowingsystem] eq {aqua}} {
2340 %W sashpos 0 $::geometry(topheight)
2342 bind .pwbottom <Map> {
2344 %W sashpos 0 $::geometry(botwidth)
2348 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2349 pack .ctop -fill both -expand 1
2350 bindall <1> {selcanvline %W %x %y}
2351 #bindall <B1-Motion> {selcanvline %W %x %y}
2352 if {[tk windowingsystem] == "win32"} {
2353 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2354 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2356 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2357 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2358 if {[tk windowingsystem] eq "aqua"} {
2359 bindall <MouseWheel> {
2360 set delta [expr {- (%D)}]
2361 allcanvs yview scroll $delta units
2363 bindall <Shift-MouseWheel> {
2364 set delta [expr {- (%D)}]
2365 $canv xview scroll $delta units
2369 bindall <$::BM> "canvscan mark %W %x %y"
2370 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2371 bindkey <Home> selfirstline
2372 bindkey <End> sellastline
2373 bind . <Key-Up> "selnextline -1"
2374 bind . <Key-Down> "selnextline 1"
2375 bind . <Shift-Key-Up> "dofind -1 0"
2376 bind . <Shift-Key-Down> "dofind 1 0"
2377 bindkey <Key-Right> "goforw"
2378 bindkey <Key-Left> "goback"
2379 bind . <Key-Prior> "selnextpage -1"
2380 bind . <Key-Next> "selnextpage 1"
2381 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2382 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2383 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2384 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2385 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2386 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2387 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2388 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2389 bindkey <Key-space> "$ctext yview scroll 1 pages"
2390 bindkey p "selnextline -1"
2391 bindkey n "selnextline 1"
2394 bindkey i "selnextline -1"
2395 bindkey k "selnextline 1"
2399 bindkey d "$ctext yview scroll 18 units"
2400 bindkey u "$ctext yview scroll -18 units"
2401 bindkey / {focus $fstring}
2402 bindkey <Key-KP_Divide> {focus $fstring}
2403 bindkey <Key-Return> {dofind 1 1}
2404 bindkey ? {dofind -1 1}
2406 bind . <F5> updatecommits
2407 bind . <$M1B-F5> reloadcommits
2408 bind . <F2> showrefs
2409 bind . <Shift-F4> {newview 0}
2410 catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2411 bind . <F4> edit_or_newview
2412 bind . <$M1B-q> doquit
2413 bind . <$M1B-f> {dofind 1 1}
2414 bind . <$M1B-g> {dofind 1 0}
2415 bind . <$M1B-r> dosearchback
2416 bind . <$M1B-s> dosearch
2417 bind . <$M1B-equal> {incrfont 1}
2418 bind . <$M1B-plus> {incrfont 1}
2419 bind . <$M1B-KP_Add> {incrfont 1}
2420 bind . <$M1B-minus> {incrfont -1}
2421 bind . <$M1B-KP_Subtract> {incrfont -1}
2422 wm protocol . WM_DELETE_WINDOW doquit
2423 bind . <Destroy> {stop_backends}
2424 bind . <Button-1> "click %W"
2425 bind $fstring <Key-Return> {dofind 1 1}
2426 bind $sha1entry <Key-Return> {gotocommit; break}
2427 bind $sha1entry <<PasteSelection>> clearsha1
2428 bind $cflist <1> {sel_flist %W %x %y; break}
2429 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2430 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2432 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2433 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2435 set maincursor [. cget -cursor]
2436 set textcursor [$ctext cget -cursor]
2437 set curtextcursor $textcursor
2439 set rowctxmenu .rowctxmenu
2440 makemenu $rowctxmenu {
2441 {mc "Diff this -> selected" command {diffvssel 0}}
2442 {mc "Diff selected -> this" command {diffvssel 1}}
2443 {mc "Make patch" command mkpatch}
2444 {mc "Create tag" command mktag}
2445 {mc "Write commit to file" command writecommit}
2446 {mc "Create new branch" command mkbranch}
2447 {mc "Cherry-pick this commit" command cherrypick}
2448 {mc "Reset HEAD branch to here" command resethead}
2449 {mc "Mark this commit" command markhere}
2450 {mc "Return to mark" command gotomark}
2451 {mc "Find descendant of this and mark" command find_common_desc}
2452 {mc "Compare with marked commit" command compare_commits}
2454 $rowctxmenu configure -tearoff 0
2456 set fakerowmenu .fakerowmenu
2457 makemenu $fakerowmenu {
2458 {mc "Diff this -> selected" command {diffvssel 0}}
2459 {mc "Diff selected -> this" command {diffvssel 1}}
2460 {mc "Make patch" command mkpatch}
2462 $fakerowmenu configure -tearoff 0
2464 set headctxmenu .headctxmenu
2465 makemenu $headctxmenu {
2466 {mc "Check out this branch" command cobranch}
2467 {mc "Remove this branch" command rmbranch}
2469 $headctxmenu configure -tearoff 0
2472 set flist_menu .flistctxmenu
2473 makemenu $flist_menu {
2474 {mc "Highlight this too" command {flist_hl 0}}
2475 {mc "Highlight this only" command {flist_hl 1}}
2476 {mc "External diff" command {external_diff}}
2477 {mc "Blame parent commit" command {external_blame 1}}
2479 $flist_menu configure -tearoff 0
2482 set diff_menu .diffctxmenu
2483 makemenu $diff_menu {
2484 {mc "Show origin of this line" command show_line_source}
2485 {mc "Run git gui blame on this line" command {external_blame_diff}}
2487 $diff_menu configure -tearoff 0
2490 # Windows sends all mouse wheel events to the current focused window, not
2491 # the one where the mouse hovers, so bind those events here and redirect
2492 # to the correct window
2493 proc windows_mousewheel_redirector {W X Y D} {
2494 global canv canv2 canv3
2495 set w [winfo containing -displayof $W $X $Y]
2497 set u [expr {$D < 0 ? 5 : -5}]
2498 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2499 allcanvs yview scroll $u units
2502 $w yview scroll $u units
2508 # Update row number label when selectedline changes
2509 proc selectedline_change {n1 n2 op} {
2510 global selectedline rownumsel
2512 if {$selectedline eq {}} {
2515 set rownumsel [expr {$selectedline + 1}]
2519 # mouse-2 makes all windows scan vertically, but only the one
2520 # the cursor is in scans horizontally
2521 proc canvscan {op w x y} {
2522 global canv canv2 canv3
2523 foreach c [list $canv $canv2 $canv3] {
2532 proc scrollcanv {cscroll f0 f1} {
2533 $cscroll set $f0 $f1
2538 # when we make a key binding for the toplevel, make sure
2539 # it doesn't get triggered when that key is pressed in the
2540 # find string entry widget.
2541 proc bindkey {ev script} {
2544 set escript [bind Entry $ev]
2545 if {$escript == {}} {
2546 set escript [bind Entry <Key>]
2548 foreach e $entries {
2549 bind $e $ev "$escript; break"
2553 # set the focus back to the toplevel for any click outside
2556 global ctext entries
2557 foreach e [concat $entries $ctext] {
2558 if {$w == $e} return
2563 # Adjust the progress bar for a change in requested extent or canvas size
2564 proc adjustprogress {} {
2565 global progresscanv progressitem progresscoords
2566 global fprogitem fprogcoord lastprogupdate progupdatepending
2567 global rprogitem rprogcoord use_ttk
2570 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2574 set w [expr {[winfo width $progresscanv] - 4}]
2575 set x0 [expr {$w * [lindex $progresscoords 0]}]
2576 set x1 [expr {$w * [lindex $progresscoords 1]}]
2577 set h [winfo height $progresscanv]
2578 $progresscanv coords $progressitem $x0 0 $x1 $h
2579 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2580 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2581 set now [clock clicks -milliseconds]
2582 if {$now >= $lastprogupdate + 100} {
2583 set progupdatepending 0
2585 } elseif {!$progupdatepending} {
2586 set progupdatepending 1
2587 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2591 proc doprogupdate {} {
2592 global lastprogupdate progupdatepending
2594 if {$progupdatepending} {
2595 set progupdatepending 0
2596 set lastprogupdate [clock clicks -milliseconds]
2601 proc savestuff {w} {
2602 global canv canv2 canv3 mainfont textfont uifont tabstop
2603 global stuffsaved findmergefiles maxgraphpct
2604 global maxwidth showneartags showlocalchanges
2605 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2606 global cmitmode wrapcomment datetimeformat limitdiffs
2607 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2608 global autoselect extdifftool perfile_attrs markbgcolor use_ttk
2611 if {$stuffsaved} return
2612 if {![winfo viewable .]} return
2614 set f [open "~/.gitk-new" w]
2615 if {$::tcl_platform(platform) eq {windows}} {
2616 file attributes "~/.gitk-new" -hidden true
2618 puts $f [list set mainfont $mainfont]
2619 puts $f [list set textfont $textfont]
2620 puts $f [list set uifont $uifont]
2621 puts $f [list set tabstop $tabstop]
2622 puts $f [list set findmergefiles $findmergefiles]
2623 puts $f [list set maxgraphpct $maxgraphpct]
2624 puts $f [list set maxwidth $maxwidth]
2625 puts $f [list set cmitmode $cmitmode]
2626 puts $f [list set wrapcomment $wrapcomment]
2627 puts $f [list set autoselect $autoselect]
2628 puts $f [list set showneartags $showneartags]
2629 puts $f [list set hideremotes $hideremotes]
2630 puts $f [list set showlocalchanges $showlocalchanges]
2631 puts $f [list set datetimeformat $datetimeformat]
2632 puts $f [list set limitdiffs $limitdiffs]
2633 puts $f [list set bgcolor $bgcolor]
2634 puts $f [list set fgcolor $fgcolor]
2635 puts $f [list set colors $colors]
2636 puts $f [list set diffcolors $diffcolors]
2637 puts $f [list set markbgcolor $markbgcolor]
2638 puts $f [list set diffcontext $diffcontext]
2639 puts $f [list set selectbgcolor $selectbgcolor]
2640 puts $f [list set extdifftool $extdifftool]
2641 puts $f [list set perfile_attrs $perfile_attrs]
2643 puts $f "set geometry(main) [wm geometry .]"
2644 puts $f "set geometry(state) [wm state .]"
2645 puts $f "set geometry(topwidth) [winfo width .tf]"
2646 puts $f "set geometry(topheight) [winfo height .tf]"
2648 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2649 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2651 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2652 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2654 puts $f "set geometry(botwidth) [winfo width .bleft]"
2655 puts $f "set geometry(botheight) [winfo height .bleft]"
2657 puts -nonewline $f "set permviews {"
2658 for {set v 0} {$v < $nextviewnum} {incr v} {
2659 if {$viewperm($v)} {
2660 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2665 file rename -force "~/.gitk-new" "~/.gitk"
2670 proc resizeclistpanes {win w} {
2671 global oldwidth use_ttk
2672 if {[info exists oldwidth($win)]} {
2674 set s0 [$win sashpos 0]
2675 set s1 [$win sashpos 1]
2677 set s0 [$win sash coord 0]
2678 set s1 [$win sash coord 1]
2681 set sash0 [expr {int($w/2 - 2)}]
2682 set sash1 [expr {int($w*5/6 - 2)}]
2684 set factor [expr {1.0 * $w / $oldwidth($win)}]
2685 set sash0 [expr {int($factor * [lindex $s0 0])}]
2686 set sash1 [expr {int($factor * [lindex $s1 0])}]
2690 if {$sash1 < $sash0 + 20} {
2691 set sash1 [expr {$sash0 + 20}]
2693 if {$sash1 > $w - 10} {
2694 set sash1 [expr {$w - 10}]
2695 if {$sash0 > $sash1 - 20} {
2696 set sash0 [expr {$sash1 - 20}]
2701 $win sashpos 0 $sash0
2702 $win sashpos 1 $sash1
2704 $win sash place 0 $sash0 [lindex $s0 1]
2705 $win sash place 1 $sash1 [lindex $s1 1]
2708 set oldwidth($win) $w
2711 proc resizecdetpanes {win w} {
2712 global oldwidth use_ttk
2713 if {[info exists oldwidth($win)]} {
2715 set s0 [$win sashpos 0]
2717 set s0 [$win sash coord 0]
2720 set sash0 [expr {int($w*3/4 - 2)}]
2722 set factor [expr {1.0 * $w / $oldwidth($win)}]
2723 set sash0 [expr {int($factor * [lindex $s0 0])}]
2727 if {$sash0 > $w - 15} {
2728 set sash0 [expr {$w - 15}]
2732 $win sashpos 0 $sash0
2734 $win sash place 0 $sash0 [lindex $s0 1]
2737 set oldwidth($win) $w
2740 proc allcanvs args {
2741 global canv canv2 canv3
2747 proc bindall {event action} {
2748 global canv canv2 canv3
2749 bind $canv $event $action
2750 bind $canv2 $event $action
2751 bind $canv3 $event $action
2757 if {[winfo exists $w]} {
2762 wm title $w [mc "About gitk"]
2764 message $w.m -text [mc "
2765 Gitk - a commit viewer for git
2767 Copyright \u00a9 2005-2009 Paul Mackerras
2769 Use and redistribute under the terms of the GNU General Public License"] \
2770 -justify center -aspect 400 -border 2 -bg white -relief groove
2771 pack $w.m -side top -fill x -padx 2 -pady 2
2772 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2773 pack $w.ok -side bottom
2774 bind $w <Visibility> "focus $w.ok"
2775 bind $w <Key-Escape> "destroy $w"
2776 bind $w <Key-Return> "destroy $w"
2777 tk::PlaceWindow $w widget .
2783 if {[winfo exists $w]} {
2787 if {[tk windowingsystem] eq {aqua}} {
2793 wm title $w [mc "Gitk key bindings"]
2795 message $w.m -text "
2796 [mc "Gitk key bindings:"]
2798 [mc "<%s-Q> Quit" $M1T]
2799 [mc "<Home> Move to first commit"]
2800 [mc "<End> Move to last commit"]
2801 [mc "<Up>, p, i Move up one commit"]
2802 [mc "<Down>, n, k Move down one commit"]
2803 [mc "<Left>, z, j Go back in history list"]
2804 [mc "<Right>, x, l Go forward in history list"]
2805 [mc "<PageUp> Move up one page in commit list"]
2806 [mc "<PageDown> Move down one page in commit list"]
2807 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2808 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2809 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2810 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2811 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2812 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2813 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2814 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2815 [mc "<Delete>, b Scroll diff view up one page"]
2816 [mc "<Backspace> Scroll diff view up one page"]
2817 [mc "<Space> Scroll diff view down one page"]
2818 [mc "u Scroll diff view up 18 lines"]
2819 [mc "d Scroll diff view down 18 lines"]
2820 [mc "<%s-F> Find" $M1T]
2821 [mc "<%s-G> Move to next find hit" $M1T]
2822 [mc "<Return> Move to next find hit"]
2823 [mc "/ Focus the search box"]
2824 [mc "? Move to previous find hit"]
2825 [mc "f Scroll diff view to next file"]
2826 [mc "<%s-S> Search for next hit in diff view" $M1T]
2827 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2828 [mc "<%s-KP+> Increase font size" $M1T]
2829 [mc "<%s-plus> Increase font size" $M1T]
2830 [mc "<%s-KP-> Decrease font size" $M1T]
2831 [mc "<%s-minus> Decrease font size" $M1T]
2834 -justify left -bg white -border 2 -relief groove
2835 pack $w.m -side top -fill both -padx 2 -pady 2
2836 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2837 bind $w <Key-Escape> [list destroy $w]
2838 pack $w.ok -side bottom
2839 bind $w <Visibility> "focus $w.ok"
2840 bind $w <Key-Escape> "destroy $w"
2841 bind $w <Key-Return> "destroy $w"
2844 # Procedures for manipulating the file list window at the
2845 # bottom right of the overall window.
2847 proc treeview {w l openlevs} {
2848 global treecontents treediropen treeheight treeparent treeindex
2858 set treecontents() {}
2859 $w conf -state normal
2861 while {[string range $f 0 $prefixend] ne $prefix} {
2862 if {$lev <= $openlevs} {
2863 $w mark set e:$treeindex($prefix) "end -1c"
2864 $w mark gravity e:$treeindex($prefix) left
2866 set treeheight($prefix) $ht
2867 incr ht [lindex $htstack end]
2868 set htstack [lreplace $htstack end end]
2869 set prefixend [lindex $prefendstack end]
2870 set prefendstack [lreplace $prefendstack end end]
2871 set prefix [string range $prefix 0 $prefixend]
2874 set tail [string range $f [expr {$prefixend+1}] end]
2875 while {[set slash [string first "/" $tail]] >= 0} {
2878 lappend prefendstack $prefixend
2879 incr prefixend [expr {$slash + 1}]
2880 set d [string range $tail 0 $slash]
2881 lappend treecontents($prefix) $d
2882 set oldprefix $prefix
2884 set treecontents($prefix) {}
2885 set treeindex($prefix) [incr ix]
2886 set treeparent($prefix) $oldprefix
2887 set tail [string range $tail [expr {$slash+1}] end]
2888 if {$lev <= $openlevs} {
2890 set treediropen($prefix) [expr {$lev < $openlevs}]
2891 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2892 $w mark set d:$ix "end -1c"
2893 $w mark gravity d:$ix left
2895 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2897 $w image create end -align center -image $bm -padx 1 \
2899 $w insert end $d [highlight_tag $prefix]
2900 $w mark set s:$ix "end -1c"
2901 $w mark gravity s:$ix left
2906 if {$lev <= $openlevs} {
2909 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2911 $w insert end $tail [highlight_tag $f]
2913 lappend treecontents($prefix) $tail
2916 while {$htstack ne {}} {
2917 set treeheight($prefix) $ht
2918 incr ht [lindex $htstack end]
2919 set htstack [lreplace $htstack end end]
2920 set prefixend [lindex $prefendstack end]
2921 set prefendstack [lreplace $prefendstack end end]
2922 set prefix [string range $prefix 0 $prefixend]
2924 $w conf -state disabled
2927 proc linetoelt {l} {
2928 global treeheight treecontents
2933 foreach e $treecontents($prefix) {
2938 if {[string index $e end] eq "/"} {
2939 set n $treeheight($prefix$e)
2951 proc highlight_tree {y prefix} {
2952 global treeheight treecontents cflist
2954 foreach e $treecontents($prefix) {
2956 if {[highlight_tag $path] ne {}} {
2957 $cflist tag add bold $y.0 "$y.0 lineend"
2960 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2961 set y [highlight_tree $y $path]
2967 proc treeclosedir {w dir} {
2968 global treediropen treeheight treeparent treeindex
2970 set ix $treeindex($dir)
2971 $w conf -state normal
2972 $w delete s:$ix e:$ix
2973 set treediropen($dir) 0
2974 $w image configure a:$ix -image tri-rt
2975 $w conf -state disabled
2976 set n [expr {1 - $treeheight($dir)}]
2977 while {$dir ne {}} {
2978 incr treeheight($dir) $n
2979 set dir $treeparent($dir)
2983 proc treeopendir {w dir} {
2984 global treediropen treeheight treeparent treecontents treeindex
2986 set ix $treeindex($dir)
2987 $w conf -state normal
2988 $w image configure a:$ix -image tri-dn
2989 $w mark set e:$ix s:$ix
2990 $w mark gravity e:$ix right
2993 set n [llength $treecontents($dir)]
2994 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2997 incr treeheight($x) $n
2999 foreach e $treecontents($dir) {
3001 if {[string index $e end] eq "/"} {
3002 set iy $treeindex($de)
3003 $w mark set d:$iy e:$ix
3004 $w mark gravity d:$iy left
3005 $w insert e:$ix $str
3006 set treediropen($de) 0
3007 $w image create e:$ix -align center -image tri-rt -padx 1 \
3009 $w insert e:$ix $e [highlight_tag $de]
3010 $w mark set s:$iy e:$ix
3011 $w mark gravity s:$iy left
3012 set treeheight($de) 1
3014 $w insert e:$ix $str
3015 $w insert e:$ix $e [highlight_tag $de]
3018 $w mark gravity e:$ix right
3019 $w conf -state disabled
3020 set treediropen($dir) 1
3021 set top [lindex [split [$w index @0,0] .] 0]
3022 set ht [$w cget -height]
3023 set l [lindex [split [$w index s:$ix] .] 0]
3026 } elseif {$l + $n + 1 > $top + $ht} {
3027 set top [expr {$l + $n + 2 - $ht}]
3035 proc treeclick {w x y} {
3036 global treediropen cmitmode ctext cflist cflist_top
3038 if {$cmitmode ne "tree"} return
3039 if {![info exists cflist_top]} return
3040 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3041 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3042 $cflist tag add highlight $l.0 "$l.0 lineend"
3048 set e [linetoelt $l]
3049 if {[string index $e end] ne "/"} {
3051 } elseif {$treediropen($e)} {
3058 proc setfilelist {id} {
3059 global treefilelist cflist jump_to_here
3061 treeview $cflist $treefilelist($id) 0
3062 if {$jump_to_here ne {}} {
3063 set f [lindex $jump_to_here 0]
3064 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3070 image create bitmap tri-rt -background black -foreground blue -data {
3071 #define tri-rt_width 13
3072 #define tri-rt_height 13
3073 static unsigned char tri-rt_bits[] = {
3074 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3075 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3078 #define tri-rt-mask_width 13
3079 #define tri-rt-mask_height 13
3080 static unsigned char tri-rt-mask_bits[] = {
3081 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3082 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3085 image create bitmap tri-dn -background black -foreground blue -data {
3086 #define tri-dn_width 13
3087 #define tri-dn_height 13
3088 static unsigned char tri-dn_bits[] = {
3089 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3090 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3093 #define tri-dn-mask_width 13
3094 #define tri-dn-mask_height 13
3095 static unsigned char tri-dn-mask_bits[] = {
3096 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3097 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3101 image create bitmap reficon-T -background black -foreground yellow -data {
3102 #define tagicon_width 13
3103 #define tagicon_height 9
3104 static unsigned char tagicon_bits[] = {
3105 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3106 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3108 #define tagicon-mask_width 13
3109 #define tagicon-mask_height 9
3110 static unsigned char tagicon-mask_bits[] = {
3111 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3112 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3115 #define headicon_width 13
3116 #define headicon_height 9
3117 static unsigned char headicon_bits[] = {
3118 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3119 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3122 #define headicon-mask_width 13
3123 #define headicon-mask_height 9
3124 static unsigned char headicon-mask_bits[] = {
3125 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3126 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3128 image create bitmap reficon-H -background black -foreground green \
3129 -data $rectdata -maskdata $rectmask
3130 image create bitmap reficon-o -background black -foreground "#ddddff" \
3131 -data $rectdata -maskdata $rectmask
3133 proc init_flist {first} {
3134 global cflist cflist_top difffilestart
3136 $cflist conf -state normal
3137 $cflist delete 0.0 end
3139 $cflist insert end $first
3141 $cflist tag add highlight 1.0 "1.0 lineend"
3143 catch {unset cflist_top}
3145 $cflist conf -state disabled
3146 set difffilestart {}
3149 proc highlight_tag {f} {
3150 global highlight_paths
3152 foreach p $highlight_paths {
3153 if {[string match $p $f]} {
3160 proc highlight_filelist {} {
3161 global cmitmode cflist
3163 $cflist conf -state normal
3164 if {$cmitmode ne "tree"} {
3165 set end [lindex [split [$cflist index end] .] 0]
3166 for {set l 2} {$l < $end} {incr l} {
3167 set line [$cflist get $l.0 "$l.0 lineend"]
3168 if {[highlight_tag $line] ne {}} {
3169 $cflist tag add bold $l.0 "$l.0 lineend"
3175 $cflist conf -state disabled
3178 proc unhighlight_filelist {} {
3181 $cflist conf -state normal
3182 $cflist tag remove bold 1.0 end
3183 $cflist conf -state disabled
3186 proc add_flist {fl} {
3189 $cflist conf -state normal
3191 $cflist insert end "\n"
3192 $cflist insert end $f [highlight_tag $f]
3194 $cflist conf -state disabled
3197 proc sel_flist {w x y} {
3198 global ctext difffilestart cflist cflist_top cmitmode
3200 if {$cmitmode eq "tree"} return
3201 if {![info exists cflist_top]} return
3202 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3203 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3204 $cflist tag add highlight $l.0 "$l.0 lineend"
3209 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3213 proc pop_flist_menu {w X Y x y} {
3214 global ctext cflist cmitmode flist_menu flist_menu_file
3215 global treediffs diffids
3218 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3220 if {$cmitmode eq "tree"} {
3221 set e [linetoelt $l]
3222 if {[string index $e end] eq "/"} return
3224 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3226 set flist_menu_file $e
3227 set xdiffstate "normal"
3228 if {$cmitmode eq "tree"} {
3229 set xdiffstate "disabled"
3231 # Disable "External diff" item in tree mode
3232 $flist_menu entryconf 2 -state $xdiffstate
3233 tk_popup $flist_menu $X $Y
3236 proc find_ctext_fileinfo {line} {
3237 global ctext_file_names ctext_file_lines
3239 set ok [bsearch $ctext_file_lines $line]
3240 set tline [lindex $ctext_file_lines $ok]
3242 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3245 return [list [lindex $ctext_file_names $ok] $tline]
3249 proc pop_diff_menu {w X Y x y} {
3250 global ctext diff_menu flist_menu_file
3251 global diff_menu_txtpos diff_menu_line
3252 global diff_menu_filebase
3254 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3255 set diff_menu_line [lindex $diff_menu_txtpos 0]
3256 # don't pop up the menu on hunk-separator or file-separator lines
3257 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3261 set f [find_ctext_fileinfo $diff_menu_line]
3262 if {$f eq {}} return
3263 set flist_menu_file [lindex $f 0]
3264 set diff_menu_filebase [lindex $f 1]
3265 tk_popup $diff_menu $X $Y
3268 proc flist_hl {only} {
3269 global flist_menu_file findstring gdttype
3271 set x [shellquote $flist_menu_file]
3272 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3275 append findstring " " $x
3277 set gdttype [mc "touching paths:"]
3280 proc save_file_from_commit {filename output what} {
3283 if {[catch {exec git show $filename -- > $output} err]} {
3284 if {[string match "fatal: bad revision *" $err]} {
3287 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3293 proc external_diff_get_one_file {diffid filename diffdir} {
3294 global nullid nullid2 nullfile
3297 if {$diffid == $nullid} {
3298 set difffile [file join [file dirname $gitdir] $filename]
3299 if {[file exists $difffile]} {
3304 if {$diffid == $nullid2} {
3305 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3306 return [save_file_from_commit :$filename $difffile index]
3308 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3309 return [save_file_from_commit $diffid:$filename $difffile \
3313 proc external_diff {} {
3314 global gitktmpdir nullid nullid2
3315 global flist_menu_file
3318 global gitdir extdifftool
3320 if {[llength $diffids] == 1} {
3321 # no reference commit given
3322 set diffidto [lindex $diffids 0]
3323 if {$diffidto eq $nullid} {
3324 # diffing working copy with index
3325 set diffidfrom $nullid2
3326 } elseif {$diffidto eq $nullid2} {
3327 # diffing index with HEAD
3328 set diffidfrom "HEAD"
3330 # use first parent commit
3331 global parentlist selectedline
3332 set diffidfrom [lindex $parentlist $selectedline 0]
3335 set diffidfrom [lindex $diffids 0]
3336 set diffidto [lindex $diffids 1]
3339 # make sure that several diffs wont collide
3340 if {![info exists gitktmpdir]} {
3341 set gitktmpdir [file join [file dirname $gitdir] \
3342 [format ".gitk-tmp.%s" [pid]]]
3343 if {[catch {file mkdir $gitktmpdir} err]} {
3344 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3351 set diffdir [file join $gitktmpdir $diffnum]
3352 if {[catch {file mkdir $diffdir} err]} {
3353 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3357 # gather files to diff
3358 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3359 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3361 if {$difffromfile ne {} && $difftofile ne {}} {
3362 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3363 if {[catch {set fl [open |$cmd r]} err]} {
3364 file delete -force $diffdir
3365 error_popup "$extdifftool: [mc "command failed:"] $err"
3367 fconfigure $fl -blocking 0
3368 filerun $fl [list delete_at_eof $fl $diffdir]
3373 proc find_hunk_blamespec {base line} {
3376 # Find and parse the hunk header
3377 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3378 if {$s_lix eq {}} return
3380 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3381 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3382 s_line old_specs osz osz1 new_line nsz]} {
3386 # base lines for the parents
3387 set base_lines [list $new_line]
3388 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3389 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3390 old_spec old_line osz]} {
3393 lappend base_lines $old_line
3396 # Now scan the lines to determine offset within the hunk
3397 set max_parent [expr {[llength $base_lines]-2}]
3399 set s_lno [lindex [split $s_lix "."] 0]
3401 # Determine if the line is removed
3402 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3403 if {[string match {[-+ ]*} $chunk]} {
3404 set removed_idx [string first "-" $chunk]
3405 # Choose a parent index
3406 if {$removed_idx >= 0} {
3407 set parent $removed_idx
3409 set unchanged_idx [string first " " $chunk]
3410 if {$unchanged_idx >= 0} {
3411 set parent $unchanged_idx
3413 # blame the current commit
3417 # then count other lines that belong to it
3418 for {set i $line} {[incr i -1] > $s_lno} {} {
3419 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3420 # Determine if the line is removed
3421 set removed_idx [string first "-" $chunk]
3423 set code [string index $chunk $parent]
3424 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3428 if {$removed_idx < 0} {
3438 incr dline [lindex $base_lines $parent]
3439 return [list $parent $dline]
3442 proc external_blame_diff {} {
3443 global currentid cmitmode
3444 global diff_menu_txtpos diff_menu_line
3445 global diff_menu_filebase flist_menu_file
3447 if {$cmitmode eq "tree"} {
3449 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3451 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3453 set parent_idx [lindex $hinfo 0]
3454 set line [lindex $hinfo 1]
3461 external_blame $parent_idx $line
3464 # Find the SHA1 ID of the blob for file $fname in the index
3466 proc index_sha1 {fname} {
3467 set f [open [list | git ls-files -s $fname] r]
3468 while {[gets $f line] >= 0} {
3469 set info [lindex [split $line "\t"] 0]
3470 set stage [lindex $info 2]
3471 if {$stage eq "0" || $stage eq "2"} {
3473 return [lindex $info 1]
3480 # Turn an absolute path into one relative to the current directory
3481 proc make_relative {f} {
3482 set elts [file split $f]
3483 set here [file split [pwd]]
3488 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3495 set elts [concat $res [lrange $elts $ei end]]
3496 return [eval file join $elts]
3499 proc external_blame {parent_idx {line {}}} {
3500 global flist_menu_file gitdir
3501 global nullid nullid2
3502 global parentlist selectedline currentid
3504 if {$parent_idx > 0} {
3505 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3507 set base_commit $currentid
3510 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3511 error_popup [mc "No such commit"]
3515 set cmdline [list git gui blame]
3516 if {$line ne {} && $line > 1} {
3517 lappend cmdline "--line=$line"
3519 set f [file join [file dirname $gitdir] $flist_menu_file]
3520 # Unfortunately it seems git gui blame doesn't like
3521 # being given an absolute path...
3522 set f [make_relative $f]
3523 lappend cmdline $base_commit $f
3524 if {[catch {eval exec $cmdline &} err]} {
3525 error_popup "[mc "git gui blame: command failed:"] $err"
3529 proc show_line_source {} {
3530 global cmitmode currentid parents curview blamestuff blameinst
3531 global diff_menu_line diff_menu_filebase flist_menu_file
3532 global nullid nullid2 gitdir
3535 if {$cmitmode eq "tree"} {
3537 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3539 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3540 if {$h eq {}} return
3541 set pi [lindex $h 0]
3543 mark_ctext_line $diff_menu_line
3547 if {$currentid eq $nullid} {
3549 # must be a merge in progress...
3551 # get the last line from .git/MERGE_HEAD
3552 set f [open [file join $gitdir MERGE_HEAD] r]
3553 set id [lindex [split [read $f] "\n"] end-1]
3556 error_popup [mc "Couldn't read merge head: %s" $err]
3559 } elseif {$parents($curview,$currentid) eq $nullid2} {
3560 # need to do the blame from the index
3562 set from_index [index_sha1 $flist_menu_file]
3564 error_popup [mc "Error reading index: %s" $err]
3568 set id $parents($curview,$currentid)
3571 set id [lindex $parents($curview,$currentid) $pi]
3573 set line [lindex $h 1]
3576 if {$from_index ne {}} {
3577 lappend blameargs | git cat-file blob $from_index
3579 lappend blameargs | git blame -p -L$line,+1
3580 if {$from_index ne {}} {
3581 lappend blameargs --contents -
3583 lappend blameargs $id
3585 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3587 set f [open $blameargs r]
3589 error_popup [mc "Couldn't start git blame: %s" $err]
3592 nowbusy blaming [mc "Searching"]
3593 fconfigure $f -blocking 0
3594 set i [reg_instance $f]
3595 set blamestuff($i) {}
3597 filerun $f [list read_line_source $f $i]
3600 proc stopblaming {} {
3603 if {[info exists blameinst]} {
3604 stop_instance $blameinst
3610 proc read_line_source {fd inst} {
3611 global blamestuff curview commfd blameinst nullid nullid2
3613 while {[gets $fd line] >= 0} {
3614 lappend blamestuff($inst) $line
3622 fconfigure $fd -blocking 1
3623 if {[catch {close $fd} err]} {
3624 error_popup [mc "Error running git blame: %s" $err]
3629 set line [split [lindex $blamestuff($inst) 0] " "]
3630 set id [lindex $line 0]
3631 set lnum [lindex $line 1]
3632 if {[string length $id] == 40 && [string is xdigit $id] &&
3633 [string is digit -strict $lnum]} {
3634 # look for "filename" line
3635 foreach l $blamestuff($inst) {
3636 if {[string match "filename *" $l]} {
3637 set fname [string range $l 9 end]
3643 # all looks good, select it
3644 if {$id eq $nullid} {
3645 # blame uses all-zeroes to mean not committed,
3646 # which would mean a change in the index
3649 if {[commitinview $id $curview]} {
3650 selectline [rowofcommit $id] 1 [list $fname $lnum]
3652 error_popup [mc "That line comes from commit %s, \
3653 which is not in this view" [shortids $id]]
3656 puts "oops couldn't parse git blame output"
3661 # delete $dir when we see eof on $f (presumably because the child has exited)
3662 proc delete_at_eof {f dir} {
3663 while {[gets $f line] >= 0} {}
3665 if {[catch {close $f} err]} {
3666 error_popup "[mc "External diff viewer failed:"] $err"
3668 file delete -force $dir
3674 # Functions for adding and removing shell-type quoting
3676 proc shellquote {str} {
3677 if {![string match "*\['\"\\ \t]*" $str]} {
3680 if {![string match "*\['\"\\]*" $str]} {
3683 if {![string match "*'*" $str]} {
3686 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3689 proc shellarglist {l} {
3695 append str [shellquote $a]
3700 proc shelldequote {str} {
3705 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3706 append ret [string range $str $used end]
3707 set used [string length $str]
3710 set first [lindex $first 0]
3711 set ch [string index $str $first]
3712 if {$first > $used} {
3713 append ret [string range $str $used [expr {$first - 1}]]
3716 if {$ch eq " " || $ch eq "\t"} break
3719 set first [string first "'" $str $used]
3721 error "unmatched single-quote"
3723 append ret [string range $str $used [expr {$first - 1}]]
3728 if {$used >= [string length $str]} {
3729 error "trailing backslash"
3731 append ret [string index $str $used]
3736 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3737 error "unmatched double-quote"
3739 set first [lindex $first 0]
3740 set ch [string index $str $first]
3741 if {$first > $used} {
3742 append ret [string range $str $used [expr {$first - 1}]]
3745 if {$ch eq "\""} break
3747 append ret [string index $str $used]
3751 return [list $used $ret]
3754 proc shellsplit {str} {
3757 set str [string trimleft $str]
3758 if {$str eq {}} break
3759 set dq [shelldequote $str]
3760 set n [lindex $dq 0]
3761 set word [lindex $dq 1]
3762 set str [string range $str $n end]
3768 # Code to implement multiple views
3770 proc newview {ishighlight} {
3771 global nextviewnum newviewname newishighlight
3772 global revtreeargs viewargscmd newviewopts curview
3774 set newishighlight $ishighlight
3776 if {[winfo exists $top]} {
3780 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3781 set newviewopts($nextviewnum,perm) 0
3782 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3783 decode_view_opts $nextviewnum $revtreeargs
3784 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3787 set known_view_options {
3788 {perm b . {} {mc "Remember this view"}}
3789 {reflabel l + {} {mc "References (space separated list):"}}
3790 {refs t15 .. {} {mc "Branches & tags:"}}
3791 {allrefs b *. "--all" {mc "All refs"}}
3792 {branches b . "--branches" {mc "All (local) branches"}}
3793 {tags b . "--tags" {mc "All tags"}}
3794 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3795 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3796 {author t15 .. "--author=*" {mc "Author:"}}
3797 {committer t15 . "--committer=*" {mc "Committer:"}}
3798 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3799 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3800 {changes_l l + {} {mc "Changes to Files:"}}
3801 {pickaxe_s r0 . {} {mc "Fixed String"}}
3802 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3803 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3804 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3805 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3806 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3807 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3808 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3809 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3810 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3811 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3812 {lright b . "--left-right" {mc "Mark branch sides"}}
3813 {first b . "--first-parent" {mc "Limit to first parent"}}
3814 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3815 {args t50 *. {} {mc "Additional arguments to git log:"}}
3816 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3817 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3820 proc encode_view_opts {n} {
3821 global known_view_options newviewopts
3824 foreach opt $known_view_options {
3825 set patterns [lindex $opt 3]
3826 if {$patterns eq {}} continue
3827 set pattern [lindex $patterns 0]
3829 if {[lindex $opt 1] eq "b"} {
3830 set val $newviewopts($n,[lindex $opt 0])
3832 lappend rargs $pattern
3834 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3835 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3836 set val $newviewopts($n,$button_id)
3837 if {$val eq $value} {
3838 lappend rargs $pattern
3841 set val $newviewopts($n,[lindex $opt 0])
3842 set val [string trim $val]
3844 set pfix [string range $pattern 0 end-1]
3845 lappend rargs $pfix$val
3849 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3850 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3853 proc decode_view_opts {n view_args} {
3854 global known_view_options newviewopts
3856 foreach opt $known_view_options {
3857 set id [lindex $opt 0]
3858 if {[lindex $opt 1] eq "b"} {
3861 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3863 regexp {^(.*_)} $id uselessvar id
3869 set newviewopts($n,$id) $val
3873 foreach arg $view_args {
3874 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3875 && ![info exists found(limit)]} {
3876 set newviewopts($n,limit) $cnt
3881 foreach opt $known_view_options {
3882 set id [lindex $opt 0]
3883 if {[info exists found($id)]} continue
3884 foreach pattern [lindex $opt 3] {
3885 if {![string match $pattern $arg]} continue
3886 if {[lindex $opt 1] eq "b"} {
3889 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3891 regexp {^(.*_)} $id uselessvar id
3895 set size [string length $pattern]
3896 set val [string range $arg [expr {$size-1}] end]
3898 set newviewopts($n,$id) $val
3902 if {[info exists val]} break
3904 if {[info exists val]} continue
3905 if {[regexp {^-} $arg]} {
3908 lappend refargs $arg
3911 set newviewopts($n,refs) [shellarglist $refargs]
3912 set newviewopts($n,args) [shellarglist $oargs]
3915 proc edit_or_newview {} {
3927 global viewname viewperm newviewname newviewopts
3928 global viewargs viewargscmd
3930 set top .gitkvedit-$curview
3931 if {[winfo exists $top]} {
3935 set newviewname($curview) $viewname($curview)
3936 set newviewopts($curview,perm) $viewperm($curview)
3937 set newviewopts($curview,cmd) $viewargscmd($curview)
3938 decode_view_opts $curview $viewargs($curview)
3939 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3942 proc vieweditor {top n title} {
3943 global newviewname newviewopts viewfiles bgcolor
3944 global known_view_options NS
3947 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3948 make_transient $top .
3951 ${NS}::frame $top.nfr
3952 ${NS}::label $top.nl -text [mc "View Name"]
3953 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
3954 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3955 pack $top.nl -in $top.nfr -side left -padx {0 5}
3956 pack $top.name -in $top.nfr -side left -padx {0 25}
3962 foreach opt $known_view_options {
3963 set id [lindex $opt 0]
3964 set type [lindex $opt 1]
3965 set flags [lindex $opt 2]
3966 set title [eval [lindex $opt 4]]
3969 if {$flags eq "+" || $flags eq "*"} {
3970 set cframe $top.fr$cnt
3972 ${NS}::frame $cframe
3973 pack $cframe -in $top -fill x -pady 3 -padx 3
3974 set cexpand [expr {$flags eq "*"}]
3975 } elseif {$flags eq ".." || $flags eq "*."} {
3976 set cframe $top.fr$cnt
3978 ${NS}::frame $cframe
3979 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
3980 set cexpand [expr {$flags eq "*."}]
3986 ${NS}::label $cframe.l_$id -text $title
3987 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
3988 } elseif {$type eq "b"} {
3989 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3990 pack $cframe.c_$id -in $cframe -side left \
3991 -padx [list $lxpad 0] -expand $cexpand -anchor w
3992 } elseif {[regexp {^r(\d+)$} $type type sz]} {
3993 regexp {^(.*_)} $id uselessvar button_id
3994 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
3995 pack $cframe.c_$id -in $cframe -side left \
3996 -padx [list $lxpad 0] -expand $cexpand -anchor w
3997 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3998 ${NS}::label $cframe.l_$id -text $title
3999 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4000 -textvariable newviewopts($n,$id)
4001 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4002 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4003 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4004 ${NS}::label $cframe.l_$id -text $title
4005 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4006 -textvariable newviewopts($n,$id)
4007 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4008 pack $cframe.e_$id -in $cframe -side top -fill x
4009 } elseif {$type eq "path"} {
4010 ${NS}::label $top.l -text $title
4011 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4012 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
4013 if {[info exists viewfiles($n)]} {
4014 foreach f $viewfiles($n) {
4015 $top.t insert end $f
4016 $top.t insert end "\n"
4018 $top.t delete {end - 1c} end
4019 $top.t mark set insert 0.0
4021 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4025 ${NS}::frame $top.buts
4026 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4027 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4028 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4029 bind $top <Control-Return> [list newviewok $top $n]
4030 bind $top <F5> [list newviewok $top $n 1]
4031 bind $top <Escape> [list destroy $top]
4032 grid $top.buts.ok $top.buts.apply $top.buts.can
4033 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4034 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4035 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4036 pack $top.buts -in $top -side top -fill x
4040 proc doviewmenu {m first cmd op argv} {
4041 set nmenu [$m index end]
4042 for {set i $first} {$i <= $nmenu} {incr i} {
4043 if {[$m entrycget $i -command] eq $cmd} {
4044 eval $m $op $i $argv
4050 proc allviewmenus {n op args} {
4053 doviewmenu .bar.view 5 [list showview $n] $op $args
4054 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4057 proc newviewok {top n {apply 0}} {
4058 global nextviewnum newviewperm newviewname newishighlight
4059 global viewname viewfiles viewperm selectedview curview
4060 global viewargs viewargscmd newviewopts viewhlmenu
4063 set newargs [encode_view_opts $n]
4065 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4069 foreach f [split [$top.t get 0.0 end] "\n"] {
4070 set ft [string trim $f]
4075 if {![info exists viewfiles($n)]} {
4076 # creating a new view
4078 set viewname($n) $newviewname($n)
4079 set viewperm($n) $newviewopts($n,perm)
4080 set viewfiles($n) $files
4081 set viewargs($n) $newargs
4082 set viewargscmd($n) $newviewopts($n,cmd)
4084 if {!$newishighlight} {
4087 run addvhighlight $n
4090 # editing an existing view
4091 set viewperm($n) $newviewopts($n,perm)
4092 if {$newviewname($n) ne $viewname($n)} {
4093 set viewname($n) $newviewname($n)
4094 doviewmenu .bar.view 5 [list showview $n] \
4095 entryconf [list -label $viewname($n)]
4096 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4097 # entryconf [list -label $viewname($n) -value $viewname($n)]
4099 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4100 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4101 set viewfiles($n) $files
4102 set viewargs($n) $newargs
4103 set viewargscmd($n) $newviewopts($n,cmd)
4104 if {$curview == $n} {
4110 catch {destroy $top}
4114 global curview viewperm hlview selectedhlview
4116 if {$curview == 0} return
4117 if {[info exists hlview] && $hlview == $curview} {
4118 set selectedhlview [mc "None"]
4121 allviewmenus $curview delete
4122 set viewperm($curview) 0
4126 proc addviewmenu {n} {
4127 global viewname viewhlmenu
4129 .bar.view add radiobutton -label $viewname($n) \
4130 -command [list showview $n] -variable selectedview -value $n
4131 #$viewhlmenu add radiobutton -label $viewname($n) \
4132 # -command [list addvhighlight $n] -variable selectedhlview
4136 global curview cached_commitrow ordertok
4137 global displayorder parentlist rowidlist rowisopt rowfinal
4138 global colormap rowtextx nextcolor canvxmax
4139 global numcommits viewcomplete
4140 global selectedline currentid canv canvy0
4142 global pending_select mainheadid
4145 global hlview selectedhlview commitinterest
4147 if {$n == $curview} return
4149 set ymax [lindex [$canv cget -scrollregion] 3]
4150 set span [$canv yview]
4151 set ytop [expr {[lindex $span 0] * $ymax}]
4152 set ybot [expr {[lindex $span 1] * $ymax}]
4153 set yscreen [expr {($ybot - $ytop) / 2}]
4154 if {$selectedline ne {}} {
4155 set selid $currentid
4156 set y [yc $selectedline]
4157 if {$ytop < $y && $y < $ybot} {
4158 set yscreen [expr {$y - $ytop}]
4160 } elseif {[info exists pending_select]} {
4161 set selid $pending_select
4162 unset pending_select
4166 catch {unset treediffs}
4168 if {[info exists hlview] && $hlview == $n} {
4170 set selectedhlview [mc "None"]
4172 catch {unset commitinterest}
4173 catch {unset cached_commitrow}
4174 catch {unset ordertok}
4178 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4179 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4182 if {![info exists viewcomplete($n)]} {
4192 set numcommits $commitidx($n)
4194 catch {unset colormap}
4195 catch {unset rowtextx}
4197 set canvxmax [$canv cget -width]
4203 if {$selid ne {} && [commitinview $selid $n]} {
4204 set row [rowofcommit $selid]
4205 # try to get the selected row in the same position on the screen
4206 set ymax [lindex [$canv cget -scrollregion] 3]
4207 set ytop [expr {[yc $row] - $yscreen}]
4211 set yf [expr {$ytop * 1.0 / $ymax}]
4213 allcanvs yview moveto $yf
4217 } elseif {!$viewcomplete($n)} {
4218 reset_pending_select $selid
4220 reset_pending_select {}
4222 if {[commitinview $pending_select $curview]} {
4223 selectline [rowofcommit $pending_select] 1
4225 set row [first_real_row]
4226 if {$row < $numcommits} {
4231 if {!$viewcomplete($n)} {
4232 if {$numcommits == 0} {
4233 show_status [mc "Reading commits..."]
4235 } elseif {$numcommits == 0} {
4236 show_status [mc "No commits selected"]
4240 # Stuff relating to the highlighting facility
4242 proc ishighlighted {id} {
4243 global vhighlights fhighlights nhighlights rhighlights
4245 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4246 return $nhighlights($id)
4248 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4249 return $vhighlights($id)
4251 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4252 return $fhighlights($id)
4254 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4255 return $rhighlights($id)
4260 proc bolden {id font} {
4261 global canv linehtag currentid boldids need_redisplay markedid
4263 # need_redisplay = 1 means the display is stale and about to be redrawn
4264 if {$need_redisplay} return
4266 $canv itemconf $linehtag($id) -font $font
4267 if {[info exists currentid] && $id eq $currentid} {
4269 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4270 -outline {{}} -tags secsel \
4271 -fill [$canv cget -selectbackground]]
4274 if {[info exists markedid] && $id eq $markedid} {
4279 proc bolden_name {id font} {
4280 global canv2 linentag currentid boldnameids need_redisplay
4282 if {$need_redisplay} return
4283 lappend boldnameids $id
4284 $canv2 itemconf $linentag($id) -font $font
4285 if {[info exists currentid] && $id eq $currentid} {
4286 $canv2 delete secsel
4287 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4288 -outline {{}} -tags secsel \
4289 -fill [$canv2 cget -selectbackground]]
4298 foreach id $boldids {
4299 if {![ishighlighted $id]} {
4302 lappend stillbold $id
4305 set boldids $stillbold
4308 proc addvhighlight {n} {
4309 global hlview viewcomplete curview vhl_done commitidx
4311 if {[info exists hlview]} {
4315 if {$n != $curview && ![info exists viewcomplete($n)]} {
4318 set vhl_done $commitidx($hlview)
4319 if {$vhl_done > 0} {
4324 proc delvhighlight {} {
4325 global hlview vhighlights
4327 if {![info exists hlview]} return
4329 catch {unset vhighlights}
4333 proc vhighlightmore {} {
4334 global hlview vhl_done commitidx vhighlights curview
4336 set max $commitidx($hlview)
4337 set vr [visiblerows]
4338 set r0 [lindex $vr 0]
4339 set r1 [lindex $vr 1]
4340 for {set i $vhl_done} {$i < $max} {incr i} {
4341 set id [commitonrow $i $hlview]
4342 if {[commitinview $id $curview]} {
4343 set row [rowofcommit $id]
4344 if {$r0 <= $row && $row <= $r1} {
4345 if {![highlighted $row]} {
4346 bolden $id mainfontbold
4348 set vhighlights($id) 1
4356 proc askvhighlight {row id} {
4357 global hlview vhighlights iddrawn
4359 if {[commitinview $id $hlview]} {
4360 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4361 bolden $id mainfontbold
4363 set vhighlights($id) 1
4365 set vhighlights($id) 0
4369 proc hfiles_change {} {
4370 global highlight_files filehighlight fhighlights fh_serial
4371 global highlight_paths
4373 if {[info exists filehighlight]} {
4374 # delete previous highlights
4375 catch {close $filehighlight}
4377 catch {unset fhighlights}
4379 unhighlight_filelist
4381 set highlight_paths {}
4382 after cancel do_file_hl $fh_serial
4384 if {$highlight_files ne {}} {
4385 after 300 do_file_hl $fh_serial
4389 proc gdttype_change {name ix op} {
4390 global gdttype highlight_files findstring findpattern
4393 if {$findstring ne {}} {
4394 if {$gdttype eq [mc "containing:"]} {
4395 if {$highlight_files ne {}} {
4396 set highlight_files {}
4401 if {$findpattern ne {}} {
4405 set highlight_files $findstring
4410 # enable/disable findtype/findloc menus too
4413 proc find_change {name ix op} {
4414 global gdttype findstring highlight_files
4417 if {$gdttype eq [mc "containing:"]} {
4420 if {$highlight_files ne $findstring} {
4421 set highlight_files $findstring
4428 proc findcom_change args {
4429 global nhighlights boldnameids
4430 global findpattern findtype findstring gdttype
4433 # delete previous highlights, if any
4434 foreach id $boldnameids {
4435 bolden_name $id mainfont
4438 catch {unset nhighlights}
4441 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4443 } elseif {$findtype eq [mc "Regexp"]} {
4444 set findpattern $findstring
4446 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4448 set findpattern "*$e*"
4452 proc makepatterns {l} {
4455 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4456 if {[string index $ee end] eq "/"} {
4466 proc do_file_hl {serial} {
4467 global highlight_files filehighlight highlight_paths gdttype fhl_list
4469 if {$gdttype eq [mc "touching paths:"]} {
4470 if {[catch {set paths [shellsplit $highlight_files]}]} return
4471 set highlight_paths [makepatterns $paths]
4473 set gdtargs [concat -- $paths]
4474 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4475 set gdtargs [list "-S$highlight_files"]
4477 # must be "containing:", i.e. we're searching commit info
4480 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4481 set filehighlight [open $cmd r+]
4482 fconfigure $filehighlight -blocking 0
4483 filerun $filehighlight readfhighlight
4489 proc flushhighlights {} {
4490 global filehighlight fhl_list
4492 if {[info exists filehighlight]} {
4494 puts $filehighlight ""
4495 flush $filehighlight
4499 proc askfilehighlight {row id} {
4500 global filehighlight fhighlights fhl_list
4502 lappend fhl_list $id
4503 set fhighlights($id) -1
4504 puts $filehighlight $id
4507 proc readfhighlight {} {
4508 global filehighlight fhighlights curview iddrawn
4509 global fhl_list find_dirn
4511 if {![info exists filehighlight]} {
4515 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4516 set line [string trim $line]
4517 set i [lsearch -exact $fhl_list $line]
4518 if {$i < 0} continue
4519 for {set j 0} {$j < $i} {incr j} {
4520 set id [lindex $fhl_list $j]
4521 set fhighlights($id) 0
4523 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4524 if {$line eq {}} continue
4525 if {![commitinview $line $curview]} continue
4526 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4527 bolden $line mainfontbold
4529 set fhighlights($line) 1
4531 if {[eof $filehighlight]} {
4533 puts "oops, git diff-tree died"
4534 catch {close $filehighlight}
4538 if {[info exists find_dirn]} {
4544 proc doesmatch {f} {
4545 global findtype findpattern
4547 if {$findtype eq [mc "Regexp"]} {
4548 return [regexp $findpattern $f]
4549 } elseif {$findtype eq [mc "IgnCase"]} {
4550 return [string match -nocase $findpattern $f]
4552 return [string match $findpattern $f]
4556 proc askfindhighlight {row id} {
4557 global nhighlights commitinfo iddrawn
4559 global markingmatches
4561 if {![info exists commitinfo($id)]} {
4564 set info $commitinfo($id)
4566 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4567 foreach f $info ty $fldtypes {
4568 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4570 if {$ty eq [mc "Author"]} {
4577 if {$isbold && [info exists iddrawn($id)]} {
4578 if {![ishighlighted $id]} {
4579 bolden $id mainfontbold
4581 bolden_name $id mainfontbold
4584 if {$markingmatches} {
4585 markrowmatches $row $id
4588 set nhighlights($id) $isbold
4591 proc markrowmatches {row id} {
4592 global canv canv2 linehtag linentag commitinfo findloc
4594 set headline [lindex $commitinfo($id) 0]
4595 set author [lindex $commitinfo($id) 1]
4596 $canv delete match$row
4597 $canv2 delete match$row
4598 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4599 set m [findmatches $headline]
4601 markmatches $canv $row $headline $linehtag($id) $m \
4602 [$canv itemcget $linehtag($id) -font] $row
4605 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4606 set m [findmatches $author]
4608 markmatches $canv2 $row $author $linentag($id) $m \
4609 [$canv2 itemcget $linentag($id) -font] $row
4614 proc vrel_change {name ix op} {
4615 global highlight_related
4618 if {$highlight_related ne [mc "None"]} {
4623 # prepare for testing whether commits are descendents or ancestors of a
4624 proc rhighlight_sel {a} {
4625 global descendent desc_todo ancestor anc_todo
4626 global highlight_related
4628 catch {unset descendent}
4629 set desc_todo [list $a]
4630 catch {unset ancestor}
4631 set anc_todo [list $a]
4632 if {$highlight_related ne [mc "None"]} {
4638 proc rhighlight_none {} {
4641 catch {unset rhighlights}
4645 proc is_descendent {a} {
4646 global curview children descendent desc_todo
4649 set la [rowofcommit $a]
4653 for {set i 0} {$i < [llength $todo]} {incr i} {
4654 set do [lindex $todo $i]
4655 if {[rowofcommit $do] < $la} {
4656 lappend leftover $do
4659 foreach nk $children($v,$do) {
4660 if {![info exists descendent($nk)]} {
4661 set descendent($nk) 1
4669 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4673 set descendent($a) 0
4674 set desc_todo $leftover
4677 proc is_ancestor {a} {
4678 global curview parents ancestor anc_todo
4681 set la [rowofcommit $a]
4685 for {set i 0} {$i < [llength $todo]} {incr i} {
4686 set do [lindex $todo $i]
4687 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4688 lappend leftover $do
4691 foreach np $parents($v,$do) {
4692 if {![info exists ancestor($np)]} {
4701 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4706 set anc_todo $leftover
4709 proc askrelhighlight {row id} {
4710 global descendent highlight_related iddrawn rhighlights
4711 global selectedline ancestor
4713 if {$selectedline eq {}} return
4715 if {$highlight_related eq [mc "Descendant"] ||
4716 $highlight_related eq [mc "Not descendant"]} {
4717 if {![info exists descendent($id)]} {
4720 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4723 } elseif {$highlight_related eq [mc "Ancestor"] ||
4724 $highlight_related eq [mc "Not ancestor"]} {
4725 if {![info exists ancestor($id)]} {
4728 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4732 if {[info exists iddrawn($id)]} {
4733 if {$isbold && ![ishighlighted $id]} {
4734 bolden $id mainfontbold
4737 set rhighlights($id) $isbold
4740 # Graph layout functions
4742 proc shortids {ids} {
4745 if {[llength $id] > 1} {
4746 lappend res [shortids $id]
4747 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4748 lappend res [string range $id 0 7]
4759 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4760 if {($n & $mask) != 0} {
4761 set ret [concat $ret $o]
4763 set o [concat $o $o]
4768 proc ordertoken {id} {
4769 global ordertok curview varcid varcstart varctok curview parents children
4770 global nullid nullid2
4772 if {[info exists ordertok($id)]} {
4773 return $ordertok($id)
4778 if {[info exists varcid($curview,$id)]} {
4779 set a $varcid($curview,$id)
4780 set p [lindex $varcstart($curview) $a]
4782 set p [lindex $children($curview,$id) 0]
4784 if {[info exists ordertok($p)]} {
4785 set tok $ordertok($p)
4788 set id [first_real_child $curview,$p]
4791 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4794 if {[llength $parents($curview,$id)] == 1} {
4795 lappend todo [list $p {}]
4797 set j [lsearch -exact $parents($curview,$id) $p]
4799 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4801 lappend todo [list $p [strrep $j]]
4804 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4805 set p [lindex $todo $i 0]
4806 append tok [lindex $todo $i 1]
4807 set ordertok($p) $tok
4809 set ordertok($origid) $tok
4813 # Work out where id should go in idlist so that order-token
4814 # values increase from left to right
4815 proc idcol {idlist id {i 0}} {
4816 set t [ordertoken $id]
4820 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4821 if {$i > [llength $idlist]} {
4822 set i [llength $idlist]
4824 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4827 if {$t > [ordertoken [lindex $idlist $i]]} {
4828 while {[incr i] < [llength $idlist] &&
4829 $t >= [ordertoken [lindex $idlist $i]]} {}
4835 proc initlayout {} {
4836 global rowidlist rowisopt rowfinal displayorder parentlist
4837 global numcommits canvxmax canv
4839 global colormap rowtextx
4848 set canvxmax [$canv cget -width]
4849 catch {unset colormap}
4850 catch {unset rowtextx}
4854 proc setcanvscroll {} {
4855 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4856 global lastscrollset lastscrollrows
4858 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4859 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4860 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4861 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4862 set lastscrollset [clock clicks -milliseconds]
4863 set lastscrollrows $numcommits
4866 proc visiblerows {} {
4867 global canv numcommits linespc
4869 set ymax [lindex [$canv cget -scrollregion] 3]
4870 if {$ymax eq {} || $ymax == 0} return
4872 set y0 [expr {int([lindex $f 0] * $ymax)}]
4873 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4877 set y1 [expr {int([lindex $f 1] * $ymax)}]
4878 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4879 if {$r1 >= $numcommits} {
4880 set r1 [expr {$numcommits - 1}]
4882 return [list $r0 $r1]
4885 proc layoutmore {} {
4886 global commitidx viewcomplete curview
4887 global numcommits pending_select curview
4888 global lastscrollset lastscrollrows
4890 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4891 [clock clicks -milliseconds] - $lastscrollset > 500} {
4894 if {[info exists pending_select] &&
4895 [commitinview $pending_select $curview]} {
4897 selectline [rowofcommit $pending_select] 1
4902 # With path limiting, we mightn't get the actual HEAD commit,
4903 # so ask git rev-list what is the first ancestor of HEAD that
4904 # touches a file in the path limit.
4905 proc get_viewmainhead {view} {
4906 global viewmainheadid vfilelimit viewinstances mainheadid
4909 set rfd [open [concat | git rev-list -1 $mainheadid \
4910 -- $vfilelimit($view)] r]
4911 set j [reg_instance $rfd]
4912 lappend viewinstances($view) $j
4913 fconfigure $rfd -blocking 0
4914 filerun $rfd [list getviewhead $rfd $j $view]
4915 set viewmainheadid($curview) {}
4919 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4920 proc getviewhead {fd inst view} {
4921 global viewmainheadid commfd curview viewinstances showlocalchanges
4924 if {[gets $fd line] < 0} {
4928 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4931 set viewmainheadid($view) $id
4934 set i [lsearch -exact $viewinstances($view) $inst]
4936 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4938 if {$showlocalchanges && $id ne {} && $view == $curview} {
4944 proc doshowlocalchanges {} {
4945 global curview viewmainheadid
4947 if {$viewmainheadid($curview) eq {}} return
4948 if {[commitinview $viewmainheadid($curview) $curview]} {
4951 interestedin $viewmainheadid($curview) dodiffindex
4955 proc dohidelocalchanges {} {
4956 global nullid nullid2 lserial curview
4958 if {[commitinview $nullid $curview]} {
4959 removefakerow $nullid
4961 if {[commitinview $nullid2 $curview]} {
4962 removefakerow $nullid2
4967 # spawn off a process to do git diff-index --cached HEAD
4968 proc dodiffindex {} {
4969 global lserial showlocalchanges vfilelimit curview
4972 if {!$showlocalchanges || !$isworktree} return
4974 set cmd "|git diff-index --cached HEAD"
4975 if {$vfilelimit($curview) ne {}} {
4976 set cmd [concat $cmd -- $vfilelimit($curview)]
4978 set fd [open $cmd r]
4979 fconfigure $fd -blocking 0
4980 set i [reg_instance $fd]
4981 filerun $fd [list readdiffindex $fd $lserial $i]
4984 proc readdiffindex {fd serial inst} {
4985 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4989 if {[gets $fd line] < 0} {
4995 # we only need to see one line and we don't really care what it says...
4998 if {$serial != $lserial} {
5002 # now see if there are any local changes not checked in to the index
5003 set cmd "|git diff-files"
5004 if {$vfilelimit($curview) ne {}} {
5005 set cmd [concat $cmd -- $vfilelimit($curview)]
5007 set fd [open $cmd r]
5008 fconfigure $fd -blocking 0
5009 set i [reg_instance $fd]
5010 filerun $fd [list readdifffiles $fd $serial $i]
5012 if {$isdiff && ![commitinview $nullid2 $curview]} {
5013 # add the line for the changes in the index to the graph
5014 set hl [mc "Local changes checked in to index but not committed"]
5015 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5016 set commitdata($nullid2) "\n $hl\n"
5017 if {[commitinview $nullid $curview]} {
5018 removefakerow $nullid
5020 insertfakerow $nullid2 $viewmainheadid($curview)
5021 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5022 if {[commitinview $nullid $curview]} {
5023 removefakerow $nullid
5025 removefakerow $nullid2
5030 proc readdifffiles {fd serial inst} {
5031 global viewmainheadid nullid nullid2 curview
5032 global commitinfo commitdata lserial
5035 if {[gets $fd line] < 0} {
5041 # we only need to see one line and we don't really care what it says...
5044 if {$serial != $lserial} {
5048 if {$isdiff && ![commitinview $nullid $curview]} {
5049 # add the line for the local diff to the graph
5050 set hl [mc "Local uncommitted changes, not checked in to index"]
5051 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5052 set commitdata($nullid) "\n $hl\n"
5053 if {[commitinview $nullid2 $curview]} {
5056 set p $viewmainheadid($curview)
5058 insertfakerow $nullid $p
5059 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5060 removefakerow $nullid
5065 proc nextuse {id row} {
5066 global curview children
5068 if {[info exists children($curview,$id)]} {
5069 foreach kid $children($curview,$id) {
5070 if {![commitinview $kid $curview]} {
5073 if {[rowofcommit $kid] > $row} {
5074 return [rowofcommit $kid]
5078 if {[commitinview $id $curview]} {
5079 return [rowofcommit $id]
5084 proc prevuse {id row} {
5085 global curview children
5088 if {[info exists children($curview,$id)]} {
5089 foreach kid $children($curview,$id) {
5090 if {![commitinview $kid $curview]} break
5091 if {[rowofcommit $kid] < $row} {
5092 set ret [rowofcommit $kid]
5099 proc make_idlist {row} {
5100 global displayorder parentlist uparrowlen downarrowlen mingaplen
5101 global commitidx curview children
5103 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5107 set ra [expr {$row - $downarrowlen}]
5111 set rb [expr {$row + $uparrowlen}]
5112 if {$rb > $commitidx($curview)} {
5113 set rb $commitidx($curview)
5115 make_disporder $r [expr {$rb + 1}]
5117 for {} {$r < $ra} {incr r} {
5118 set nextid [lindex $displayorder [expr {$r + 1}]]
5119 foreach p [lindex $parentlist $r] {
5120 if {$p eq $nextid} continue
5121 set rn [nextuse $p $r]
5123 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5124 lappend ids [list [ordertoken $p] $p]
5128 for {} {$r < $row} {incr r} {
5129 set nextid [lindex $displayorder [expr {$r + 1}]]
5130 foreach p [lindex $parentlist $r] {
5131 if {$p eq $nextid} continue
5132 set rn [nextuse $p $r]
5133 if {$rn < 0 || $rn >= $row} {
5134 lappend ids [list [ordertoken $p] $p]
5138 set id [lindex $displayorder $row]
5139 lappend ids [list [ordertoken $id] $id]
5141 foreach p [lindex $parentlist $r] {
5142 set firstkid [lindex $children($curview,$p) 0]
5143 if {[rowofcommit $firstkid] < $row} {
5144 lappend ids [list [ordertoken $p] $p]
5148 set id [lindex $displayorder $r]
5150 set firstkid [lindex $children($curview,$id) 0]
5151 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5152 lappend ids [list [ordertoken $id] $id]
5157 foreach idx [lsort -unique $ids] {
5158 lappend idlist [lindex $idx 1]
5163 proc rowsequal {a b} {
5164 while {[set i [lsearch -exact $a {}]] >= 0} {
5165 set a [lreplace $a $i $i]
5167 while {[set i [lsearch -exact $b {}]] >= 0} {
5168 set b [lreplace $b $i $i]
5170 return [expr {$a eq $b}]
5173 proc makeupline {id row rend col} {
5174 global rowidlist uparrowlen downarrowlen mingaplen
5176 for {set r $rend} {1} {set r $rstart} {
5177 set rstart [prevuse $id $r]
5178 if {$rstart < 0} return
5179 if {$rstart < $row} break
5181 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5182 set rstart [expr {$rend - $uparrowlen - 1}]
5184 for {set r $rstart} {[incr r] <= $row} {} {
5185 set idlist [lindex $rowidlist $r]
5186 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5187 set col [idcol $idlist $id $col]
5188 lset rowidlist $r [linsert $idlist $col $id]
5194 proc layoutrows {row endrow} {
5195 global rowidlist rowisopt rowfinal displayorder
5196 global uparrowlen downarrowlen maxwidth mingaplen
5197 global children parentlist
5198 global commitidx viewcomplete curview
5200 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5203 set rm1 [expr {$row - 1}]
5204 foreach id [lindex $rowidlist $rm1] {
5209 set final [lindex $rowfinal $rm1]
5211 for {} {$row < $endrow} {incr row} {
5212 set rm1 [expr {$row - 1}]
5213 if {$rm1 < 0 || $idlist eq {}} {
5214 set idlist [make_idlist $row]
5217 set id [lindex $displayorder $rm1]
5218 set col [lsearch -exact $idlist $id]
5219 set idlist [lreplace $idlist $col $col]
5220 foreach p [lindex $parentlist $rm1] {
5221 if {[lsearch -exact $idlist $p] < 0} {
5222 set col [idcol $idlist $p $col]
5223 set idlist [linsert $idlist $col $p]
5224 # if not the first child, we have to insert a line going up
5225 if {$id ne [lindex $children($curview,$p) 0]} {
5226 makeupline $p $rm1 $row $col
5230 set id [lindex $displayorder $row]
5231 if {$row > $downarrowlen} {
5232 set termrow [expr {$row - $downarrowlen - 1}]
5233 foreach p [lindex $parentlist $termrow] {
5234 set i [lsearch -exact $idlist $p]
5235 if {$i < 0} continue
5236 set nr [nextuse $p $termrow]
5237 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5238 set idlist [lreplace $idlist $i $i]
5242 set col [lsearch -exact $idlist $id]
5244 set col [idcol $idlist $id]
5245 set idlist [linsert $idlist $col $id]
5246 if {$children($curview,$id) ne {}} {
5247 makeupline $id $rm1 $row $col
5250 set r [expr {$row + $uparrowlen - 1}]
5251 if {$r < $commitidx($curview)} {
5253 foreach p [lindex $parentlist $r] {
5254 if {[lsearch -exact $idlist $p] >= 0} continue
5255 set fk [lindex $children($curview,$p) 0]
5256 if {[rowofcommit $fk] < $row} {
5257 set x [idcol $idlist $p $x]
5258 set idlist [linsert $idlist $x $p]
5261 if {[incr r] < $commitidx($curview)} {
5262 set p [lindex $displayorder $r]
5263 if {[lsearch -exact $idlist $p] < 0} {
5264 set fk [lindex $children($curview,$p) 0]
5265 if {$fk ne {} && [rowofcommit $fk] < $row} {
5266 set x [idcol $idlist $p $x]
5267 set idlist [linsert $idlist $x $p]
5273 if {$final && !$viewcomplete($curview) &&
5274 $row + $uparrowlen + $mingaplen + $downarrowlen
5275 >= $commitidx($curview)} {
5278 set l [llength $rowidlist]
5280 lappend rowidlist $idlist
5282 lappend rowfinal $final
5283 } elseif {$row < $l} {
5284 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5285 lset rowidlist $row $idlist
5288 lset rowfinal $row $final
5290 set pad [ntimes [expr {$row - $l}] {}]
5291 set rowidlist [concat $rowidlist $pad]
5292 lappend rowidlist $idlist
5293 set rowfinal [concat $rowfinal $pad]
5294 lappend rowfinal $final
5295 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5301 proc changedrow {row} {
5302 global displayorder iddrawn rowisopt need_redisplay
5304 set l [llength $rowisopt]
5306 lset rowisopt $row 0
5307 if {$row + 1 < $l} {
5308 lset rowisopt [expr {$row + 1}] 0
5309 if {$row + 2 < $l} {
5310 lset rowisopt [expr {$row + 2}] 0
5314 set id [lindex $displayorder $row]
5315 if {[info exists iddrawn($id)]} {
5316 set need_redisplay 1
5320 proc insert_pad {row col npad} {
5323 set pad [ntimes $npad {}]
5324 set idlist [lindex $rowidlist $row]
5325 set bef [lrange $idlist 0 [expr {$col - 1}]]
5326 set aft [lrange $idlist $col end]
5327 set i [lsearch -exact $aft {}]
5329 set aft [lreplace $aft $i $i]
5331 lset rowidlist $row [concat $bef $pad $aft]
5335 proc optimize_rows {row col endrow} {
5336 global rowidlist rowisopt displayorder curview children
5341 for {} {$row < $endrow} {incr row; set col 0} {
5342 if {[lindex $rowisopt $row]} continue
5344 set y0 [expr {$row - 1}]
5345 set ym [expr {$row - 2}]
5346 set idlist [lindex $rowidlist $row]
5347 set previdlist [lindex $rowidlist $y0]
5348 if {$idlist eq {} || $previdlist eq {}} continue
5350 set pprevidlist [lindex $rowidlist $ym]
5351 if {$pprevidlist eq {}} continue
5357 for {} {$col < [llength $idlist]} {incr col} {
5358 set id [lindex $idlist $col]
5359 if {[lindex $previdlist $col] eq $id} continue
5364 set x0 [lsearch -exact $previdlist $id]
5365 if {$x0 < 0} continue
5366 set z [expr {$x0 - $col}]
5370 set xm [lsearch -exact $pprevidlist $id]
5372 set z0 [expr {$xm - $x0}]
5376 # if row y0 is the first child of $id then it's not an arrow
5377 if {[lindex $children($curview,$id) 0] ne
5378 [lindex $displayorder $y0]} {
5382 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5383 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5386 # Looking at lines from this row to the previous row,
5387 # make them go straight up if they end in an arrow on
5388 # the previous row; otherwise make them go straight up
5390 if {$z < -1 || ($z < 0 && $isarrow)} {
5391 # Line currently goes left too much;
5392 # insert pads in the previous row, then optimize it
5393 set npad [expr {-1 - $z + $isarrow}]
5394 insert_pad $y0 $x0 $npad
5396 optimize_rows $y0 $x0 $row
5398 set previdlist [lindex $rowidlist $y0]
5399 set x0 [lsearch -exact $previdlist $id]
5400 set z [expr {$x0 - $col}]
5402 set pprevidlist [lindex $rowidlist $ym]
5403 set xm [lsearch -exact $pprevidlist $id]
5404 set z0 [expr {$xm - $x0}]
5406 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5407 # Line currently goes right too much;
5408 # insert pads in this line
5409 set npad [expr {$z - 1 + $isarrow}]
5410 insert_pad $row $col $npad
5411 set idlist [lindex $rowidlist $row]
5413 set z [expr {$x0 - $col}]
5416 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5417 # this line links to its first child on row $row-2
5418 set id [lindex $displayorder $ym]
5419 set xc [lsearch -exact $pprevidlist $id]
5421 set z0 [expr {$xc - $x0}]
5424 # avoid lines jigging left then immediately right
5425 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5426 insert_pad $y0 $x0 1
5428 optimize_rows $y0 $x0 $row
5429 set previdlist [lindex $rowidlist $y0]
5433 # Find the first column that doesn't have a line going right
5434 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5435 set id [lindex $idlist $col]
5436 if {$id eq {}} break
5437 set x0 [lsearch -exact $previdlist $id]
5439 # check if this is the link to the first child
5440 set kid [lindex $displayorder $y0]
5441 if {[lindex $children($curview,$id) 0] eq $kid} {
5442 # it is, work out offset to child
5443 set x0 [lsearch -exact $previdlist $kid]
5446 if {$x0 <= $col} break
5448 # Insert a pad at that column as long as it has a line and
5449 # isn't the last column
5450 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5451 set idlist [linsert $idlist $col {}]
5452 lset rowidlist $row $idlist
5460 global canvx0 linespc
5461 return [expr {$canvx0 + $col * $linespc}]
5465 global canvy0 linespc
5466 return [expr {$canvy0 + $row * $linespc}]
5469 proc linewidth {id} {
5470 global thickerline lthickness
5473 if {[info exists thickerline] && $id eq $thickerline} {
5474 set wid [expr {2 * $lthickness}]
5479 proc rowranges {id} {
5480 global curview children uparrowlen downarrowlen
5483 set kids $children($curview,$id)
5489 foreach child $kids {
5490 if {![commitinview $child $curview]} break
5491 set row [rowofcommit $child]
5492 if {![info exists prev]} {
5493 lappend ret [expr {$row + 1}]
5495 if {$row <= $prevrow} {
5496 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5498 # see if the line extends the whole way from prevrow to row
5499 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5500 [lsearch -exact [lindex $rowidlist \
5501 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5502 # it doesn't, see where it ends
5503 set r [expr {$prevrow + $downarrowlen}]
5504 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5505 while {[incr r -1] > $prevrow &&
5506 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5508 while {[incr r] <= $row &&
5509 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5513 # see where it starts up again
5514 set r [expr {$row - $uparrowlen}]
5515 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5516 while {[incr r] < $row &&
5517 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5519 while {[incr r -1] >= $prevrow &&
5520 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5526 if {$child eq $id} {
5535 proc drawlineseg {id row endrow arrowlow} {
5536 global rowidlist displayorder iddrawn linesegs
5537 global canv colormap linespc curview maxlinelen parentlist
5539 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5540 set le [expr {$row + 1}]
5543 set c [lsearch -exact [lindex $rowidlist $le] $id]
5549 set x [lindex $displayorder $le]
5554 if {[info exists iddrawn($x)] || $le == $endrow} {
5555 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5571 if {[info exists linesegs($id)]} {
5572 set lines $linesegs($id)
5574 set r0 [lindex $li 0]
5576 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5586 set li [lindex $lines [expr {$i-1}]]
5587 set r1 [lindex $li 1]
5588 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5593 set x [lindex $cols [expr {$le - $row}]]
5594 set xp [lindex $cols [expr {$le - 1 - $row}]]
5595 set dir [expr {$xp - $x}]
5597 set ith [lindex $lines $i 2]
5598 set coords [$canv coords $ith]
5599 set ah [$canv itemcget $ith -arrow]
5600 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5601 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5602 if {$x2 ne {} && $x - $x2 == $dir} {
5603 set coords [lrange $coords 0 end-2]
5606 set coords [list [xc $le $x] [yc $le]]
5609 set itl [lindex $lines [expr {$i-1}] 2]
5610 set al [$canv itemcget $itl -arrow]
5611 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5612 } elseif {$arrowlow} {
5613 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5614 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5618 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5619 for {set y $le} {[incr y -1] > $row} {} {
5621 set xp [lindex $cols [expr {$y - 1 - $row}]]
5622 set ndir [expr {$xp - $x}]
5623 if {$dir != $ndir || $xp < 0} {
5624 lappend coords [xc $y $x] [yc $y]
5630 # join parent line to first child
5631 set ch [lindex $displayorder $row]
5632 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5634 puts "oops: drawlineseg: child $ch not on row $row"
5635 } elseif {$xc != $x} {
5636 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5637 set d [expr {int(0.5 * $linespc)}]
5640 set x2 [expr {$x1 - $d}]
5642 set x2 [expr {$x1 + $d}]
5645 set y1 [expr {$y2 + $d}]
5646 lappend coords $x1 $y1 $x2 $y2
5647 } elseif {$xc < $x - 1} {
5648 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5649 } elseif {$xc > $x + 1} {
5650 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5654 lappend coords [xc $row $x] [yc $row]
5656 set xn [xc $row $xp]
5658 lappend coords $xn $yn
5662 set t [$canv create line $coords -width [linewidth $id] \
5663 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5666 set lines [linsert $lines $i [list $row $le $t]]
5668 $canv coords $ith $coords
5669 if {$arrow ne $ah} {
5670 $canv itemconf $ith -arrow $arrow
5672 lset lines $i 0 $row
5675 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5676 set ndir [expr {$xo - $xp}]
5677 set clow [$canv coords $itl]
5678 if {$dir == $ndir} {
5679 set clow [lrange $clow 2 end]
5681 set coords [concat $coords $clow]
5683 lset lines [expr {$i-1}] 1 $le
5685 # coalesce two pieces
5687 set b [lindex $lines [expr {$i-1}] 0]
5688 set e [lindex $lines $i 1]
5689 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5691 $canv coords $itl $coords
5692 if {$arrow ne $al} {
5693 $canv itemconf $itl -arrow $arrow
5697 set linesegs($id) $lines
5701 proc drawparentlinks {id row} {
5702 global rowidlist canv colormap curview parentlist
5703 global idpos linespc
5705 set rowids [lindex $rowidlist $row]
5706 set col [lsearch -exact $rowids $id]
5707 if {$col < 0} return
5708 set olds [lindex $parentlist $row]
5709 set row2 [expr {$row + 1}]
5710 set x [xc $row $col]
5713 set d [expr {int(0.5 * $linespc)}]
5714 set ymid [expr {$y + $d}]
5715 set ids [lindex $rowidlist $row2]
5716 # rmx = right-most X coord used
5719 set i [lsearch -exact $ids $p]
5721 puts "oops, parent $p of $id not in list"
5724 set x2 [xc $row2 $i]
5728 set j [lsearch -exact $rowids $p]
5730 # drawlineseg will do this one for us
5734 # should handle duplicated parents here...
5735 set coords [list $x $y]
5737 # if attaching to a vertical segment, draw a smaller
5738 # slant for visual distinctness
5741 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5743 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5745 } elseif {$i < $col && $i < $j} {
5746 # segment slants towards us already
5747 lappend coords [xc $row $j] $y
5749 if {$i < $col - 1} {
5750 lappend coords [expr {$x2 + $linespc}] $y
5751 } elseif {$i > $col + 1} {
5752 lappend coords [expr {$x2 - $linespc}] $y
5754 lappend coords $x2 $y2
5757 lappend coords $x2 $y2
5759 set t [$canv create line $coords -width [linewidth $p] \
5760 -fill $colormap($p) -tags lines.$p]
5764 if {$rmx > [lindex $idpos($id) 1]} {
5765 lset idpos($id) 1 $rmx
5770 proc drawlines {id} {
5773 $canv itemconf lines.$id -width [linewidth $id]
5776 proc drawcmittext {id row col} {
5777 global linespc canv canv2 canv3 fgcolor curview
5778 global cmitlisted commitinfo rowidlist parentlist
5779 global rowtextx idpos idtags idheads idotherrefs
5780 global linehtag linentag linedtag selectedline
5781 global canvxmax boldids boldnameids fgcolor markedid
5782 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5784 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5785 set listed $cmitlisted($curview,$id)
5786 if {$id eq $nullid} {
5788 } elseif {$id eq $nullid2} {
5790 } elseif {$id eq $mainheadid} {
5793 set ofill [lindex $circlecolors $listed]
5795 set x [xc $row $col]
5797 set orad [expr {$linespc / 3}]
5799 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5800 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5801 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5802 } elseif {$listed == 3} {
5803 # triangle pointing left for left-side commits
5804 set t [$canv create polygon \
5805 [expr {$x - $orad}] $y \
5806 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5807 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5808 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5810 # triangle pointing right for right-side commits
5811 set t [$canv create polygon \
5812 [expr {$x + $orad - 1}] $y \
5813 [expr {$x - $orad}] [expr {$y - $orad}] \
5814 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5815 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5817 set circleitem($row) $t
5819 $canv bind $t <1> {selcanvline {} %x %y}
5820 set rmx [llength [lindex $rowidlist $row]]
5821 set olds [lindex $parentlist $row]
5823 set nextids [lindex $rowidlist [expr {$row + 1}]]
5825 set i [lsearch -exact $nextids $p]
5831 set xt [xc $row $rmx]
5832 set rowtextx($row) $xt
5833 set idpos($id) [list $x $xt $y]
5834 if {[info exists idtags($id)] || [info exists idheads($id)]
5835 || [info exists idotherrefs($id)]} {
5836 set xt [drawtags $id $x $xt $y]
5838 set headline [lindex $commitinfo($id) 0]
5839 set name [lindex $commitinfo($id) 1]
5840 set date [lindex $commitinfo($id) 2]
5841 set date [formatdate $date]
5844 set isbold [ishighlighted $id]
5847 set font mainfontbold
5849 lappend boldnameids $id
5850 set nfont mainfontbold
5853 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5854 -text $headline -font $font -tags text]
5855 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5856 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5857 -text $name -font $nfont -tags text]
5858 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5859 -text $date -font mainfont -tags text]
5860 if {$selectedline == $row} {
5863 if {[info exists markedid] && $markedid eq $id} {
5866 set xr [expr {$xt + [font measure $font $headline]}]
5867 if {$xr > $canvxmax} {
5873 proc drawcmitrow {row} {
5874 global displayorder rowidlist nrows_drawn
5875 global iddrawn markingmatches
5876 global commitinfo numcommits
5877 global filehighlight fhighlights findpattern nhighlights
5878 global hlview vhighlights
5879 global highlight_related rhighlights
5881 if {$row >= $numcommits} return
5883 set id [lindex $displayorder $row]
5884 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5885 askvhighlight $row $id
5887 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5888 askfilehighlight $row $id
5890 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5891 askfindhighlight $row $id
5893 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5894 askrelhighlight $row $id
5896 if {![info exists iddrawn($id)]} {
5897 set col [lsearch -exact [lindex $rowidlist $row] $id]
5899 puts "oops, row $row id $id not in list"
5902 if {![info exists commitinfo($id)]} {
5906 drawcmittext $id $row $col
5910 if {$markingmatches} {
5911 markrowmatches $row $id
5915 proc drawcommits {row {endrow {}}} {
5916 global numcommits iddrawn displayorder curview need_redisplay
5917 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5922 if {$endrow eq {}} {
5925 if {$endrow >= $numcommits} {
5926 set endrow [expr {$numcommits - 1}]
5929 set rl1 [expr {$row - $downarrowlen - 3}]
5933 set ro1 [expr {$row - 3}]
5937 set r2 [expr {$endrow + $uparrowlen + 3}]
5938 if {$r2 > $numcommits} {
5941 for {set r $rl1} {$r < $r2} {incr r} {
5942 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5946 set rl1 [expr {$r + 1}]
5952 optimize_rows $ro1 0 $r2
5953 if {$need_redisplay || $nrows_drawn > 2000} {
5957 # make the lines join to already-drawn rows either side
5958 set r [expr {$row - 1}]
5959 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5962 set er [expr {$endrow + 1}]
5963 if {$er >= $numcommits ||
5964 ![info exists iddrawn([lindex $displayorder $er])]} {
5967 for {} {$r <= $er} {incr r} {
5968 set id [lindex $displayorder $r]
5969 set wasdrawn [info exists iddrawn($id)]
5971 if {$r == $er} break
5972 set nextid [lindex $displayorder [expr {$r + 1}]]
5973 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5974 drawparentlinks $id $r
5976 set rowids [lindex $rowidlist $r]
5977 foreach lid $rowids {
5978 if {$lid eq {}} continue
5979 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5981 # see if this is the first child of any of its parents
5982 foreach p [lindex $parentlist $r] {
5983 if {[lsearch -exact $rowids $p] < 0} {
5984 # make this line extend up to the child
5985 set lineend($p) [drawlineseg $p $r $er 0]
5989 set lineend($lid) [drawlineseg $lid $r $er 1]
5995 proc undolayout {row} {
5996 global uparrowlen mingaplen downarrowlen
5997 global rowidlist rowisopt rowfinal need_redisplay
5999 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6003 if {[llength $rowidlist] > $r} {
6005 set rowidlist [lrange $rowidlist 0 $r]
6006 set rowfinal [lrange $rowfinal 0 $r]
6007 set rowisopt [lrange $rowisopt 0 $r]
6008 set need_redisplay 1
6013 proc drawvisible {} {
6014 global canv linespc curview vrowmod selectedline targetrow targetid
6015 global need_redisplay cscroll numcommits
6017 set fs [$canv yview]
6018 set ymax [lindex [$canv cget -scrollregion] 3]
6019 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6020 set f0 [lindex $fs 0]
6021 set f1 [lindex $fs 1]
6022 set y0 [expr {int($f0 * $ymax)}]
6023 set y1 [expr {int($f1 * $ymax)}]
6025 if {[info exists targetid]} {
6026 if {[commitinview $targetid $curview]} {
6027 set r [rowofcommit $targetid]
6028 if {$r != $targetrow} {
6029 # Fix up the scrollregion and change the scrolling position
6030 # now that our target row has moved.
6031 set diff [expr {($r - $targetrow) * $linespc}]
6034 set ymax [lindex [$canv cget -scrollregion] 3]
6037 set f0 [expr {$y0 / $ymax}]
6038 set f1 [expr {$y1 / $ymax}]
6039 allcanvs yview moveto $f0
6040 $cscroll set $f0 $f1
6041 set need_redisplay 1
6048 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6049 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6050 if {$endrow >= $vrowmod($curview)} {
6051 update_arcrows $curview
6053 if {$selectedline ne {} &&
6054 $row <= $selectedline && $selectedline <= $endrow} {
6055 set targetrow $selectedline
6056 } elseif {[info exists targetid]} {
6057 set targetrow [expr {int(($row + $endrow) / 2)}]
6059 if {[info exists targetrow]} {
6060 if {$targetrow >= $numcommits} {
6061 set targetrow [expr {$numcommits - 1}]
6063 set targetid [commitonrow $targetrow]
6065 drawcommits $row $endrow
6068 proc clear_display {} {
6069 global iddrawn linesegs need_redisplay nrows_drawn
6070 global vhighlights fhighlights nhighlights rhighlights
6071 global linehtag linentag linedtag boldids boldnameids
6074 catch {unset iddrawn}
6075 catch {unset linesegs}
6076 catch {unset linehtag}
6077 catch {unset linentag}
6078 catch {unset linedtag}
6081 catch {unset vhighlights}
6082 catch {unset fhighlights}
6083 catch {unset nhighlights}
6084 catch {unset rhighlights}
6085 set need_redisplay 0
6089 proc findcrossings {id} {
6090 global rowidlist parentlist numcommits displayorder
6094 foreach {s e} [rowranges $id] {
6095 if {$e >= $numcommits} {
6096 set e [expr {$numcommits - 1}]
6098 if {$e <= $s} continue
6099 for {set row $e} {[incr row -1] >= $s} {} {
6100 set x [lsearch -exact [lindex $rowidlist $row] $id]
6102 set olds [lindex $parentlist $row]
6103 set kid [lindex $displayorder $row]
6104 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6105 if {$kidx < 0} continue
6106 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6108 set px [lsearch -exact $nextrow $p]
6109 if {$px < 0} continue
6110 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6111 if {[lsearch -exact $ccross $p] >= 0} continue
6112 if {$x == $px + ($kidx < $px? -1: 1)} {
6114 } elseif {[lsearch -exact $cross $p] < 0} {
6121 return [concat $ccross {{}} $cross]
6124 proc assigncolor {id} {
6125 global colormap colors nextcolor
6126 global parents children children curview
6128 if {[info exists colormap($id)]} return
6129 set ncolors [llength $colors]
6130 if {[info exists children($curview,$id)]} {
6131 set kids $children($curview,$id)
6135 if {[llength $kids] == 1} {
6136 set child [lindex $kids 0]
6137 if {[info exists colormap($child)]
6138 && [llength $parents($curview,$child)] == 1} {
6139 set colormap($id) $colormap($child)
6145 foreach x [findcrossings $id] {
6147 # delimiter between corner crossings and other crossings
6148 if {[llength $badcolors] >= $ncolors - 1} break
6149 set origbad $badcolors
6151 if {[info exists colormap($x)]
6152 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6153 lappend badcolors $colormap($x)
6156 if {[llength $badcolors] >= $ncolors} {
6157 set badcolors $origbad
6159 set origbad $badcolors
6160 if {[llength $badcolors] < $ncolors - 1} {
6161 foreach child $kids {
6162 if {[info exists colormap($child)]
6163 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6164 lappend badcolors $colormap($child)
6166 foreach p $parents($curview,$child) {
6167 if {[info exists colormap($p)]
6168 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6169 lappend badcolors $colormap($p)
6173 if {[llength $badcolors] >= $ncolors} {
6174 set badcolors $origbad
6177 for {set i 0} {$i <= $ncolors} {incr i} {
6178 set c [lindex $colors $nextcolor]
6179 if {[incr nextcolor] >= $ncolors} {
6182 if {[lsearch -exact $badcolors $c]} break
6184 set colormap($id) $c
6187 proc bindline {t id} {
6190 $canv bind $t <Enter> "lineenter %x %y $id"
6191 $canv bind $t <Motion> "linemotion %x %y $id"
6192 $canv bind $t <Leave> "lineleave $id"
6193 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6196 proc drawtags {id x xt y1} {
6197 global idtags idheads idotherrefs mainhead
6198 global linespc lthickness
6199 global canv rowtextx curview fgcolor bgcolor ctxbut
6204 if {[info exists idtags($id)]} {
6205 set marks $idtags($id)
6206 set ntags [llength $marks]
6208 if {[info exists idheads($id)]} {
6209 set marks [concat $marks $idheads($id)]
6210 set nheads [llength $idheads($id)]
6212 if {[info exists idotherrefs($id)]} {
6213 set marks [concat $marks $idotherrefs($id)]
6219 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6220 set yt [expr {$y1 - 0.5 * $linespc}]
6221 set yb [expr {$yt + $linespc - 1}]
6225 foreach tag $marks {
6227 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6228 set wid [font measure mainfontbold $tag]
6230 set wid [font measure mainfont $tag]
6234 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6236 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6237 -width $lthickness -fill black -tags tag.$id]
6239 foreach tag $marks x $xvals wid $wvals {
6240 set xl [expr {$x + $delta}]
6241 set xr [expr {$x + $delta + $wid + $lthickness}]
6243 if {[incr ntags -1] >= 0} {
6245 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6246 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6247 -width 1 -outline black -fill yellow -tags tag.$id]
6248 $canv bind $t <1> [list showtag $tag 1]
6249 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6251 # draw a head or other ref
6252 if {[incr nheads -1] >= 0} {
6254 if {$tag eq $mainhead} {
6255 set font mainfontbold
6260 set xl [expr {$xl - $delta/2}]
6261 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6262 -width 1 -outline black -fill $col -tags tag.$id
6263 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6264 set rwid [font measure mainfont $remoteprefix]
6265 set xi [expr {$x + 1}]
6266 set yti [expr {$yt + 1}]
6267 set xri [expr {$x + $rwid}]
6268 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6269 -width 0 -fill "#ffddaa" -tags tag.$id
6272 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6273 -font $font -tags [list tag.$id text]]
6275 $canv bind $t <1> [list showtag $tag 1]
6276 } elseif {$nheads >= 0} {
6277 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6283 proc xcoord {i level ln} {
6284 global canvx0 xspc1 xspc2
6286 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6287 if {$i > 0 && $i == $level} {
6288 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6289 } elseif {$i > $level} {
6290 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6295 proc show_status {msg} {
6299 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6300 -tags text -fill $fgcolor
6303 # Don't change the text pane cursor if it is currently the hand cursor,
6304 # showing that we are over a sha1 ID link.
6305 proc settextcursor {c} {
6306 global ctext curtextcursor
6308 if {[$ctext cget -cursor] == $curtextcursor} {
6309 $ctext config -cursor $c
6311 set curtextcursor $c
6314 proc nowbusy {what {name {}}} {
6315 global isbusy busyname statusw
6317 if {[array names isbusy] eq {}} {
6318 . config -cursor watch
6322 set busyname($what) $name
6324 $statusw conf -text $name
6328 proc notbusy {what} {
6329 global isbusy maincursor textcursor busyname statusw
6333 if {$busyname($what) ne {} &&
6334 [$statusw cget -text] eq $busyname($what)} {
6335 $statusw conf -text {}
6338 if {[array names isbusy] eq {}} {
6339 . config -cursor $maincursor
6340 settextcursor $textcursor
6344 proc findmatches {f} {
6345 global findtype findstring
6346 if {$findtype == [mc "Regexp"]} {
6347 set matches [regexp -indices -all -inline $findstring $f]
6350 if {$findtype == [mc "IgnCase"]} {
6351 set f [string tolower $f]
6352 set fs [string tolower $fs]
6356 set l [string length $fs]
6357 while {[set j [string first $fs $f $i]] >= 0} {
6358 lappend matches [list $j [expr {$j+$l-1}]]
6359 set i [expr {$j + $l}]
6365 proc dofind {{dirn 1} {wrap 1}} {
6366 global findstring findstartline findcurline selectedline numcommits
6367 global gdttype filehighlight fh_serial find_dirn findallowwrap
6369 if {[info exists find_dirn]} {
6370 if {$find_dirn == $dirn} return
6374 if {$findstring eq {} || $numcommits == 0} return
6375 if {$selectedline eq {}} {
6376 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6378 set findstartline $selectedline
6380 set findcurline $findstartline
6381 nowbusy finding [mc "Searching"]
6382 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6383 after cancel do_file_hl $fh_serial
6384 do_file_hl $fh_serial
6387 set findallowwrap $wrap
6391 proc stopfinding {} {
6392 global find_dirn findcurline fprogcoord
6394 if {[info exists find_dirn]} {
6405 global commitdata commitinfo numcommits findpattern findloc
6406 global findstartline findcurline findallowwrap
6407 global find_dirn gdttype fhighlights fprogcoord
6408 global curview varcorder vrownum varccommits vrowmod
6410 if {![info exists find_dirn]} {
6413 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6416 if {$find_dirn > 0} {
6418 if {$l >= $numcommits} {
6421 if {$l <= $findstartline} {
6422 set lim [expr {$findstartline + 1}]
6425 set moretodo $findallowwrap
6432 if {$l >= $findstartline} {
6433 set lim [expr {$findstartline - 1}]
6436 set moretodo $findallowwrap
6439 set n [expr {($lim - $l) * $find_dirn}]
6444 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6445 update_arcrows $curview
6449 set ai [bsearch $vrownum($curview) $l]
6450 set a [lindex $varcorder($curview) $ai]
6451 set arow [lindex $vrownum($curview) $ai]
6452 set ids [lindex $varccommits($curview,$a)]
6453 set arowend [expr {$arow + [llength $ids]}]
6454 if {$gdttype eq [mc "containing:"]} {
6455 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6456 if {$l < $arow || $l >= $arowend} {
6458 set a [lindex $varcorder($curview) $ai]
6459 set arow [lindex $vrownum($curview) $ai]
6460 set ids [lindex $varccommits($curview,$a)]
6461 set arowend [expr {$arow + [llength $ids]}]
6463 set id [lindex $ids [expr {$l - $arow}]]
6464 # shouldn't happen unless git log doesn't give all the commits...
6465 if {![info exists commitdata($id)] ||
6466 ![doesmatch $commitdata($id)]} {
6469 if {![info exists commitinfo($id)]} {
6472 set info $commitinfo($id)
6473 foreach f $info ty $fldtypes {
6474 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6483 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6484 if {$l < $arow || $l >= $arowend} {
6486 set a [lindex $varcorder($curview) $ai]
6487 set arow [lindex $vrownum($curview) $ai]
6488 set ids [lindex $varccommits($curview,$a)]
6489 set arowend [expr {$arow + [llength $ids]}]
6491 set id [lindex $ids [expr {$l - $arow}]]
6492 if {![info exists fhighlights($id)]} {
6493 # this sets fhighlights($id) to -1
6494 askfilehighlight $l $id
6496 if {$fhighlights($id) > 0} {
6500 if {$fhighlights($id) < 0} {
6503 set findcurline [expr {$l - $find_dirn}]
6508 if {$found || ($domore && !$moretodo)} {
6524 set findcurline [expr {$l - $find_dirn}]
6526 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6530 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6535 proc findselectline {l} {
6536 global findloc commentend ctext findcurline markingmatches gdttype
6538 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6541 if {$markingmatches &&
6542 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6543 # highlight the matches in the comments
6544 set f [$ctext get 1.0 $commentend]
6545 set matches [findmatches $f]
6546 foreach match $matches {
6547 set start [lindex $match 0]
6548 set end [expr {[lindex $match 1] + 1}]
6549 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6555 # mark the bits of a headline or author that match a find string
6556 proc markmatches {canv l str tag matches font row} {
6559 set bbox [$canv bbox $tag]
6560 set x0 [lindex $bbox 0]
6561 set y0 [lindex $bbox 1]
6562 set y1 [lindex $bbox 3]
6563 foreach match $matches {
6564 set start [lindex $match 0]
6565 set end [lindex $match 1]
6566 if {$start > $end} continue
6567 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6568 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6569 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6570 [expr {$x0+$xlen+2}] $y1 \
6571 -outline {} -tags [list match$l matches] -fill yellow]
6573 if {$row == $selectedline} {
6574 $canv raise $t secsel
6579 proc unmarkmatches {} {
6580 global markingmatches
6582 allcanvs delete matches
6583 set markingmatches 0
6587 proc selcanvline {w x y} {
6588 global canv canvy0 ctext linespc
6590 set ymax [lindex [$canv cget -scrollregion] 3]
6591 if {$ymax == {}} return
6592 set yfrac [lindex [$canv yview] 0]
6593 set y [expr {$y + $yfrac * $ymax}]
6594 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6599 set xmax [lindex [$canv cget -scrollregion] 2]
6600 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6601 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6607 proc commit_descriptor {p} {
6609 if {![info exists commitinfo($p)]} {
6613 if {[llength $commitinfo($p)] > 1} {
6614 set l [lindex $commitinfo($p) 0]
6619 # append some text to the ctext widget, and make any SHA1 ID
6620 # that we know about be a clickable link.
6621 proc appendwithlinks {text tags} {
6622 global ctext linknum curview
6624 set start [$ctext index "end - 1c"]
6625 $ctext insert end $text $tags
6626 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6630 set linkid [string range $text $s $e]
6632 $ctext tag delete link$linknum
6633 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6634 setlink $linkid link$linknum
6639 proc setlink {id lk} {
6640 global curview ctext pendinglinks
6643 if {[string length $id] < 40} {
6644 set matches [longid $id]
6645 if {[llength $matches] > 0} {
6646 if {[llength $matches] > 1} return
6648 set id [lindex $matches 0]
6651 set known [commitinview $id $curview]
6654 $ctext tag conf $lk -foreground blue -underline 1
6655 $ctext tag bind $lk <1> [list selbyid $id]
6656 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6657 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6659 lappend pendinglinks($id) $lk
6660 interestedin $id {makelink %P}
6664 proc appendshortlink {id {pre {}} {post {}}} {
6665 global ctext linknum
6667 $ctext insert end $pre
6668 $ctext tag delete link$linknum
6669 $ctext insert end [string range $id 0 7] link$linknum
6670 $ctext insert end $post
6671 setlink $id link$linknum
6675 proc makelink {id} {
6678 if {![info exists pendinglinks($id)]} return
6679 foreach lk $pendinglinks($id) {
6682 unset pendinglinks($id)
6685 proc linkcursor {w inc} {
6686 global linkentercount curtextcursor
6688 if {[incr linkentercount $inc] > 0} {
6689 $w configure -cursor hand2
6691 $w configure -cursor $curtextcursor
6692 if {$linkentercount < 0} {
6693 set linkentercount 0
6698 proc viewnextline {dir} {
6702 set ymax [lindex [$canv cget -scrollregion] 3]
6703 set wnow [$canv yview]
6704 set wtop [expr {[lindex $wnow 0] * $ymax}]
6705 set newtop [expr {$wtop + $dir * $linespc}]
6708 } elseif {$newtop > $ymax} {
6711 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6714 # add a list of tag or branch names at position pos
6715 # returns the number of names inserted
6716 proc appendrefs {pos ids var} {
6717 global ctext linknum curview $var maxrefs
6719 if {[catch {$ctext index $pos}]} {
6722 $ctext conf -state normal
6723 $ctext delete $pos "$pos lineend"
6726 foreach tag [set $var\($id\)] {
6727 lappend tags [list $tag $id]
6730 if {[llength $tags] > $maxrefs} {
6731 $ctext insert $pos "[mc "many"] ([llength $tags])"
6733 set tags [lsort -index 0 -decreasing $tags]
6736 set id [lindex $ti 1]
6739 $ctext tag delete $lk
6740 $ctext insert $pos $sep
6741 $ctext insert $pos [lindex $ti 0] $lk
6746 $ctext conf -state disabled
6747 return [llength $tags]
6750 # called when we have finished computing the nearby tags
6751 proc dispneartags {delay} {
6752 global selectedline currentid showneartags tagphase
6754 if {$selectedline eq {} || !$showneartags} return
6755 after cancel dispnexttag
6757 after 200 dispnexttag
6760 after idle dispnexttag
6765 proc dispnexttag {} {
6766 global selectedline currentid showneartags tagphase ctext
6768 if {$selectedline eq {} || !$showneartags} return
6769 switch -- $tagphase {
6771 set dtags [desctags $currentid]
6773 appendrefs precedes $dtags idtags
6777 set atags [anctags $currentid]
6779 appendrefs follows $atags idtags
6783 set dheads [descheads $currentid]
6784 if {$dheads ne {}} {
6785 if {[appendrefs branch $dheads idheads] > 1
6786 && [$ctext get "branch -3c"] eq "h"} {
6787 # turn "Branch" into "Branches"
6788 $ctext conf -state normal
6789 $ctext insert "branch -2c" "es"
6790 $ctext conf -state disabled
6795 if {[incr tagphase] <= 2} {
6796 after idle dispnexttag
6800 proc make_secsel {id} {
6801 global linehtag linentag linedtag canv canv2 canv3
6803 if {![info exists linehtag($id)]} return
6805 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6806 -tags secsel -fill [$canv cget -selectbackground]]
6808 $canv2 delete secsel
6809 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6810 -tags secsel -fill [$canv2 cget -selectbackground]]
6812 $canv3 delete secsel
6813 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6814 -tags secsel -fill [$canv3 cget -selectbackground]]
6818 proc make_idmark {id} {
6819 global linehtag canv fgcolor
6821 if {![info exists linehtag($id)]} return
6823 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6824 -tags markid -outline $fgcolor]
6828 proc selectline {l isnew {desired_loc {}}} {
6829 global canv ctext commitinfo selectedline
6830 global canvy0 linespc parents children curview
6831 global currentid sha1entry
6832 global commentend idtags linknum
6833 global mergemax numcommits pending_select
6834 global cmitmode showneartags allcommits
6835 global targetrow targetid lastscrollrows
6836 global autoselect jump_to_here
6838 catch {unset pending_select}
6843 if {$l < 0 || $l >= $numcommits} return
6844 set id [commitonrow $l]
6849 if {$lastscrollrows < $numcommits} {
6853 set y [expr {$canvy0 + $l * $linespc}]
6854 set ymax [lindex [$canv cget -scrollregion] 3]
6855 set ytop [expr {$y - $linespc - 1}]
6856 set ybot [expr {$y + $linespc + 1}]
6857 set wnow [$canv yview]
6858 set wtop [expr {[lindex $wnow 0] * $ymax}]
6859 set wbot [expr {[lindex $wnow 1] * $ymax}]
6860 set wh [expr {$wbot - $wtop}]
6862 if {$ytop < $wtop} {
6863 if {$ybot < $wtop} {
6864 set newtop [expr {$y - $wh / 2.0}]
6867 if {$newtop > $wtop - $linespc} {
6868 set newtop [expr {$wtop - $linespc}]
6871 } elseif {$ybot > $wbot} {
6872 if {$ytop > $wbot} {
6873 set newtop [expr {$y - $wh / 2.0}]
6875 set newtop [expr {$ybot - $wh}]
6876 if {$newtop < $wtop + $linespc} {
6877 set newtop [expr {$wtop + $linespc}]
6881 if {$newtop != $wtop} {
6885 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6892 addtohistory [list selbyid $id 0] savecmitpos
6895 $sha1entry delete 0 end
6896 $sha1entry insert 0 $id
6898 $sha1entry selection range 0 end
6902 $ctext conf -state normal
6905 if {![info exists commitinfo($id)]} {
6908 set info $commitinfo($id)
6909 set date [formatdate [lindex $info 2]]
6910 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6911 set date [formatdate [lindex $info 4]]
6912 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6913 if {[info exists idtags($id)]} {
6914 $ctext insert end [mc "Tags:"]
6915 foreach tag $idtags($id) {
6916 $ctext insert end " $tag"
6918 $ctext insert end "\n"
6922 set olds $parents($curview,$id)
6923 if {[llength $olds] > 1} {
6926 if {$np >= $mergemax} {
6931 $ctext insert end "[mc "Parent"]: " $tag
6932 appendwithlinks [commit_descriptor $p] {}
6937 append headers "[mc "Parent"]: [commit_descriptor $p]"
6941 foreach c $children($curview,$id) {
6942 append headers "[mc "Child"]: [commit_descriptor $c]"
6945 # make anything that looks like a SHA1 ID be a clickable link
6946 appendwithlinks $headers {}
6947 if {$showneartags} {
6948 if {![info exists allcommits]} {
6951 $ctext insert end "[mc "Branch"]: "
6952 $ctext mark set branch "end -1c"
6953 $ctext mark gravity branch left
6954 $ctext insert end "\n[mc "Follows"]: "
6955 $ctext mark set follows "end -1c"
6956 $ctext mark gravity follows left
6957 $ctext insert end "\n[mc "Precedes"]: "
6958 $ctext mark set precedes "end -1c"
6959 $ctext mark gravity precedes left
6960 $ctext insert end "\n"
6963 $ctext insert end "\n"
6964 set comment [lindex $info 5]
6965 if {[string first "\r" $comment] >= 0} {
6966 set comment [string map {"\r" "\n "} $comment]
6968 appendwithlinks $comment {comment}
6970 $ctext tag remove found 1.0 end
6971 $ctext conf -state disabled
6972 set commentend [$ctext index "end - 1c"]
6974 set jump_to_here $desired_loc
6975 init_flist [mc "Comments"]
6976 if {$cmitmode eq "tree"} {
6978 } elseif {[llength $olds] <= 1} {
6985 proc selfirstline {} {
6990 proc sellastline {} {
6993 set l [expr {$numcommits - 1}]
6997 proc selnextline {dir} {
7000 if {$selectedline eq {}} return
7001 set l [expr {$selectedline + $dir}]
7006 proc selnextpage {dir} {
7007 global canv linespc selectedline numcommits
7009 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7013 allcanvs yview scroll [expr {$dir * $lpp}] units
7015 if {$selectedline eq {}} return
7016 set l [expr {$selectedline + $dir * $lpp}]
7019 } elseif {$l >= $numcommits} {
7020 set l [expr $numcommits - 1]
7026 proc unselectline {} {
7027 global selectedline currentid
7030 catch {unset currentid}
7031 allcanvs delete secsel
7035 proc reselectline {} {
7038 if {$selectedline ne {}} {
7039 selectline $selectedline 0
7043 proc addtohistory {cmd {saveproc {}}} {
7044 global history historyindex curview
7048 set elt [list $curview $cmd $saveproc {}]
7049 if {$historyindex > 0
7050 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7054 if {$historyindex < [llength $history]} {
7055 set history [lreplace $history $historyindex end $elt]
7057 lappend history $elt
7060 if {$historyindex > 1} {
7061 .tf.bar.leftbut conf -state normal
7063 .tf.bar.leftbut conf -state disabled
7065 .tf.bar.rightbut conf -state disabled
7068 # save the scrolling position of the diff display pane
7069 proc save_position {} {
7070 global historyindex history
7072 if {$historyindex < 1} return
7073 set hi [expr {$historyindex - 1}]
7074 set fn [lindex $history $hi 2]
7076 lset history $hi 3 [eval $fn]
7080 proc unset_posvars {} {
7083 if {[info exists last_posvars]} {
7084 foreach {var val} $last_posvars {
7093 global curview last_posvars
7095 set view [lindex $elt 0]
7096 set cmd [lindex $elt 1]
7097 set pv [lindex $elt 3]
7098 if {$curview != $view} {
7102 foreach {var val} $pv {
7106 set last_posvars $pv
7111 global history historyindex
7114 if {$historyindex > 1} {
7116 incr historyindex -1
7117 godo [lindex $history [expr {$historyindex - 1}]]
7118 .tf.bar.rightbut conf -state normal
7120 if {$historyindex <= 1} {
7121 .tf.bar.leftbut conf -state disabled
7126 global history historyindex
7129 if {$historyindex < [llength $history]} {
7131 set cmd [lindex $history $historyindex]
7134 .tf.bar.leftbut conf -state normal
7136 if {$historyindex >= [llength $history]} {
7137 .tf.bar.rightbut conf -state disabled
7142 global treefilelist treeidlist diffids diffmergeid treepending
7143 global nullid nullid2
7146 catch {unset diffmergeid}
7147 if {![info exists treefilelist($id)]} {
7148 if {![info exists treepending]} {
7149 if {$id eq $nullid} {
7150 set cmd [list | git ls-files]
7151 } elseif {$id eq $nullid2} {
7152 set cmd [list | git ls-files --stage -t]
7154 set cmd [list | git ls-tree -r $id]
7156 if {[catch {set gtf [open $cmd r]}]} {
7160 set treefilelist($id) {}
7161 set treeidlist($id) {}
7162 fconfigure $gtf -blocking 0 -encoding binary
7163 filerun $gtf [list gettreeline $gtf $id]
7170 proc gettreeline {gtf id} {
7171 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7174 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7175 if {$diffids eq $nullid} {
7178 set i [string first "\t" $line]
7179 if {$i < 0} continue
7180 set fname [string range $line [expr {$i+1}] end]
7181 set line [string range $line 0 [expr {$i-1}]]
7182 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7183 set sha1 [lindex $line 2]
7184 lappend treeidlist($id) $sha1
7186 if {[string index $fname 0] eq "\""} {
7187 set fname [lindex $fname 0]
7189 set fname [encoding convertfrom $fname]
7190 lappend treefilelist($id) $fname
7193 return [expr {$nl >= 1000? 2: 1}]
7197 if {$cmitmode ne "tree"} {
7198 if {![info exists diffmergeid]} {
7199 gettreediffs $diffids
7201 } elseif {$id ne $diffids} {
7210 global treefilelist treeidlist diffids nullid nullid2
7211 global ctext_file_names ctext_file_lines
7212 global ctext commentend
7214 set i [lsearch -exact $treefilelist($diffids) $f]
7216 puts "oops, $f not in list for id $diffids"
7219 if {$diffids eq $nullid} {
7220 if {[catch {set bf [open $f r]} err]} {
7221 puts "oops, can't read $f: $err"
7225 set blob [lindex $treeidlist($diffids) $i]
7226 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7227 puts "oops, error reading blob $blob: $err"
7231 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7232 filerun $bf [list getblobline $bf $diffids]
7233 $ctext config -state normal
7234 clear_ctext $commentend
7235 lappend ctext_file_names $f
7236 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7237 $ctext insert end "\n"
7238 $ctext insert end "$f\n" filesep
7239 $ctext config -state disabled
7240 $ctext yview $commentend
7244 proc getblobline {bf id} {
7245 global diffids cmitmode ctext
7247 if {$id ne $diffids || $cmitmode ne "tree"} {
7251 $ctext config -state normal
7253 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7254 $ctext insert end "$line\n"
7257 global jump_to_here ctext_file_names commentend
7259 # delete last newline
7260 $ctext delete "end - 2c" "end - 1c"
7262 if {$jump_to_here ne {} &&
7263 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7264 set lnum [expr {[lindex $jump_to_here 1] +
7265 [lindex [split $commentend .] 0]}]
7266 mark_ctext_line $lnum
7270 $ctext config -state disabled
7271 return [expr {$nl >= 1000? 2: 1}]
7274 proc mark_ctext_line {lnum} {
7275 global ctext markbgcolor
7277 $ctext tag delete omark
7278 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7279 $ctext tag conf omark -background $markbgcolor
7283 proc mergediff {id} {
7285 global diffids treediffs
7286 global parents curview
7290 set treediffs($id) {}
7291 set np [llength $parents($curview,$id)]
7296 proc startdiff {ids} {
7297 global treediffs diffids treepending diffmergeid nullid nullid2
7301 catch {unset diffmergeid}
7302 if {![info exists treediffs($ids)] ||
7303 [lsearch -exact $ids $nullid] >= 0 ||
7304 [lsearch -exact $ids $nullid2] >= 0} {
7305 if {![info exists treepending]} {
7313 proc path_filter {filter name} {
7315 set l [string length $p]
7316 if {[string index $p end] eq "/"} {
7317 if {[string compare -length $l $p $name] == 0} {
7321 if {[string compare -length $l $p $name] == 0 &&
7322 ([string length $name] == $l ||
7323 [string index $name $l] eq "/")} {
7331 proc addtocflist {ids} {
7334 add_flist $treediffs($ids)
7338 proc diffcmd {ids flags} {
7339 global nullid nullid2
7341 set i [lsearch -exact $ids $nullid]
7342 set j [lsearch -exact $ids $nullid2]
7344 if {[llength $ids] > 1 && $j < 0} {
7345 # comparing working directory with some specific revision
7346 set cmd [concat | git diff-index $flags]
7348 lappend cmd -R [lindex $ids 1]
7350 lappend cmd [lindex $ids 0]
7353 # comparing working directory with index
7354 set cmd [concat | git diff-files $flags]
7359 } elseif {$j >= 0} {
7360 set cmd [concat | git diff-index --cached $flags]
7361 if {[llength $ids] > 1} {
7362 # comparing index with specific revision
7364 lappend cmd -R [lindex $ids 1]
7366 lappend cmd [lindex $ids 0]
7369 # comparing index with HEAD
7373 set cmd [concat | git diff-tree -r $flags $ids]
7378 proc gettreediffs {ids} {
7379 global treediff treepending
7381 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7383 set treepending $ids
7385 fconfigure $gdtf -blocking 0 -encoding binary
7386 filerun $gdtf [list gettreediffline $gdtf $ids]
7389 proc gettreediffline {gdtf ids} {
7390 global treediff treediffs treepending diffids diffmergeid
7391 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7396 if {$perfile_attrs} {
7397 # cache_gitattr is slow, and even slower on win32 where we
7398 # have to invoke it for only about 30 paths at a time
7400 if {[tk windowingsystem] == "win32"} {
7404 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7405 set i [string first "\t" $line]
7407 set file [string range $line [expr {$i+1}] end]
7408 if {[string index $file 0] eq "\""} {
7409 set file [lindex $file 0]
7411 set file [encoding convertfrom $file]
7412 if {$file ne [lindex $treediff end]} {
7413 lappend treediff $file
7414 lappend sublist $file
7418 if {$perfile_attrs} {
7419 cache_gitattr encoding $sublist
7422 return [expr {$nr >= $max? 2: 1}]
7425 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7427 foreach f $treediff {
7428 if {[path_filter $vfilelimit($curview) $f]} {
7432 set treediffs($ids) $flist
7434 set treediffs($ids) $treediff
7437 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7439 } elseif {$ids != $diffids} {
7440 if {![info exists diffmergeid]} {
7441 gettreediffs $diffids
7449 # empty string or positive integer
7450 proc diffcontextvalidate {v} {
7451 return [regexp {^(|[1-9][0-9]*)$} $v]
7454 proc diffcontextchange {n1 n2 op} {
7455 global diffcontextstring diffcontext
7457 if {[string is integer -strict $diffcontextstring]} {
7458 if {$diffcontextstring >= 0} {
7459 set diffcontext $diffcontextstring
7465 proc changeignorespace {} {
7469 proc getblobdiffs {ids} {
7470 global blobdifffd diffids env
7471 global diffinhdr treediffs
7474 global limitdiffs vfilelimit curview
7475 global diffencoding targetline diffnparents
7479 if {[package vcompare $git_version "1.6.1"] >= 0} {
7480 set textconv "--textconv"
7482 set cmd [diffcmd $ids "-p $textconv -C --cc --no-commit-id -U$diffcontext"]
7486 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7487 set cmd [concat $cmd -- $vfilelimit($curview)]
7489 if {[catch {set bdf [open $cmd r]} err]} {
7490 error_popup [mc "Error getting diffs: %s" $err]
7496 set diffencoding [get_path_encoding {}]
7497 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7498 set blobdifffd($ids) $bdf
7499 filerun $bdf [list getblobdiffline $bdf $diffids]
7502 proc savecmitpos {} {
7503 global ctext cmitmode
7505 if {$cmitmode eq "tree"} {
7508 return [list target_scrollpos [$ctext index @0,0]]
7511 proc savectextpos {} {
7514 return [list target_scrollpos [$ctext index @0,0]]
7517 proc maybe_scroll_ctext {ateof} {
7518 global ctext target_scrollpos
7520 if {![info exists target_scrollpos]} return
7522 set nlines [expr {[winfo height $ctext]
7523 / [font metrics textfont -linespace]}]
7524 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7526 $ctext yview $target_scrollpos
7527 unset target_scrollpos
7530 proc setinlist {var i val} {
7533 while {[llength [set $var]] < $i} {
7536 if {[llength [set $var]] == $i} {
7543 proc makediffhdr {fname ids} {
7544 global ctext curdiffstart treediffs diffencoding
7545 global ctext_file_names jump_to_here targetline diffline
7547 set fname [encoding convertfrom $fname]
7548 set diffencoding [get_path_encoding $fname]
7549 set i [lsearch -exact $treediffs($ids) $fname]
7551 setinlist difffilestart $i $curdiffstart
7553 lset ctext_file_names end $fname
7554 set l [expr {(78 - [string length $fname]) / 2}]
7555 set pad [string range "----------------------------------------" 1 $l]
7556 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7558 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7559 set targetline [lindex $jump_to_here 1]
7564 proc getblobdiffline {bdf ids} {
7565 global diffids blobdifffd ctext curdiffstart
7566 global diffnexthead diffnextnote difffilestart
7567 global ctext_file_names ctext_file_lines
7568 global diffinhdr treediffs mergemax diffnparents
7569 global diffencoding jump_to_here targetline diffline
7572 $ctext conf -state normal
7573 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7574 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7578 if {![string compare -length 5 "diff " $line]} {
7579 if {![regexp {^diff (--cc|--git) } $line m type]} {
7580 set line [encoding convertfrom $line]
7581 $ctext insert end "$line\n" hunksep
7584 # start of a new file
7586 $ctext insert end "\n"
7587 set curdiffstart [$ctext index "end - 1c"]
7588 lappend ctext_file_names ""
7589 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7590 $ctext insert end "\n" filesep
7592 if {$type eq "--cc"} {
7593 # start of a new file in a merge diff
7594 set fname [string range $line 10 end]
7595 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7596 lappend treediffs($ids) $fname
7597 add_flist [list $fname]
7601 set line [string range $line 11 end]
7602 # If the name hasn't changed the length will be odd,
7603 # the middle char will be a space, and the two bits either
7604 # side will be a/name and b/name, or "a/name" and "b/name".
7605 # If the name has changed we'll get "rename from" and
7606 # "rename to" or "copy from" and "copy to" lines following
7607 # this, and we'll use them to get the filenames.
7608 # This complexity is necessary because spaces in the
7609 # filename(s) don't get escaped.
7610 set l [string length $line]
7611 set i [expr {$l / 2}]
7612 if {!(($l & 1) && [string index $line $i] eq " " &&
7613 [string range $line 2 [expr {$i - 1}]] eq \
7614 [string range $line [expr {$i + 3}] end])} {
7617 # unescape if quoted and chop off the a/ from the front
7618 if {[string index $line 0] eq "\""} {
7619 set fname [string range [lindex $line 0] 2 end]
7621 set fname [string range $line 2 [expr {$i - 1}]]
7624 makediffhdr $fname $ids
7626 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7627 set fname [encoding convertfrom [string range $line 16 end]]
7628 $ctext insert end "\n"
7629 set curdiffstart [$ctext index "end - 1c"]
7630 lappend ctext_file_names $fname
7631 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7632 $ctext insert end "$line\n" filesep
7633 set i [lsearch -exact $treediffs($ids) $fname]
7635 setinlist difffilestart $i $curdiffstart
7638 } elseif {![string compare -length 2 "@@" $line]} {
7639 regexp {^@@+} $line ats
7640 set line [encoding convertfrom $diffencoding $line]
7641 $ctext insert end "$line\n" hunksep
7642 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7645 set diffnparents [expr {[string length $ats] - 1}]
7648 } elseif {$diffinhdr} {
7649 if {![string compare -length 12 "rename from " $line]} {
7650 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7651 if {[string index $fname 0] eq "\""} {
7652 set fname [lindex $fname 0]
7654 set fname [encoding convertfrom $fname]
7655 set i [lsearch -exact $treediffs($ids) $fname]
7657 setinlist difffilestart $i $curdiffstart
7659 } elseif {![string compare -length 10 $line "rename to "] ||
7660 ![string compare -length 8 $line "copy to "]} {
7661 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7662 if {[string index $fname 0] eq "\""} {
7663 set fname [lindex $fname 0]
7665 makediffhdr $fname $ids
7666 } elseif {[string compare -length 3 $line "---"] == 0} {
7669 } elseif {[string compare -length 3 $line "+++"] == 0} {
7673 $ctext insert end "$line\n" filesep
7676 set line [string map {\x1A ^Z} \
7677 [encoding convertfrom $diffencoding $line]]
7678 # parse the prefix - one ' ', '-' or '+' for each parent
7679 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7680 set tag [expr {$diffnparents > 1? "m": "d"}]
7681 if {[string trim $prefix " -+"] eq {}} {
7682 # prefix only has " ", "-" and "+" in it: normal diff line
7683 set num [string first "-" $prefix]
7685 # removed line, first parent with line is $num
7686 if {$num >= $mergemax} {
7689 $ctext insert end "$line\n" $tag$num
7692 if {[string first "+" $prefix] >= 0} {
7694 lappend tags ${tag}result
7695 if {$diffnparents > 1} {
7696 set num [string first " " $prefix]
7698 if {$num >= $mergemax} {
7705 if {$targetline ne {}} {
7706 if {$diffline == $targetline} {
7707 set seehere [$ctext index "end - 1 chars"]
7713 $ctext insert end "$line\n" $tags
7716 # "\ No newline at end of file",
7717 # or something else we don't recognize
7718 $ctext insert end "$line\n" hunksep
7722 if {[info exists seehere]} {
7723 mark_ctext_line [lindex [split $seehere .] 0]
7725 maybe_scroll_ctext [eof $bdf]
7726 $ctext conf -state disabled
7731 return [expr {$nr >= 1000? 2: 1}]
7734 proc changediffdisp {} {
7735 global ctext diffelide
7737 $ctext tag conf d0 -elide [lindex $diffelide 0]
7738 $ctext tag conf dresult -elide [lindex $diffelide 1]
7741 proc highlightfile {loc cline} {
7742 global ctext cflist cflist_top
7745 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7746 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7747 $cflist see $cline.0
7748 set cflist_top $cline
7752 global difffilestart ctext cmitmode
7754 if {$cmitmode eq "tree"} return
7757 set here [$ctext index @0,0]
7758 foreach loc $difffilestart {
7759 if {[$ctext compare $loc >= $here]} {
7760 highlightfile $prev $prevline
7766 highlightfile $prev $prevline
7770 global difffilestart ctext cmitmode
7772 if {$cmitmode eq "tree"} return
7773 set here [$ctext index @0,0]
7775 foreach loc $difffilestart {
7777 if {[$ctext compare $loc > $here]} {
7778 highlightfile $loc $line
7784 proc clear_ctext {{first 1.0}} {
7785 global ctext smarktop smarkbot
7786 global ctext_file_names ctext_file_lines
7789 set l [lindex [split $first .] 0]
7790 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7793 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7796 $ctext delete $first end
7797 if {$first eq "1.0"} {
7798 catch {unset pendinglinks}
7800 set ctext_file_names {}
7801 set ctext_file_lines {}
7804 proc settabs {{firstab {}}} {
7805 global firsttabstop tabstop ctext have_tk85
7807 if {$firstab ne {} && $have_tk85} {
7808 set firsttabstop $firstab
7810 set w [font measure textfont "0"]
7811 if {$firsttabstop != 0} {
7812 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7813 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7814 } elseif {$have_tk85 || $tabstop != 8} {
7815 $ctext conf -tabs [expr {$tabstop * $w}]
7817 $ctext conf -tabs {}
7821 proc incrsearch {name ix op} {
7822 global ctext searchstring searchdirn
7824 $ctext tag remove found 1.0 end
7825 if {[catch {$ctext index anchor}]} {
7826 # no anchor set, use start of selection, or of visible area
7827 set sel [$ctext tag ranges sel]
7829 $ctext mark set anchor [lindex $sel 0]
7830 } elseif {$searchdirn eq "-forwards"} {
7831 $ctext mark set anchor @0,0
7833 $ctext mark set anchor @0,[winfo height $ctext]
7836 if {$searchstring ne {}} {
7837 set here [$ctext search $searchdirn -- $searchstring anchor]
7846 global sstring ctext searchstring searchdirn
7849 $sstring icursor end
7850 set searchdirn -forwards
7851 if {$searchstring ne {}} {
7852 set sel [$ctext tag ranges sel]
7854 set start "[lindex $sel 0] + 1c"
7855 } elseif {[catch {set start [$ctext index anchor]}]} {
7858 set match [$ctext search -count mlen -- $searchstring $start]
7859 $ctext tag remove sel 1.0 end
7865 set mend "$match + $mlen c"
7866 $ctext tag add sel $match $mend
7867 $ctext mark unset anchor
7871 proc dosearchback {} {
7872 global sstring ctext searchstring searchdirn
7875 $sstring icursor end
7876 set searchdirn -backwards
7877 if {$searchstring ne {}} {
7878 set sel [$ctext tag ranges sel]
7880 set start [lindex $sel 0]
7881 } elseif {[catch {set start [$ctext index anchor]}]} {
7882 set start @0,[winfo height $ctext]
7884 set match [$ctext search -backwards -count ml -- $searchstring $start]
7885 $ctext tag remove sel 1.0 end
7891 set mend "$match + $ml c"
7892 $ctext tag add sel $match $mend
7893 $ctext mark unset anchor
7897 proc searchmark {first last} {
7898 global ctext searchstring
7902 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7903 if {$match eq {}} break
7904 set mend "$match + $mlen c"
7905 $ctext tag add found $match $mend
7909 proc searchmarkvisible {doall} {
7910 global ctext smarktop smarkbot
7912 set topline [lindex [split [$ctext index @0,0] .] 0]
7913 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7914 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7915 # no overlap with previous
7916 searchmark $topline $botline
7917 set smarktop $topline
7918 set smarkbot $botline
7920 if {$topline < $smarktop} {
7921 searchmark $topline [expr {$smarktop-1}]
7922 set smarktop $topline
7924 if {$botline > $smarkbot} {
7925 searchmark [expr {$smarkbot+1}] $botline
7926 set smarkbot $botline
7931 proc scrolltext {f0 f1} {
7934 .bleft.bottom.sb set $f0 $f1
7935 if {$searchstring ne {}} {
7941 global linespc charspc canvx0 canvy0
7942 global xspc1 xspc2 lthickness
7944 set linespc [font metrics mainfont -linespace]
7945 set charspc [font measure mainfont "m"]
7946 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7947 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7948 set lthickness [expr {int($linespc / 9) + 1}]
7949 set xspc1(0) $linespc
7957 set ymax [lindex [$canv cget -scrollregion] 3]
7958 if {$ymax eq {} || $ymax == 0} return
7959 set span [$canv yview]
7962 allcanvs yview moveto [lindex $span 0]
7964 if {$selectedline ne {}} {
7965 selectline $selectedline 0
7966 allcanvs yview moveto [lindex $span 0]
7970 proc parsefont {f n} {
7973 set fontattr($f,family) [lindex $n 0]
7975 if {$s eq {} || $s == 0} {
7978 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7980 set fontattr($f,size) $s
7981 set fontattr($f,weight) normal
7982 set fontattr($f,slant) roman
7983 foreach style [lrange $n 2 end] {
7986 "bold" {set fontattr($f,weight) $style}
7988 "italic" {set fontattr($f,slant) $style}
7993 proc fontflags {f {isbold 0}} {
7996 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7997 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7998 -slant $fontattr($f,slant)]
8004 set n [list $fontattr($f,family) $fontattr($f,size)]
8005 if {$fontattr($f,weight) eq "bold"} {
8008 if {$fontattr($f,slant) eq "italic"} {
8014 proc incrfont {inc} {
8015 global mainfont textfont ctext canv cflist showrefstop
8016 global stopped entries fontattr
8019 set s $fontattr(mainfont,size)
8024 set fontattr(mainfont,size) $s
8025 font config mainfont -size $s
8026 font config mainfontbold -size $s
8027 set mainfont [fontname mainfont]
8028 set s $fontattr(textfont,size)
8033 set fontattr(textfont,size) $s
8034 font config textfont -size $s
8035 font config textfontbold -size $s
8036 set textfont [fontname textfont]
8043 global sha1entry sha1string
8044 if {[string length $sha1string] == 40} {
8045 $sha1entry delete 0 end
8049 proc sha1change {n1 n2 op} {
8050 global sha1string currentid sha1but
8051 if {$sha1string == {}
8052 || ([info exists currentid] && $sha1string == $currentid)} {
8057 if {[$sha1but cget -state] == $state} return
8058 if {$state == "normal"} {
8059 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8061 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8065 proc gotocommit {} {
8066 global sha1string tagids headids curview varcid
8068 if {$sha1string == {}
8069 || ([info exists currentid] && $sha1string == $currentid)} return
8070 if {[info exists tagids($sha1string)]} {
8071 set id $tagids($sha1string)
8072 } elseif {[info exists headids($sha1string)]} {
8073 set id $headids($sha1string)
8075 set id [string tolower $sha1string]
8076 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8077 set matches [longid $id]
8078 if {$matches ne {}} {
8079 if {[llength $matches] > 1} {
8080 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8083 set id [lindex $matches 0]
8086 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8087 error_popup [mc "Revision %s is not known" $sha1string]
8092 if {[commitinview $id $curview]} {
8093 selectline [rowofcommit $id] 1
8096 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8097 set msg [mc "SHA1 id %s is not known" $sha1string]
8099 set msg [mc "Revision %s is not in the current view" $sha1string]
8104 proc lineenter {x y id} {
8105 global hoverx hovery hoverid hovertimer
8106 global commitinfo canv
8108 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8112 if {[info exists hovertimer]} {
8113 after cancel $hovertimer
8115 set hovertimer [after 500 linehover]
8119 proc linemotion {x y id} {
8120 global hoverx hovery hoverid hovertimer
8122 if {[info exists hoverid] && $id == $hoverid} {
8125 if {[info exists hovertimer]} {
8126 after cancel $hovertimer
8128 set hovertimer [after 500 linehover]
8132 proc lineleave {id} {
8133 global hoverid hovertimer canv
8135 if {[info exists hoverid] && $id == $hoverid} {
8137 if {[info exists hovertimer]} {
8138 after cancel $hovertimer
8146 global hoverx hovery hoverid hovertimer
8147 global canv linespc lthickness
8150 set text [lindex $commitinfo($hoverid) 0]
8151 set ymax [lindex [$canv cget -scrollregion] 3]
8152 if {$ymax == {}} return
8153 set yfrac [lindex [$canv yview] 0]
8154 set x [expr {$hoverx + 2 * $linespc}]
8155 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8156 set x0 [expr {$x - 2 * $lthickness}]
8157 set y0 [expr {$y - 2 * $lthickness}]
8158 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8159 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8160 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8161 -fill \#ffff80 -outline black -width 1 -tags hover]
8163 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8168 proc clickisonarrow {id y} {
8171 set ranges [rowranges $id]
8172 set thresh [expr {2 * $lthickness + 6}]
8173 set n [expr {[llength $ranges] - 1}]
8174 for {set i 1} {$i < $n} {incr i} {
8175 set row [lindex $ranges $i]
8176 if {abs([yc $row] - $y) < $thresh} {
8183 proc arrowjump {id n y} {
8186 # 1 <-> 2, 3 <-> 4, etc...
8187 set n [expr {(($n - 1) ^ 1) + 1}]
8188 set row [lindex [rowranges $id] $n]
8190 set ymax [lindex [$canv cget -scrollregion] 3]
8191 if {$ymax eq {} || $ymax <= 0} return
8192 set view [$canv yview]
8193 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8194 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8198 allcanvs yview moveto $yfrac
8201 proc lineclick {x y id isnew} {
8202 global ctext commitinfo children canv thickerline curview
8204 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8209 # draw this line thicker than normal
8213 set ymax [lindex [$canv cget -scrollregion] 3]
8214 if {$ymax eq {}} return
8215 set yfrac [lindex [$canv yview] 0]
8216 set y [expr {$y + $yfrac * $ymax}]
8218 set dirn [clickisonarrow $id $y]
8220 arrowjump $id $dirn $y
8225 addtohistory [list lineclick $x $y $id 0] savectextpos
8227 # fill the details pane with info about this line
8228 $ctext conf -state normal
8231 $ctext insert end "[mc "Parent"]:\t"
8232 $ctext insert end $id link0
8234 set info $commitinfo($id)
8235 $ctext insert end "\n\t[lindex $info 0]\n"
8236 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8237 set date [formatdate [lindex $info 2]]
8238 $ctext insert end "\t[mc "Date"]:\t$date\n"
8239 set kids $children($curview,$id)
8241 $ctext insert end "\n[mc "Children"]:"
8243 foreach child $kids {
8245 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8246 set info $commitinfo($child)
8247 $ctext insert end "\n\t"
8248 $ctext insert end $child link$i
8249 setlink $child link$i
8250 $ctext insert end "\n\t[lindex $info 0]"
8251 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8252 set date [formatdate [lindex $info 2]]
8253 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8256 maybe_scroll_ctext 1
8257 $ctext conf -state disabled
8261 proc normalline {} {
8263 if {[info exists thickerline]} {
8270 proc selbyid {id {isnew 1}} {
8272 if {[commitinview $id $curview]} {
8273 selectline [rowofcommit $id] $isnew
8279 if {![info exists startmstime]} {
8280 set startmstime [clock clicks -milliseconds]
8282 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8285 proc rowmenu {x y id} {
8286 global rowctxmenu selectedline rowmenuid curview
8287 global nullid nullid2 fakerowmenu mainhead markedid
8291 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8296 if {$id ne $nullid && $id ne $nullid2} {
8297 set menu $rowctxmenu
8298 if {$mainhead ne {}} {
8299 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8301 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8303 if {[info exists markedid] && $markedid ne $id} {
8304 $menu entryconfigure 9 -state normal
8305 $menu entryconfigure 10 -state normal
8306 $menu entryconfigure 11 -state normal
8308 $menu entryconfigure 9 -state disabled
8309 $menu entryconfigure 10 -state disabled
8310 $menu entryconfigure 11 -state disabled
8313 set menu $fakerowmenu
8315 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8316 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8317 $menu entryconfigure [mca "Make patch"] -state $state
8318 tk_popup $menu $x $y
8322 global rowmenuid markedid canv
8324 set markedid $rowmenuid
8325 make_idmark $markedid
8331 if {[info exists markedid]} {
8336 proc replace_by_kids {l r} {
8337 global curview children
8339 set id [commitonrow $r]
8340 set l [lreplace $l 0 0]
8341 foreach kid $children($curview,$id) {
8342 lappend l [rowofcommit $kid]
8344 return [lsort -integer -decreasing -unique $l]
8347 proc find_common_desc {} {
8348 global markedid rowmenuid curview children
8350 if {![info exists markedid]} return
8351 if {![commitinview $markedid $curview] ||
8352 ![commitinview $rowmenuid $curview]} return
8353 #set t1 [clock clicks -milliseconds]
8354 set l1 [list [rowofcommit $markedid]]
8355 set l2 [list [rowofcommit $rowmenuid]]
8357 set r1 [lindex $l1 0]
8358 set r2 [lindex $l2 0]
8359 if {$r1 eq {} || $r2 eq {}} break
8365 set l1 [replace_by_kids $l1 $r1]
8367 set l2 [replace_by_kids $l2 $r2]
8370 #set t2 [clock clicks -milliseconds]
8371 #puts "took [expr {$t2-$t1}]ms"
8374 proc compare_commits {} {
8375 global markedid rowmenuid curview children
8377 if {![info exists markedid]} return
8378 if {![commitinview $markedid $curview]} return
8379 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8380 do_cmp_commits $markedid $rowmenuid
8383 proc getpatchid {id} {
8386 if {![info exists patchids($id)]} {
8387 set cmd [diffcmd [list $id] {-p --root}]
8388 # trim off the initial "|"
8389 set cmd [lrange $cmd 1 end]
8391 set x [eval exec $cmd | git patch-id]
8392 set patchids($id) [lindex $x 0]
8394 set patchids($id) "error"
8397 return $patchids($id)
8400 proc do_cmp_commits {a b} {
8401 global ctext curview parents children patchids commitinfo
8403 $ctext conf -state normal
8406 for {set i 0} {$i < 100} {incr i} {
8409 if {[llength $parents($curview,$a)] > 1} {
8410 appendshortlink $a [mc "Skipping merge commit "] "\n"
8413 set patcha [getpatchid $a]
8415 if {[llength $parents($curview,$b)] > 1} {
8416 appendshortlink $b [mc "Skipping merge commit "] "\n"
8419 set patchb [getpatchid $b]
8421 if {!$skipa && !$skipb} {
8422 set heada [lindex $commitinfo($a) 0]
8423 set headb [lindex $commitinfo($b) 0]
8424 if {$patcha eq "error"} {
8425 appendshortlink $a [mc "Error getting patch ID for "] \
8426 [mc " - stopping\n"]
8429 if {$patchb eq "error"} {
8430 appendshortlink $b [mc "Error getting patch ID for "] \
8431 [mc " - stopping\n"]
8434 if {$patcha eq $patchb} {
8435 if {$heada eq $headb} {
8436 appendshortlink $a [mc "Commit "]
8437 appendshortlink $b " == " " $heada\n"
8439 appendshortlink $a [mc "Commit "] " $heada\n"
8440 appendshortlink $b [mc " is the same patch as\n "] \
8446 $ctext insert end "\n"
8447 appendshortlink $a [mc "Commit "] " $heada\n"
8448 appendshortlink $b [mc " differs from\n "] \
8450 $ctext insert end [mc "- stopping\n"]
8455 if {[llength $children($curview,$a)] != 1} {
8456 $ctext insert end "\n"
8457 appendshortlink $a [mc "Commit "] \
8458 [mc " has %s children - stopping\n" \
8459 [llength $children($curview,$a)]]
8462 set a [lindex $children($curview,$a) 0]
8465 if {[llength $children($curview,$b)] != 1} {
8466 appendshortlink $b [mc "Commit "] \
8467 [mc " has %s children - stopping\n" \
8468 [llength $children($curview,$b)]]
8471 set b [lindex $children($curview,$b) 0]
8474 $ctext conf -state disabled
8477 proc diffvssel {dirn} {
8478 global rowmenuid selectedline
8480 if {$selectedline eq {}} return
8482 set oldid [commitonrow $selectedline]
8483 set newid $rowmenuid
8485 set oldid $rowmenuid
8486 set newid [commitonrow $selectedline]
8488 addtohistory [list doseldiff $oldid $newid] savectextpos
8489 doseldiff $oldid $newid
8492 proc doseldiff {oldid newid} {
8496 $ctext conf -state normal
8498 init_flist [mc "Top"]
8499 $ctext insert end "[mc "From"] "
8500 $ctext insert end $oldid link0
8501 setlink $oldid link0
8502 $ctext insert end "\n "
8503 $ctext insert end [lindex $commitinfo($oldid) 0]
8504 $ctext insert end "\n\n[mc "To"] "
8505 $ctext insert end $newid link1
8506 setlink $newid link1
8507 $ctext insert end "\n "
8508 $ctext insert end [lindex $commitinfo($newid) 0]
8509 $ctext insert end "\n"
8510 $ctext conf -state disabled
8511 $ctext tag remove found 1.0 end
8512 startdiff [list $oldid $newid]
8516 global rowmenuid currentid commitinfo patchtop patchnum NS
8518 if {![info exists currentid]} return
8519 set oldid $currentid
8520 set oldhead [lindex $commitinfo($oldid) 0]
8521 set newid $rowmenuid
8522 set newhead [lindex $commitinfo($newid) 0]
8525 catch {destroy $top}
8527 make_transient $top .
8528 ${NS}::label $top.title -text [mc "Generate patch"]
8529 grid $top.title - -pady 10
8530 ${NS}::label $top.from -text [mc "From:"]
8531 ${NS}::entry $top.fromsha1 -width 40
8532 $top.fromsha1 insert 0 $oldid
8533 $top.fromsha1 conf -state readonly
8534 grid $top.from $top.fromsha1 -sticky w
8535 ${NS}::entry $top.fromhead -width 60
8536 $top.fromhead insert 0 $oldhead
8537 $top.fromhead conf -state readonly
8538 grid x $top.fromhead -sticky w
8539 ${NS}::label $top.to -text [mc "To:"]
8540 ${NS}::entry $top.tosha1 -width 40
8541 $top.tosha1 insert 0 $newid
8542 $top.tosha1 conf -state readonly
8543 grid $top.to $top.tosha1 -sticky w
8544 ${NS}::entry $top.tohead -width 60
8545 $top.tohead insert 0 $newhead
8546 $top.tohead conf -state readonly
8547 grid x $top.tohead -sticky w
8548 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8549 grid $top.rev x -pady 10 -padx 5
8550 ${NS}::label $top.flab -text [mc "Output file:"]
8551 ${NS}::entry $top.fname -width 60
8552 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8554 grid $top.flab $top.fname -sticky w
8555 ${NS}::frame $top.buts
8556 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8557 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8558 bind $top <Key-Return> mkpatchgo
8559 bind $top <Key-Escape> mkpatchcan
8560 grid $top.buts.gen $top.buts.can
8561 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8562 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8563 grid $top.buts - -pady 10 -sticky ew
8567 proc mkpatchrev {} {
8570 set oldid [$patchtop.fromsha1 get]
8571 set oldhead [$patchtop.fromhead get]
8572 set newid [$patchtop.tosha1 get]
8573 set newhead [$patchtop.tohead get]
8574 foreach e [list fromsha1 fromhead tosha1 tohead] \
8575 v [list $newid $newhead $oldid $oldhead] {
8576 $patchtop.$e conf -state normal
8577 $patchtop.$e delete 0 end
8578 $patchtop.$e insert 0 $v
8579 $patchtop.$e conf -state readonly
8584 global patchtop nullid nullid2
8586 set oldid [$patchtop.fromsha1 get]
8587 set newid [$patchtop.tosha1 get]
8588 set fname [$patchtop.fname get]
8589 set cmd [diffcmd [list $oldid $newid] -p]
8590 # trim off the initial "|"
8591 set cmd [lrange $cmd 1 end]
8592 lappend cmd >$fname &
8593 if {[catch {eval exec $cmd} err]} {
8594 error_popup "[mc "Error creating patch:"] $err" $patchtop
8596 catch {destroy $patchtop}
8600 proc mkpatchcan {} {
8603 catch {destroy $patchtop}
8608 global rowmenuid mktagtop commitinfo NS
8612 catch {destroy $top}
8614 make_transient $top .
8615 ${NS}::label $top.title -text [mc "Create tag"]
8616 grid $top.title - -pady 10
8617 ${NS}::label $top.id -text [mc "ID:"]
8618 ${NS}::entry $top.sha1 -width 40
8619 $top.sha1 insert 0 $rowmenuid
8620 $top.sha1 conf -state readonly
8621 grid $top.id $top.sha1 -sticky w
8622 ${NS}::entry $top.head -width 60
8623 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8624 $top.head conf -state readonly
8625 grid x $top.head -sticky w
8626 ${NS}::label $top.tlab -text [mc "Tag name:"]
8627 ${NS}::entry $top.tag -width 60
8628 grid $top.tlab $top.tag -sticky w
8629 ${NS}::frame $top.buts
8630 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8631 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8632 bind $top <Key-Return> mktaggo
8633 bind $top <Key-Escape> mktagcan
8634 grid $top.buts.gen $top.buts.can
8635 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8636 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8637 grid $top.buts - -pady 10 -sticky ew
8642 global mktagtop env tagids idtags
8644 set id [$mktagtop.sha1 get]
8645 set tag [$mktagtop.tag get]
8647 error_popup [mc "No tag name specified"] $mktagtop
8650 if {[info exists tagids($tag)]} {
8651 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8655 exec git tag $tag $id
8657 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8661 set tagids($tag) $id
8662 lappend idtags($id) $tag
8670 proc redrawtags {id} {
8671 global canv linehtag idpos currentid curview cmitlisted markedid
8672 global canvxmax iddrawn circleitem mainheadid circlecolors
8674 if {![commitinview $id $curview]} return
8675 if {![info exists iddrawn($id)]} return
8676 set row [rowofcommit $id]
8677 if {$id eq $mainheadid} {
8680 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8682 $canv itemconf $circleitem($row) -fill $ofill
8683 $canv delete tag.$id
8684 set xt [eval drawtags $id $idpos($id)]
8685 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8686 set text [$canv itemcget $linehtag($id) -text]
8687 set font [$canv itemcget $linehtag($id) -font]
8688 set xr [expr {$xt + [font measure $font $text]}]
8689 if {$xr > $canvxmax} {
8693 if {[info exists currentid] && $currentid == $id} {
8696 if {[info exists markedid] && $markedid eq $id} {
8704 catch {destroy $mktagtop}
8709 if {![domktag]} return
8713 proc writecommit {} {
8714 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8716 set top .writecommit
8718 catch {destroy $top}
8720 make_transient $top .
8721 ${NS}::label $top.title -text [mc "Write commit to file"]
8722 grid $top.title - -pady 10
8723 ${NS}::label $top.id -text [mc "ID:"]
8724 ${NS}::entry $top.sha1 -width 40
8725 $top.sha1 insert 0 $rowmenuid
8726 $top.sha1 conf -state readonly
8727 grid $top.id $top.sha1 -sticky w
8728 ${NS}::entry $top.head -width 60
8729 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8730 $top.head conf -state readonly
8731 grid x $top.head -sticky w
8732 ${NS}::label $top.clab -text [mc "Command:"]
8733 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8734 grid $top.clab $top.cmd -sticky w -pady 10
8735 ${NS}::label $top.flab -text [mc "Output file:"]
8736 ${NS}::entry $top.fname -width 60
8737 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8738 grid $top.flab $top.fname -sticky w
8739 ${NS}::frame $top.buts
8740 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8741 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8742 bind $top <Key-Return> wrcomgo
8743 bind $top <Key-Escape> wrcomcan
8744 grid $top.buts.gen $top.buts.can
8745 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8746 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8747 grid $top.buts - -pady 10 -sticky ew
8754 set id [$wrcomtop.sha1 get]
8755 set cmd "echo $id | [$wrcomtop.cmd get]"
8756 set fname [$wrcomtop.fname get]
8757 if {[catch {exec sh -c $cmd >$fname &} err]} {
8758 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8760 catch {destroy $wrcomtop}
8767 catch {destroy $wrcomtop}
8772 global rowmenuid mkbrtop NS
8775 catch {destroy $top}
8777 make_transient $top .
8778 ${NS}::label $top.title -text [mc "Create new branch"]
8779 grid $top.title - -pady 10
8780 ${NS}::label $top.id -text [mc "ID:"]
8781 ${NS}::entry $top.sha1 -width 40
8782 $top.sha1 insert 0 $rowmenuid
8783 $top.sha1 conf -state readonly
8784 grid $top.id $top.sha1 -sticky w
8785 ${NS}::label $top.nlab -text [mc "Name:"]
8786 ${NS}::entry $top.name -width 40
8787 grid $top.nlab $top.name -sticky w
8788 ${NS}::frame $top.buts
8789 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8790 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8791 bind $top <Key-Return> [list mkbrgo $top]
8792 bind $top <Key-Escape> "catch {destroy $top}"
8793 grid $top.buts.go $top.buts.can
8794 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8795 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8796 grid $top.buts - -pady 10 -sticky ew
8801 global headids idheads
8803 set name [$top.name get]
8804 set id [$top.sha1 get]
8808 error_popup [mc "Please specify a name for the new branch"] $top
8811 if {[info exists headids($name)]} {
8812 if {![confirm_popup [mc \
8813 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8816 set old_id $headids($name)
8819 catch {destroy $top}
8820 lappend cmdargs $name $id
8824 eval exec git branch $cmdargs
8830 if {$old_id ne {}} {
8836 set headids($name) $id
8837 lappend idheads($id) $name
8846 proc exec_citool {tool_args {baseid {}}} {
8847 global commitinfo env
8849 set save_env [array get env GIT_AUTHOR_*]
8851 if {$baseid ne {}} {
8852 if {![info exists commitinfo($baseid)]} {
8855 set author [lindex $commitinfo($baseid) 1]
8856 set date [lindex $commitinfo($baseid) 2]
8857 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8858 $author author name email]
8860 set env(GIT_AUTHOR_NAME) $name
8861 set env(GIT_AUTHOR_EMAIL) $email
8862 set env(GIT_AUTHOR_DATE) $date
8866 eval exec git citool $tool_args &
8868 array unset env GIT_AUTHOR_*
8869 array set env $save_env
8872 proc cherrypick {} {
8873 global rowmenuid curview
8874 global mainhead mainheadid
8876 set oldhead [exec git rev-parse HEAD]
8877 set dheads [descheads $rowmenuid]
8878 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8879 set ok [confirm_popup [mc "Commit %s is already\
8880 included in branch %s -- really re-apply it?" \
8881 [string range $rowmenuid 0 7] $mainhead]]
8884 nowbusy cherrypick [mc "Cherry-picking"]
8886 # Unfortunately git-cherry-pick writes stuff to stderr even when
8887 # no error occurs, and exec takes that as an indication of error...
8888 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8891 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8893 error_popup [mc "Cherry-pick failed because of local changes\
8894 to file '%s'.\nPlease commit, reset or stash\
8895 your changes and try again." $fname]
8896 } elseif {[regexp -line \
8897 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8899 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8900 conflict.\nDo you wish to run git citool to\
8902 # Force citool to read MERGE_MSG
8903 file delete [file join [gitdir] "GITGUI_MSG"]
8904 exec_citool {} $rowmenuid
8912 set newhead [exec git rev-parse HEAD]
8913 if {$newhead eq $oldhead} {
8915 error_popup [mc "No changes committed"]
8918 addnewchild $newhead $oldhead
8919 if {[commitinview $oldhead $curview]} {
8920 # XXX this isn't right if we have a path limit...
8921 insertrow $newhead $oldhead $curview
8922 if {$mainhead ne {}} {
8923 movehead $newhead $mainhead
8924 movedhead $newhead $mainhead
8926 set mainheadid $newhead
8935 global mainhead rowmenuid confirm_ok resettype NS
8938 set w ".confirmreset"
8941 wm title $w [mc "Confirm reset"]
8942 ${NS}::label $w.m -text \
8943 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
8944 pack $w.m -side top -fill x -padx 20 -pady 20
8945 ${NS}::labelframe $w.f -text [mc "Reset type:"]
8947 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
8948 -text [mc "Soft: Leave working tree and index untouched"]
8949 grid $w.f.soft -sticky w
8950 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
8951 -text [mc "Mixed: Leave working tree untouched, reset index"]
8952 grid $w.f.mixed -sticky w
8953 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
8954 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8955 grid $w.f.hard -sticky w
8956 pack $w.f -side top -fill x -padx 4
8957 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8958 pack $w.ok -side left -fill x -padx 20 -pady 20
8959 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
8960 bind $w <Key-Escape> [list destroy $w]
8961 pack $w.cancel -side right -fill x -padx 20 -pady 20
8962 bind $w <Visibility> "grab $w; focus $w"
8964 if {!$confirm_ok} return
8965 if {[catch {set fd [open \
8966 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8970 filerun $fd [list readresetstat $fd]
8971 nowbusy reset [mc "Resetting"]
8976 proc readresetstat {fd} {
8977 global mainhead mainheadid showlocalchanges rprogcoord
8979 if {[gets $fd line] >= 0} {
8980 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8981 set rprogcoord [expr {1.0 * $m / $n}]
8989 if {[catch {close $fd} err]} {
8992 set oldhead $mainheadid
8993 set newhead [exec git rev-parse HEAD]
8994 if {$newhead ne $oldhead} {
8995 movehead $newhead $mainhead
8996 movedhead $newhead $mainhead
8997 set mainheadid $newhead
9001 if {$showlocalchanges} {
9007 # context menu for a head
9008 proc headmenu {x y id head} {
9009 global headmenuid headmenuhead headctxmenu mainhead
9013 set headmenuhead $head
9015 if {$head eq $mainhead} {
9018 $headctxmenu entryconfigure 0 -state $state
9019 $headctxmenu entryconfigure 1 -state $state
9020 tk_popup $headctxmenu $x $y
9024 global headmenuid headmenuhead headids
9025 global showlocalchanges
9027 # check the tree is clean first??
9028 nowbusy checkout [mc "Checking out"]
9032 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9036 if {$showlocalchanges} {
9040 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9044 proc readcheckoutstat {fd newhead newheadid} {
9045 global mainhead mainheadid headids showlocalchanges progresscoords
9046 global viewmainheadid curview
9048 if {[gets $fd line] >= 0} {
9049 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9050 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9055 set progresscoords {0 0}
9058 if {[catch {close $fd} err]} {
9061 set oldmainid $mainheadid
9062 set mainhead $newhead
9063 set mainheadid $newheadid
9064 set viewmainheadid($curview) $newheadid
9065 redrawtags $oldmainid
9066 redrawtags $newheadid
9068 if {$showlocalchanges} {
9074 global headmenuid headmenuhead mainhead
9077 set head $headmenuhead
9079 # this check shouldn't be needed any more...
9080 if {$head eq $mainhead} {
9081 error_popup [mc "Cannot delete the currently checked-out branch"]
9084 set dheads [descheads $id]
9085 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9086 # the stuff on this branch isn't on any other branch
9087 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9088 branch.\nReally delete branch %s?" $head $head]]} return
9092 if {[catch {exec git branch -D $head} err]} {
9097 removehead $id $head
9098 removedhead $id $head
9105 # Display a list of tags and heads
9107 global showrefstop bgcolor fgcolor selectbgcolor NS
9108 global bglist fglist reflistfilter reflist maincursor
9111 set showrefstop $top
9112 if {[winfo exists $top]} {
9118 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9119 make_transient $top .
9120 text $top.list -background $bgcolor -foreground $fgcolor \
9121 -selectbackground $selectbgcolor -font mainfont \
9122 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9123 -width 30 -height 20 -cursor $maincursor \
9124 -spacing1 1 -spacing3 1 -state disabled
9125 $top.list tag configure highlight -background $selectbgcolor
9126 lappend bglist $top.list
9127 lappend fglist $top.list
9128 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9129 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9130 grid $top.list $top.ysb -sticky nsew
9131 grid $top.xsb x -sticky ew
9133 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9134 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9135 set reflistfilter "*"
9136 trace add variable reflistfilter write reflistfilter_change
9137 pack $top.f.e -side right -fill x -expand 1
9138 pack $top.f.l -side left
9139 grid $top.f - -sticky ew -pady 2
9140 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9141 bind $top <Key-Escape> [list destroy $top]
9143 grid columnconfigure $top 0 -weight 1
9144 grid rowconfigure $top 0 -weight 1
9145 bind $top.list <1> {break}
9146 bind $top.list <B1-Motion> {break}
9147 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9152 proc sel_reflist {w x y} {
9153 global showrefstop reflist headids tagids otherrefids
9155 if {![winfo exists $showrefstop]} return
9156 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9157 set ref [lindex $reflist [expr {$l-1}]]
9158 set n [lindex $ref 0]
9159 switch -- [lindex $ref 1] {
9160 "H" {selbyid $headids($n)}
9161 "T" {selbyid $tagids($n)}
9162 "o" {selbyid $otherrefids($n)}
9164 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9167 proc unsel_reflist {} {
9170 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9171 $showrefstop.list tag remove highlight 0.0 end
9174 proc reflistfilter_change {n1 n2 op} {
9175 global reflistfilter
9177 after cancel refill_reflist
9178 after 200 refill_reflist
9181 proc refill_reflist {} {
9182 global reflist reflistfilter showrefstop headids tagids otherrefids
9185 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9187 foreach n [array names headids] {
9188 if {[string match $reflistfilter $n]} {
9189 if {[commitinview $headids($n) $curview]} {
9190 lappend refs [list $n H]
9192 interestedin $headids($n) {run refill_reflist}
9196 foreach n [array names tagids] {
9197 if {[string match $reflistfilter $n]} {
9198 if {[commitinview $tagids($n) $curview]} {
9199 lappend refs [list $n T]
9201 interestedin $tagids($n) {run refill_reflist}
9205 foreach n [array names otherrefids] {
9206 if {[string match $reflistfilter $n]} {
9207 if {[commitinview $otherrefids($n) $curview]} {
9208 lappend refs [list $n o]
9210 interestedin $otherrefids($n) {run refill_reflist}
9214 set refs [lsort -index 0 $refs]
9215 if {$refs eq $reflist} return
9217 # Update the contents of $showrefstop.list according to the
9218 # differences between $reflist (old) and $refs (new)
9219 $showrefstop.list conf -state normal
9220 $showrefstop.list insert end "\n"
9223 while {$i < [llength $reflist] || $j < [llength $refs]} {
9224 if {$i < [llength $reflist]} {
9225 if {$j < [llength $refs]} {
9226 set cmp [string compare [lindex $reflist $i 0] \
9227 [lindex $refs $j 0]]
9229 set cmp [string compare [lindex $reflist $i 1] \
9230 [lindex $refs $j 1]]
9240 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9248 set l [expr {$j + 1}]
9249 $showrefstop.list image create $l.0 -align baseline \
9250 -image reficon-[lindex $refs $j 1] -padx 2
9251 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9257 # delete last newline
9258 $showrefstop.list delete end-2c end-1c
9259 $showrefstop.list conf -state disabled
9262 # Stuff for finding nearby tags
9263 proc getallcommits {} {
9264 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9265 global idheads idtags idotherrefs allparents tagobjid
9267 if {![info exists allcommits]} {
9273 set allccache [file join [gitdir] "gitk.cache"]
9275 set f [open $allccache r]
9284 set cmd [list | git rev-list --parents]
9285 set allcupdate [expr {$seeds ne {}}]
9289 set refs [concat [array names idheads] [array names idtags] \
9290 [array names idotherrefs]]
9293 foreach name [array names tagobjid] {
9294 lappend tagobjs $tagobjid($name)
9296 foreach id [lsort -unique $refs] {
9297 if {![info exists allparents($id)] &&
9298 [lsearch -exact $tagobjs $id] < 0} {
9309 set fd [open [concat $cmd $ids] r]
9310 fconfigure $fd -blocking 0
9313 filerun $fd [list getallclines $fd]
9319 # Since most commits have 1 parent and 1 child, we group strings of
9320 # such commits into "arcs" joining branch/merge points (BMPs), which
9321 # are commits that either don't have 1 parent or don't have 1 child.
9323 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9324 # arcout(id) - outgoing arcs for BMP
9325 # arcids(a) - list of IDs on arc including end but not start
9326 # arcstart(a) - BMP ID at start of arc
9327 # arcend(a) - BMP ID at end of arc
9328 # growing(a) - arc a is still growing
9329 # arctags(a) - IDs out of arcids (excluding end) that have tags
9330 # archeads(a) - IDs out of arcids (excluding end) that have heads
9331 # The start of an arc is at the descendent end, so "incoming" means
9332 # coming from descendents, and "outgoing" means going towards ancestors.
9334 proc getallclines {fd} {
9335 global allparents allchildren idtags idheads nextarc
9336 global arcnos arcids arctags arcout arcend arcstart archeads growing
9337 global seeds allcommits cachedarcs allcupdate
9340 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9341 set id [lindex $line 0]
9342 if {[info exists allparents($id)]} {
9347 set olds [lrange $line 1 end]
9348 set allparents($id) $olds
9349 if {![info exists allchildren($id)]} {
9350 set allchildren($id) {}
9355 if {[llength $olds] == 1 && [llength $a] == 1} {
9356 lappend arcids($a) $id
9357 if {[info exists idtags($id)]} {
9358 lappend arctags($a) $id
9360 if {[info exists idheads($id)]} {
9361 lappend archeads($a) $id
9363 if {[info exists allparents($olds)]} {
9364 # seen parent already
9365 if {![info exists arcout($olds)]} {
9368 lappend arcids($a) $olds
9369 set arcend($a) $olds
9372 lappend allchildren($olds) $id
9373 lappend arcnos($olds) $a
9377 foreach a $arcnos($id) {
9378 lappend arcids($a) $id
9385 lappend allchildren($p) $id
9386 set a [incr nextarc]
9387 set arcstart($a) $id
9394 if {[info exists allparents($p)]} {
9395 # seen it already, may need to make a new branch
9396 if {![info exists arcout($p)]} {
9399 lappend arcids($a) $p
9403 lappend arcnos($p) $a
9408 global cached_dheads cached_dtags cached_atags
9409 catch {unset cached_dheads}
9410 catch {unset cached_dtags}
9411 catch {unset cached_atags}
9414 return [expr {$nid >= 1000? 2: 1}]
9418 fconfigure $fd -blocking 1
9421 # got an error reading the list of commits
9422 # if we were updating, try rereading the whole thing again
9428 error_popup "[mc "Error reading commit topology information;\
9429 branch and preceding/following tag information\
9430 will be incomplete."]\n($err)"
9433 if {[incr allcommits -1] == 0} {
9443 proc recalcarc {a} {
9444 global arctags archeads arcids idtags idheads
9448 foreach id [lrange $arcids($a) 0 end-1] {
9449 if {[info exists idtags($id)]} {
9452 if {[info exists idheads($id)]} {
9457 set archeads($a) $ah
9461 global arcnos arcids nextarc arctags archeads idtags idheads
9462 global arcstart arcend arcout allparents growing
9465 if {[llength $a] != 1} {
9466 puts "oops splitarc called but [llength $a] arcs already"
9470 set i [lsearch -exact $arcids($a) $p]
9472 puts "oops splitarc $p not in arc $a"
9475 set na [incr nextarc]
9476 if {[info exists arcend($a)]} {
9477 set arcend($na) $arcend($a)
9479 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9480 set j [lsearch -exact $arcnos($l) $a]
9481 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9483 set tail [lrange $arcids($a) [expr {$i+1}] end]
9484 set arcids($a) [lrange $arcids($a) 0 $i]
9486 set arcstart($na) $p
9488 set arcids($na) $tail
9489 if {[info exists growing($a)]} {
9495 if {[llength $arcnos($id)] == 1} {
9498 set j [lsearch -exact $arcnos($id) $a]
9499 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9503 # reconstruct tags and heads lists
9504 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9509 set archeads($na) {}
9513 # Update things for a new commit added that is a child of one
9514 # existing commit. Used when cherry-picking.
9515 proc addnewchild {id p} {
9516 global allparents allchildren idtags nextarc
9517 global arcnos arcids arctags arcout arcend arcstart archeads growing
9518 global seeds allcommits
9520 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9521 set allparents($id) [list $p]
9522 set allchildren($id) {}
9525 lappend allchildren($p) $id
9526 set a [incr nextarc]
9527 set arcstart($a) $id
9530 set arcids($a) [list $p]
9532 if {![info exists arcout($p)]} {
9535 lappend arcnos($p) $a
9536 set arcout($id) [list $a]
9539 # This implements a cache for the topology information.
9540 # The cache saves, for each arc, the start and end of the arc,
9541 # the ids on the arc, and the outgoing arcs from the end.
9542 proc readcache {f} {
9543 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9544 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9549 if {$lim - $a > 500} {
9550 set lim [expr {$a + 500}]
9554 # finish reading the cache and setting up arctags, etc.
9556 if {$line ne "1"} {error "bad final version"}
9558 foreach id [array names idtags] {
9559 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9560 [llength $allparents($id)] == 1} {
9561 set a [lindex $arcnos($id) 0]
9562 if {$arctags($a) eq {}} {
9567 foreach id [array names idheads] {
9568 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9569 [llength $allparents($id)] == 1} {
9570 set a [lindex $arcnos($id) 0]
9571 if {$archeads($a) eq {}} {
9576 foreach id [lsort -unique $possible_seeds] {
9577 if {$arcnos($id) eq {}} {
9583 while {[incr a] <= $lim} {
9585 if {[llength $line] != 3} {error "bad line"}
9586 set s [lindex $line 0]
9588 lappend arcout($s) $a
9589 if {![info exists arcnos($s)]} {
9590 lappend possible_seeds $s
9593 set e [lindex $line 1]
9598 if {![info exists arcout($e)]} {
9602 set arcids($a) [lindex $line 2]
9603 foreach id $arcids($a) {
9604 lappend allparents($s) $id
9606 lappend arcnos($id) $a
9608 if {![info exists allparents($s)]} {
9609 set allparents($s) {}
9614 set nextarc [expr {$a - 1}]
9627 global nextarc cachedarcs possible_seeds
9631 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9632 # make sure it's an integer
9633 set cachedarcs [expr {int([lindex $line 1])}]
9634 if {$cachedarcs < 0} {error "bad number of arcs"}
9636 set possible_seeds {}
9644 proc dropcache {err} {
9645 global allcwait nextarc cachedarcs seeds
9647 #puts "dropping cache ($err)"
9648 foreach v {arcnos arcout arcids arcstart arcend growing \
9649 arctags archeads allparents allchildren} {
9660 proc writecache {f} {
9661 global cachearc cachedarcs allccache
9662 global arcstart arcend arcnos arcids arcout
9666 if {$lim - $a > 1000} {
9667 set lim [expr {$a + 1000}]
9670 while {[incr a] <= $lim} {
9671 if {[info exists arcend($a)]} {
9672 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9674 puts $f [list $arcstart($a) {} $arcids($a)]
9679 catch {file delete $allccache}
9680 #puts "writing cache failed ($err)"
9683 set cachearc [expr {$a - 1}]
9684 if {$a > $cachedarcs} {
9693 global nextarc cachedarcs cachearc allccache
9695 if {$nextarc == $cachedarcs} return
9697 set cachedarcs $nextarc
9699 set f [open $allccache w]
9700 puts $f [list 1 $cachedarcs]
9705 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9706 # or 0 if neither is true.
9707 proc anc_or_desc {a b} {
9708 global arcout arcstart arcend arcnos cached_isanc
9710 if {$arcnos($a) eq $arcnos($b)} {
9711 # Both are on the same arc(s); either both are the same BMP,
9712 # or if one is not a BMP, the other is also not a BMP or is
9713 # the BMP at end of the arc (and it only has 1 incoming arc).
9714 # Or both can be BMPs with no incoming arcs.
9715 if {$a eq $b || $arcnos($a) eq {}} {
9718 # assert {[llength $arcnos($a)] == 1}
9719 set arc [lindex $arcnos($a) 0]
9720 set i [lsearch -exact $arcids($arc) $a]
9721 set j [lsearch -exact $arcids($arc) $b]
9722 if {$i < 0 || $i > $j} {
9729 if {![info exists arcout($a)]} {
9730 set arc [lindex $arcnos($a) 0]
9731 if {[info exists arcend($arc)]} {
9732 set aend $arcend($arc)
9736 set a $arcstart($arc)
9740 if {![info exists arcout($b)]} {
9741 set arc [lindex $arcnos($b) 0]
9742 if {[info exists arcend($arc)]} {
9743 set bend $arcend($arc)
9747 set b $arcstart($arc)
9757 if {[info exists cached_isanc($a,$bend)]} {
9758 if {$cached_isanc($a,$bend)} {
9762 if {[info exists cached_isanc($b,$aend)]} {
9763 if {$cached_isanc($b,$aend)} {
9766 if {[info exists cached_isanc($a,$bend)]} {
9771 set todo [list $a $b]
9774 for {set i 0} {$i < [llength $todo]} {incr i} {
9775 set x [lindex $todo $i]
9776 if {$anc($x) eq {}} {
9779 foreach arc $arcnos($x) {
9780 set xd $arcstart($arc)
9782 set cached_isanc($a,$bend) 1
9783 set cached_isanc($b,$aend) 0
9785 } elseif {$xd eq $aend} {
9786 set cached_isanc($b,$aend) 1
9787 set cached_isanc($a,$bend) 0
9790 if {![info exists anc($xd)]} {
9791 set anc($xd) $anc($x)
9793 } elseif {$anc($xd) ne $anc($x)} {
9798 set cached_isanc($a,$bend) 0
9799 set cached_isanc($b,$aend) 0
9803 # This identifies whether $desc has an ancestor that is
9804 # a growing tip of the graph and which is not an ancestor of $anc
9805 # and returns 0 if so and 1 if not.
9806 # If we subsequently discover a tag on such a growing tip, and that
9807 # turns out to be a descendent of $anc (which it could, since we
9808 # don't necessarily see children before parents), then $desc
9809 # isn't a good choice to display as a descendent tag of
9810 # $anc (since it is the descendent of another tag which is
9811 # a descendent of $anc). Similarly, $anc isn't a good choice to
9812 # display as a ancestor tag of $desc.
9814 proc is_certain {desc anc} {
9815 global arcnos arcout arcstart arcend growing problems
9818 if {[llength $arcnos($anc)] == 1} {
9819 # tags on the same arc are certain
9820 if {$arcnos($desc) eq $arcnos($anc)} {
9823 if {![info exists arcout($anc)]} {
9824 # if $anc is partway along an arc, use the start of the arc instead
9825 set a [lindex $arcnos($anc) 0]
9826 set anc $arcstart($a)
9829 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9832 set a [lindex $arcnos($desc) 0]
9838 set anclist [list $x]
9842 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9843 set x [lindex $anclist $i]
9848 foreach a $arcout($x) {
9849 if {[info exists growing($a)]} {
9850 if {![info exists growanc($x)] && $dl($x)} {
9856 if {[info exists dl($y)]} {
9860 if {![info exists done($y)]} {
9863 if {[info exists growanc($x)]} {
9867 for {set k 0} {$k < [llength $xl]} {incr k} {
9868 set z [lindex $xl $k]
9869 foreach c $arcout($z) {
9870 if {[info exists arcend($c)]} {
9872 if {[info exists dl($v)] && $dl($v)} {
9874 if {![info exists done($v)]} {
9877 if {[info exists growanc($v)]} {
9887 } elseif {$y eq $anc || !$dl($x)} {
9898 foreach x [array names growanc] {
9907 proc validate_arctags {a} {
9908 global arctags idtags
9912 foreach id $arctags($a) {
9914 if {![info exists idtags($id)]} {
9915 set na [lreplace $na $i $i]
9922 proc validate_archeads {a} {
9923 global archeads idheads
9926 set na $archeads($a)
9927 foreach id $archeads($a) {
9929 if {![info exists idheads($id)]} {
9930 set na [lreplace $na $i $i]
9934 set archeads($a) $na
9937 # Return the list of IDs that have tags that are descendents of id,
9938 # ignoring IDs that are descendents of IDs already reported.
9939 proc desctags {id} {
9940 global arcnos arcstart arcids arctags idtags allparents
9941 global growing cached_dtags
9943 if {![info exists allparents($id)]} {
9946 set t1 [clock clicks -milliseconds]
9948 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9949 # part-way along an arc; check that arc first
9950 set a [lindex $arcnos($id) 0]
9951 if {$arctags($a) ne {}} {
9953 set i [lsearch -exact $arcids($a) $id]
9955 foreach t $arctags($a) {
9956 set j [lsearch -exact $arcids($a) $t]
9964 set id $arcstart($a)
9965 if {[info exists idtags($id)]} {
9969 if {[info exists cached_dtags($id)]} {
9970 return $cached_dtags($id)
9977 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9978 set id [lindex $todo $i]
9980 set ta [info exists hastaggedancestor($id)]
9984 # ignore tags on starting node
9985 if {!$ta && $i > 0} {
9986 if {[info exists idtags($id)]} {
9989 } elseif {[info exists cached_dtags($id)]} {
9990 set tagloc($id) $cached_dtags($id)
9994 foreach a $arcnos($id) {
9996 if {!$ta && $arctags($a) ne {}} {
9998 if {$arctags($a) ne {}} {
9999 lappend tagloc($id) [lindex $arctags($a) end]
10002 if {$ta || $arctags($a) ne {}} {
10003 set tomark [list $d]
10004 for {set j 0} {$j < [llength $tomark]} {incr j} {
10005 set dd [lindex $tomark $j]
10006 if {![info exists hastaggedancestor($dd)]} {
10007 if {[info exists done($dd)]} {
10008 foreach b $arcnos($dd) {
10009 lappend tomark $arcstart($b)
10011 if {[info exists tagloc($dd)]} {
10014 } elseif {[info exists queued($dd)]} {
10017 set hastaggedancestor($dd) 1
10021 if {![info exists queued($d)]} {
10024 if {![info exists hastaggedancestor($d)]} {
10031 foreach id [array names tagloc] {
10032 if {![info exists hastaggedancestor($id)]} {
10033 foreach t $tagloc($id) {
10034 if {[lsearch -exact $tags $t] < 0} {
10040 set t2 [clock clicks -milliseconds]
10043 # remove tags that are descendents of other tags
10044 for {set i 0} {$i < [llength $tags]} {incr i} {
10045 set a [lindex $tags $i]
10046 for {set j 0} {$j < $i} {incr j} {
10047 set b [lindex $tags $j]
10048 set r [anc_or_desc $a $b]
10050 set tags [lreplace $tags $j $j]
10053 } elseif {$r == -1} {
10054 set tags [lreplace $tags $i $i]
10061 if {[array names growing] ne {}} {
10062 # graph isn't finished, need to check if any tag could get
10063 # eclipsed by another tag coming later. Simply ignore any
10064 # tags that could later get eclipsed.
10067 if {[is_certain $t $origid]} {
10071 if {$tags eq $ctags} {
10072 set cached_dtags($origid) $tags
10077 set cached_dtags($origid) $tags
10079 set t3 [clock clicks -milliseconds]
10080 if {0 && $t3 - $t1 >= 100} {
10081 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10082 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10087 proc anctags {id} {
10088 global arcnos arcids arcout arcend arctags idtags allparents
10089 global growing cached_atags
10091 if {![info exists allparents($id)]} {
10094 set t1 [clock clicks -milliseconds]
10096 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10097 # part-way along an arc; check that arc first
10098 set a [lindex $arcnos($id) 0]
10099 if {$arctags($a) ne {}} {
10100 validate_arctags $a
10101 set i [lsearch -exact $arcids($a) $id]
10102 foreach t $arctags($a) {
10103 set j [lsearch -exact $arcids($a) $t]
10109 if {![info exists arcend($a)]} {
10113 if {[info exists idtags($id)]} {
10117 if {[info exists cached_atags($id)]} {
10118 return $cached_atags($id)
10122 set todo [list $id]
10126 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10127 set id [lindex $todo $i]
10129 set td [info exists hastaggeddescendent($id)]
10133 # ignore tags on starting node
10134 if {!$td && $i > 0} {
10135 if {[info exists idtags($id)]} {
10136 set tagloc($id) $id
10138 } elseif {[info exists cached_atags($id)]} {
10139 set tagloc($id) $cached_atags($id)
10143 foreach a $arcout($id) {
10144 if {!$td && $arctags($a) ne {}} {
10145 validate_arctags $a
10146 if {$arctags($a) ne {}} {
10147 lappend tagloc($id) [lindex $arctags($a) 0]
10150 if {![info exists arcend($a)]} continue
10152 if {$td || $arctags($a) ne {}} {
10153 set tomark [list $d]
10154 for {set j 0} {$j < [llength $tomark]} {incr j} {
10155 set dd [lindex $tomark $j]
10156 if {![info exists hastaggeddescendent($dd)]} {
10157 if {[info exists done($dd)]} {
10158 foreach b $arcout($dd) {
10159 if {[info exists arcend($b)]} {
10160 lappend tomark $arcend($b)
10163 if {[info exists tagloc($dd)]} {
10166 } elseif {[info exists queued($dd)]} {
10169 set hastaggeddescendent($dd) 1
10173 if {![info exists queued($d)]} {
10176 if {![info exists hastaggeddescendent($d)]} {
10182 set t2 [clock clicks -milliseconds]
10185 foreach id [array names tagloc] {
10186 if {![info exists hastaggeddescendent($id)]} {
10187 foreach t $tagloc($id) {
10188 if {[lsearch -exact $tags $t] < 0} {
10195 # remove tags that are ancestors of other tags
10196 for {set i 0} {$i < [llength $tags]} {incr i} {
10197 set a [lindex $tags $i]
10198 for {set j 0} {$j < $i} {incr j} {
10199 set b [lindex $tags $j]
10200 set r [anc_or_desc $a $b]
10202 set tags [lreplace $tags $j $j]
10205 } elseif {$r == 1} {
10206 set tags [lreplace $tags $i $i]
10213 if {[array names growing] ne {}} {
10214 # graph isn't finished, need to check if any tag could get
10215 # eclipsed by another tag coming later. Simply ignore any
10216 # tags that could later get eclipsed.
10219 if {[is_certain $origid $t]} {
10223 if {$tags eq $ctags} {
10224 set cached_atags($origid) $tags
10229 set cached_atags($origid) $tags
10231 set t3 [clock clicks -milliseconds]
10232 if {0 && $t3 - $t1 >= 100} {
10233 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10234 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10239 # Return the list of IDs that have heads that are descendents of id,
10240 # including id itself if it has a head.
10241 proc descheads {id} {
10242 global arcnos arcstart arcids archeads idheads cached_dheads
10245 if {![info exists allparents($id)]} {
10249 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10250 # part-way along an arc; check it first
10251 set a [lindex $arcnos($id) 0]
10252 if {$archeads($a) ne {}} {
10253 validate_archeads $a
10254 set i [lsearch -exact $arcids($a) $id]
10255 foreach t $archeads($a) {
10256 set j [lsearch -exact $arcids($a) $t]
10261 set id $arcstart($a)
10264 set todo [list $id]
10267 for {set i 0} {$i < [llength $todo]} {incr i} {
10268 set id [lindex $todo $i]
10269 if {[info exists cached_dheads($id)]} {
10270 set ret [concat $ret $cached_dheads($id)]
10272 if {[info exists idheads($id)]} {
10275 foreach a $arcnos($id) {
10276 if {$archeads($a) ne {}} {
10277 validate_archeads $a
10278 if {$archeads($a) ne {}} {
10279 set ret [concat $ret $archeads($a)]
10282 set d $arcstart($a)
10283 if {![info exists seen($d)]} {
10290 set ret [lsort -unique $ret]
10291 set cached_dheads($origid) $ret
10292 return [concat $ret $aret]
10295 proc addedtag {id} {
10296 global arcnos arcout cached_dtags cached_atags
10298 if {![info exists arcnos($id)]} return
10299 if {![info exists arcout($id)]} {
10300 recalcarc [lindex $arcnos($id) 0]
10302 catch {unset cached_dtags}
10303 catch {unset cached_atags}
10306 proc addedhead {hid head} {
10307 global arcnos arcout cached_dheads
10309 if {![info exists arcnos($hid)]} return
10310 if {![info exists arcout($hid)]} {
10311 recalcarc [lindex $arcnos($hid) 0]
10313 catch {unset cached_dheads}
10316 proc removedhead {hid head} {
10317 global cached_dheads
10319 catch {unset cached_dheads}
10322 proc movedhead {hid head} {
10323 global arcnos arcout cached_dheads
10325 if {![info exists arcnos($hid)]} return
10326 if {![info exists arcout($hid)]} {
10327 recalcarc [lindex $arcnos($hid) 0]
10329 catch {unset cached_dheads}
10332 proc changedrefs {} {
10333 global cached_dheads cached_dtags cached_atags
10334 global arctags archeads arcnos arcout idheads idtags
10336 foreach id [concat [array names idheads] [array names idtags]] {
10337 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10338 set a [lindex $arcnos($id) 0]
10339 if {![info exists donearc($a)]} {
10345 catch {unset cached_dtags}
10346 catch {unset cached_atags}
10347 catch {unset cached_dheads}
10350 proc rereadrefs {} {
10351 global idtags idheads idotherrefs mainheadid
10353 set refids [concat [array names idtags] \
10354 [array names idheads] [array names idotherrefs]]
10355 foreach id $refids {
10356 if {![info exists ref($id)]} {
10357 set ref($id) [listrefs $id]
10360 set oldmainhead $mainheadid
10363 set refids [lsort -unique [concat $refids [array names idtags] \
10364 [array names idheads] [array names idotherrefs]]]
10365 foreach id $refids {
10366 set v [listrefs $id]
10367 if {![info exists ref($id)] || $ref($id) != $v} {
10371 if {$oldmainhead ne $mainheadid} {
10372 redrawtags $oldmainhead
10373 redrawtags $mainheadid
10378 proc listrefs {id} {
10379 global idtags idheads idotherrefs
10382 if {[info exists idtags($id)]} {
10386 if {[info exists idheads($id)]} {
10387 set y $idheads($id)
10390 if {[info exists idotherrefs($id)]} {
10391 set z $idotherrefs($id)
10393 return [list $x $y $z]
10396 proc showtag {tag isnew} {
10397 global ctext tagcontents tagids linknum tagobjid
10400 addtohistory [list showtag $tag 0] savectextpos
10402 $ctext conf -state normal
10406 if {![info exists tagcontents($tag)]} {
10408 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
10411 if {[info exists tagcontents($tag)]} {
10412 set text $tagcontents($tag)
10414 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10416 appendwithlinks $text {}
10418 $ctext conf -state disabled
10430 if {[info exists gitktmpdir]} {
10431 catch {file delete -force $gitktmpdir}
10435 proc mkfontdisp {font top which} {
10436 global fontattr fontpref $font NS use_ttk
10438 set fontpref($font) [set $font]
10439 ${NS}::button $top.${font}but -text $which \
10440 -command [list choosefont $font $which]
10441 if {!$use_ttk} {$top.${font}but configure -font optionfont}
10442 ${NS}::label $top.$font -relief flat -font $font \
10443 -text $fontattr($font,family) -justify left
10444 grid x $top.${font}but $top.$font -sticky w
10447 proc choosefont {font which} {
10448 global fontparam fontlist fonttop fontattr
10451 set fontparam(which) $which
10452 set fontparam(font) $font
10453 set fontparam(family) [font actual $font -family]
10454 set fontparam(size) $fontattr($font,size)
10455 set fontparam(weight) $fontattr($font,weight)
10456 set fontparam(slant) $fontattr($font,slant)
10459 if {![winfo exists $top]} {
10461 eval font config sample [font actual $font]
10463 make_transient $top $prefstop
10464 wm title $top [mc "Gitk font chooser"]
10465 ${NS}::label $top.l -textvariable fontparam(which)
10466 pack $top.l -side top
10467 set fontlist [lsort [font families]]
10468 ${NS}::frame $top.f
10469 listbox $top.f.fam -listvariable fontlist \
10470 -yscrollcommand [list $top.f.sb set]
10471 bind $top.f.fam <<ListboxSelect>> selfontfam
10472 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10473 pack $top.f.sb -side right -fill y
10474 pack $top.f.fam -side left -fill both -expand 1
10475 pack $top.f -side top -fill both -expand 1
10476 ${NS}::frame $top.g
10477 spinbox $top.g.size -from 4 -to 40 -width 4 \
10478 -textvariable fontparam(size) \
10479 -validatecommand {string is integer -strict %s}
10480 checkbutton $top.g.bold -padx 5 \
10481 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10482 -variable fontparam(weight) -onvalue bold -offvalue normal
10483 checkbutton $top.g.ital -padx 5 \
10484 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10485 -variable fontparam(slant) -onvalue italic -offvalue roman
10486 pack $top.g.size $top.g.bold $top.g.ital -side left
10487 pack $top.g -side top
10488 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10490 $top.c create text 100 25 -anchor center -text $which -font sample \
10491 -fill black -tags text
10492 bind $top.c <Configure> [list centertext $top.c]
10493 pack $top.c -side top -fill x
10494 ${NS}::frame $top.buts
10495 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10496 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10497 bind $top <Key-Return> fontok
10498 bind $top <Key-Escape> fontcan
10499 grid $top.buts.ok $top.buts.can
10500 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10501 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10502 pack $top.buts -side bottom -fill x
10503 trace add variable fontparam write chg_fontparam
10506 $top.c itemconf text -text $which
10508 set i [lsearch -exact $fontlist $fontparam(family)]
10510 $top.f.fam selection set $i
10515 proc centertext {w} {
10516 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10520 global fontparam fontpref prefstop
10522 set f $fontparam(font)
10523 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10524 if {$fontparam(weight) eq "bold"} {
10525 lappend fontpref($f) "bold"
10527 if {$fontparam(slant) eq "italic"} {
10528 lappend fontpref($f) "italic"
10531 $w conf -text $fontparam(family) -font $fontpref($f)
10537 global fonttop fontparam
10539 if {[info exists fonttop]} {
10540 catch {destroy $fonttop}
10541 catch {font delete sample}
10547 if {[package vsatisfies [package provide Tk] 8.6]} {
10548 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10549 # function to make use of it.
10550 proc choosefont {font which} {
10551 tk fontchooser configure -title $which -font $font \
10552 -command [list on_choosefont $font $which]
10553 tk fontchooser show
10555 proc on_choosefont {font which newfont} {
10557 puts stderr "$font $newfont"
10558 array set f [font actual $newfont]
10559 set fontparam(which) $which
10560 set fontparam(font) $font
10561 set fontparam(family) $f(-family)
10562 set fontparam(size) $f(-size)
10563 set fontparam(weight) $f(-weight)
10564 set fontparam(slant) $f(-slant)
10569 proc selfontfam {} {
10570 global fonttop fontparam
10572 set i [$fonttop.f.fam curselection]
10574 set fontparam(family) [$fonttop.f.fam get $i]
10578 proc chg_fontparam {v sub op} {
10581 font config sample -$sub $fontparam($sub)
10585 global maxwidth maxgraphpct use_ttk NS
10586 global oldprefs prefstop showneartags showlocalchanges
10587 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10588 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10593 if {[winfo exists $top]} {
10597 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10598 limitdiffs tabstop perfile_attrs hideremotes} {
10599 set oldprefs($v) [set $v]
10602 wm title $top [mc "Gitk preferences"]
10603 make_transient $top .
10604 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10605 grid $top.ldisp - -sticky w -pady 10
10606 ${NS}::label $top.spacer -text " "
10607 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10608 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10609 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10610 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10611 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10612 grid x $top.maxpctl $top.maxpct -sticky w
10613 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10614 -variable showlocalchanges
10615 grid x $top.showlocal -sticky w
10616 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10617 -variable autoselect
10618 grid x $top.autoselect -sticky w
10620 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10621 grid $top.ddisp - -sticky w -pady 10
10622 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10623 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10624 grid x $top.tabstopl $top.tabstop -sticky w
10625 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10626 -variable showneartags
10627 grid x $top.ntag -sticky w
10628 ${NS}::checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10629 -variable hideremotes
10630 grid x $top.hideremotes -sticky w
10631 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10632 -variable limitdiffs
10633 grid x $top.ldiff -sticky w
10634 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10635 -variable perfile_attrs
10636 grid x $top.lattr -sticky w
10638 ${NS}::entry $top.extdifft -textvariable extdifftool
10639 ${NS}::frame $top.extdifff
10640 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10641 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10642 pack $top.extdifff.l $top.extdifff.b -side left
10643 pack configure $top.extdifff.l -padx 10
10644 grid x $top.extdifff $top.extdifft -sticky ew
10646 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10647 grid $top.cdisp - -sticky w -pady 10
10648 label $top.bg -padx 40 -relief sunk -background $bgcolor
10649 ${NS}::button $top.bgbut -text [mc "Background"] \
10650 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10651 grid x $top.bgbut $top.bg -sticky w
10652 label $top.fg -padx 40 -relief sunk -background $fgcolor
10653 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10654 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10655 grid x $top.fgbut $top.fg -sticky w
10656 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10657 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10658 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10659 [list $ctext tag conf d0 -foreground]]
10660 grid x $top.diffoldbut $top.diffold -sticky w
10661 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10662 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10663 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10664 [list $ctext tag conf dresult -foreground]]
10665 grid x $top.diffnewbut $top.diffnew -sticky w
10666 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10667 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10668 -command [list choosecolor diffcolors 2 $top.hunksep \
10669 [mc "diff hunk header"] \
10670 [list $ctext tag conf hunksep -foreground]]
10671 grid x $top.hunksepbut $top.hunksep -sticky w
10672 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10673 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10674 -command [list choosecolor markbgcolor {} $top.markbgsep \
10675 [mc "marked line background"] \
10676 [list $ctext tag conf omark -background]]
10677 grid x $top.markbgbut $top.markbgsep -sticky w
10678 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10679 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10680 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10681 grid x $top.selbgbut $top.selbgsep -sticky w
10683 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10684 grid $top.cfont - -sticky w -pady 10
10685 mkfontdisp mainfont $top [mc "Main font"]
10686 mkfontdisp textfont $top [mc "Diff display font"]
10687 mkfontdisp uifont $top [mc "User interface font"]
10690 foreach w {maxpctl maxwidthl showlocal autoselect tabstopl ntag
10691 ldiff lattr extdifff.l extdifff.b bgbut fgbut
10692 diffoldbut diffnewbut hunksepbut markbgbut selbgbut} {
10693 $top.$w configure -font optionfont
10697 ${NS}::frame $top.buts
10698 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10699 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10700 bind $top <Key-Return> prefsok
10701 bind $top <Key-Escape> prefscan
10702 grid $top.buts.ok $top.buts.can
10703 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10704 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10705 grid $top.buts - - -pady 10 -sticky ew
10706 grid columnconfigure $top 2 -weight 1
10707 bind $top <Visibility> "focus $top.buts.ok"
10710 proc choose_extdiff {} {
10713 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10715 set extdifftool $prog
10719 proc choosecolor {v vi w x cmd} {
10722 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10723 -title [mc "Gitk: choose color for %s" $x]]
10724 if {$c eq {}} return
10725 $w conf -background $c
10730 proc setselbg {c} {
10731 global bglist cflist
10732 foreach w $bglist {
10733 $w configure -selectbackground $c
10735 $cflist tag configure highlight \
10736 -background [$cflist cget -selectbackground]
10737 allcanvs itemconf secsel -fill $c
10743 foreach w $bglist {
10744 $w conf -background $c
10751 foreach w $fglist {
10752 $w conf -foreground $c
10754 allcanvs itemconf text -fill $c
10755 $canv itemconf circle -outline $c
10756 $canv itemconf markid -outline $c
10760 global oldprefs prefstop
10762 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10763 limitdiffs tabstop perfile_attrs hideremotes} {
10765 set $v $oldprefs($v)
10767 catch {destroy $prefstop}
10773 global maxwidth maxgraphpct
10774 global oldprefs prefstop showneartags showlocalchanges
10775 global fontpref mainfont textfont uifont
10776 global limitdiffs treediffs perfile_attrs
10779 catch {destroy $prefstop}
10783 if {$mainfont ne $fontpref(mainfont)} {
10784 set mainfont $fontpref(mainfont)
10785 parsefont mainfont $mainfont
10786 eval font configure mainfont [fontflags mainfont]
10787 eval font configure mainfontbold [fontflags mainfont 1]
10791 if {$textfont ne $fontpref(textfont)} {
10792 set textfont $fontpref(textfont)
10793 parsefont textfont $textfont
10794 eval font configure textfont [fontflags textfont]
10795 eval font configure textfontbold [fontflags textfont 1]
10797 if {$uifont ne $fontpref(uifont)} {
10798 set uifont $fontpref(uifont)
10799 parsefont uifont $uifont
10800 eval font configure uifont [fontflags uifont]
10803 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10804 if {$showlocalchanges} {
10810 if {$limitdiffs != $oldprefs(limitdiffs) ||
10811 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10812 # treediffs elements are limited by path;
10813 # won't have encodings cached if perfile_attrs was just turned on
10814 catch {unset treediffs}
10816 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10817 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10819 } elseif {$showneartags != $oldprefs(showneartags) ||
10820 $limitdiffs != $oldprefs(limitdiffs)} {
10823 if {$hideremotes != $oldprefs(hideremotes)} {
10828 proc formatdate {d} {
10829 global datetimeformat
10831 set d [clock format $d -format $datetimeformat]
10836 # This list of encoding names and aliases is distilled from
10837 # http://www.iana.org/assignments/character-sets.
10838 # Not all of them are supported by Tcl.
10839 set encoding_aliases {
10840 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10841 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10842 { ISO-10646-UTF-1 csISO10646UTF1 }
10843 { ISO_646.basic:1983 ref csISO646basic1983 }
10844 { INVARIANT csINVARIANT }
10845 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10846 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10847 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10848 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10849 { NATS-DANO iso-ir-9-1 csNATSDANO }
10850 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10851 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10852 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10853 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10854 { ISO-2022-KR csISO2022KR }
10856 { ISO-2022-JP csISO2022JP }
10857 { ISO-2022-JP-2 csISO2022JP2 }
10858 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10859 csISO13JISC6220jp }
10860 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10861 { IT iso-ir-15 ISO646-IT csISO15Italian }
10862 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10863 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10864 { greek7-old iso-ir-18 csISO18Greek7Old }
10865 { latin-greek iso-ir-19 csISO19LatinGreek }
10866 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10867 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10868 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10869 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10870 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10871 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10872 { INIS iso-ir-49 csISO49INIS }
10873 { INIS-8 iso-ir-50 csISO50INIS8 }
10874 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10875 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10876 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10877 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10878 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10879 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10880 csISO60Norwegian1 }
10881 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10882 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10883 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10884 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10885 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10886 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10887 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10888 { greek7 iso-ir-88 csISO88Greek7 }
10889 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10890 { iso-ir-90 csISO90 }
10891 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10892 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10893 csISO92JISC62991984b }
10894 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10895 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10896 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10897 csISO95JIS62291984handadd }
10898 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10899 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10900 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10901 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10902 CP819 csISOLatin1 }
10903 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10904 { T.61-7bit iso-ir-102 csISO102T617bit }
10905 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10906 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10907 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10908 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10909 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10910 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10911 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10912 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10913 arabic csISOLatinArabic }
10914 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10915 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10916 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10917 greek greek8 csISOLatinGreek }
10918 { T.101-G2 iso-ir-128 csISO128T101G2 }
10919 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10921 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10922 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10923 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10924 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10925 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10926 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10927 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10928 csISOLatinCyrillic }
10929 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10930 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10931 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10932 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10933 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10934 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10935 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10936 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10937 { ISO_10367-box iso-ir-155 csISO10367Box }
10938 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10939 { latin-lap lap iso-ir-158 csISO158Lap }
10940 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10941 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10944 { JIS_X0201 X0201 csHalfWidthKatakana }
10945 { KSC5636 ISO646-KR csKSC5636 }
10946 { ISO-10646-UCS-2 csUnicode }
10947 { ISO-10646-UCS-4 csUCS4 }
10948 { DEC-MCS dec csDECMCS }
10949 { hp-roman8 roman8 r8 csHPRoman8 }
10950 { macintosh mac csMacintosh }
10951 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10953 { IBM038 EBCDIC-INT cp038 csIBM038 }
10954 { IBM273 CP273 csIBM273 }
10955 { IBM274 EBCDIC-BE CP274 csIBM274 }
10956 { IBM275 EBCDIC-BR cp275 csIBM275 }
10957 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10958 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10959 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10960 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10961 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10962 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10963 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10964 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10965 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10966 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10967 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10968 { IBM437 cp437 437 csPC8CodePage437 }
10969 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10970 { IBM775 cp775 csPC775Baltic }
10971 { IBM850 cp850 850 csPC850Multilingual }
10972 { IBM851 cp851 851 csIBM851 }
10973 { IBM852 cp852 852 csPCp852 }
10974 { IBM855 cp855 855 csIBM855 }
10975 { IBM857 cp857 857 csIBM857 }
10976 { IBM860 cp860 860 csIBM860 }
10977 { IBM861 cp861 861 cp-is csIBM861 }
10978 { IBM862 cp862 862 csPC862LatinHebrew }
10979 { IBM863 cp863 863 csIBM863 }
10980 { IBM864 cp864 csIBM864 }
10981 { IBM865 cp865 865 csIBM865 }
10982 { IBM866 cp866 866 csIBM866 }
10983 { IBM868 CP868 cp-ar csIBM868 }
10984 { IBM869 cp869 869 cp-gr csIBM869 }
10985 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10986 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10987 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10988 { IBM891 cp891 csIBM891 }
10989 { IBM903 cp903 csIBM903 }
10990 { IBM904 cp904 904 csIBBM904 }
10991 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10992 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10993 { IBM1026 CP1026 csIBM1026 }
10994 { EBCDIC-AT-DE csIBMEBCDICATDE }
10995 { EBCDIC-AT-DE-A csEBCDICATDEA }
10996 { EBCDIC-CA-FR csEBCDICCAFR }
10997 { EBCDIC-DK-NO csEBCDICDKNO }
10998 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10999 { EBCDIC-FI-SE csEBCDICFISE }
11000 { EBCDIC-FI-SE-A csEBCDICFISEA }
11001 { EBCDIC-FR csEBCDICFR }
11002 { EBCDIC-IT csEBCDICIT }
11003 { EBCDIC-PT csEBCDICPT }
11004 { EBCDIC-ES csEBCDICES }
11005 { EBCDIC-ES-A csEBCDICESA }
11006 { EBCDIC-ES-S csEBCDICESS }
11007 { EBCDIC-UK csEBCDICUK }
11008 { EBCDIC-US csEBCDICUS }
11009 { UNKNOWN-8BIT csUnknown8BiT }
11010 { MNEMONIC csMnemonic }
11012 { VISCII csVISCII }
11015 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11016 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11017 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11018 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11019 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11020 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11021 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11022 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11023 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11024 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11025 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11026 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11027 { IBM1047 IBM-1047 }
11028 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11029 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11030 { UNICODE-1-1 csUnicode11 }
11031 { CESU-8 csCESU-8 }
11032 { BOCU-1 csBOCU-1 }
11033 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11034 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11036 { ISO-8859-15 ISO_8859-15 Latin-9 }
11037 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11038 { GBK CP936 MS936 windows-936 }
11039 { JIS_Encoding csJISEncoding }
11040 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11041 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11043 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11044 { ISO-10646-UCS-Basic csUnicodeASCII }
11045 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11046 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11047 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11048 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11049 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11050 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11051 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11052 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11053 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11054 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11055 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11056 { Ventura-US csVenturaUS }
11057 { Ventura-International csVenturaInternational }
11058 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11059 { PC8-Turkish csPC8Turkish }
11060 { IBM-Symbols csIBMSymbols }
11061 { IBM-Thai csIBMThai }
11062 { HP-Legal csHPLegal }
11063 { HP-Pi-font csHPPiFont }
11064 { HP-Math8 csHPMath8 }
11065 { Adobe-Symbol-Encoding csHPPSMath }
11066 { HP-DeskTop csHPDesktop }
11067 { Ventura-Math csVenturaMath }
11068 { Microsoft-Publishing csMicrosoftPublishing }
11069 { Windows-31J csWindows31J }
11070 { GB2312 csGB2312 }
11074 proc tcl_encoding {enc} {
11075 global encoding_aliases tcl_encoding_cache
11076 if {[info exists tcl_encoding_cache($enc)]} {
11077 return $tcl_encoding_cache($enc)
11079 set names [encoding names]
11080 set lcnames [string tolower $names]
11081 set enc [string tolower $enc]
11082 set i [lsearch -exact $lcnames $enc]
11084 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11085 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11086 set i [lsearch -exact $lcnames $encx]
11090 foreach l $encoding_aliases {
11091 set ll [string tolower $l]
11092 if {[lsearch -exact $ll $enc] < 0} continue
11093 # look through the aliases for one that tcl knows about
11095 set i [lsearch -exact $lcnames $e]
11097 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11098 set i [lsearch -exact $lcnames $ex]
11108 set tclenc [lindex $names $i]
11110 set tcl_encoding_cache($enc) $tclenc
11114 proc gitattr {path attr default} {
11115 global path_attr_cache
11116 if {[info exists path_attr_cache($attr,$path)]} {
11117 set r $path_attr_cache($attr,$path)
11119 set r "unspecified"
11120 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11121 regexp "(.*): $attr: (.*)" $line m f r
11123 set path_attr_cache($attr,$path) $r
11125 if {$r eq "unspecified"} {
11131 proc cache_gitattr {attr pathlist} {
11132 global path_attr_cache
11134 foreach path $pathlist {
11135 if {![info exists path_attr_cache($attr,$path)]} {
11136 lappend newlist $path
11140 if {[tk windowingsystem] == "win32"} {
11141 # windows has a 32k limit on the arguments to a command...
11144 while {$newlist ne {}} {
11145 set head [lrange $newlist 0 [expr {$lim - 1}]]
11146 set newlist [lrange $newlist $lim end]
11147 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11148 foreach row [split $rlist "\n"] {
11149 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11150 if {[string index $path 0] eq "\""} {
11151 set path [encoding convertfrom [lindex $path 0]]
11153 set path_attr_cache($attr,$path) $value
11160 proc get_path_encoding {path} {
11161 global gui_encoding perfile_attrs
11162 set tcl_enc $gui_encoding
11163 if {$path ne {} && $perfile_attrs} {
11164 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11172 # First check that Tcl/Tk is recent enough
11173 if {[catch {package require Tk 8.4} err]} {
11174 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11175 Gitk requires at least Tcl/Tk 8.4."]
11180 set wrcomcmd "git diff-tree --stdin -p --pretty"
11184 set gitencoding [exec git config --get i18n.commitencoding]
11187 set gitencoding [exec git config --get i18n.logoutputencoding]
11189 if {$gitencoding == ""} {
11190 set gitencoding "utf-8"
11192 set tclencoding [tcl_encoding $gitencoding]
11193 if {$tclencoding == {}} {
11194 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11197 set gui_encoding [encoding system]
11199 set enc [exec git config --get gui.encoding]
11201 set tclenc [tcl_encoding $enc]
11202 if {$tclenc ne {}} {
11203 set gui_encoding $tclenc
11205 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11210 if {[tk windowingsystem] eq "aqua"} {
11211 set mainfont {{Lucida Grande} 9}
11212 set textfont {Monaco 9}
11213 set uifont {{Lucida Grande} 9 bold}
11215 set mainfont {Helvetica 9}
11216 set textfont {Courier 9}
11217 set uifont {Helvetica 9 bold}
11220 set findmergefiles 0
11228 set cmitmode "patch"
11229 set wrapcomment "none"
11234 set showlocalchanges 1
11236 set datetimeformat "%Y-%m-%d %H:%M:%S"
11238 set perfile_attrs 0
11240 if {[tk windowingsystem] eq "aqua"} {
11241 set extdifftool "opendiff"
11243 set extdifftool "meld"
11246 set colors {green red blue magenta darkgrey brown orange}
11249 set diffcolors {red "#00a000" blue}
11252 set selectbgcolor gray85
11253 set markbgcolor "#e0e0ff"
11255 set circlecolors {white blue gray blue blue}
11257 # button for popping up context menus
11258 if {[tk windowingsystem] eq "aqua"} {
11259 set ctxbut <Button-2>
11261 set ctxbut <Button-3>
11264 ## For msgcat loading, first locate the installation location.
11265 if { [info exists ::env(GITK_MSGSDIR)] } {
11266 ## Msgsdir was manually set in the environment.
11267 set gitk_msgsdir $::env(GITK_MSGSDIR)
11269 ## Let's guess the prefix from argv0.
11270 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11271 set gitk_libdir [file join $gitk_prefix share gitk lib]
11272 set gitk_msgsdir [file join $gitk_libdir msgs]
11276 ## Internationalization (i18n) through msgcat and gettext. See
11277 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11278 package require msgcat
11279 namespace import ::msgcat::mc
11280 ## And eventually load the actual message catalog
11281 ::msgcat::mcload $gitk_msgsdir
11283 catch {source ~/.gitk}
11285 font create optionfont -family sans-serif -size -12
11287 parsefont mainfont $mainfont
11288 eval font create mainfont [fontflags mainfont]
11289 eval font create mainfontbold [fontflags mainfont 1]
11291 parsefont textfont $textfont
11292 eval font create textfont [fontflags textfont]
11293 eval font create textfontbold [fontflags textfont 1]
11295 parsefont uifont $uifont
11296 eval font create uifont [fontflags uifont]
11300 # check that we can find a .git directory somewhere...
11301 if {[catch {set gitdir [gitdir]}]} {
11302 show_error {} . [mc "Cannot find a git repository here."]
11305 if {![file isdirectory $gitdir]} {
11306 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11311 set selectheadid {}
11314 set cmdline_files {}
11316 set revtreeargscmd {}
11317 foreach arg $argv {
11318 switch -glob -- $arg {
11321 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11324 "--select-commit=*" {
11325 set selecthead [string range $arg 16 end]
11328 set revtreeargscmd [string range $arg 10 end]
11331 lappend revtreeargs $arg
11337 if {$selecthead eq "HEAD"} {
11341 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11342 # no -- on command line, but some arguments (other than --argscmd)
11344 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11345 set cmdline_files [split $f "\n"]
11346 set n [llength $cmdline_files]
11347 set revtreeargs [lrange $revtreeargs 0 end-$n]
11348 # Unfortunately git rev-parse doesn't produce an error when
11349 # something is both a revision and a filename. To be consistent
11350 # with git log and git rev-list, check revtreeargs for filenames.
11351 foreach arg $revtreeargs {
11352 if {[file exists $arg]} {
11353 show_error {} . [mc "Ambiguous argument '%s': both revision\
11354 and filename" $arg]
11359 # unfortunately we get both stdout and stderr in $err,
11360 # so look for "fatal:".
11361 set i [string first "fatal:" $err]
11363 set err [string range $err [expr {$i + 6}] end]
11365 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11370 set nullid "0000000000000000000000000000000000000000"
11371 set nullid2 "0000000000000000000000000000000000000001"
11372 set nullfile "/dev/null"
11374 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11375 if {![info exists use_ttk]} {
11376 set use_ttk [llength [info commands ::ttk::style]]
11378 set NS [expr {$use_ttk ? "ttk" : ""}]
11379 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11386 set highlight_paths {}
11388 set searchdirn -forwards
11391 set diffelide {0 0}
11392 set markingmatches 0
11393 set linkentercount 0
11394 set need_redisplay 0
11401 set selectedhlview [mc "None"]
11402 set highlight_related [mc "None"]
11403 set highlight_files {}
11404 set viewfiles(0) {}
11407 set viewargscmd(0) {}
11409 set selectedline {}
11417 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11421 image create photo gitlogo -width 16 -height 16
11423 image create photo gitlogominus -width 4 -height 2
11424 gitlogominus put #C00000 -to 0 0 4 2
11425 gitlogo copy gitlogominus -to 1 5
11426 gitlogo copy gitlogominus -to 6 5
11427 gitlogo copy gitlogominus -to 11 5
11428 image delete gitlogominus
11430 image create photo gitlogoplus -width 4 -height 4
11431 gitlogoplus put #008000 -to 1 0 3 4
11432 gitlogoplus put #008000 -to 0 1 4 3
11433 gitlogo copy gitlogoplus -to 1 9
11434 gitlogo copy gitlogoplus -to 6 9
11435 gitlogo copy gitlogoplus -to 11 9
11436 image delete gitlogoplus
11438 image create photo gitlogo32 -width 32 -height 32
11439 gitlogo32 copy gitlogo -zoom 2 2
11441 wm iconphoto . -default gitlogo gitlogo32
11443 # wait for the window to become visible
11444 tkwait visibility .
11445 wm title . "[file tail $argv0]: [file tail [pwd]]"
11449 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11450 # create a view for the files/dirs specified on the command line
11454 set viewname(1) [mc "Command line"]
11455 set viewfiles(1) $cmdline_files
11456 set viewargs(1) $revtreeargs
11457 set viewargscmd(1) $revtreeargscmd
11461 .bar.view entryconf [mca "Edit view..."] -state normal
11462 .bar.view entryconf [mca "Delete view"] -state normal
11465 if {[info exists permviews]} {
11466 foreach v $permviews {
11469 set viewname($n) [lindex $v 0]
11470 set viewfiles($n) [lindex $v 1]
11471 set viewargs($n) [lindex $v 2]
11472 set viewargscmd($n) [lindex $v 3]
11478 if {[tk windowingsystem] eq "win32"} {