2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
12 if {[info exists env
(GIT_DIR
)]} {
15 return [exec git rev-parse
--git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
25 global isonrunq runq currunq
28 if {[info exists isonrunq
($script)]} return
29 if {$runq eq
{} && ![info exists currunq
]} {
32 lappend runq
[list
{} $script]
33 set isonrunq
($script) 1
36 proc filerun
{fd
script} {
37 fileevent
$fd readable
[list filereadable
$fd $script]
40 proc filereadable
{fd
script} {
43 fileevent
$fd readable
{}
44 if {$runq eq
{} && ![info exists currunq
]} {
47 lappend runq
[list
$fd $script]
53 for {set i
0} {$i < [llength
$runq]} {} {
54 if {[lindex
$runq $i 0] eq
$fd} {
55 set runq
[lreplace
$runq $i $i]
63 global isonrunq runq currunq
65 set tstart
[clock clicks
-milliseconds]
67 while {[llength
$runq] > 0} {
68 set fd
[lindex
$runq 0 0]
69 set script [lindex
$runq 0 1]
70 set currunq
[lindex
$runq 0]
71 set runq
[lrange
$runq 1 end
]
72 set repeat
[eval $script]
74 set t1
[clock clicks
-milliseconds]
75 set t
[expr {$t1 - $t0}]
76 if {$repeat ne
{} && $repeat} {
77 if {$fd eq
{} ||
$repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq
[list
$fd $script]
82 fileevent
$fd readable
[list filereadable
$fd $script]
84 } elseif
{$fd eq
{}} {
85 unset isonrunq
($script)
88 if {$t1 - $tstart >= 80} break
95 proc reg_instance
{fd
} {
96 global commfd leftover loginstance
98 set i
[incr loginstance
]
104 proc unmerged_files
{files
} {
107 # find the list of unmerged files
111 set fd
[open
"| git ls-files -u" r
]
113 show_error
{} .
"[mc "Couldn
't get list of unmerged files:"] $err"
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
122 if {$files eq {} || [path_filter $files $fname]} {
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
139 set origargs $arglist
143 foreach arg $arglist {
150 switch -glob -- $arg {
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
158 # These request or affect diff output, which we don't want.
159 # Some could be used to set our defaults for diff display.
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 lappend diffargs
$arg
168 # These cause our parsing of git log's output to fail, or else
169 # they're options we want to set ourselves, so ignore them.
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" {
178 # These are harmless, and some are even useful
179 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
180 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
181 "--full-history" - "--dense" - "--sparse" -
182 "--follow" - "--left-right" - "--encoding=*" {
185 # These mean that we get a subset of the commits
186 "--diff-filter=*" - "--no-merges" - "--unpacked" -
187 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
188 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
189 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
190 "--remove-empty" - "--first-parent" - "--cherry-pick" -
191 "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
195 # This appears to be the only one that has a value as a
196 # separate word following it
203 set notflag
[expr {!$notflag}]
211 # git rev-parse doesn't understand --merge
212 lappend revargs
--gitk-symmetric-diff-marker MERGE_HEAD...HEAD
214 # Other flag arguments including -<n>
216 if {[string is digit
-strict [string range
$arg 1 end
]]} {
219 # a flag argument that we don't recognize;
220 # that means we can't optimize
225 # Non-flag arguments specify commits or ranges of commits
227 if {[string match
"*...*" $arg]} {
228 lappend revargs
--gitk-symmetric-diff-marker
234 set vdflags
($n) $diffargs
235 set vflags
($n) $glflags
236 set vrevs
($n) $revargs
237 set vfiltered
($n) $filtered
238 set vorigargs
($n) $origargs
242 proc parseviewrevs
{view revs
} {
243 global vposids vnegids
248 if {[catch
{set ids
[eval exec git rev-parse
$revs]} err
]} {
249 # we get stdout followed by stderr in $err
250 # for an unknown rev, git rev-parse echoes it and then errors out
251 set errlines
[split $err "\n"]
253 for {set l
0} {$l < [llength
$errlines]} {incr l
} {
254 set line
[lindex
$errlines $l]
255 if {!([string length
$line] == 40 && [string is xdigit
$line])} {
256 if {[string match
"fatal:*" $line]} {
257 if {[string match
"fatal: ambiguous argument*" $line]
259 if {[llength
$badrev] == 1} {
260 set err
"unknown revision $badrev"
262 set err
"unknown revisions: [join $badrev ", "]"
265 set err
[join [lrange
$errlines $l end
] "\n"]
272 error_popup
"[mc "Error parsing revisions
:"] $err"
279 foreach id
[split $ids "\n"] {
280 if {$id eq
"--gitk-symmetric-diff-marker"} {
282 } elseif
{[string match
"^*" $id]} {
289 lappend neg
[string range
$id 1 end
]
294 lset ret end
[lindex
$ret end
]...
$id
300 set vposids
($view) $pos
301 set vnegids
($view) $neg
305 # Start off a git log process and arrange to read its output
306 proc start_rev_list
{view
} {
307 global startmsecs commitidx viewcomplete curview
309 global viewargs viewargscmd viewfiles vfilelimit
310 global showlocalchanges commitinterest
311 global viewactive viewinstances vmergeonly
313 global vcanopt vflags vrevs vorigargs
315 set startmsecs
[clock clicks
-milliseconds]
316 set commitidx
($view) 0
317 # these are set this way for the error exits
318 set viewcomplete
($view) 1
319 set viewactive
($view) 0
322 set args
$viewargs($view)
323 if {$viewargscmd($view) ne
{}} {
325 set str
[exec sh
-c $viewargscmd($view)]
327 error_popup
"[mc "Error executing
--argscmd command:"] $err"
330 set args
[concat
$args [split $str "\n"]]
332 set vcanopt
($view) [parseviewargs
$view $args]
334 set files
$viewfiles($view)
335 if {$vmergeonly($view)} {
336 set files
[unmerged_files
$files]
339 if {$nr_unmerged == 0} {
340 error_popup
[mc
"No files selected: --merge specified but\
341 no files are unmerged."]
343 error_popup
[mc
"No files selected: --merge specified but\
344 no unmerged files are within file limit."]
349 set vfilelimit
($view) $files
351 if {$vcanopt($view)} {
352 set revs
[parseviewrevs
$view $vrevs($view)]
356 set args
[concat
$vflags($view) $revs]
358 set args
$vorigargs($view)
362 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
363 --boundary $args "--" $files] r
]
365 error_popup
"[mc "Error executing git log
:"] $err"
368 set i
[reg_instance
$fd]
369 set viewinstances
($view) [list
$i]
370 if {$showlocalchanges && $mainheadid ne
{}} {
371 lappend commitinterest
($mainheadid) {dodiffindex
}
373 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
374 if {$tclencoding != {}} {
375 fconfigure
$fd -encoding $tclencoding
377 filerun
$fd [list getcommitlines
$fd $i $view 0]
378 nowbusy
$view [mc
"Reading"]
379 set viewcomplete
($view) 0
380 set viewactive
($view) 1
384 proc stop_instance
{inst
} {
385 global commfd leftover
387 set fd
$commfd($inst)
391 if {$
::tcl_platform
(platform
) eq
{windows
}} {
400 unset leftover
($inst)
403 proc stop_backends
{} {
406 foreach inst
[array names commfd
] {
411 proc stop_rev_list
{view
} {
414 foreach inst
$viewinstances($view) {
417 set viewinstances
($view) {}
420 proc reset_pending_select
{selid
} {
421 global pending_select mainheadid selectheadid
424 set pending_select
$selid
425 } elseif
{$selectheadid ne
{}} {
426 set pending_select
$selectheadid
428 set pending_select
$mainheadid
432 proc getcommits
{selid
} {
433 global canv curview need_redisplay viewactive
436 if {[start_rev_list
$curview]} {
437 reset_pending_select
$selid
438 show_status
[mc
"Reading commits..."]
441 show_status
[mc
"No commits selected"]
445 proc updatecommits
{} {
446 global curview vcanopt vorigargs vfilelimit viewinstances
447 global viewactive viewcomplete tclencoding
448 global startmsecs showneartags showlocalchanges
449 global mainheadid pending_select
451 global varcid vposids vnegids vflags vrevs
453 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
454 set oldmainid
$mainheadid
456 if {$showlocalchanges} {
457 if {$mainheadid ne
$oldmainid} {
460 if {[commitinview
$mainheadid $curview]} {
465 if {$vcanopt($view)} {
466 set oldpos
$vposids($view)
467 set oldneg
$vnegids($view)
468 set revs
[parseviewrevs
$view $vrevs($view)]
472 # note: getting the delta when negative refs change is hard,
473 # and could require multiple git log invocations, so in that
474 # case we ask git log for all the commits (not just the delta)
475 if {$oldneg eq
$vnegids($view)} {
478 # take out positive refs that we asked for before or
479 # that we have already seen
481 if {[string length
$rev] == 40} {
482 if {[lsearch
-exact $oldpos $rev] < 0
483 && ![info exists varcid
($view,$rev)]} {
488 lappend
$newrevs $rev
491 if {$npos == 0} return
493 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
495 set args
[concat
$vflags($view) $revs --not $oldpos]
497 set args
$vorigargs($view)
500 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
501 --boundary $args "--" $vfilelimit($view)] r
]
503 error_popup
"[mc "Error executing git log
:"] $err"
506 if {$viewactive($view) == 0} {
507 set startmsecs
[clock clicks
-milliseconds]
509 set i
[reg_instance
$fd]
510 lappend viewinstances
($view) $i
511 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
512 if {$tclencoding != {}} {
513 fconfigure
$fd -encoding $tclencoding
515 filerun
$fd [list getcommitlines
$fd $i $view 1]
516 incr viewactive
($view)
517 set viewcomplete
($view) 0
518 reset_pending_select
{}
519 nowbusy
$view "Reading"
525 proc reloadcommits
{} {
526 global curview viewcomplete selectedline currentid thickerline
527 global showneartags treediffs commitinterest cached_commitrow
531 if {$selectedline ne
{}} {
535 if {!$viewcomplete($curview)} {
536 stop_rev_list
$curview
540 catch
{unset currentid
}
541 catch
{unset thickerline
}
542 catch
{unset treediffs
}
549 catch
{unset commitinterest
}
550 catch
{unset cached_commitrow
}
551 catch
{unset targetid
}
557 # This makes a string representation of a positive integer which
558 # sorts as a string in numerical order
561 return [format
"%x" $n]
562 } elseif
{$n < 256} {
563 return [format
"x%.2x" $n]
564 } elseif
{$n < 65536} {
565 return [format
"y%.4x" $n]
567 return [format
"z%.8x" $n]
570 # Procedures used in reordering commits from git log (without
571 # --topo-order) into the order for display.
573 proc varcinit
{view
} {
574 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
575 global vtokmod varcmod vrowmod varcix vlastins
577 set varcstart
($view) {{}}
578 set vupptr
($view) {0}
579 set vdownptr
($view) {0}
580 set vleftptr
($view) {0}
581 set vbackptr
($view) {0}
582 set varctok
($view) {{}}
583 set varcrow
($view) {{}}
584 set vtokmod
($view) {}
587 set varcix
($view) {{}}
588 set vlastins
($view) {0}
591 proc resetvarcs
{view
} {
592 global varcid varccommits parents children vseedcount ordertok
594 foreach vid
[array names varcid
$view,*] {
599 # some commits might have children but haven't been seen yet
600 foreach vid
[array names children
$view,*] {
603 foreach va
[array names varccommits
$view,*] {
604 unset varccommits
($va)
606 foreach vd
[array names vseedcount
$view,*] {
607 unset vseedcount
($vd)
609 catch
{unset ordertok
}
612 # returns a list of the commits with no children
614 global vdownptr vleftptr varcstart
617 set a
[lindex
$vdownptr($v) 0]
619 lappend ret
[lindex
$varcstart($v) $a]
620 set a
[lindex
$vleftptr($v) $a]
625 proc newvarc
{view id
} {
626 global varcid varctok parents children vdatemode
627 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
628 global commitdata commitinfo vseedcount varccommits vlastins
630 set a
[llength
$varctok($view)]
632 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
633 if {![info exists commitinfo
($id)]} {
634 parsecommit
$id $commitdata($id) 1
636 set cdate
[lindex
$commitinfo($id) 4]
637 if {![string is integer
-strict $cdate]} {
640 if {![info exists vseedcount
($view,$cdate)]} {
641 set vseedcount
($view,$cdate) -1
643 set c
[incr vseedcount
($view,$cdate)]
644 set cdate
[expr {$cdate ^
0xffffffff}]
645 set tok
"s[strrep $cdate][strrep $c]"
650 if {[llength
$children($vid)] > 0} {
651 set kid
[lindex
$children($vid) end
]
652 set k
$varcid($view,$kid)
653 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
656 set tok
[lindex
$varctok($view) $k]
660 set i
[lsearch
-exact $parents($view,$ki) $id]
661 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
662 append tok
[strrep
$j]
664 set c
[lindex
$vlastins($view) $ka]
665 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
667 set b
[lindex
$vdownptr($view) $ka]
669 set b
[lindex
$vleftptr($view) $c]
671 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
673 set b
[lindex
$vleftptr($view) $c]
676 lset vdownptr
($view) $ka $a
677 lappend vbackptr
($view) 0
679 lset vleftptr
($view) $c $a
680 lappend vbackptr
($view) $c
682 lset vlastins
($view) $ka $a
683 lappend vupptr
($view) $ka
684 lappend vleftptr
($view) $b
686 lset vbackptr
($view) $b $a
688 lappend varctok
($view) $tok
689 lappend varcstart
($view) $id
690 lappend vdownptr
($view) 0
691 lappend varcrow
($view) {}
692 lappend varcix
($view) {}
693 set varccommits
($view,$a) {}
694 lappend vlastins
($view) 0
698 proc splitvarc
{p v
} {
699 global varcid varcstart varccommits varctok
700 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
702 set oa
$varcid($v,$p)
703 set ac
$varccommits($v,$oa)
704 set i
[lsearch
-exact $varccommits($v,$oa) $p]
706 set na
[llength
$varctok($v)]
707 # "%" sorts before "0"...
708 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
709 lappend varctok
($v) $tok
710 lappend varcrow
($v) {}
711 lappend varcix
($v) {}
712 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
713 set varccommits
($v,$na) [lrange
$ac $i end
]
714 lappend varcstart
($v) $p
715 foreach id
$varccommits($v,$na) {
716 set varcid
($v,$id) $na
718 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
719 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
720 lset vdownptr
($v) $oa $na
721 lset vlastins
($v) $oa 0
722 lappend vupptr
($v) $oa
723 lappend vleftptr
($v) 0
724 lappend vbackptr
($v) 0
725 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
726 lset vupptr
($v) $b $na
730 proc renumbervarc
{a v
} {
731 global parents children varctok varcstart varccommits
732 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
734 set t1
[clock clicks
-milliseconds]
740 if {[info exists isrelated
($a)]} {
742 set id
[lindex
$varccommits($v,$a) end
]
743 foreach p
$parents($v,$id) {
744 if {[info exists varcid
($v,$p)]} {
745 set isrelated
($varcid($v,$p)) 1
750 set b
[lindex
$vdownptr($v) $a]
753 set b
[lindex
$vleftptr($v) $a]
755 set a
[lindex
$vupptr($v) $a]
761 if {![info exists kidchanged
($a)]} continue
762 set id
[lindex
$varcstart($v) $a]
763 if {[llength
$children($v,$id)] > 1} {
764 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
767 set oldtok
[lindex
$varctok($v) $a]
768 if {!$vdatemode($v)} {
774 set kid
[last_real_child
$v,$id]
776 set k
$varcid($v,$kid)
777 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
780 set tok
[lindex
$varctok($v) $k]
784 set i
[lsearch
-exact $parents($v,$ki) $id]
785 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
786 append tok
[strrep
$j]
788 if {$tok eq
$oldtok} {
791 set id
[lindex
$varccommits($v,$a) end
]
792 foreach p
$parents($v,$id) {
793 if {[info exists varcid
($v,$p)]} {
794 set kidchanged
($varcid($v,$p)) 1
799 lset varctok
($v) $a $tok
800 set b
[lindex
$vupptr($v) $a]
802 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
805 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
808 set c
[lindex
$vbackptr($v) $a]
809 set d
[lindex
$vleftptr($v) $a]
811 lset vdownptr
($v) $b $d
813 lset vleftptr
($v) $c $d
816 lset vbackptr
($v) $d $c
818 if {[lindex
$vlastins($v) $b] == $a} {
819 lset vlastins
($v) $b $c
821 lset vupptr
($v) $a $ka
822 set c
[lindex
$vlastins($v) $ka]
824 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
826 set b
[lindex
$vdownptr($v) $ka]
828 set b
[lindex
$vleftptr($v) $c]
831 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
833 set b
[lindex
$vleftptr($v) $c]
836 lset vdownptr
($v) $ka $a
837 lset vbackptr
($v) $a 0
839 lset vleftptr
($v) $c $a
840 lset vbackptr
($v) $a $c
842 lset vleftptr
($v) $a $b
844 lset vbackptr
($v) $b $a
846 lset vlastins
($v) $ka $a
849 foreach id
[array names sortkids
] {
850 if {[llength
$children($v,$id)] > 1} {
851 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
855 set t2
[clock clicks
-milliseconds]
856 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
859 # Fix up the graph after we have found out that in view $v,
860 # $p (a commit that we have already seen) is actually the parent
861 # of the last commit in arc $a.
862 proc fix_reversal
{p a v
} {
863 global varcid varcstart varctok vupptr
865 set pa
$varcid($v,$p)
866 if {$p ne
[lindex
$varcstart($v) $pa]} {
868 set pa
$varcid($v,$p)
870 # seeds always need to be renumbered
871 if {[lindex
$vupptr($v) $pa] == 0 ||
872 [string compare
[lindex
$varctok($v) $a] \
873 [lindex
$varctok($v) $pa]] > 0} {
878 proc insertrow
{id p v
} {
879 global cmitlisted children parents varcid varctok vtokmod
880 global varccommits ordertok commitidx numcommits curview
881 global targetid targetrow
885 set cmitlisted
($vid) 1
886 set children
($vid) {}
887 set parents
($vid) [list
$p]
888 set a
[newvarc
$v $id]
890 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
893 lappend varccommits
($v,$a) $id
895 if {[llength
[lappend children
($vp) $id]] > 1} {
896 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
897 catch
{unset ordertok
}
899 fix_reversal
$p $a $v
901 if {$v == $curview} {
902 set numcommits
$commitidx($v)
904 if {[info exists targetid
]} {
905 if {![comes_before
$targetid $p]} {
912 proc insertfakerow
{id p
} {
913 global varcid varccommits parents children cmitlisted
914 global commitidx varctok vtokmod targetid targetrow curview numcommits
918 set i
[lsearch
-exact $varccommits($v,$a) $p]
920 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
923 set children
($v,$id) {}
924 set parents
($v,$id) [list
$p]
925 set varcid
($v,$id) $a
926 lappend children
($v,$p) $id
927 set cmitlisted
($v,$id) 1
928 set numcommits
[incr commitidx
($v)]
929 # note we deliberately don't update varcstart($v) even if $i == 0
930 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
932 if {[info exists targetid
]} {
933 if {![comes_before
$targetid $p]} {
941 proc removefakerow
{id
} {
942 global varcid varccommits parents children commitidx
943 global varctok vtokmod cmitlisted currentid selectedline
944 global targetid curview numcommits
947 if {[llength
$parents($v,$id)] != 1} {
948 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
951 set p
[lindex
$parents($v,$id) 0]
952 set a
$varcid($v,$id)
953 set i
[lsearch
-exact $varccommits($v,$a) $id]
955 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
959 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
960 unset parents
($v,$id)
961 unset children
($v,$id)
962 unset cmitlisted
($v,$id)
963 set numcommits
[incr commitidx
($v) -1]
964 set j
[lsearch
-exact $children($v,$p) $id]
966 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
969 if {[info exist currentid
] && $id eq
$currentid} {
973 if {[info exists targetid
] && $targetid eq
$id} {
980 proc first_real_child
{vp
} {
981 global children nullid nullid2
983 foreach id
$children($vp) {
984 if {$id ne
$nullid && $id ne
$nullid2} {
991 proc last_real_child
{vp
} {
992 global children nullid nullid2
994 set kids
$children($vp)
995 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
996 set id
[lindex
$kids $i]
997 if {$id ne
$nullid && $id ne
$nullid2} {
1004 proc vtokcmp
{v a b
} {
1005 global varctok varcid
1007 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1008 [lindex
$varctok($v) $varcid($v,$b)]]
1011 # This assumes that if lim is not given, the caller has checked that
1012 # arc a's token is less than $vtokmod($v)
1013 proc modify_arc
{v a
{lim
{}}} {
1014 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1017 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
1020 set r
[lindex
$varcrow($v) $a]
1021 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
1024 set vtokmod
($v) [lindex
$varctok($v) $a]
1026 if {$v == $curview} {
1027 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
1028 set a
[lindex
$vupptr($v) $a]
1034 set lim
[llength
$varccommits($v,$a)]
1036 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1043 proc update_arcrows
{v
} {
1044 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1045 global varcid vrownum varcorder varcix varccommits
1046 global vupptr vdownptr vleftptr varctok
1047 global displayorder parentlist curview cached_commitrow
1049 if {$vrowmod($v) == $commitidx($v)} return
1050 if {$v == $curview} {
1051 if {[llength
$displayorder] > $vrowmod($v)} {
1052 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1053 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1055 catch
{unset cached_commitrow
}
1057 set narctot
[expr {[llength
$varctok($v)] - 1}]
1059 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1060 # go up the tree until we find something that has a row number,
1061 # or we get to a seed
1062 set a
[lindex
$vupptr($v) $a]
1065 set a
[lindex
$vdownptr($v) 0]
1068 set varcorder
($v) [list
$a]
1069 lset varcix
($v) $a 0
1070 lset varcrow
($v) $a 0
1074 set arcn
[lindex
$varcix($v) $a]
1075 if {[llength
$vrownum($v)] > $arcn + 1} {
1076 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1077 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1079 set row
[lindex
$varcrow($v) $a]
1083 incr row
[llength
$varccommits($v,$a)]
1084 # go down if possible
1085 set b
[lindex
$vdownptr($v) $a]
1087 # if not, go left, or go up until we can go left
1089 set b
[lindex
$vleftptr($v) $a]
1091 set a
[lindex
$vupptr($v) $a]
1097 lappend vrownum
($v) $row
1098 lappend varcorder
($v) $a
1099 lset varcix
($v) $a $arcn
1100 lset varcrow
($v) $a $row
1102 set vtokmod
($v) [lindex
$varctok($v) $p]
1104 set vrowmod
($v) $row
1105 if {[info exists currentid
]} {
1106 set selectedline
[rowofcommit
$currentid]
1110 # Test whether view $v contains commit $id
1111 proc commitinview
{id v
} {
1114 return [info exists varcid
($v,$id)]
1117 # Return the row number for commit $id in the current view
1118 proc rowofcommit
{id
} {
1119 global varcid varccommits varcrow curview cached_commitrow
1120 global varctok vtokmod
1123 if {![info exists varcid
($v,$id)]} {
1124 puts
"oops rowofcommit no arc for [shortids $id]"
1127 set a
$varcid($v,$id)
1128 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1131 if {[info exists cached_commitrow
($id)]} {
1132 return $cached_commitrow($id)
1134 set i
[lsearch
-exact $varccommits($v,$a) $id]
1136 puts
"oops didn't find commit [shortids $id] in arc $a"
1139 incr i
[lindex
$varcrow($v) $a]
1140 set cached_commitrow
($id) $i
1144 # Returns 1 if a is on an earlier row than b, otherwise 0
1145 proc comes_before
{a b
} {
1146 global varcid varctok curview
1149 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1150 ![info exists varcid
($v,$b)]} {
1153 if {$varcid($v,$a) != $varcid($v,$b)} {
1154 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1155 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1157 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1160 proc bsearch
{l elt
} {
1161 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1166 while {$hi - $lo > 1} {
1167 set mid
[expr {int
(($lo + $hi) / 2)}]
1168 set t
[lindex
$l $mid]
1171 } elseif
{$elt > $t} {
1180 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1181 proc make_disporder
{start end
} {
1182 global vrownum curview commitidx displayorder parentlist
1183 global varccommits varcorder parents vrowmod varcrow
1184 global d_valid_start d_valid_end
1186 if {$end > $vrowmod($curview)} {
1187 update_arcrows
$curview
1189 set ai
[bsearch
$vrownum($curview) $start]
1190 set start
[lindex
$vrownum($curview) $ai]
1191 set narc
[llength
$vrownum($curview)]
1192 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1193 set a
[lindex
$varcorder($curview) $ai]
1194 set l
[llength
$displayorder]
1195 set al
[llength
$varccommits($curview,$a)]
1196 if {$l < $r + $al} {
1198 set pad
[ntimes
[expr {$r - $l}] {}]
1199 set displayorder
[concat
$displayorder $pad]
1200 set parentlist
[concat
$parentlist $pad]
1201 } elseif
{$l > $r} {
1202 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1203 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1205 foreach id
$varccommits($curview,$a) {
1206 lappend displayorder
$id
1207 lappend parentlist
$parents($curview,$id)
1209 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1211 foreach id
$varccommits($curview,$a) {
1212 lset displayorder
$i $id
1213 lset parentlist
$i $parents($curview,$id)
1221 proc commitonrow
{row
} {
1224 set id
[lindex
$displayorder $row]
1226 make_disporder
$row [expr {$row + 1}]
1227 set id
[lindex
$displayorder $row]
1232 proc closevarcs
{v
} {
1233 global varctok varccommits varcid parents children
1234 global cmitlisted commitidx commitinterest vtokmod
1236 set missing_parents
0
1238 set narcs
[llength
$varctok($v)]
1239 for {set a
1} {$a < $narcs} {incr a
} {
1240 set id
[lindex
$varccommits($v,$a) end
]
1241 foreach p
$parents($v,$id) {
1242 if {[info exists varcid
($v,$p)]} continue
1243 # add p as a new commit
1244 incr missing_parents
1245 set cmitlisted
($v,$p) 0
1246 set parents
($v,$p) {}
1247 if {[llength
$children($v,$p)] == 1 &&
1248 [llength
$parents($v,$id)] == 1} {
1251 set b
[newvarc
$v $p]
1253 set varcid
($v,$p) $b
1254 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1257 lappend varccommits
($v,$b) $p
1259 if {[info exists commitinterest
($p)]} {
1260 foreach
script $commitinterest($p) {
1261 lappend scripts
[string map
[list
"%I" $p] $script]
1263 unset commitinterest
($id)
1267 if {$missing_parents > 0} {
1268 foreach s
$scripts {
1274 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1275 # Assumes we already have an arc for $rwid.
1276 proc rewrite_commit
{v id rwid
} {
1277 global children parents varcid varctok vtokmod varccommits
1279 foreach ch
$children($v,$id) {
1280 # make $rwid be $ch's parent in place of $id
1281 set i
[lsearch
-exact $parents($v,$ch) $id]
1283 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1285 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1286 # add $ch to $rwid's children and sort the list if necessary
1287 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1288 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1289 $children($v,$rwid)]
1291 # fix the graph after joining $id to $rwid
1292 set a
$varcid($v,$ch)
1293 fix_reversal
$rwid $a $v
1294 # parentlist is wrong for the last element of arc $a
1295 # even if displayorder is right, hence the 3rd arg here
1296 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1300 proc getcommitlines
{fd inst view updating
} {
1301 global cmitlisted commitinterest leftover
1302 global commitidx commitdata vdatemode
1303 global parents children curview hlview
1304 global idpending ordertok
1305 global varccommits varcid varctok vtokmod vfilelimit
1307 set stuff
[read $fd 500000]
1308 # git log doesn't terminate the last commit with a null...
1309 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1316 global commfd viewcomplete viewactive viewname
1317 global viewinstances
1319 set i
[lsearch
-exact $viewinstances($view) $inst]
1321 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1323 # set it blocking so we wait for the process to terminate
1324 fconfigure
$fd -blocking 1
1325 if {[catch
{close
$fd} err
]} {
1327 if {$view != $curview} {
1328 set fv
" for the \"$viewname($view)\" view"
1330 if {[string range
$err 0 4] == "usage"} {
1331 set err
"Gitk: error reading commits$fv:\
1332 bad arguments to git log."
1333 if {$viewname($view) eq
"Command line"} {
1335 " (Note: arguments to gitk are passed to git log\
1336 to allow selection of commits to be displayed.)"
1339 set err
"Error reading commits$fv: $err"
1343 if {[incr viewactive
($view) -1] <= 0} {
1344 set viewcomplete
($view) 1
1345 # Check if we have seen any ids listed as parents that haven't
1346 # appeared in the list
1350 if {$view == $curview} {
1359 set i
[string first
"\0" $stuff $start]
1361 append leftover
($inst) [string range
$stuff $start end
]
1365 set cmit
$leftover($inst)
1366 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1367 set leftover
($inst) {}
1369 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1371 set start
[expr {$i + 1}]
1372 set j
[string first
"\n" $cmit]
1375 if {$j >= 0 && [string match
"commit *" $cmit]} {
1376 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1377 if {[string match
{[-^
<>]*} $ids]} {
1378 switch
-- [string index
$ids 0] {
1384 set ids
[string range
$ids 1 end
]
1388 if {[string length
$id] != 40} {
1396 if {[string length
$shortcmit] > 80} {
1397 set shortcmit
"[string range $shortcmit 0 80]..."
1399 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1402 set id [lindex $ids 0]
1405 if {!$listed && $updating && ![info exists varcid($vid)] &&
1406 $vfilelimit($view) ne {}} {
1407 # git log doesn't rewrite parents
for unlisted commits
1408 # when doing path limiting, so work around that here
1409 # by working out the rewritten parent with git rev-list
1410 # and if we already know about it, using the rewritten
1411 # parent as a substitute parent for $id's children.
1413 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1414 $id -- $vfilelimit($view)]
1416 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1417 # use $rwid in place of $id
1418 rewrite_commit
$view $id $rwid
1425 if {[info exists varcid
($vid)]} {
1426 if {$cmitlisted($vid) ||
!$listed} continue
1430 set olds
[lrange
$ids 1 end
]
1434 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1435 set cmitlisted
($vid) $listed
1436 set parents
($vid) $olds
1437 if {![info exists children
($vid)]} {
1438 set children
($vid) {}
1439 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1440 set k
[lindex
$children($vid) 0]
1441 if {[llength
$parents($view,$k)] == 1 &&
1442 (!$vdatemode($view) ||
1443 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1444 set a
$varcid($view,$k)
1449 set a
[newvarc
$view $id]
1451 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1454 if {![info exists varcid
($vid)]} {
1456 lappend varccommits
($view,$a) $id
1457 incr commitidx
($view)
1462 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1464 if {[llength
[lappend children
($vp) $id]] > 1 &&
1465 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1466 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1468 catch
{unset ordertok
}
1470 if {[info exists varcid
($view,$p)]} {
1471 fix_reversal
$p $a $view
1477 if {[info exists commitinterest
($id)]} {
1478 foreach
script $commitinterest($id) {
1479 lappend scripts
[string map
[list
"%I" $id] $script]
1481 unset commitinterest
($id)
1486 global numcommits hlview
1488 if {$view == $curview} {
1489 set numcommits
$commitidx($view)
1492 if {[info exists hlview
] && $view == $hlview} {
1493 # we never actually get here...
1496 foreach s
$scripts {
1503 proc chewcommits
{} {
1504 global curview hlview viewcomplete
1505 global pending_select
1508 if {$viewcomplete($curview)} {
1509 global commitidx varctok
1510 global numcommits startmsecs
1512 if {[info exists pending_select
]} {
1514 reset_pending_select
{}
1516 if {[commitinview
$pending_select $curview]} {
1517 selectline
[rowofcommit
$pending_select] 1
1519 set row
[first_real_row
]
1523 if {$commitidx($curview) > 0} {
1524 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1525 #puts "overall $ms ms for $numcommits commits"
1526 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1528 show_status
[mc
"No commits selected"]
1535 proc readcommit
{id
} {
1536 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1537 parsecommit
$id $contents 0
1540 proc parsecommit
{id contents listed
} {
1541 global commitinfo cdate
1550 set hdrend
[string first
"\n\n" $contents]
1552 # should never happen...
1553 set hdrend
[string length
$contents]
1555 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1556 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1557 foreach line
[split $header "\n"] {
1558 set tag
[lindex
$line 0]
1559 if {$tag == "author"} {
1560 set audate
[lindex
$line end-1
]
1561 set auname
[lrange
$line 1 end-2
]
1562 } elseif
{$tag == "committer"} {
1563 set comdate
[lindex
$line end-1
]
1564 set comname
[lrange
$line 1 end-2
]
1568 # take the first non-blank line of the comment as the headline
1569 set headline
[string trimleft
$comment]
1570 set i
[string first
"\n" $headline]
1572 set headline
[string range
$headline 0 $i]
1574 set headline
[string trimright
$headline]
1575 set i
[string first
"\r" $headline]
1577 set headline
[string trimright
[string range
$headline 0 $i]]
1580 # git log indents the comment by 4 spaces;
1581 # if we got this via git cat-file, add the indentation
1583 foreach line
[split $comment "\n"] {
1584 append newcomment
" "
1585 append newcomment
$line
1586 append newcomment
"\n"
1588 set comment
$newcomment
1590 if {$comdate != {}} {
1591 set cdate
($id) $comdate
1593 set commitinfo
($id) [list
$headline $auname $audate \
1594 $comname $comdate $comment]
1597 proc getcommit
{id
} {
1598 global commitdata commitinfo
1600 if {[info exists commitdata
($id)]} {
1601 parsecommit
$id $commitdata($id) 1
1604 if {![info exists commitinfo
($id)]} {
1605 set commitinfo
($id) [list
[mc
"No commit information available"]]
1612 global tagids idtags headids idheads tagobjid
1613 global otherrefids idotherrefs mainhead mainheadid
1614 global selecthead selectheadid
1616 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1619 set refd
[open
[list | git show-ref
-d] r
]
1620 while {[gets
$refd line
] >= 0} {
1621 if {[string index
$line 40] ne
" "} continue
1622 set id
[string range
$line 0 39]
1623 set ref
[string range
$line 41 end
]
1624 if {![string match
"refs/*" $ref]} continue
1625 set name
[string range
$ref 5 end
]
1626 if {[string match
"remotes/*" $name]} {
1627 if {![string match
"*/HEAD" $name]} {
1628 set headids
($name) $id
1629 lappend idheads
($id) $name
1631 } elseif
{[string match
"heads/*" $name]} {
1632 set name
[string range
$name 6 end
]
1633 set headids
($name) $id
1634 lappend idheads
($id) $name
1635 } elseif
{[string match
"tags/*" $name]} {
1636 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1637 # which is what we want since the former is the commit ID
1638 set name
[string range
$name 5 end
]
1639 if {[string match
"*^{}" $name]} {
1640 set name
[string range
$name 0 end-3
]
1642 set tagobjid
($name) $id
1644 set tagids
($name) $id
1645 lappend idtags
($id) $name
1647 set otherrefids
($name) $id
1648 lappend idotherrefs
($id) $name
1655 set mainheadid
[exec git rev-parse HEAD
]
1656 set thehead
[exec git symbolic-ref HEAD
]
1657 if {[string match
"refs/heads/*" $thehead]} {
1658 set mainhead
[string range
$thehead 11 end
]
1662 if {$selecthead ne
{}} {
1664 set selectheadid
[exec git rev-parse
--verify $selecthead]
1669 # skip over fake commits
1670 proc first_real_row
{} {
1671 global nullid nullid2 numcommits
1673 for {set row
0} {$row < $numcommits} {incr row
} {
1674 set id
[commitonrow
$row]
1675 if {$id ne
$nullid && $id ne
$nullid2} {
1682 # update things for a head moved to a child of its previous location
1683 proc movehead
{id name
} {
1684 global headids idheads
1686 removehead
$headids($name) $name
1687 set headids
($name) $id
1688 lappend idheads
($id) $name
1691 # update things when a head has been removed
1692 proc removehead
{id name
} {
1693 global headids idheads
1695 if {$idheads($id) eq
$name} {
1698 set i
[lsearch
-exact $idheads($id) $name]
1700 set idheads
($id) [lreplace
$idheads($id) $i $i]
1703 unset headids
($name)
1706 proc show_error
{w top msg
} {
1707 message
$w.m
-text $msg -justify center
-aspect 400
1708 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1709 button
$w.ok
-text [mc OK
] -command "destroy $top"
1710 pack
$w.ok
-side bottom
-fill x
1711 bind $top <Visibility
> "grab $top; focus $top"
1712 bind $top <Key-Return
> "destroy $top"
1716 proc error_popup msg
{
1720 show_error
$w $w $msg
1723 proc confirm_popup msg
{
1729 message
$w.m
-text $msg -justify center
-aspect 400
1730 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1731 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1732 pack
$w.ok
-side left
-fill x
1733 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1734 pack
$w.cancel
-side right
-fill x
1735 bind $w <Visibility
> "grab $w; focus $w"
1740 proc setoptions
{} {
1741 option add
*Panedwindow.showHandle
1 startupFile
1742 option add
*Panedwindow.sashRelief raised startupFile
1743 option add
*Button.font uifont startupFile
1744 option add
*Checkbutton.font uifont startupFile
1745 option add
*Radiobutton.font uifont startupFile
1746 option add
*Menu.font uifont startupFile
1747 option add
*Menubutton.font uifont startupFile
1748 option add
*Label.font uifont startupFile
1749 option add
*Message.font uifont startupFile
1750 option add
*Entry.font uifont startupFile
1753 proc makemenu
{m items
} {
1756 set name
[mc
[lindex
$i 0]]
1757 set type [lindex
$i 1]
1758 set thing
[lindex
$i 2]
1759 set params
[list
$type]
1761 set u
[string first
"&" [string map
{&& x
} $name]]
1762 lappend params
-label [string map
{&& & & {}} $name]
1764 lappend params
-underline $u
1769 set submenu
[string tolower
[string map
{& ""} [lindex
$i 0]]]
1770 lappend params
-menu $m.
$submenu
1773 lappend params
-command $thing
1776 lappend params
-variable [lindex
$thing 0] \
1777 -value [lindex
$thing 1]
1780 eval $m add
$params [lrange
$i 3 end
]
1781 if {$type eq
"cascade"} {
1782 makemenu
$m.
$submenu $thing
1787 # translate string and remove ampersands
1789 return [string map
{&& & & {}} [mc
$str]]
1792 proc makewindow
{} {
1793 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1795 global findtype findtypemenu findloc findstring fstring geometry
1796 global entries sha1entry sha1string sha1but
1797 global diffcontextstring diffcontext
1799 global maincursor textcursor curtextcursor
1800 global rowctxmenu fakerowmenu mergemax wrapcomment
1801 global highlight_files gdttype
1802 global searchstring sstring
1803 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1804 global headctxmenu progresscanv progressitem progresscoords statusw
1805 global fprogitem fprogcoord lastprogupdate progupdatepending
1806 global rprogitem rprogcoord rownumsel numcommits
1811 {"Update" command updatecommits
-accelerator F5
}
1812 {"Reload" command reloadcommits
}
1813 {"Reread references" command rereadrefs
}
1814 {"List references" command showrefs
}
1815 {"Quit" command doquit
}
1818 {"Preferences" command doprefs
}
1821 {"New view..." command {newview
0}}
1822 {"Edit view..." command editview
-state disabled
}
1823 {"Delete view" command delview
-state disabled
}
1825 {"All files" radiobutton
{selectedview
0} -command {showview
0}}
1828 {"About gitk" command about
}
1829 {"Key bindings" command keys
}
1832 . configure
-menu .bar
1834 # the gui has upper and lower half, parts of a paned window.
1835 panedwindow .ctop
-orient vertical
1837 # possibly use assumed geometry
1838 if {![info exists geometry
(pwsash0
)]} {
1839 set geometry
(topheight
) [expr {15 * $linespc}]
1840 set geometry
(topwidth
) [expr {80 * $charspc}]
1841 set geometry
(botheight
) [expr {15 * $linespc}]
1842 set geometry
(botwidth
) [expr {50 * $charspc}]
1843 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1844 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1847 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1848 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1850 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1852 # create three canvases
1853 set cscroll .tf.histframe.csb
1854 set canv .tf.histframe.pwclist.canv
1856 -selectbackground $selectbgcolor \
1857 -background $bgcolor -bd 0 \
1858 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1859 .tf.histframe.pwclist add
$canv
1860 set canv2 .tf.histframe.pwclist.canv2
1862 -selectbackground $selectbgcolor \
1863 -background $bgcolor -bd 0 -yscrollincr $linespc
1864 .tf.histframe.pwclist add
$canv2
1865 set canv3 .tf.histframe.pwclist.canv3
1867 -selectbackground $selectbgcolor \
1868 -background $bgcolor -bd 0 -yscrollincr $linespc
1869 .tf.histframe.pwclist add
$canv3
1870 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1871 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1873 # a scroll bar to rule them
1874 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1875 pack
$cscroll -side right
-fill y
1876 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1877 lappend bglist
$canv $canv2 $canv3
1878 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1880 # we have two button bars at bottom of top frame. Bar 1
1882 frame .tf.lbar
-height 15
1884 set sha1entry .tf.bar.sha1
1885 set entries
$sha1entry
1886 set sha1but .tf.bar.sha1label
1887 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
1888 -command gotocommit
-width 8
1889 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1890 pack .tf.bar.sha1label
-side left
1891 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1892 trace add variable sha1string
write sha1change
1893 pack
$sha1entry -side left
-pady 2
1895 image create bitmap bm-left
-data {
1896 #define left_width 16
1897 #define left_height 16
1898 static unsigned char left_bits
[] = {
1899 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1900 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1901 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1903 image create bitmap bm-right
-data {
1904 #define right_width 16
1905 #define right_height 16
1906 static unsigned char right_bits
[] = {
1907 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1908 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1909 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1911 button .tf.bar.leftbut
-image bm-left
-command goback \
1912 -state disabled
-width 26
1913 pack .tf.bar.leftbut
-side left
-fill y
1914 button .tf.bar.rightbut
-image bm-right
-command goforw \
1915 -state disabled
-width 26
1916 pack .tf.bar.rightbut
-side left
-fill y
1918 label .tf.bar.rowlabel
-text [mc
"Row"]
1920 label .tf.bar.rownum
-width 7 -font textfont
-textvariable rownumsel \
1921 -relief sunken
-anchor e
1922 label .tf.bar.rowlabel2
-text "/"
1923 label .tf.bar.numcommits
-width 7 -font textfont
-textvariable numcommits \
1924 -relief sunken
-anchor e
1925 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1928 trace add variable selectedline
write selectedline_change
1930 # Status label and progress bar
1931 set statusw .tf.bar.status
1932 label
$statusw -width 15 -relief sunken
1933 pack
$statusw -side left
-padx 5
1934 set h
[expr {[font metrics uifont
-linespace] + 2}]
1935 set progresscanv .tf.bar.progress
1936 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1937 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1938 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1939 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1940 pack
$progresscanv -side right
-expand 1 -fill x
1941 set progresscoords
{0 0}
1944 bind $progresscanv <Configure
> adjustprogress
1945 set lastprogupdate
[clock clicks
-milliseconds]
1946 set progupdatepending
0
1948 # build up the bottom bar of upper window
1949 label .tf.lbar.flabel
-text "[mc "Find
"] "
1950 button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
1951 button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
1952 label .tf.lbar.flab2
-text " [mc "commit
"] "
1953 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1955 set gdttype
[mc
"containing:"]
1956 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1957 [mc
"containing:"] \
1958 [mc
"touching paths:"] \
1959 [mc
"adding/removing string:"]]
1960 trace add variable gdttype
write gdttype_change
1961 pack .tf.lbar.gdttype
-side left
-fill y
1964 set fstring .tf.lbar.findstring
1965 lappend entries
$fstring
1966 entry
$fstring -width 30 -font textfont
-textvariable findstring
1967 trace add variable findstring
write find_change
1968 set findtype
[mc
"Exact"]
1969 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1970 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
1971 trace add variable findtype
write findcom_change
1972 set findloc
[mc
"All fields"]
1973 tk_optionMenu .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
1974 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
1975 trace add variable findloc
write find_change
1976 pack .tf.lbar.findloc
-side right
1977 pack .tf.lbar.findtype
-side right
1978 pack
$fstring -side left
-expand 1 -fill x
1980 # Finish putting the upper half of the viewer together
1981 pack .tf.lbar
-in .tf
-side bottom
-fill x
1982 pack .tf.bar
-in .tf
-side bottom
-fill x
1983 pack .tf.histframe
-fill both
-side top
-expand 1
1985 .ctop paneconfigure .tf
-height $geometry(topheight
)
1986 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1988 # now build up the bottom
1989 panedwindow .pwbottom
-orient horizontal
1991 # lower left, a text box over search bar, scroll bar to the right
1992 # if we know window height, then that will set the lower text height, otherwise
1993 # we set lower text height which will drive window height
1994 if {[info exists geometry
(main
)]} {
1995 frame .bleft
-width $geometry(botwidth
)
1997 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
2003 button .bleft.top.search
-text [mc
"Search"] -command dosearch
2004 pack .bleft.top.search
-side left
-padx 5
2005 set sstring .bleft.top.sstring
2006 entry
$sstring -width 20 -font textfont
-textvariable searchstring
2007 lappend entries
$sstring
2008 trace add variable searchstring
write incrsearch
2009 pack
$sstring -side left
-expand 1 -fill x
2010 radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
2011 -command changediffdisp
-variable diffelide
-value {0 0}
2012 radiobutton .bleft.mid.old
-text [mc
"Old version"] \
2013 -command changediffdisp
-variable diffelide
-value {0 1}
2014 radiobutton .bleft.mid.new
-text [mc
"New version"] \
2015 -command changediffdisp
-variable diffelide
-value {1 0}
2016 label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
2017 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
2018 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
2019 -from 1 -increment 1 -to 10000000 \
2020 -validate all
-validatecommand "diffcontextvalidate %P" \
2021 -textvariable diffcontextstring
2022 .bleft.mid.diffcontext
set $diffcontext
2023 trace add variable diffcontextstring
write diffcontextchange
2024 lappend entries .bleft.mid.diffcontext
2025 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
2026 checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
2027 -command changeignorespace
-variable ignorespace
2028 pack .bleft.mid.ignspace
-side left
-padx 5
2029 set ctext .bleft.bottom.ctext
2030 text
$ctext -background $bgcolor -foreground $fgcolor \
2031 -state disabled
-font textfont \
2032 -yscrollcommand scrolltext
-wrap none \
2033 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2035 $ctext conf
-tabstyle wordprocessor
2037 scrollbar .bleft.bottom.sb
-command "$ctext yview"
2038 scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h \
2040 pack .bleft.top
-side top
-fill x
2041 pack .bleft.mid
-side top
-fill x
2042 grid
$ctext .bleft.bottom.sb
-sticky nsew
2043 grid .bleft.bottom.sbhorizontal
-sticky ew
2044 grid columnconfigure .bleft.bottom
0 -weight 1
2045 grid rowconfigure .bleft.bottom
0 -weight 1
2046 grid rowconfigure .bleft.bottom
1 -weight 0
2047 pack .bleft.bottom
-side top
-fill both
-expand 1
2048 lappend bglist
$ctext
2049 lappend fglist
$ctext
2051 $ctext tag conf comment
-wrap $wrapcomment
2052 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
2053 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
2054 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
2055 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
2056 $ctext tag conf m0
-fore red
2057 $ctext tag conf m1
-fore blue
2058 $ctext tag conf m2
-fore green
2059 $ctext tag conf m3
-fore purple
2060 $ctext tag conf
m4 -fore brown
2061 $ctext tag conf m5
-fore "#009090"
2062 $ctext tag conf m6
-fore magenta
2063 $ctext tag conf m7
-fore "#808000"
2064 $ctext tag conf m8
-fore "#009000"
2065 $ctext tag conf m9
-fore "#ff0080"
2066 $ctext tag conf m10
-fore cyan
2067 $ctext tag conf m11
-fore "#b07070"
2068 $ctext tag conf m12
-fore "#70b0f0"
2069 $ctext tag conf m13
-fore "#70f0b0"
2070 $ctext tag conf m14
-fore "#f0b070"
2071 $ctext tag conf m15
-fore "#ff70b0"
2072 $ctext tag conf mmax
-fore darkgrey
2074 $ctext tag conf mresult
-font textfontbold
2075 $ctext tag conf msep
-font textfontbold
2076 $ctext tag conf found
-back yellow
2078 .pwbottom add .bleft
2079 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2084 radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2085 -command reselectline
-variable cmitmode
-value "patch"
2086 radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2087 -command reselectline
-variable cmitmode
-value "tree"
2088 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2089 pack .bright.mode
-side top
-fill x
2090 set cflist .bright.cfiles
2091 set indent
[font measure mainfont
"nn"]
2093 -selectbackground $selectbgcolor \
2094 -background $bgcolor -foreground $fgcolor \
2096 -tabs [list
$indent [expr {2 * $indent}]] \
2097 -yscrollcommand ".bright.sb set" \
2098 -cursor [. cget
-cursor] \
2099 -spacing1 1 -spacing3 1
2100 lappend bglist
$cflist
2101 lappend fglist
$cflist
2102 scrollbar .bright.sb
-command "$cflist yview"
2103 pack .bright.sb
-side right
-fill y
2104 pack
$cflist -side left
-fill both
-expand 1
2105 $cflist tag configure highlight \
2106 -background [$cflist cget
-selectbackground]
2107 $cflist tag configure bold
-font mainfontbold
2109 .pwbottom add .bright
2112 # restore window width & height if known
2113 if {[info exists geometry
(main
)]} {
2114 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2115 if {$w > [winfo screenwidth .
]} {
2116 set w
[winfo screenwidth .
]
2118 if {$h > [winfo screenheight .
]} {
2119 set h
[winfo screenheight .
]
2121 wm geometry .
"${w}x$h"
2125 if {[tk windowingsystem
] eq
{aqua
}} {
2131 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2132 pack .ctop
-fill both
-expand 1
2133 bindall
<1> {selcanvline
%W
%x
%y
}
2134 #bindall <B1-Motion> {selcanvline %W %x %y}
2135 if {[tk windowingsystem
] == "win32"} {
2136 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2137 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2139 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2140 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2141 if {[tk windowingsystem
] eq
"aqua"} {
2142 bindall
<MouseWheel
> {
2143 set delta
[expr {- (%D
)}]
2144 allcanvs yview scroll
$delta units
2148 bindall
<2> "canvscan mark %W %x %y"
2149 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
2150 bindkey
<Home
> selfirstline
2151 bindkey
<End
> sellastline
2152 bind .
<Key-Up
> "selnextline -1"
2153 bind .
<Key-Down
> "selnextline 1"
2154 bind .
<Shift-Key-Up
> "dofind -1 0"
2155 bind .
<Shift-Key-Down
> "dofind 1 0"
2156 bindkey
<Key-Right
> "goforw"
2157 bindkey
<Key-Left
> "goback"
2158 bind .
<Key-Prior
> "selnextpage -1"
2159 bind .
<Key-Next
> "selnextpage 1"
2160 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2161 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2162 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2163 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2164 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2165 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2166 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2167 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2168 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2169 bindkey p
"selnextline -1"
2170 bindkey n
"selnextline 1"
2173 bindkey i
"selnextline -1"
2174 bindkey k
"selnextline 1"
2178 bindkey d
"$ctext yview scroll 18 units"
2179 bindkey u
"$ctext yview scroll -18 units"
2180 bindkey
/ {dofind
1 1}
2181 bindkey
<Key-Return
> {dofind
1 1}
2182 bindkey ?
{dofind
-1 1}
2184 bindkey
<F5
> updatecommits
2185 bind .
<$M1B-q> doquit
2186 bind .
<$M1B-f> {dofind
1 1}
2187 bind .
<$M1B-g> {dofind
1 0}
2188 bind .
<$M1B-r> dosearchback
2189 bind .
<$M1B-s> dosearch
2190 bind .
<$M1B-equal> {incrfont
1}
2191 bind .
<$M1B-plus> {incrfont
1}
2192 bind .
<$M1B-KP_Add> {incrfont
1}
2193 bind .
<$M1B-minus> {incrfont
-1}
2194 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2195 wm protocol . WM_DELETE_WINDOW doquit
2196 bind .
<Destroy
> {stop_backends
}
2197 bind .
<Button-1
> "click %W"
2198 bind $fstring <Key-Return
> {dofind
1 1}
2199 bind $sha1entry <Key-Return
> {gotocommit
; break}
2200 bind $sha1entry <<PasteSelection>> clearsha1
2201 bind $cflist <1> {sel_flist %W %x %y; break}
2202 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2203 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2205 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2207 set maincursor [. cget -cursor]
2208 set textcursor [$ctext cget -cursor]
2209 set curtextcursor $textcursor
2211 set rowctxmenu .rowctxmenu
2212 makemenu $rowctxmenu {
2213 {"Diff this -> selected" command {diffvssel 0}}
2214 {"Diff selected -> this" command {diffvssel 1}}
2215 {"Make patch" command mkpatch}
2216 {"Create tag" command mktag}
2217 {"Write commit to file" command writecommit}
2218 {"Create new branch" command mkbranch}
2219 {"Cherry-pick this commit" command cherrypick}
2220 {"Reset HEAD branch to here" command resethead}
2222 $rowctxmenu configure -tearoff 0
2224 set fakerowmenu .fakerowmenu
2225 makemenu $fakerowmenu {
2226 {"Diff this -> selected" command {diffvssel 0}}
2227 {"Diff selected -> this" command {diffvssel 1}}
2228 {"Make patch" command mkpatch}
2230 $fakerowmenu configure -tearoff 0
2232 set headctxmenu .headctxmenu
2233 makemenu $headctxmenu {
2234 {"Check out this branch" command cobranch}
2235 {"Remove this branch" command rmbranch}
2237 $headctxmenu configure -tearoff 0
2240 set flist_menu .flistctxmenu
2241 makemenu $flist_menu {
2242 {"Highlight this too" command {flist_hl 0}}
2243 {"Highlight this only" command {flist_hl 1}}
2244 {"External diff" command {external_diff}}
2245 {"Blame parent commit" command {external_blame 1}}
2247 $flist_menu configure -tearoff 0
2250 # Windows sends all mouse wheel events to the current focused window, not
2251 # the one where the mouse hovers, so bind those events here and redirect
2252 # to the correct window
2253 proc windows_mousewheel_redirector {W X Y D} {
2254 global canv canv2 canv3
2255 set w [winfo containing -displayof $W $X $Y]
2257 set u [expr {$D < 0 ? 5 : -5}]
2258 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2259 allcanvs yview scroll $u units
2262 $w yview scroll $u units
2268 # Update row number label when selectedline changes
2269 proc selectedline_change {n1 n2 op} {
2270 global selectedline rownumsel
2272 if {$selectedline eq {}} {
2275 set rownumsel [expr {$selectedline + 1}]
2279 # mouse-2 makes all windows scan vertically, but only the one
2280 # the cursor is in scans horizontally
2281 proc canvscan {op w x y} {
2282 global canv canv2 canv3
2283 foreach c [list $canv $canv2 $canv3] {
2292 proc scrollcanv {cscroll f0 f1} {
2293 $cscroll set $f0 $f1
2298 # when we make a key binding for the toplevel, make sure
2299 # it doesn't get triggered when that key is pressed in the
2300 # find string entry widget.
2301 proc bindkey {ev script} {
2304 set escript [bind Entry $ev]
2305 if {$escript == {}} {
2306 set escript [bind Entry <Key>]
2308 foreach e $entries {
2309 bind $e $ev "$escript; break"
2313 # set the focus back to the toplevel for any click outside
2316 global ctext entries
2317 foreach e [concat $entries $ctext] {
2318 if {$w == $e} return
2323 # Adjust the progress bar for a change in requested extent or canvas size
2324 proc adjustprogress {} {
2325 global progresscanv progressitem progresscoords
2326 global fprogitem fprogcoord lastprogupdate progupdatepending
2327 global rprogitem rprogcoord
2329 set w [expr {[winfo width $progresscanv] - 4}]
2330 set x0 [expr {$w * [lindex $progresscoords 0]}]
2331 set x1 [expr {$w * [lindex $progresscoords 1]}]
2332 set h [winfo height $progresscanv]
2333 $progresscanv coords $progressitem $x0 0 $x1 $h
2334 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2335 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2336 set now [clock clicks -milliseconds]
2337 if {$now >= $lastprogupdate + 100} {
2338 set progupdatepending 0
2340 } elseif {!$progupdatepending} {
2341 set progupdatepending 1
2342 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2346 proc doprogupdate {} {
2347 global lastprogupdate progupdatepending
2349 if {$progupdatepending} {
2350 set progupdatepending 0
2351 set lastprogupdate [clock clicks -milliseconds]
2356 proc savestuff {w} {
2357 global canv canv2 canv3 mainfont textfont uifont tabstop
2358 global stuffsaved findmergefiles maxgraphpct
2359 global maxwidth showneartags showlocalchanges
2360 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2361 global cmitmode wrapcomment datetimeformat limitdiffs
2362 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2363 global autoselect extdifftool perfile_attrs
2365 if {$stuffsaved} return
2366 if {![winfo viewable .]} return
2368 set f [open "~/.gitk-new" w]
2369 puts $f [list set mainfont $mainfont]
2370 puts $f [list set textfont $textfont]
2371 puts $f [list set uifont $uifont]
2372 puts $f [list set tabstop $tabstop]
2373 puts $f [list set findmergefiles $findmergefiles]
2374 puts $f [list set maxgraphpct $maxgraphpct]
2375 puts $f [list set maxwidth $maxwidth]
2376 puts $f [list set cmitmode $cmitmode]
2377 puts $f [list set wrapcomment $wrapcomment]
2378 puts $f [list set autoselect $autoselect]
2379 puts $f [list set showneartags $showneartags]
2380 puts $f [list set showlocalchanges $showlocalchanges]
2381 puts $f [list set datetimeformat $datetimeformat]
2382 puts $f [list set limitdiffs $limitdiffs]
2383 puts $f [list set bgcolor $bgcolor]
2384 puts $f [list set fgcolor $fgcolor]
2385 puts $f [list set colors $colors]
2386 puts $f [list set diffcolors $diffcolors]
2387 puts $f [list set diffcontext $diffcontext]
2388 puts $f [list set selectbgcolor $selectbgcolor]
2389 puts $f [list set extdifftool $extdifftool]
2390 puts $f [list set perfile_attrs $perfile_attrs]
2392 puts $f "set geometry(main) [wm geometry .]"
2393 puts $f "set geometry(topwidth) [winfo width .tf]"
2394 puts $f "set geometry(topheight) [winfo height .tf]"
2395 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2396 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2397 puts $f "set geometry(botwidth) [winfo width .bleft]"
2398 puts $f "set geometry(botheight) [winfo height .bleft]"
2400 puts -nonewline $f "set permviews {"
2401 for {set v 0} {$v < $nextviewnum} {incr v} {
2402 if {$viewperm($v)} {
2403 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2408 file rename -force "~/.gitk-new" "~/.gitk"
2413 proc resizeclistpanes {win w} {
2415 if {[info exists oldwidth($win)]} {
2416 set s0 [$win sash coord 0]
2417 set s1 [$win sash coord 1]
2419 set sash0 [expr {int($w/2 - 2)}]
2420 set sash1 [expr {int($w*5/6 - 2)}]
2422 set factor [expr {1.0 * $w / $oldwidth($win)}]
2423 set sash0 [expr {int($factor * [lindex $s0 0])}]
2424 set sash1 [expr {int($factor * [lindex $s1 0])}]
2428 if {$sash1 < $sash0 + 20} {
2429 set sash1 [expr {$sash0 + 20}]
2431 if {$sash1 > $w - 10} {
2432 set sash1 [expr {$w - 10}]
2433 if {$sash0 > $sash1 - 20} {
2434 set sash0 [expr {$sash1 - 20}]
2438 $win sash place 0 $sash0 [lindex $s0 1]
2439 $win sash place 1 $sash1 [lindex $s1 1]
2441 set oldwidth($win) $w
2444 proc resizecdetpanes {win w} {
2446 if {[info exists oldwidth($win)]} {
2447 set s0 [$win sash coord 0]
2449 set sash0 [expr {int($w*3/4 - 2)}]
2451 set factor [expr {1.0 * $w / $oldwidth($win)}]
2452 set sash0 [expr {int($factor * [lindex $s0 0])}]
2456 if {$sash0 > $w - 15} {
2457 set sash0 [expr {$w - 15}]
2460 $win sash place 0 $sash0 [lindex $s0 1]
2462 set oldwidth($win) $w
2465 proc allcanvs args {
2466 global canv canv2 canv3
2472 proc bindall {event action} {
2473 global canv canv2 canv3
2474 bind $canv $event $action
2475 bind $canv2 $event $action
2476 bind $canv3 $event $action
2482 if {[winfo exists $w]} {
2487 wm title $w [mc "About gitk"]
2488 message $w.m -text [mc "
2489 Gitk - a commit viewer for git
2491 Copyright © 2005-2008 Paul Mackerras
2493 Use and redistribute under the terms of the GNU General Public License"] \
2494 -justify center -aspect 400 -border 2 -bg white -relief groove
2495 pack $w.m -side top -fill x -padx 2 -pady 2
2496 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2497 pack $w.ok -side bottom
2498 bind $w <Visibility> "focus $w.ok"
2499 bind $w <Key-Escape> "destroy $w"
2500 bind $w <Key-Return> "destroy $w"
2505 if {[winfo exists $w]} {
2509 if {[tk windowingsystem] eq {aqua}} {
2515 wm title $w [mc "Gitk key bindings"]
2516 message $w.m -text "
2517 [mc "Gitk key bindings:"]
2519 [mc "<%s-Q> Quit" $M1T]
2520 [mc "<Home> Move to first commit"]
2521 [mc "<End> Move to last commit"]
2522 [mc "<Up>, p, i Move up one commit"]
2523 [mc "<Down>, n, k Move down one commit"]
2524 [mc "<Left>, z, j Go back in history list"]
2525 [mc "<Right>, x, l Go forward in history list"]
2526 [mc "<PageUp> Move up one page in commit list"]
2527 [mc "<PageDown> Move down one page in commit list"]
2528 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2529 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2530 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2531 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2532 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2533 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2534 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2535 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2536 [mc "<Delete>, b Scroll diff view up one page"]
2537 [mc "<Backspace> Scroll diff view up one page"]
2538 [mc "<Space> Scroll diff view down one page"]
2539 [mc "u Scroll diff view up 18 lines"]
2540 [mc "d Scroll diff view down 18 lines"]
2541 [mc "<%s-F> Find" $M1T]
2542 [mc "<%s-G> Move to next find hit" $M1T]
2543 [mc "<Return> Move to next find hit"]
2544 [mc "/ Move to next find hit, or redo find"]
2545 [mc "? Move to previous find hit"]
2546 [mc "f Scroll diff view to next file"]
2547 [mc "<%s-S> Search for next hit in diff view" $M1T]
2548 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2549 [mc "<%s-KP+> Increase font size" $M1T]
2550 [mc "<%s-plus> Increase font size" $M1T]
2551 [mc "<%s-KP-> Decrease font size" $M1T]
2552 [mc "<%s-minus> Decrease font size" $M1T]
2555 -justify left -bg white -border 2 -relief groove
2556 pack $w.m -side top -fill both -padx 2 -pady 2
2557 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2558 pack $w.ok -side bottom
2559 bind $w <Visibility> "focus $w.ok"
2560 bind $w <Key-Escape> "destroy $w"
2561 bind $w <Key-Return> "destroy $w"
2564 # Procedures for manipulating the file list window at the
2565 # bottom right of the overall window.
2567 proc treeview {w l openlevs} {
2568 global treecontents treediropen treeheight treeparent treeindex
2578 set treecontents() {}
2579 $w conf -state normal
2581 while {[string range $f 0 $prefixend] ne $prefix} {
2582 if {$lev <= $openlevs} {
2583 $w mark set e:$treeindex($prefix) "end -1c"
2584 $w mark gravity e:$treeindex($prefix) left
2586 set treeheight($prefix) $ht
2587 incr ht [lindex $htstack end]
2588 set htstack [lreplace $htstack end end]
2589 set prefixend [lindex $prefendstack end]
2590 set prefendstack [lreplace $prefendstack end end]
2591 set prefix [string range $prefix 0 $prefixend]
2594 set tail [string range $f [expr {$prefixend+1}] end]
2595 while {[set slash [string first "/" $tail]] >= 0} {
2598 lappend prefendstack $prefixend
2599 incr prefixend [expr {$slash + 1}]
2600 set d [string range $tail 0 $slash]
2601 lappend treecontents($prefix) $d
2602 set oldprefix $prefix
2604 set treecontents($prefix) {}
2605 set treeindex($prefix) [incr ix]
2606 set treeparent($prefix) $oldprefix
2607 set tail [string range $tail [expr {$slash+1}] end]
2608 if {$lev <= $openlevs} {
2610 set treediropen($prefix) [expr {$lev < $openlevs}]
2611 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2612 $w mark set d:$ix "end -1c"
2613 $w mark gravity d:$ix left
2615 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2617 $w image create end -align center -image $bm -padx 1 \
2619 $w insert end $d [highlight_tag $prefix]
2620 $w mark set s:$ix "end -1c"
2621 $w mark gravity s:$ix left
2626 if {$lev <= $openlevs} {
2629 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2631 $w insert end $tail [highlight_tag $f]
2633 lappend treecontents($prefix) $tail
2636 while {$htstack ne {}} {
2637 set treeheight($prefix) $ht
2638 incr ht [lindex $htstack end]
2639 set htstack [lreplace $htstack end end]
2640 set prefixend [lindex $prefendstack end]
2641 set prefendstack [lreplace $prefendstack end end]
2642 set prefix [string range $prefix 0 $prefixend]
2644 $w conf -state disabled
2647 proc linetoelt {l} {
2648 global treeheight treecontents
2653 foreach e $treecontents($prefix) {
2658 if {[string index $e end] eq "/"} {
2659 set n $treeheight($prefix$e)
2671 proc highlight_tree {y prefix} {
2672 global treeheight treecontents cflist
2674 foreach e $treecontents($prefix) {
2676 if {[highlight_tag $path] ne {}} {
2677 $cflist tag add bold $y.0 "$y.0 lineend"
2680 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2681 set y [highlight_tree $y $path]
2687 proc treeclosedir {w dir} {
2688 global treediropen treeheight treeparent treeindex
2690 set ix $treeindex($dir)
2691 $w conf -state normal
2692 $w delete s:$ix e:$ix
2693 set treediropen($dir) 0
2694 $w image configure a:$ix -image tri-rt
2695 $w conf -state disabled
2696 set n [expr {1 - $treeheight($dir)}]
2697 while {$dir ne {}} {
2698 incr treeheight($dir) $n
2699 set dir $treeparent($dir)
2703 proc treeopendir {w dir} {
2704 global treediropen treeheight treeparent treecontents treeindex
2706 set ix $treeindex($dir)
2707 $w conf -state normal
2708 $w image configure a:$ix -image tri-dn
2709 $w mark set e:$ix s:$ix
2710 $w mark gravity e:$ix right
2713 set n [llength $treecontents($dir)]
2714 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2717 incr treeheight($x) $n
2719 foreach e $treecontents($dir) {
2721 if {[string index $e end] eq "/"} {
2722 set iy $treeindex($de)
2723 $w mark set d:$iy e:$ix
2724 $w mark gravity d:$iy left
2725 $w insert e:$ix $str
2726 set treediropen($de) 0
2727 $w image create e:$ix -align center -image tri-rt -padx 1 \
2729 $w insert e:$ix $e [highlight_tag $de]
2730 $w mark set s:$iy e:$ix
2731 $w mark gravity s:$iy left
2732 set treeheight($de) 1
2734 $w insert e:$ix $str
2735 $w insert e:$ix $e [highlight_tag $de]
2738 $w mark gravity e:$ix right
2739 $w conf -state disabled
2740 set treediropen($dir) 1
2741 set top [lindex [split [$w index @0,0] .] 0]
2742 set ht [$w cget -height]
2743 set l [lindex [split [$w index s:$ix] .] 0]
2746 } elseif {$l + $n + 1 > $top + $ht} {
2747 set top [expr {$l + $n + 2 - $ht}]
2755 proc treeclick {w x y} {
2756 global treediropen cmitmode ctext cflist cflist_top
2758 if {$cmitmode ne "tree"} return
2759 if {![info exists cflist_top]} return
2760 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2761 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2762 $cflist tag add highlight $l.0 "$l.0 lineend"
2768 set e [linetoelt $l]
2769 if {[string index $e end] ne "/"} {
2771 } elseif {$treediropen($e)} {
2778 proc setfilelist {id} {
2779 global treefilelist cflist
2781 treeview $cflist $treefilelist($id) 0
2784 image create bitmap tri-rt -background black -foreground blue -data {
2785 #define tri-rt_width 13
2786 #define tri-rt_height 13
2787 static unsigned char tri-rt_bits[] = {
2788 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2789 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2792 #define tri-rt-mask_width 13
2793 #define tri-rt-mask_height 13
2794 static unsigned char tri-rt-mask_bits[] = {
2795 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2796 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2799 image create bitmap tri-dn -background black -foreground blue -data {
2800 #define tri-dn_width 13
2801 #define tri-dn_height 13
2802 static unsigned char tri-dn_bits[] = {
2803 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2804 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2807 #define tri-dn-mask_width 13
2808 #define tri-dn-mask_height 13
2809 static unsigned char tri-dn-mask_bits[] = {
2810 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2811 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2815 image create bitmap reficon-T -background black -foreground yellow -data {
2816 #define tagicon_width 13
2817 #define tagicon_height 9
2818 static unsigned char tagicon_bits[] = {
2819 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2820 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2822 #define tagicon-mask_width 13
2823 #define tagicon-mask_height 9
2824 static unsigned char tagicon-mask_bits[] = {
2825 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2826 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2829 #define headicon_width 13
2830 #define headicon_height 9
2831 static unsigned char headicon_bits[] = {
2832 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2833 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2836 #define headicon-mask_width 13
2837 #define headicon-mask_height 9
2838 static unsigned char headicon-mask_bits[] = {
2839 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2840 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2842 image create bitmap reficon-H -background black -foreground green \
2843 -data $rectdata -maskdata $rectmask
2844 image create bitmap reficon-o -background black -foreground "#ddddff" \
2845 -data $rectdata -maskdata $rectmask
2847 proc init_flist {first} {
2848 global cflist cflist_top difffilestart
2850 $cflist conf -state normal
2851 $cflist delete 0.0 end
2853 $cflist insert end $first
2855 $cflist tag add highlight 1.0 "1.0 lineend"
2857 catch {unset cflist_top}
2859 $cflist conf -state disabled
2860 set difffilestart {}
2863 proc highlight_tag {f} {
2864 global highlight_paths
2866 foreach p $highlight_paths {
2867 if {[string match $p $f]} {
2874 proc highlight_filelist {} {
2875 global cmitmode cflist
2877 $cflist conf -state normal
2878 if {$cmitmode ne "tree"} {
2879 set end [lindex [split [$cflist index end] .] 0]
2880 for {set l 2} {$l < $end} {incr l} {
2881 set line [$cflist get $l.0 "$l.0 lineend"]
2882 if {[highlight_tag $line] ne {}} {
2883 $cflist tag add bold $l.0 "$l.0 lineend"
2889 $cflist conf -state disabled
2892 proc unhighlight_filelist {} {
2895 $cflist conf -state normal
2896 $cflist tag remove bold 1.0 end
2897 $cflist conf -state disabled
2900 proc add_flist {fl} {
2903 $cflist conf -state normal
2905 $cflist insert end "\n"
2906 $cflist insert end $f [highlight_tag $f]
2908 $cflist conf -state disabled
2911 proc sel_flist {w x y} {
2912 global ctext difffilestart cflist cflist_top cmitmode
2914 if {$cmitmode eq "tree"} return
2915 if {![info exists cflist_top]} return
2916 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2917 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2918 $cflist tag add highlight $l.0 "$l.0 lineend"
2923 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2927 proc pop_flist_menu {w X Y x y} {
2928 global ctext cflist cmitmode flist_menu flist_menu_file
2929 global treediffs diffids
2932 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2934 if {$cmitmode eq "tree"} {
2935 set e [linetoelt $l]
2936 if {[string index $e end] eq "/"} return
2938 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2940 set flist_menu_file $e
2941 set xdiffstate "normal"
2942 if {$cmitmode eq "tree"} {
2943 set xdiffstate "disabled"
2945 # Disable "External diff" item in tree mode
2946 $flist_menu entryconf 2 -state $xdiffstate
2947 tk_popup $flist_menu $X $Y
2950 proc flist_hl {only} {
2951 global flist_menu_file findstring gdttype
2953 set x [shellquote $flist_menu_file]
2954 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2957 append findstring " " $x
2959 set gdttype [mc "touching paths:"]
2962 proc save_file_from_commit {filename output what} {
2965 if {[catch {exec git show $filename -- > $output} err]} {
2966 if {[string match "fatal: bad revision *" $err]} {
2969 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
2975 proc external_diff_get_one_file {diffid filename diffdir} {
2976 global nullid nullid2 nullfile
2979 if {$diffid == $nullid} {
2980 set difffile [file join [file dirname $gitdir] $filename]
2981 if {[file exists $difffile]} {
2986 if {$diffid == $nullid2} {
2987 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2988 return [save_file_from_commit :$filename $difffile index]
2990 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2991 return [save_file_from_commit $diffid:$filename $difffile \
2995 proc external_diff {} {
2996 global gitktmpdir nullid nullid2
2997 global flist_menu_file
3000 global gitdir extdifftool
3002 if {[llength $diffids] == 1} {
3003 # no reference commit given
3004 set diffidto [lindex $diffids 0]
3005 if {$diffidto eq $nullid} {
3006 # diffing working copy with index
3007 set diffidfrom $nullid2
3008 } elseif {$diffidto eq $nullid2} {
3009 # diffing index with HEAD
3010 set diffidfrom "HEAD"
3012 # use first parent commit
3013 global parentlist selectedline
3014 set diffidfrom [lindex $parentlist $selectedline 0]
3017 set diffidfrom [lindex $diffids 0]
3018 set diffidto [lindex $diffids 1]
3021 # make sure that several diffs wont collide
3022 if {![info exists gitktmpdir]} {
3023 set gitktmpdir [file join [file dirname $gitdir] \
3024 [format ".gitk-tmp.%s" [pid]]]
3025 if {[catch {file mkdir $gitktmpdir} err]} {
3026 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3033 set diffdir [file join $gitktmpdir $diffnum]
3034 if {[catch {file mkdir $diffdir} err]} {
3035 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3039 # gather files to diff
3040 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3041 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3043 if {$difffromfile ne {} && $difftofile ne {}} {
3044 set cmd [concat | [shellsplit $extdifftool] \
3045 [list $difffromfile $difftofile]]
3046 if {[catch {set fl [open $cmd r]} err]} {
3047 file delete -force $diffdir
3048 error_popup "$extdifftool: [mc "command failed:"] $err"
3050 fconfigure $fl -blocking 0
3051 filerun $fl [list delete_at_eof $fl $diffdir]
3056 proc external_blame {parent_idx} {
3057 global flist_menu_file
3058 global nullid nullid2
3059 global parentlist selectedline currentid
3061 if {$parent_idx > 0} {
3062 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3064 set base_commit $currentid
3067 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3068 error_popup [mc "No such commit"]
3072 if {[catch {exec git gui blame $base_commit $flist_menu_file &} err]} {
3073 error_popup "[mc "git gui blame: command failed:"] $err"
3077 # delete $dir when we see eof on $f (presumably because the child has exited)
3078 proc delete_at_eof {f dir} {
3079 while {[gets $f line] >= 0} {}
3081 if {[catch {close $f} err]} {
3082 error_popup "[mc "External diff viewer failed:"] $err"
3084 file delete -force $dir
3090 # Functions for adding and removing shell-type quoting
3092 proc shellquote {str} {
3093 if {![string match "*\['\"\\ \t]*" $str]} {
3096 if {![string match "*\['\"\\]*" $str]} {
3099 if {![string match "*'*" $str]} {
3102 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3105 proc shellarglist {l} {
3111 append str [shellquote $a]
3116 proc shelldequote {str} {
3121 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3122 append ret [string range $str $used end]
3123 set used [string length $str]
3126 set first [lindex $first 0]
3127 set ch [string index $str $first]
3128 if {$first > $used} {
3129 append ret [string range $str $used [expr {$first - 1}]]
3132 if {$ch eq " " || $ch eq "\t"} break
3135 set first [string first "'" $str $used]
3137 error "unmatched single-quote"
3139 append ret [string range $str $used [expr {$first - 1}]]
3144 if {$used >= [string length $str]} {
3145 error "trailing backslash"
3147 append ret [string index $str $used]
3152 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3153 error "unmatched double-quote"
3155 set first [lindex $first 0]
3156 set ch [string index $str $first]
3157 if {$first > $used} {
3158 append ret [string range $str $used [expr {$first - 1}]]
3161 if {$ch eq "\""} break
3163 append ret [string index $str $used]
3167 return [list $used $ret]
3170 proc shellsplit {str} {
3173 set str [string trimleft $str]
3174 if {$str eq {}} break
3175 set dq [shelldequote $str]
3176 set n [lindex $dq 0]
3177 set word [lindex $dq 1]
3178 set str [string range $str $n end]
3184 # Code to implement multiple views
3186 proc newview {ishighlight} {
3187 global nextviewnum newviewname newviewperm newishighlight
3188 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3190 set newishighlight $ishighlight
3192 if {[winfo exists $top]} {
3196 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3197 set newviewperm($nextviewnum) 0
3198 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3199 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3200 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3205 global viewname viewperm newviewname newviewperm
3206 global viewargs newviewargs viewargscmd newviewargscmd
3208 set top .gitkvedit-$curview
3209 if {[winfo exists $top]} {
3213 set newviewname($curview) $viewname($curview)
3214 set newviewperm($curview) $viewperm($curview)
3215 set newviewargs($curview) [shellarglist $viewargs($curview)]
3216 set newviewargscmd($curview) $viewargscmd($curview)
3217 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3220 proc vieweditor {top n title} {
3221 global newviewname newviewperm viewfiles bgcolor
3224 wm title $top $title
3225 label $top.nl -text [mc "Name"]
3226 entry $top.name -width 20 -textvariable newviewname($n)
3227 grid $top.nl $top.name -sticky w -pady 5
3228 checkbutton $top.perm -text [mc "Remember this view"] \
3229 -variable newviewperm($n)
3230 grid $top.perm - -pady 5 -sticky w
3231 message $top.al -aspect 1000 \
3232 -text [mc "Commits to include (arguments to git log):"]
3233 grid $top.al - -sticky w -pady 5
3234 entry $top.args -width 50 -textvariable newviewargs($n) \
3235 -background $bgcolor
3236 grid $top.args - -sticky ew -padx 5
3238 message $top.ac -aspect 1000 \
3239 -text [mc "Command to generate more commits to include:"]
3240 grid $top.ac - -sticky w -pady 5
3241 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3243 grid $top.argscmd - -sticky ew -padx 5
3245 message $top.l -aspect 1000 \
3246 -text [mc "Enter files and directories to include, one per line:"]
3247 grid $top.l - -sticky w
3248 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3249 if {[info exists viewfiles($n)]} {
3250 foreach f $viewfiles($n) {
3251 $top.t insert end $f
3252 $top.t insert end "\n"
3254 $top.t delete {end - 1c} end
3255 $top.t mark set insert 0.0
3257 grid $top.t - -sticky ew -padx 5
3259 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3260 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3261 grid $top.buts.ok $top.buts.can
3262 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3263 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3264 grid $top.buts - -pady 10 -sticky ew
3268 proc doviewmenu {m first cmd op argv} {
3269 set nmenu [$m index end]
3270 for {set i $first} {$i <= $nmenu} {incr i} {
3271 if {[$m entrycget $i -command] eq $cmd} {
3272 eval $m $op $i $argv
3278 proc allviewmenus {n op args} {
3281 doviewmenu .bar.view 5 [list showview $n] $op $args
3282 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3285 proc newviewok {top n} {
3286 global nextviewnum newviewperm newviewname newishighlight
3287 global viewname viewfiles viewperm selectedview curview
3288 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3291 set newargs [shellsplit $newviewargs($n)]
3293 error_popup "[mc "Error in commit selection arguments:"] $err"
3299 foreach f [split [$top.t get 0.0 end] "\n"] {
3300 set ft [string trim $f]
3305 if {![info exists viewfiles($n)]} {
3306 # creating a new view
3308 set viewname($n) $newviewname($n)
3309 set viewperm($n) $newviewperm($n)
3310 set viewfiles($n) $files
3311 set viewargs($n) $newargs
3312 set viewargscmd($n) $newviewargscmd($n)
3314 if {!$newishighlight} {
3317 run addvhighlight $n
3320 # editing an existing view
3321 set viewperm($n) $newviewperm($n)
3322 if {$newviewname($n) ne $viewname($n)} {
3323 set viewname($n) $newviewname($n)
3324 doviewmenu .bar.view 5 [list showview $n] \
3325 entryconf [list -label $viewname($n)]
3326 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3327 # entryconf [list -label $viewname($n) -value $viewname($n)]
3329 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3330 $newviewargscmd($n) ne $viewargscmd($n)} {
3331 set viewfiles($n) $files
3332 set viewargs($n) $newargs
3333 set viewargscmd($n) $newviewargscmd($n)
3334 if {$curview == $n} {
3339 catch {destroy $top}
3343 global curview viewperm hlview selectedhlview
3345 if {$curview == 0} return
3346 if {[info exists hlview] && $hlview == $curview} {
3347 set selectedhlview [mc "None"]
3350 allviewmenus $curview delete
3351 set viewperm($curview) 0
3355 proc addviewmenu {n} {
3356 global viewname viewhlmenu
3358 .bar.view add radiobutton -label $viewname($n) \
3359 -command [list showview $n] -variable selectedview -value $n
3360 #$viewhlmenu add radiobutton -label $viewname($n) \
3361 # -command [list addvhighlight $n] -variable selectedhlview
3365 global curview cached_commitrow ordertok
3366 global displayorder parentlist rowidlist rowisopt rowfinal
3367 global colormap rowtextx nextcolor canvxmax
3368 global numcommits viewcomplete
3369 global selectedline currentid canv canvy0
3371 global pending_select mainheadid
3374 global hlview selectedhlview commitinterest
3376 if {$n == $curview} return
3378 set ymax [lindex [$canv cget -scrollregion] 3]
3379 set span [$canv yview]
3380 set ytop [expr {[lindex $span 0] * $ymax}]
3381 set ybot [expr {[lindex $span 1] * $ymax}]
3382 set yscreen [expr {($ybot - $ytop) / 2}]
3383 if {$selectedline ne {}} {
3384 set selid $currentid
3385 set y [yc $selectedline]
3386 if {$ytop < $y && $y < $ybot} {
3387 set yscreen [expr {$y - $ytop}]
3389 } elseif {[info exists pending_select]} {
3390 set selid $pending_select
3391 unset pending_select
3395 catch {unset treediffs}
3397 if {[info exists hlview] && $hlview == $n} {
3399 set selectedhlview [mc "None"]
3401 catch {unset commitinterest}
3402 catch {unset cached_commitrow}
3403 catch {unset ordertok}
3407 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3408 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3411 if {![info exists viewcomplete($n)]} {
3421 set numcommits $commitidx($n)
3423 catch {unset colormap}
3424 catch {unset rowtextx}
3426 set canvxmax [$canv cget -width]
3432 if {$selid ne {} && [commitinview $selid $n]} {
3433 set row [rowofcommit $selid]
3434 # try to get the selected row in the same position on the screen
3435 set ymax [lindex [$canv cget -scrollregion] 3]
3436 set ytop [expr {[yc $row] - $yscreen}]
3440 set yf [expr {$ytop * 1.0 / $ymax}]
3442 allcanvs yview moveto $yf
3446 } elseif {!$viewcomplete($n)} {
3447 reset_pending_select $selid
3449 reset_pending_select {}
3451 if {[commitinview $pending_select $curview]} {
3452 selectline [rowofcommit $pending_select] 1
3454 set row [first_real_row]
3455 if {$row < $numcommits} {
3460 if {!$viewcomplete($n)} {
3461 if {$numcommits == 0} {
3462 show_status [mc "Reading commits..."]
3464 } elseif {$numcommits == 0} {
3465 show_status [mc "No commits selected"]
3469 # Stuff relating to the highlighting facility
3471 proc ishighlighted {id} {
3472 global vhighlights fhighlights nhighlights rhighlights
3474 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3475 return $nhighlights($id)
3477 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3478 return $vhighlights($id)
3480 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3481 return $fhighlights($id)
3483 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3484 return $rhighlights($id)
3489 proc bolden {row font} {
3490 global canv linehtag selectedline boldrows
3492 lappend boldrows $row
3493 $canv itemconf $linehtag($row) -font $font
3494 if {$row == $selectedline} {
3496 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3497 -outline {{}} -tags secsel \
3498 -fill [$canv cget -selectbackground]]
3503 proc bolden_name {row font} {
3504 global canv2 linentag selectedline boldnamerows
3506 lappend boldnamerows $row
3507 $canv2 itemconf $linentag($row) -font $font
3508 if {$row == $selectedline} {
3509 $canv2 delete secsel
3510 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3511 -outline {{}} -tags secsel \
3512 -fill [$canv2 cget -selectbackground]]
3521 foreach row $boldrows {
3522 if {![ishighlighted [commitonrow $row]]} {
3523 bolden $row mainfont
3525 lappend stillbold $row
3528 set boldrows $stillbold
3531 proc addvhighlight {n} {
3532 global hlview viewcomplete curview vhl_done commitidx
3534 if {[info exists hlview]} {
3538 if {$n != $curview && ![info exists viewcomplete($n)]} {
3541 set vhl_done $commitidx($hlview)
3542 if {$vhl_done > 0} {
3547 proc delvhighlight {} {
3548 global hlview vhighlights
3550 if {![info exists hlview]} return
3552 catch {unset vhighlights}
3556 proc vhighlightmore {} {
3557 global hlview vhl_done commitidx vhighlights curview
3559 set max $commitidx($hlview)
3560 set vr [visiblerows]
3561 set r0 [lindex $vr 0]
3562 set r1 [lindex $vr 1]
3563 for {set i $vhl_done} {$i < $max} {incr i} {
3564 set id [commitonrow $i $hlview]
3565 if {[commitinview $id $curview]} {
3566 set row [rowofcommit $id]
3567 if {$r0 <= $row && $row <= $r1} {
3568 if {![highlighted $row]} {
3569 bolden $row mainfontbold
3571 set vhighlights($id) 1
3579 proc askvhighlight {row id} {
3580 global hlview vhighlights iddrawn
3582 if {[commitinview $id $hlview]} {
3583 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3584 bolden $row mainfontbold
3586 set vhighlights($id) 1
3588 set vhighlights($id) 0
3592 proc hfiles_change {} {
3593 global highlight_files filehighlight fhighlights fh_serial
3594 global highlight_paths gdttype
3596 if {[info exists filehighlight]} {
3597 # delete previous highlights
3598 catch {close $filehighlight}
3600 catch {unset fhighlights}
3602 unhighlight_filelist
3604 set highlight_paths {}
3605 after cancel do_file_hl $fh_serial
3607 if {$highlight_files ne {}} {
3608 after 300 do_file_hl $fh_serial
3612 proc gdttype_change {name ix op} {
3613 global gdttype highlight_files findstring findpattern
3616 if {$findstring ne {}} {
3617 if {$gdttype eq [mc "containing:"]} {
3618 if {$highlight_files ne {}} {
3619 set highlight_files {}
3624 if {$findpattern ne {}} {
3628 set highlight_files $findstring
3633 # enable/disable findtype/findloc menus too
3636 proc find_change {name ix op} {
3637 global gdttype findstring highlight_files
3640 if {$gdttype eq [mc "containing:"]} {
3643 if {$highlight_files ne $findstring} {
3644 set highlight_files $findstring
3651 proc findcom_change args {
3652 global nhighlights boldnamerows
3653 global findpattern findtype findstring gdttype
3656 # delete previous highlights, if any
3657 foreach row $boldnamerows {
3658 bolden_name $row mainfont
3661 catch {unset nhighlights}
3664 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3666 } elseif {$findtype eq [mc "Regexp"]} {
3667 set findpattern $findstring
3669 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3671 set findpattern "*$e*"
3675 proc makepatterns {l} {
3678 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3679 if {[string index $ee end] eq "/"} {
3689 proc do_file_hl {serial} {
3690 global highlight_files filehighlight highlight_paths gdttype fhl_list
3692 if {$gdttype eq [mc "touching paths:"]} {
3693 if {[catch {set paths [shellsplit $highlight_files]}]} return
3694 set highlight_paths [makepatterns $paths]
3696 set gdtargs [concat -- $paths]
3697 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3698 set gdtargs [list "-S$highlight_files"]
3700 # must be "containing:", i.e. we're searching commit info
3703 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3704 set filehighlight [open $cmd r+]
3705 fconfigure $filehighlight -blocking 0
3706 filerun $filehighlight readfhighlight
3712 proc flushhighlights {} {
3713 global filehighlight fhl_list
3715 if {[info exists filehighlight]} {
3717 puts $filehighlight ""
3718 flush $filehighlight
3722 proc askfilehighlight {row id} {
3723 global filehighlight fhighlights fhl_list
3725 lappend fhl_list $id
3726 set fhighlights($id) -1
3727 puts $filehighlight $id
3730 proc readfhighlight {} {
3731 global filehighlight fhighlights curview iddrawn
3732 global fhl_list find_dirn
3734 if {![info exists filehighlight]} {
3738 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3739 set line [string trim $line]
3740 set i [lsearch -exact $fhl_list $line]
3741 if {$i < 0} continue
3742 for {set j 0} {$j < $i} {incr j} {
3743 set id [lindex $fhl_list $j]
3744 set fhighlights($id) 0
3746 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3747 if {$line eq {}} continue
3748 if {![commitinview $line $curview]} continue
3749 set row [rowofcommit $line]
3750 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3751 bolden $row mainfontbold
3753 set fhighlights($line) 1
3755 if {[eof $filehighlight]} {
3757 puts "oops, git diff-tree died"
3758 catch {close $filehighlight}
3762 if {[info exists find_dirn]} {
3768 proc doesmatch {f} {
3769 global findtype findpattern
3771 if {$findtype eq [mc "Regexp"]} {
3772 return [regexp $findpattern $f]
3773 } elseif {$findtype eq [mc "IgnCase"]} {
3774 return [string match -nocase $findpattern $f]
3776 return [string match $findpattern $f]
3780 proc askfindhighlight {row id} {
3781 global nhighlights commitinfo iddrawn
3783 global markingmatches
3785 if {![info exists commitinfo($id)]} {
3788 set info $commitinfo($id)
3790 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3791 foreach f $info ty $fldtypes {
3792 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3794 if {$ty eq [mc "Author"]} {
3801 if {$isbold && [info exists iddrawn($id)]} {
3802 if {![ishighlighted $id]} {
3803 bolden $row mainfontbold
3805 bolden_name $row mainfontbold
3808 if {$markingmatches} {
3809 markrowmatches $row $id
3812 set nhighlights($id) $isbold
3815 proc markrowmatches {row id} {
3816 global canv canv2 linehtag linentag commitinfo findloc
3818 set headline [lindex $commitinfo($id) 0]
3819 set author [lindex $commitinfo($id) 1]
3820 $canv delete match$row
3821 $canv2 delete match$row
3822 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3823 set m [findmatches $headline]
3825 markmatches $canv $row $headline $linehtag($row) $m \
3826 [$canv itemcget $linehtag($row) -font] $row
3829 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3830 set m [findmatches $author]
3832 markmatches $canv2 $row $author $linentag($row) $m \
3833 [$canv2 itemcget $linentag($row) -font] $row
3838 proc vrel_change {name ix op} {
3839 global highlight_related
3842 if {$highlight_related ne [mc "None"]} {
3847 # prepare for testing whether commits are descendents or ancestors of a
3848 proc rhighlight_sel {a} {
3849 global descendent desc_todo ancestor anc_todo
3850 global highlight_related
3852 catch {unset descendent}
3853 set desc_todo [list $a]
3854 catch {unset ancestor}
3855 set anc_todo [list $a]
3856 if {$highlight_related ne [mc "None"]} {
3862 proc rhighlight_none {} {
3865 catch {unset rhighlights}
3869 proc is_descendent {a} {
3870 global curview children descendent desc_todo
3873 set la [rowofcommit $a]
3877 for {set i 0} {$i < [llength $todo]} {incr i} {
3878 set do [lindex $todo $i]
3879 if {[rowofcommit $do] < $la} {
3880 lappend leftover $do
3883 foreach nk $children($v,$do) {
3884 if {![info exists descendent($nk)]} {
3885 set descendent($nk) 1
3893 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3897 set descendent($a) 0
3898 set desc_todo $leftover
3901 proc is_ancestor {a} {
3902 global curview parents ancestor anc_todo
3905 set la [rowofcommit $a]
3909 for {set i 0} {$i < [llength $todo]} {incr i} {
3910 set do [lindex $todo $i]
3911 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3912 lappend leftover $do
3915 foreach np $parents($v,$do) {
3916 if {![info exists ancestor($np)]} {
3925 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3930 set anc_todo $leftover
3933 proc askrelhighlight {row id} {
3934 global descendent highlight_related iddrawn rhighlights
3935 global selectedline ancestor
3937 if {$selectedline eq {}} return
3939 if {$highlight_related eq [mc "Descendant"] ||
3940 $highlight_related eq [mc "Not descendant"]} {
3941 if {![info exists descendent($id)]} {
3944 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3947 } elseif {$highlight_related eq [mc "Ancestor"] ||
3948 $highlight_related eq [mc "Not ancestor"]} {
3949 if {![info exists ancestor($id)]} {
3952 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3956 if {[info exists iddrawn($id)]} {
3957 if {$isbold && ![ishighlighted $id]} {
3958 bolden $row mainfontbold
3961 set rhighlights($id) $isbold
3964 # Graph layout functions
3966 proc shortids {ids} {
3969 if {[llength $id] > 1} {
3970 lappend res [shortids $id]
3971 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3972 lappend res [string range $id 0 7]
3983 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3984 if {($n & $mask) != 0} {
3985 set ret [concat $ret $o]
3987 set o [concat $o $o]
3992 proc ordertoken {id} {
3993 global ordertok curview varcid varcstart varctok curview parents children
3994 global nullid nullid2
3996 if {[info exists ordertok($id)]} {
3997 return $ordertok($id)
4002 if {[info exists varcid($curview,$id)]} {
4003 set a $varcid($curview,$id)
4004 set p [lindex $varcstart($curview) $a]
4006 set p [lindex $children($curview,$id) 0]
4008 if {[info exists ordertok($p)]} {
4009 set tok $ordertok($p)
4012 set id [first_real_child $curview,$p]
4015 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4018 if {[llength $parents($curview,$id)] == 1} {
4019 lappend todo [list $p {}]
4021 set j [lsearch -exact $parents($curview,$id) $p]
4023 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4025 lappend todo [list $p [strrep $j]]
4028 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4029 set p [lindex $todo $i 0]
4030 append tok [lindex $todo $i 1]
4031 set ordertok($p) $tok
4033 set ordertok($origid) $tok
4037 # Work out where id should go in idlist so that order-token
4038 # values increase from left to right
4039 proc idcol {idlist id {i 0}} {
4040 set t [ordertoken $id]
4044 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4045 if {$i > [llength $idlist]} {
4046 set i [llength $idlist]
4048 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4051 if {$t > [ordertoken [lindex $idlist $i]]} {
4052 while {[incr i] < [llength $idlist] &&
4053 $t >= [ordertoken [lindex $idlist $i]]} {}
4059 proc initlayout {} {
4060 global rowidlist rowisopt rowfinal displayorder parentlist
4061 global numcommits canvxmax canv
4063 global colormap rowtextx
4072 set canvxmax [$canv cget -width]
4073 catch {unset colormap}
4074 catch {unset rowtextx}
4078 proc setcanvscroll {} {
4079 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4080 global lastscrollset lastscrollrows
4082 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4083 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4084 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4085 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4086 set lastscrollset [clock clicks -milliseconds]
4087 set lastscrollrows $numcommits
4090 proc visiblerows {} {
4091 global canv numcommits linespc
4093 set ymax [lindex [$canv cget -scrollregion] 3]
4094 if {$ymax eq {} || $ymax == 0} return
4096 set y0 [expr {int([lindex $f 0] * $ymax)}]
4097 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4101 set y1 [expr {int([lindex $f 1] * $ymax)}]
4102 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4103 if {$r1 >= $numcommits} {
4104 set r1 [expr {$numcommits - 1}]
4106 return [list $r0 $r1]
4109 proc layoutmore {} {
4110 global commitidx viewcomplete curview
4111 global numcommits pending_select curview
4112 global lastscrollset lastscrollrows commitinterest
4114 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4115 [clock clicks -milliseconds] - $lastscrollset > 500} {
4118 if {[info exists pending_select] &&
4119 [commitinview $pending_select $curview]} {
4121 selectline [rowofcommit $pending_select] 1
4126 proc doshowlocalchanges {} {
4127 global curview mainheadid
4129 if {$mainheadid eq {}} return
4130 if {[commitinview $mainheadid $curview]} {
4133 lappend commitinterest($mainheadid) {dodiffindex}
4137 proc dohidelocalchanges {} {
4138 global nullid nullid2 lserial curview
4140 if {[commitinview $nullid $curview]} {
4141 removefakerow $nullid
4143 if {[commitinview $nullid2 $curview]} {
4144 removefakerow $nullid2
4149 # spawn off a process to do git diff-index --cached HEAD
4150 proc dodiffindex {} {
4151 global lserial showlocalchanges
4154 if {!$showlocalchanges || !$isworktree} return
4156 set fd [open "|git diff-index --cached HEAD" r]
4157 fconfigure $fd -blocking 0
4158 set i [reg_instance $fd]
4159 filerun $fd [list readdiffindex $fd $lserial $i]
4162 proc readdiffindex {fd serial inst} {
4163 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4166 if {[gets $fd line] < 0} {
4172 # we only need to see one line and we don't really care what it says...
4175 if {$serial != $lserial} {
4179 # now see if there are any local changes not checked in to the index
4180 set fd [open "|git diff-files" r]
4181 fconfigure $fd -blocking 0
4182 set i [reg_instance $fd]
4183 filerun $fd [list readdifffiles $fd $serial $i]
4185 if {$isdiff && ![commitinview $nullid2 $curview]} {
4186 # add the line for the changes in the index to the graph
4187 set hl [mc "Local changes checked in to index but not committed"]
4188 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4189 set commitdata($nullid2) "\n $hl\n"
4190 if {[commitinview $nullid $curview]} {
4191 removefakerow $nullid
4193 insertfakerow $nullid2 $mainheadid
4194 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4195 removefakerow $nullid2
4200 proc readdifffiles {fd serial inst} {
4201 global mainheadid nullid nullid2 curview
4202 global commitinfo commitdata lserial
4205 if {[gets $fd line] < 0} {
4211 # we only need to see one line and we don't really care what it says...
4214 if {$serial != $lserial} {
4218 if {$isdiff && ![commitinview $nullid $curview]} {
4219 # add the line for the local diff to the graph
4220 set hl [mc "Local uncommitted changes, not checked in to index"]
4221 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4222 set commitdata($nullid) "\n $hl\n"
4223 if {[commitinview $nullid2 $curview]} {
4228 insertfakerow $nullid $p
4229 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4230 removefakerow $nullid
4235 proc nextuse {id row} {
4236 global curview children
4238 if {[info exists children($curview,$id)]} {
4239 foreach kid $children($curview,$id) {
4240 if {![commitinview $kid $curview]} {
4243 if {[rowofcommit $kid] > $row} {
4244 return [rowofcommit $kid]
4248 if {[commitinview $id $curview]} {
4249 return [rowofcommit $id]
4254 proc prevuse {id row} {
4255 global curview children
4258 if {[info exists children($curview,$id)]} {
4259 foreach kid $children($curview,$id) {
4260 if {![commitinview $kid $curview]} break
4261 if {[rowofcommit $kid] < $row} {
4262 set ret [rowofcommit $kid]
4269 proc make_idlist {row} {
4270 global displayorder parentlist uparrowlen downarrowlen mingaplen
4271 global commitidx curview children
4273 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4277 set ra [expr {$row - $downarrowlen}]
4281 set rb [expr {$row + $uparrowlen}]
4282 if {$rb > $commitidx($curview)} {
4283 set rb $commitidx($curview)
4285 make_disporder $r [expr {$rb + 1}]
4287 for {} {$r < $ra} {incr r} {
4288 set nextid [lindex $displayorder [expr {$r + 1}]]
4289 foreach p [lindex $parentlist $r] {
4290 if {$p eq $nextid} continue
4291 set rn [nextuse $p $r]
4293 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4294 lappend ids [list [ordertoken $p] $p]
4298 for {} {$r < $row} {incr r} {
4299 set nextid [lindex $displayorder [expr {$r + 1}]]
4300 foreach p [lindex $parentlist $r] {
4301 if {$p eq $nextid} continue
4302 set rn [nextuse $p $r]
4303 if {$rn < 0 || $rn >= $row} {
4304 lappend ids [list [ordertoken $p] $p]
4308 set id [lindex $displayorder $row]
4309 lappend ids [list [ordertoken $id] $id]
4311 foreach p [lindex $parentlist $r] {
4312 set firstkid [lindex $children($curview,$p) 0]
4313 if {[rowofcommit $firstkid] < $row} {
4314 lappend ids [list [ordertoken $p] $p]
4318 set id [lindex $displayorder $r]
4320 set firstkid [lindex $children($curview,$id) 0]
4321 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4322 lappend ids [list [ordertoken $id] $id]
4327 foreach idx [lsort -unique $ids] {
4328 lappend idlist [lindex $idx 1]
4333 proc rowsequal {a b} {
4334 while {[set i [lsearch -exact $a {}]] >= 0} {
4335 set a [lreplace $a $i $i]
4337 while {[set i [lsearch -exact $b {}]] >= 0} {
4338 set b [lreplace $b $i $i]
4340 return [expr {$a eq $b}]
4343 proc makeupline {id row rend col} {
4344 global rowidlist uparrowlen downarrowlen mingaplen
4346 for {set r $rend} {1} {set r $rstart} {
4347 set rstart [prevuse $id $r]
4348 if {$rstart < 0} return
4349 if {$rstart < $row} break
4351 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4352 set rstart [expr {$rend - $uparrowlen - 1}]
4354 for {set r $rstart} {[incr r] <= $row} {} {
4355 set idlist [lindex $rowidlist $r]
4356 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4357 set col [idcol $idlist $id $col]
4358 lset rowidlist $r [linsert $idlist $col $id]
4364 proc layoutrows {row endrow} {
4365 global rowidlist rowisopt rowfinal displayorder
4366 global uparrowlen downarrowlen maxwidth mingaplen
4367 global children parentlist
4368 global commitidx viewcomplete curview
4370 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4373 set rm1 [expr {$row - 1}]
4374 foreach id [lindex $rowidlist $rm1] {
4379 set final [lindex $rowfinal $rm1]
4381 for {} {$row < $endrow} {incr row} {
4382 set rm1 [expr {$row - 1}]
4383 if {$rm1 < 0 || $idlist eq {}} {
4384 set idlist [make_idlist $row]
4387 set id [lindex $displayorder $rm1]
4388 set col [lsearch -exact $idlist $id]
4389 set idlist [lreplace $idlist $col $col]
4390 foreach p [lindex $parentlist $rm1] {
4391 if {[lsearch -exact $idlist $p] < 0} {
4392 set col [idcol $idlist $p $col]
4393 set idlist [linsert $idlist $col $p]
4394 # if not the first child, we have to insert a line going up
4395 if {$id ne [lindex $children($curview,$p) 0]} {
4396 makeupline $p $rm1 $row $col
4400 set id [lindex $displayorder $row]
4401 if {$row > $downarrowlen} {
4402 set termrow [expr {$row - $downarrowlen - 1}]
4403 foreach p [lindex $parentlist $termrow] {
4404 set i [lsearch -exact $idlist $p]
4405 if {$i < 0} continue
4406 set nr [nextuse $p $termrow]
4407 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4408 set idlist [lreplace $idlist $i $i]
4412 set col [lsearch -exact $idlist $id]
4414 set col [idcol $idlist $id]
4415 set idlist [linsert $idlist $col $id]
4416 if {$children($curview,$id) ne {}} {
4417 makeupline $id $rm1 $row $col
4420 set r [expr {$row + $uparrowlen - 1}]
4421 if {$r < $commitidx($curview)} {
4423 foreach p [lindex $parentlist $r] {
4424 if {[lsearch -exact $idlist $p] >= 0} continue
4425 set fk [lindex $children($curview,$p) 0]
4426 if {[rowofcommit $fk] < $row} {
4427 set x [idcol $idlist $p $x]
4428 set idlist [linsert $idlist $x $p]
4431 if {[incr r] < $commitidx($curview)} {
4432 set p [lindex $displayorder $r]
4433 if {[lsearch -exact $idlist $p] < 0} {
4434 set fk [lindex $children($curview,$p) 0]
4435 if {$fk ne {} && [rowofcommit $fk] < $row} {
4436 set x [idcol $idlist $p $x]
4437 set idlist [linsert $idlist $x $p]
4443 if {$final && !$viewcomplete($curview) &&
4444 $row + $uparrowlen + $mingaplen + $downarrowlen
4445 >= $commitidx($curview)} {
4448 set l [llength $rowidlist]
4450 lappend rowidlist $idlist
4452 lappend rowfinal $final
4453 } elseif {$row < $l} {
4454 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4455 lset rowidlist $row $idlist
4458 lset rowfinal $row $final
4460 set pad [ntimes [expr {$row - $l}] {}]
4461 set rowidlist [concat $rowidlist $pad]
4462 lappend rowidlist $idlist
4463 set rowfinal [concat $rowfinal $pad]
4464 lappend rowfinal $final
4465 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4471 proc changedrow {row} {
4472 global displayorder iddrawn rowisopt need_redisplay
4474 set l [llength $rowisopt]
4476 lset rowisopt $row 0
4477 if {$row + 1 < $l} {
4478 lset rowisopt [expr {$row + 1}] 0
4479 if {$row + 2 < $l} {
4480 lset rowisopt [expr {$row + 2}] 0
4484 set id [lindex $displayorder $row]
4485 if {[info exists iddrawn($id)]} {
4486 set need_redisplay 1
4490 proc insert_pad {row col npad} {
4493 set pad [ntimes $npad {}]
4494 set idlist [lindex $rowidlist $row]
4495 set bef [lrange $idlist 0 [expr {$col - 1}]]
4496 set aft [lrange $idlist $col end]
4497 set i [lsearch -exact $aft {}]
4499 set aft [lreplace $aft $i $i]
4501 lset rowidlist $row [concat $bef $pad $aft]
4505 proc optimize_rows {row col endrow} {
4506 global rowidlist rowisopt displayorder curview children
4511 for {} {$row < $endrow} {incr row; set col 0} {
4512 if {[lindex $rowisopt $row]} continue
4514 set y0 [expr {$row - 1}]
4515 set ym [expr {$row - 2}]
4516 set idlist [lindex $rowidlist $row]
4517 set previdlist [lindex $rowidlist $y0]
4518 if {$idlist eq {} || $previdlist eq {}} continue
4520 set pprevidlist [lindex $rowidlist $ym]
4521 if {$pprevidlist eq {}} continue
4527 for {} {$col < [llength $idlist]} {incr col} {
4528 set id [lindex $idlist $col]
4529 if {[lindex $previdlist $col] eq $id} continue
4534 set x0 [lsearch -exact $previdlist $id]
4535 if {$x0 < 0} continue
4536 set z [expr {$x0 - $col}]
4540 set xm [lsearch -exact $pprevidlist $id]
4542 set z0 [expr {$xm - $x0}]
4546 # if row y0 is the first child of $id then it's not an arrow
4547 if {[lindex $children($curview,$id) 0] ne
4548 [lindex $displayorder $y0]} {
4552 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4553 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4556 # Looking at lines from this row to the previous row,
4557 # make them go straight up if they end in an arrow on
4558 # the previous row; otherwise make them go straight up
4560 if {$z < -1 || ($z < 0 && $isarrow)} {
4561 # Line currently goes left too much;
4562 # insert pads in the previous row, then optimize it
4563 set npad [expr {-1 - $z + $isarrow}]
4564 insert_pad $y0 $x0 $npad
4566 optimize_rows $y0 $x0 $row
4568 set previdlist [lindex $rowidlist $y0]
4569 set x0 [lsearch -exact $previdlist $id]
4570 set z [expr {$x0 - $col}]
4572 set pprevidlist [lindex $rowidlist $ym]
4573 set xm [lsearch -exact $pprevidlist $id]
4574 set z0 [expr {$xm - $x0}]
4576 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4577 # Line currently goes right too much;
4578 # insert pads in this line
4579 set npad [expr {$z - 1 + $isarrow}]
4580 insert_pad $row $col $npad
4581 set idlist [lindex $rowidlist $row]
4583 set z [expr {$x0 - $col}]
4586 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4587 # this line links to its first child on row $row-2
4588 set id [lindex $displayorder $ym]
4589 set xc [lsearch -exact $pprevidlist $id]
4591 set z0 [expr {$xc - $x0}]
4594 # avoid lines jigging left then immediately right
4595 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4596 insert_pad $y0 $x0 1
4598 optimize_rows $y0 $x0 $row
4599 set previdlist [lindex $rowidlist $y0]
4603 # Find the first column that doesn't have a line going right
4604 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4605 set id [lindex $idlist $col]
4606 if {$id eq {}} break
4607 set x0 [lsearch -exact $previdlist $id]
4609 # check if this is the link to the first child
4610 set kid [lindex $displayorder $y0]
4611 if {[lindex $children($curview,$id) 0] eq $kid} {
4612 # it is, work out offset to child
4613 set x0 [lsearch -exact $previdlist $kid]
4616 if {$x0 <= $col} break
4618 # Insert a pad at that column as long as it has a line and
4619 # isn't the last column
4620 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4621 set idlist [linsert $idlist $col {}]
4622 lset rowidlist $row $idlist
4630 global canvx0 linespc
4631 return [expr {$canvx0 + $col * $linespc}]
4635 global canvy0 linespc
4636 return [expr {$canvy0 + $row * $linespc}]
4639 proc linewidth {id} {
4640 global thickerline lthickness
4643 if {[info exists thickerline] && $id eq $thickerline} {
4644 set wid [expr {2 * $lthickness}]
4649 proc rowranges {id} {
4650 global curview children uparrowlen downarrowlen
4653 set kids $children($curview,$id)
4659 foreach child $kids {
4660 if {![commitinview $child $curview]} break
4661 set row [rowofcommit $child]
4662 if {![info exists prev]} {
4663 lappend ret [expr {$row + 1}]
4665 if {$row <= $prevrow} {
4666 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4668 # see if the line extends the whole way from prevrow to row
4669 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4670 [lsearch -exact [lindex $rowidlist \
4671 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4672 # it doesn't, see where it ends
4673 set r [expr {$prevrow + $downarrowlen}]
4674 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4675 while {[incr r -1] > $prevrow &&
4676 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4678 while {[incr r] <= $row &&
4679 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4683 # see where it starts up again
4684 set r [expr {$row - $uparrowlen}]
4685 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4686 while {[incr r] < $row &&
4687 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4689 while {[incr r -1] >= $prevrow &&
4690 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4696 if {$child eq $id} {
4705 proc drawlineseg {id row endrow arrowlow} {
4706 global rowidlist displayorder iddrawn linesegs
4707 global canv colormap linespc curview maxlinelen parentlist
4709 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4710 set le [expr {$row + 1}]
4713 set c [lsearch -exact [lindex $rowidlist $le] $id]
4719 set x [lindex $displayorder $le]
4724 if {[info exists iddrawn($x)] || $le == $endrow} {
4725 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4741 if {[info exists linesegs($id)]} {
4742 set lines $linesegs($id)
4744 set r0 [lindex $li 0]
4746 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4756 set li [lindex $lines [expr {$i-1}]]
4757 set r1 [lindex $li 1]
4758 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4763 set x [lindex $cols [expr {$le - $row}]]
4764 set xp [lindex $cols [expr {$le - 1 - $row}]]
4765 set dir [expr {$xp - $x}]
4767 set ith [lindex $lines $i 2]
4768 set coords [$canv coords $ith]
4769 set ah [$canv itemcget $ith -arrow]
4770 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4771 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4772 if {$x2 ne {} && $x - $x2 == $dir} {
4773 set coords [lrange $coords 0 end-2]
4776 set coords [list [xc $le $x] [yc $le]]
4779 set itl [lindex $lines [expr {$i-1}] 2]
4780 set al [$canv itemcget $itl -arrow]
4781 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4782 } elseif {$arrowlow} {
4783 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4784 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4788 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4789 for {set y $le} {[incr y -1] > $row} {} {
4791 set xp [lindex $cols [expr {$y - 1 - $row}]]
4792 set ndir [expr {$xp - $x}]
4793 if {$dir != $ndir || $xp < 0} {
4794 lappend coords [xc $y $x] [yc $y]
4800 # join parent line to first child
4801 set ch [lindex $displayorder $row]
4802 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4804 puts "oops: drawlineseg: child $ch not on row $row"
4805 } elseif {$xc != $x} {
4806 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4807 set d [expr {int(0.5 * $linespc)}]
4810 set x2 [expr {$x1 - $d}]
4812 set x2 [expr {$x1 + $d}]
4815 set y1 [expr {$y2 + $d}]
4816 lappend coords $x1 $y1 $x2 $y2
4817 } elseif {$xc < $x - 1} {
4818 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4819 } elseif {$xc > $x + 1} {
4820 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4824 lappend coords [xc $row $x] [yc $row]
4826 set xn [xc $row $xp]
4828 lappend coords $xn $yn
4832 set t [$canv create line $coords -width [linewidth $id] \
4833 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4836 set lines [linsert $lines $i [list $row $le $t]]
4838 $canv coords $ith $coords
4839 if {$arrow ne $ah} {
4840 $canv itemconf $ith -arrow $arrow
4842 lset lines $i 0 $row
4845 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4846 set ndir [expr {$xo - $xp}]
4847 set clow [$canv coords $itl]
4848 if {$dir == $ndir} {
4849 set clow [lrange $clow 2 end]
4851 set coords [concat $coords $clow]
4853 lset lines [expr {$i-1}] 1 $le
4855 # coalesce two pieces
4857 set b [lindex $lines [expr {$i-1}] 0]
4858 set e [lindex $lines $i 1]
4859 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4861 $canv coords $itl $coords
4862 if {$arrow ne $al} {
4863 $canv itemconf $itl -arrow $arrow
4867 set linesegs($id) $lines
4871 proc drawparentlinks {id row} {
4872 global rowidlist canv colormap curview parentlist
4873 global idpos linespc
4875 set rowids [lindex $rowidlist $row]
4876 set col [lsearch -exact $rowids $id]
4877 if {$col < 0} return
4878 set olds [lindex $parentlist $row]
4879 set row2 [expr {$row + 1}]
4880 set x [xc $row $col]
4883 set d [expr {int(0.5 * $linespc)}]
4884 set ymid [expr {$y + $d}]
4885 set ids [lindex $rowidlist $row2]
4886 # rmx = right-most X coord used
4889 set i [lsearch -exact $ids $p]
4891 puts "oops, parent $p of $id not in list"
4894 set x2 [xc $row2 $i]
4898 set j [lsearch -exact $rowids $p]
4900 # drawlineseg will do this one for us
4904 # should handle duplicated parents here...
4905 set coords [list $x $y]
4907 # if attaching to a vertical segment, draw a smaller
4908 # slant for visual distinctness
4911 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4913 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4915 } elseif {$i < $col && $i < $j} {
4916 # segment slants towards us already
4917 lappend coords [xc $row $j] $y
4919 if {$i < $col - 1} {
4920 lappend coords [expr {$x2 + $linespc}] $y
4921 } elseif {$i > $col + 1} {
4922 lappend coords [expr {$x2 - $linespc}] $y
4924 lappend coords $x2 $y2
4927 lappend coords $x2 $y2
4929 set t [$canv create line $coords -width [linewidth $p] \
4930 -fill $colormap($p) -tags lines.$p]
4934 if {$rmx > [lindex $idpos($id) 1]} {
4935 lset idpos($id) 1 $rmx
4940 proc drawlines {id} {
4943 $canv itemconf lines.$id -width [linewidth $id]
4946 proc drawcmittext {id row col} {
4947 global linespc canv canv2 canv3 fgcolor curview
4948 global cmitlisted commitinfo rowidlist parentlist
4949 global rowtextx idpos idtags idheads idotherrefs
4950 global linehtag linentag linedtag selectedline
4951 global canvxmax boldrows boldnamerows fgcolor
4952 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
4954 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4955 set listed $cmitlisted($curview,$id)
4956 if {$id eq $nullid} {
4958 } elseif {$id eq $nullid2} {
4960 } elseif {$id eq $mainheadid} {
4963 set ofill [lindex $circlecolors $listed]
4965 set x [xc $row $col]
4967 set orad [expr {$linespc / 3}]
4969 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4970 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4971 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4972 } elseif {$listed == 3} {
4973 # triangle pointing left for left-side commits
4974 set t [$canv create polygon \
4975 [expr {$x - $orad}] $y \
4976 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4977 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4978 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4980 # triangle pointing right for right-side commits
4981 set t [$canv create polygon \
4982 [expr {$x + $orad - 1}] $y \
4983 [expr {$x - $orad}] [expr {$y - $orad}] \
4984 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4985 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4987 set circleitem($row) $t
4989 $canv bind $t <1> {selcanvline {} %x %y}
4990 set rmx [llength [lindex $rowidlist $row]]
4991 set olds [lindex $parentlist $row]
4993 set nextids [lindex $rowidlist [expr {$row + 1}]]
4995 set i [lsearch -exact $nextids $p]
5001 set xt [xc $row $rmx]
5002 set rowtextx($row) $xt
5003 set idpos($id) [list $x $xt $y]
5004 if {[info exists idtags($id)] || [info exists idheads($id)]
5005 || [info exists idotherrefs($id)]} {
5006 set xt [drawtags $id $x $xt $y]
5008 set headline [lindex $commitinfo($id) 0]
5009 set name [lindex $commitinfo($id) 1]
5010 set date [lindex $commitinfo($id) 2]
5011 set date [formatdate $date]
5014 set isbold [ishighlighted $id]
5016 lappend boldrows $row
5017 set font mainfontbold
5019 lappend boldnamerows $row
5020 set nfont mainfontbold
5023 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
5024 -text $headline -font $font -tags text]
5025 $canv bind $linehtag($row) $ctxbut "rowmenu %X %Y $id"
5026 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5027 -text $name -font $nfont -tags text]
5028 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5029 -text $date -font mainfont -tags text]
5030 if {$selectedline == $row} {
5033 set xr [expr {$xt + [font measure $font $headline]}]
5034 if {$xr > $canvxmax} {
5040 proc drawcmitrow {row} {
5041 global displayorder rowidlist nrows_drawn
5042 global iddrawn markingmatches
5043 global commitinfo numcommits
5044 global filehighlight fhighlights findpattern nhighlights
5045 global hlview vhighlights
5046 global highlight_related rhighlights
5048 if {$row >= $numcommits} return
5050 set id [lindex $displayorder $row]
5051 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5052 askvhighlight $row $id
5054 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5055 askfilehighlight $row $id
5057 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5058 askfindhighlight $row $id
5060 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5061 askrelhighlight $row $id
5063 if {![info exists iddrawn($id)]} {
5064 set col [lsearch -exact [lindex $rowidlist $row] $id]
5066 puts "oops, row $row id $id not in list"
5069 if {![info exists commitinfo($id)]} {
5073 drawcmittext $id $row $col
5077 if {$markingmatches} {
5078 markrowmatches $row $id
5082 proc drawcommits {row {endrow {}}} {
5083 global numcommits iddrawn displayorder curview need_redisplay
5084 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5089 if {$endrow eq {}} {
5092 if {$endrow >= $numcommits} {
5093 set endrow [expr {$numcommits - 1}]
5096 set rl1 [expr {$row - $downarrowlen - 3}]
5100 set ro1 [expr {$row - 3}]
5104 set r2 [expr {$endrow + $uparrowlen + 3}]
5105 if {$r2 > $numcommits} {
5108 for {set r $rl1} {$r < $r2} {incr r} {
5109 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5113 set rl1 [expr {$r + 1}]
5119 optimize_rows $ro1 0 $r2
5120 if {$need_redisplay || $nrows_drawn > 2000} {
5125 # make the lines join to already-drawn rows either side
5126 set r [expr {$row - 1}]
5127 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5130 set er [expr {$endrow + 1}]
5131 if {$er >= $numcommits ||
5132 ![info exists iddrawn([lindex $displayorder $er])]} {
5135 for {} {$r <= $er} {incr r} {
5136 set id [lindex $displayorder $r]
5137 set wasdrawn [info exists iddrawn($id)]
5139 if {$r == $er} break
5140 set nextid [lindex $displayorder [expr {$r + 1}]]
5141 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5142 drawparentlinks $id $r
5144 set rowids [lindex $rowidlist $r]
5145 foreach lid $rowids {
5146 if {$lid eq {}} continue
5147 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5149 # see if this is the first child of any of its parents
5150 foreach p [lindex $parentlist $r] {
5151 if {[lsearch -exact $rowids $p] < 0} {
5152 # make this line extend up to the child
5153 set lineend($p) [drawlineseg $p $r $er 0]
5157 set lineend($lid) [drawlineseg $lid $r $er 1]
5163 proc undolayout {row} {
5164 global uparrowlen mingaplen downarrowlen
5165 global rowidlist rowisopt rowfinal need_redisplay
5167 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5171 if {[llength $rowidlist] > $r} {
5173 set rowidlist [lrange $rowidlist 0 $r]
5174 set rowfinal [lrange $rowfinal 0 $r]
5175 set rowisopt [lrange $rowisopt 0 $r]
5176 set need_redisplay 1
5181 proc drawvisible {} {
5182 global canv linespc curview vrowmod selectedline targetrow targetid
5183 global need_redisplay cscroll numcommits
5185 set fs [$canv yview]
5186 set ymax [lindex [$canv cget -scrollregion] 3]
5187 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5188 set f0 [lindex $fs 0]
5189 set f1 [lindex $fs 1]
5190 set y0 [expr {int($f0 * $ymax)}]
5191 set y1 [expr {int($f1 * $ymax)}]
5193 if {[info exists targetid]} {
5194 if {[commitinview $targetid $curview]} {
5195 set r [rowofcommit $targetid]
5196 if {$r != $targetrow} {
5197 # Fix up the scrollregion and change the scrolling position
5198 # now that our target row has moved.
5199 set diff [expr {($r - $targetrow) * $linespc}]
5202 set ymax [lindex [$canv cget -scrollregion] 3]
5205 set f0 [expr {$y0 / $ymax}]
5206 set f1 [expr {$y1 / $ymax}]
5207 allcanvs yview moveto $f0
5208 $cscroll set $f0 $f1
5209 set need_redisplay 1
5216 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5217 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5218 if {$endrow >= $vrowmod($curview)} {
5219 update_arcrows $curview
5221 if {$selectedline ne {} &&
5222 $row <= $selectedline && $selectedline <= $endrow} {
5223 set targetrow $selectedline
5224 } elseif {[info exists targetid]} {
5225 set targetrow [expr {int(($row + $endrow) / 2)}]
5227 if {[info exists targetrow]} {
5228 if {$targetrow >= $numcommits} {
5229 set targetrow [expr {$numcommits - 1}]
5231 set targetid [commitonrow $targetrow]
5233 drawcommits $row $endrow
5236 proc clear_display {} {
5237 global iddrawn linesegs need_redisplay nrows_drawn
5238 global vhighlights fhighlights nhighlights rhighlights
5239 global linehtag linentag linedtag boldrows boldnamerows
5242 catch {unset iddrawn}
5243 catch {unset linesegs}
5244 catch {unset linehtag}
5245 catch {unset linentag}
5246 catch {unset linedtag}
5249 catch {unset vhighlights}
5250 catch {unset fhighlights}
5251 catch {unset nhighlights}
5252 catch {unset rhighlights}
5253 set need_redisplay 0
5257 proc findcrossings {id} {
5258 global rowidlist parentlist numcommits displayorder
5262 foreach {s e} [rowranges $id] {
5263 if {$e >= $numcommits} {
5264 set e [expr {$numcommits - 1}]
5266 if {$e <= $s} continue
5267 for {set row $e} {[incr row -1] >= $s} {} {
5268 set x [lsearch -exact [lindex $rowidlist $row] $id]
5270 set olds [lindex $parentlist $row]
5271 set kid [lindex $displayorder $row]
5272 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5273 if {$kidx < 0} continue
5274 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5276 set px [lsearch -exact $nextrow $p]
5277 if {$px < 0} continue
5278 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5279 if {[lsearch -exact $ccross $p] >= 0} continue
5280 if {$x == $px + ($kidx < $px? -1: 1)} {
5282 } elseif {[lsearch -exact $cross $p] < 0} {
5289 return [concat $ccross {{}} $cross]
5292 proc assigncolor {id} {
5293 global colormap colors nextcolor
5294 global parents children children curview
5296 if {[info exists colormap($id)]} return
5297 set ncolors [llength $colors]
5298 if {[info exists children($curview,$id)]} {
5299 set kids $children($curview,$id)
5303 if {[llength $kids] == 1} {
5304 set child [lindex $kids 0]
5305 if {[info exists colormap($child)]
5306 && [llength $parents($curview,$child)] == 1} {
5307 set colormap($id) $colormap($child)
5313 foreach x [findcrossings $id] {
5315 # delimiter between corner crossings and other crossings
5316 if {[llength $badcolors] >= $ncolors - 1} break
5317 set origbad $badcolors
5319 if {[info exists colormap($x)]
5320 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5321 lappend badcolors $colormap($x)
5324 if {[llength $badcolors] >= $ncolors} {
5325 set badcolors $origbad
5327 set origbad $badcolors
5328 if {[llength $badcolors] < $ncolors - 1} {
5329 foreach child $kids {
5330 if {[info exists colormap($child)]
5331 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5332 lappend badcolors $colormap($child)
5334 foreach p $parents($curview,$child) {
5335 if {[info exists colormap($p)]
5336 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5337 lappend badcolors $colormap($p)
5341 if {[llength $badcolors] >= $ncolors} {
5342 set badcolors $origbad
5345 for {set i 0} {$i <= $ncolors} {incr i} {
5346 set c [lindex $colors $nextcolor]
5347 if {[incr nextcolor] >= $ncolors} {
5350 if {[lsearch -exact $badcolors $c]} break
5352 set colormap($id) $c
5355 proc bindline {t id} {
5358 $canv bind $t <Enter> "lineenter %x %y $id"
5359 $canv bind $t <Motion> "linemotion %x %y $id"
5360 $canv bind $t <Leave> "lineleave $id"
5361 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5364 proc drawtags {id x xt y1} {
5365 global idtags idheads idotherrefs mainhead
5366 global linespc lthickness
5367 global canv rowtextx curview fgcolor bgcolor ctxbut
5372 if {[info exists idtags($id)]} {
5373 set marks $idtags($id)
5374 set ntags [llength $marks]
5376 if {[info exists idheads($id)]} {
5377 set marks [concat $marks $idheads($id)]
5378 set nheads [llength $idheads($id)]
5380 if {[info exists idotherrefs($id)]} {
5381 set marks [concat $marks $idotherrefs($id)]
5387 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5388 set yt [expr {$y1 - 0.5 * $linespc}]
5389 set yb [expr {$yt + $linespc - 1}]
5393 foreach tag $marks {
5395 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5396 set wid [font measure mainfontbold $tag]
5398 set wid [font measure mainfont $tag]
5402 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5404 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5405 -width $lthickness -fill black -tags tag.$id]
5407 foreach tag $marks x $xvals wid $wvals {
5408 set xl [expr {$x + $delta}]
5409 set xr [expr {$x + $delta + $wid + $lthickness}]
5411 if {[incr ntags -1] >= 0} {
5413 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5414 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5415 -width 1 -outline black -fill yellow -tags tag.$id]
5416 $canv bind $t <1> [list showtag $tag 1]
5417 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5419 # draw a head or other ref
5420 if {[incr nheads -1] >= 0} {
5422 if {$tag eq $mainhead} {
5423 set font mainfontbold
5428 set xl [expr {$xl - $delta/2}]
5429 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5430 -width 1 -outline black -fill $col -tags tag.$id
5431 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5432 set rwid [font measure mainfont $remoteprefix]
5433 set xi [expr {$x + 1}]
5434 set yti [expr {$yt + 1}]
5435 set xri [expr {$x + $rwid}]
5436 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5437 -width 0 -fill "#ffddaa" -tags tag.$id
5440 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5441 -font $font -tags [list tag.$id text]]
5443 $canv bind $t <1> [list showtag $tag 1]
5444 } elseif {$nheads >= 0} {
5445 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
5451 proc xcoord {i level ln} {
5452 global canvx0 xspc1 xspc2
5454 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5455 if {$i > 0 && $i == $level} {
5456 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5457 } elseif {$i > $level} {
5458 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5463 proc show_status {msg} {
5467 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5468 -tags text -fill $fgcolor
5471 # Don't change the text pane cursor if it is currently the hand cursor,
5472 # showing that we are over a sha1 ID link.
5473 proc settextcursor {c} {
5474 global ctext curtextcursor
5476 if {[$ctext cget -cursor] == $curtextcursor} {
5477 $ctext config -cursor $c
5479 set curtextcursor $c
5482 proc nowbusy {what {name {}}} {
5483 global isbusy busyname statusw
5485 if {[array names isbusy] eq {}} {
5486 . config -cursor watch
5490 set busyname($what) $name
5492 $statusw conf -text $name
5496 proc notbusy {what} {
5497 global isbusy maincursor textcursor busyname statusw
5501 if {$busyname($what) ne {} &&
5502 [$statusw cget -text] eq $busyname($what)} {
5503 $statusw conf -text {}
5506 if {[array names isbusy] eq {}} {
5507 . config -cursor $maincursor
5508 settextcursor $textcursor
5512 proc findmatches {f} {
5513 global findtype findstring
5514 if {$findtype == [mc "Regexp"]} {
5515 set matches [regexp -indices -all -inline $findstring $f]
5518 if {$findtype == [mc "IgnCase"]} {
5519 set f [string tolower $f]
5520 set fs [string tolower $fs]
5524 set l [string length $fs]
5525 while {[set j [string first $fs $f $i]] >= 0} {
5526 lappend matches [list $j [expr {$j+$l-1}]]
5527 set i [expr {$j + $l}]
5533 proc dofind {{dirn 1} {wrap 1}} {
5534 global findstring findstartline findcurline selectedline numcommits
5535 global gdttype filehighlight fh_serial find_dirn findallowwrap
5537 if {[info exists find_dirn]} {
5538 if {$find_dirn == $dirn} return
5542 if {$findstring eq {} || $numcommits == 0} return
5543 if {$selectedline eq {}} {
5544 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5546 set findstartline $selectedline
5548 set findcurline $findstartline
5549 nowbusy finding [mc "Searching"]
5550 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5551 after cancel do_file_hl $fh_serial
5552 do_file_hl $fh_serial
5555 set findallowwrap $wrap
5559 proc stopfinding {} {
5560 global find_dirn findcurline fprogcoord
5562 if {[info exists find_dirn]} {
5572 global commitdata commitinfo numcommits findpattern findloc
5573 global findstartline findcurline findallowwrap
5574 global find_dirn gdttype fhighlights fprogcoord
5575 global curview varcorder vrownum varccommits vrowmod
5577 if {![info exists find_dirn]} {
5580 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5583 if {$find_dirn > 0} {
5585 if {$l >= $numcommits} {
5588 if {$l <= $findstartline} {
5589 set lim [expr {$findstartline + 1}]
5592 set moretodo $findallowwrap
5599 if {$l >= $findstartline} {
5600 set lim [expr {$findstartline - 1}]
5603 set moretodo $findallowwrap
5606 set n [expr {($lim - $l) * $find_dirn}]
5611 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5612 update_arcrows $curview
5616 set ai [bsearch $vrownum($curview) $l]
5617 set a [lindex $varcorder($curview) $ai]
5618 set arow [lindex $vrownum($curview) $ai]
5619 set ids [lindex $varccommits($curview,$a)]
5620 set arowend [expr {$arow + [llength $ids]}]
5621 if {$gdttype eq [mc "containing:"]} {
5622 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5623 if {$l < $arow || $l >= $arowend} {
5625 set a [lindex $varcorder($curview) $ai]
5626 set arow [lindex $vrownum($curview) $ai]
5627 set ids [lindex $varccommits($curview,$a)]
5628 set arowend [expr {$arow + [llength $ids]}]
5630 set id [lindex $ids [expr {$l - $arow}]]
5631 # shouldn't happen unless git log doesn't give all the commits...
5632 if {![info exists commitdata($id)] ||
5633 ![doesmatch $commitdata($id)]} {
5636 if {![info exists commitinfo($id)]} {
5639 set info $commitinfo($id)
5640 foreach f $info ty $fldtypes {
5641 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5650 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5651 if {$l < $arow || $l >= $arowend} {
5653 set a [lindex $varcorder($curview) $ai]
5654 set arow [lindex $vrownum($curview) $ai]
5655 set ids [lindex $varccommits($curview,$a)]
5656 set arowend [expr {$arow + [llength $ids]}]
5658 set id [lindex $ids [expr {$l - $arow}]]
5659 if {![info exists fhighlights($id)]} {
5660 # this sets fhighlights($id) to -1
5661 askfilehighlight $l $id
5663 if {$fhighlights($id) > 0} {
5667 if {$fhighlights($id) < 0} {
5670 set findcurline [expr {$l - $find_dirn}]
5675 if {$found || ($domore && !$moretodo)} {
5691 set findcurline [expr {$l - $find_dirn}]
5693 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5697 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5702 proc findselectline {l} {
5703 global findloc commentend ctext findcurline markingmatches gdttype
5705 set markingmatches 1
5708 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5709 # highlight the matches in the comments
5710 set f [$ctext get 1.0 $commentend]
5711 set matches [findmatches $f]
5712 foreach match $matches {
5713 set start [lindex $match 0]
5714 set end [expr {[lindex $match 1] + 1}]
5715 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5721 # mark the bits of a headline or author that match a find string
5722 proc markmatches {canv l str tag matches font row} {
5725 set bbox [$canv bbox $tag]
5726 set x0 [lindex $bbox 0]
5727 set y0 [lindex $bbox 1]
5728 set y1 [lindex $bbox 3]
5729 foreach match $matches {
5730 set start [lindex $match 0]
5731 set end [lindex $match 1]
5732 if {$start > $end} continue
5733 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5734 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5735 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5736 [expr {$x0+$xlen+2}] $y1 \
5737 -outline {} -tags [list match$l matches] -fill yellow]
5739 if {$row == $selectedline} {
5740 $canv raise $t secsel
5745 proc unmarkmatches {} {
5746 global markingmatches
5748 allcanvs delete matches
5749 set markingmatches 0
5753 proc selcanvline {w x y} {
5754 global canv canvy0 ctext linespc
5756 set ymax [lindex [$canv cget -scrollregion] 3]
5757 if {$ymax == {}} return
5758 set yfrac [lindex [$canv yview] 0]
5759 set y [expr {$y + $yfrac * $ymax}]
5760 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5765 set xmax [lindex [$canv cget -scrollregion] 2]
5766 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5767 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5773 proc commit_descriptor {p} {
5775 if {![info exists commitinfo($p)]} {
5779 if {[llength $commitinfo($p)] > 1} {
5780 set l [lindex $commitinfo($p) 0]
5785 # append some text to the ctext widget, and make any SHA1 ID
5786 # that we know about be a clickable link.
5787 proc appendwithlinks {text tags} {
5788 global ctext linknum curview pendinglinks
5790 set start [$ctext index "end - 1c"]
5791 $ctext insert end $text $tags
5792 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5796 set linkid [string range $text $s $e]
5798 $ctext tag delete link$linknum
5799 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5800 setlink $linkid link$linknum
5805 proc setlink {id lk} {
5806 global curview ctext pendinglinks commitinterest
5808 if {[commitinview $id $curview]} {
5809 $ctext tag conf $lk -foreground blue -underline 1
5810 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5811 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5812 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5814 lappend pendinglinks($id) $lk
5815 lappend commitinterest($id) {makelink %I}
5819 proc makelink {id} {
5822 if {![info exists pendinglinks($id)]} return
5823 foreach lk $pendinglinks($id) {
5826 unset pendinglinks($id)
5829 proc linkcursor {w inc} {
5830 global linkentercount curtextcursor
5832 if {[incr linkentercount $inc] > 0} {
5833 $w configure -cursor hand2
5835 $w configure -cursor $curtextcursor
5836 if {$linkentercount < 0} {
5837 set linkentercount 0
5842 proc viewnextline {dir} {
5846 set ymax [lindex [$canv cget -scrollregion] 3]
5847 set wnow [$canv yview]
5848 set wtop [expr {[lindex $wnow 0] * $ymax}]
5849 set newtop [expr {$wtop + $dir * $linespc}]
5852 } elseif {$newtop > $ymax} {
5855 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5858 # add a list of tag or branch names at position pos
5859 # returns the number of names inserted
5860 proc appendrefs {pos ids var} {
5861 global ctext linknum curview $var maxrefs
5863 if {[catch {$ctext index $pos}]} {
5866 $ctext conf -state normal
5867 $ctext delete $pos "$pos lineend"
5870 foreach tag [set $var\($id\)] {
5871 lappend tags [list $tag $id]
5874 if {[llength $tags] > $maxrefs} {
5875 $ctext insert $pos "many ([llength $tags])"
5877 set tags [lsort -index 0 -decreasing $tags]
5880 set id [lindex $ti 1]
5883 $ctext tag delete $lk
5884 $ctext insert $pos $sep
5885 $ctext insert $pos [lindex $ti 0] $lk
5890 $ctext conf -state disabled
5891 return [llength $tags]
5894 # called when we have finished computing the nearby tags
5895 proc dispneartags {delay} {
5896 global selectedline currentid showneartags tagphase
5898 if {$selectedline eq {} || !$showneartags} return
5899 after cancel dispnexttag
5901 after 200 dispnexttag
5904 after idle dispnexttag
5909 proc dispnexttag {} {
5910 global selectedline currentid showneartags tagphase ctext
5912 if {$selectedline eq {} || !$showneartags} return
5913 switch -- $tagphase {
5915 set dtags [desctags $currentid]
5917 appendrefs precedes $dtags idtags
5921 set atags [anctags $currentid]
5923 appendrefs follows $atags idtags
5927 set dheads [descheads $currentid]
5928 if {$dheads ne {}} {
5929 if {[appendrefs branch $dheads idheads] > 1
5930 && [$ctext get "branch -3c"] eq "h"} {
5931 # turn "Branch" into "Branches"
5932 $ctext conf -state normal
5933 $ctext insert "branch -2c" "es"
5934 $ctext conf -state disabled
5939 if {[incr tagphase] <= 2} {
5940 after idle dispnexttag
5944 proc make_secsel {l} {
5945 global linehtag linentag linedtag canv canv2 canv3
5947 if {![info exists linehtag($l)]} return
5949 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5950 -tags secsel -fill [$canv cget -selectbackground]]
5952 $canv2 delete secsel
5953 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5954 -tags secsel -fill [$canv2 cget -selectbackground]]
5956 $canv3 delete secsel
5957 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5958 -tags secsel -fill [$canv3 cget -selectbackground]]
5962 proc selectline {l isnew} {
5963 global canv ctext commitinfo selectedline
5964 global canvy0 linespc parents children curview
5965 global currentid sha1entry
5966 global commentend idtags linknum
5967 global mergemax numcommits pending_select
5968 global cmitmode showneartags allcommits
5969 global targetrow targetid lastscrollrows
5972 catch {unset pending_select}
5977 if {$l < 0 || $l >= $numcommits} return
5978 set id [commitonrow $l]
5983 if {$lastscrollrows < $numcommits} {
5987 set y [expr {$canvy0 + $l * $linespc}]
5988 set ymax [lindex [$canv cget -scrollregion] 3]
5989 set ytop [expr {$y - $linespc - 1}]
5990 set ybot [expr {$y + $linespc + 1}]
5991 set wnow [$canv yview]
5992 set wtop [expr {[lindex $wnow 0] * $ymax}]
5993 set wbot [expr {[lindex $wnow 1] * $ymax}]
5994 set wh [expr {$wbot - $wtop}]
5996 if {$ytop < $wtop} {
5997 if {$ybot < $wtop} {
5998 set newtop [expr {$y - $wh / 2.0}]
6001 if {$newtop > $wtop - $linespc} {
6002 set newtop [expr {$wtop - $linespc}]
6005 } elseif {$ybot > $wbot} {
6006 if {$ytop > $wbot} {
6007 set newtop [expr {$y - $wh / 2.0}]
6009 set newtop [expr {$ybot - $wh}]
6010 if {$newtop < $wtop + $linespc} {
6011 set newtop [expr {$wtop + $linespc}]
6015 if {$newtop != $wtop} {
6019 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6026 addtohistory [list selbyid $id]
6029 $sha1entry delete 0 end
6030 $sha1entry insert 0 $id
6032 $sha1entry selection from 0
6033 $sha1entry selection to end
6037 $ctext conf -state normal
6040 if {![info exists commitinfo($id)]} {
6043 set info $commitinfo($id)
6044 set date [formatdate [lindex $info 2]]
6045 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6046 set date [formatdate [lindex $info 4]]
6047 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6048 if {[info exists idtags($id)]} {
6049 $ctext insert end [mc "Tags:"]
6050 foreach tag $idtags($id) {
6051 $ctext insert end " $tag"
6053 $ctext insert end "\n"
6057 set olds $parents($curview,$id)
6058 if {[llength $olds] > 1} {
6061 if {$np >= $mergemax} {
6066 $ctext insert end "[mc "Parent"]: " $tag
6067 appendwithlinks [commit_descriptor $p] {}
6072 append headers "[mc "Parent"]: [commit_descriptor $p]"
6076 foreach c $children($curview,$id) {
6077 append headers "[mc "Child"]: [commit_descriptor $c]"
6080 # make anything that looks like a SHA1 ID be a clickable link
6081 appendwithlinks $headers {}
6082 if {$showneartags} {
6083 if {![info exists allcommits]} {
6086 $ctext insert end "[mc "Branch"]: "
6087 $ctext mark set branch "end -1c"
6088 $ctext mark gravity branch left
6089 $ctext insert end "\n[mc "Follows"]: "
6090 $ctext mark set follows "end -1c"
6091 $ctext mark gravity follows left
6092 $ctext insert end "\n[mc "Precedes"]: "
6093 $ctext mark set precedes "end -1c"
6094 $ctext mark gravity precedes left
6095 $ctext insert end "\n"
6098 $ctext insert end "\n"
6099 set comment [lindex $info 5]
6100 if {[string first "\r" $comment] >= 0} {
6101 set comment [string map {"\r" "\n "} $comment]
6103 appendwithlinks $comment {comment}
6105 $ctext tag remove found 1.0 end
6106 $ctext conf -state disabled
6107 set commentend [$ctext index "end - 1c"]
6109 init_flist [mc "Comments"]
6110 if {$cmitmode eq "tree"} {
6112 } elseif {[llength $olds] <= 1} {
6119 proc selfirstline {} {
6124 proc sellastline {} {
6127 set l [expr {$numcommits - 1}]
6131 proc selnextline {dir} {
6134 if {$selectedline eq {}} return
6135 set l [expr {$selectedline + $dir}]
6140 proc selnextpage {dir} {
6141 global canv linespc selectedline numcommits
6143 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6147 allcanvs yview scroll [expr {$dir * $lpp}] units
6149 if {$selectedline eq {}} return
6150 set l [expr {$selectedline + $dir * $lpp}]
6153 } elseif {$l >= $numcommits} {
6154 set l [expr $numcommits - 1]
6160 proc unselectline {} {
6161 global selectedline currentid
6164 catch {unset currentid}
6165 allcanvs delete secsel
6169 proc reselectline {} {
6172 if {$selectedline ne {}} {
6173 selectline $selectedline 0
6177 proc addtohistory {cmd} {
6178 global history historyindex curview
6180 set elt [list $curview $cmd]
6181 if {$historyindex > 0
6182 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6186 if {$historyindex < [llength $history]} {
6187 set history [lreplace $history $historyindex end $elt]
6189 lappend history $elt
6192 if {$historyindex > 1} {
6193 .tf.bar.leftbut conf -state normal
6195 .tf.bar.leftbut conf -state disabled
6197 .tf.bar.rightbut conf -state disabled
6203 set view [lindex $elt 0]
6204 set cmd [lindex $elt 1]
6205 if {$curview != $view} {
6212 global history historyindex
6215 if {$historyindex > 1} {
6216 incr historyindex -1
6217 godo [lindex $history [expr {$historyindex - 1}]]
6218 .tf.bar.rightbut conf -state normal
6220 if {$historyindex <= 1} {
6221 .tf.bar.leftbut conf -state disabled
6226 global history historyindex
6229 if {$historyindex < [llength $history]} {
6230 set cmd [lindex $history $historyindex]
6233 .tf.bar.leftbut conf -state normal
6235 if {$historyindex >= [llength $history]} {
6236 .tf.bar.rightbut conf -state disabled
6241 global treefilelist treeidlist diffids diffmergeid treepending
6242 global nullid nullid2
6245 catch {unset diffmergeid}
6246 if {![info exists treefilelist($id)]} {
6247 if {![info exists treepending]} {
6248 if {$id eq $nullid} {
6249 set cmd [list | git ls-files]
6250 } elseif {$id eq $nullid2} {
6251 set cmd [list | git ls-files --stage -t]
6253 set cmd [list | git ls-tree -r $id]
6255 if {[catch {set gtf [open $cmd r]}]} {
6259 set treefilelist($id) {}
6260 set treeidlist($id) {}
6261 fconfigure $gtf -blocking 0 -encoding binary
6262 filerun $gtf [list gettreeline $gtf $id]
6269 proc gettreeline {gtf id} {
6270 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6273 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6274 if {$diffids eq $nullid} {
6277 set i [string first "\t" $line]
6278 if {$i < 0} continue
6279 set fname [string range $line [expr {$i+1}] end]
6280 set line [string range $line 0 [expr {$i-1}]]
6281 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6282 set sha1 [lindex $line 2]
6283 lappend treeidlist($id) $sha1
6285 if {[string index $fname 0] eq "\""} {
6286 set fname [lindex $fname 0]
6288 set fname [encoding convertfrom $fname]
6289 lappend treefilelist($id) $fname
6292 return [expr {$nl >= 1000? 2: 1}]
6296 if {$cmitmode ne "tree"} {
6297 if {![info exists diffmergeid]} {
6298 gettreediffs $diffids
6300 } elseif {$id ne $diffids} {
6309 global treefilelist treeidlist diffids nullid nullid2
6310 global ctext commentend
6312 set i [lsearch -exact $treefilelist($diffids) $f]
6314 puts "oops, $f not in list for id $diffids"
6317 if {$diffids eq $nullid} {
6318 if {[catch {set bf [open $f r]} err]} {
6319 puts "oops, can't read $f: $err"
6323 set blob [lindex $treeidlist($diffids) $i]
6324 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6325 puts "oops, error reading blob $blob: $err"
6329 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6330 filerun $bf [list getblobline $bf $diffids]
6331 $ctext config -state normal
6332 clear_ctext $commentend
6333 $ctext insert end "\n"
6334 $ctext insert end "$f\n" filesep
6335 $ctext config -state disabled
6336 $ctext yview $commentend
6340 proc getblobline {bf id} {
6341 global diffids cmitmode ctext
6343 if {$id ne $diffids || $cmitmode ne "tree"} {
6347 $ctext config -state normal
6349 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6350 $ctext insert end "$line\n"
6353 # delete last newline
6354 $ctext delete "end - 2c" "end - 1c"
6358 $ctext config -state disabled
6359 return [expr {$nl >= 1000? 2: 1}]
6362 proc mergediff {id} {
6363 global diffmergeid mdifffd
6368 global limitdiffs vfilelimit curview
6372 # this doesn't seem to actually affect anything...
6373 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6374 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6375 set cmd [concat $cmd -- $vfilelimit($curview)]
6377 if {[catch {set mdf [open $cmd r]} err]} {
6378 error_popup "[mc "Error getting merge diffs:"] $err"
6381 fconfigure $mdf -blocking 0 -encoding binary
6382 set mdifffd($id) $mdf
6383 set np [llength $parents($curview,$id)]
6384 set diffencoding [get_path_encoding {}]
6386 filerun $mdf [list getmergediffline $mdf $id $np]
6389 proc getmergediffline {mdf id np} {
6390 global diffmergeid ctext cflist mergemax
6391 global difffilestart mdifffd
6394 $ctext conf -state normal
6396 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6397 if {![info exists diffmergeid] || $id != $diffmergeid
6398 || $mdf != $mdifffd($id)} {
6402 if {[regexp {^diff --cc (.*)} $line match fname]} {
6403 # start of a new file
6404 set fname [encoding convertfrom $fname]
6405 $ctext insert end "\n"
6406 set here [$ctext index "end - 1c"]
6407 lappend difffilestart $here
6408 add_flist [list $fname]
6409 set diffencoding [get_path_encoding $fname]
6410 set l [expr {(78 - [string length $fname]) / 2}]
6411 set pad [string range "----------------------------------------" 1 $l]
6412 $ctext insert end "$pad $fname $pad\n" filesep
6413 } elseif {[regexp {^@@} $line]} {
6414 set line [encoding convertfrom $diffencoding $line]
6415 $ctext insert end "$line\n" hunksep
6416 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6419 set line [encoding convertfrom $diffencoding $line]
6420 # parse the prefix - one ' ', '-' or '+' for each parent
6425 for {set j 0} {$j < $np} {incr j} {
6426 set c [string range $line $j $j]
6429 } elseif {$c == "-"} {
6431 } elseif {$c == "+"} {
6440 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6441 # line doesn't appear in result, parents in $minuses have the line
6442 set num [lindex $minuses 0]
6443 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6444 # line appears in result, parents in $pluses don't have the line
6445 lappend tags mresult
6446 set num [lindex $spaces 0]
6449 if {$num >= $mergemax} {
6454 $ctext insert end "$line\n" $tags
6457 $ctext conf -state disabled
6462 return [expr {$nr >= 1000? 2: 1}]
6465 proc startdiff {ids} {
6466 global treediffs diffids treepending diffmergeid nullid nullid2
6470 catch {unset diffmergeid}
6471 if {![info exists treediffs($ids)] ||
6472 [lsearch -exact $ids $nullid] >= 0 ||
6473 [lsearch -exact $ids $nullid2] >= 0} {
6474 if {![info exists treepending]} {
6482 proc path_filter {filter name} {
6484 set l [string length $p]
6485 if {[string index $p end] eq "/"} {
6486 if {[string compare -length $l $p $name] == 0} {
6490 if {[string compare -length $l $p $name] == 0 &&
6491 ([string length $name] == $l ||
6492 [string index $name $l] eq "/")} {
6500 proc addtocflist {ids} {
6503 add_flist $treediffs($ids)
6507 proc diffcmd {ids flags} {
6508 global nullid nullid2
6510 set i [lsearch -exact $ids $nullid]
6511 set j [lsearch -exact $ids $nullid2]
6513 if {[llength $ids] > 1 && $j < 0} {
6514 # comparing working directory with some specific revision
6515 set cmd [concat | git diff-index $flags]
6517 lappend cmd -R [lindex $ids 1]
6519 lappend cmd [lindex $ids 0]
6522 # comparing working directory with index
6523 set cmd [concat | git diff-files $flags]
6528 } elseif {$j >= 0} {
6529 set cmd [concat | git diff-index --cached $flags]
6530 if {[llength $ids] > 1} {
6531 # comparing index with specific revision
6533 lappend cmd -R [lindex $ids 1]
6535 lappend cmd [lindex $ids 0]
6538 # comparing index with HEAD
6542 set cmd [concat | git diff-tree -r $flags $ids]
6547 proc gettreediffs {ids} {
6548 global treediff treepending
6550 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6552 set treepending $ids
6554 fconfigure $gdtf -blocking 0 -encoding binary
6555 filerun $gdtf [list gettreediffline $gdtf $ids]
6558 proc gettreediffline {gdtf ids} {
6559 global treediff treediffs treepending diffids diffmergeid
6560 global cmitmode vfilelimit curview limitdiffs perfile_attrs
6565 if {$perfile_attrs} {
6566 # cache_gitattr is slow, and even slower on win32 where we
6567 # have to invoke it for only about 30 paths at a time
6569 if {[tk windowingsystem] == "win32"} {
6573 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
6574 set i [string first "\t" $line]
6576 set file [string range $line [expr {$i+1}] end]
6577 if {[string index $file 0] eq "\""} {
6578 set file [lindex $file 0]
6580 set file [encoding convertfrom $file]
6581 lappend treediff $file
6582 lappend sublist $file
6585 if {$perfile_attrs} {
6586 cache_gitattr encoding $sublist
6589 return [expr {$nr >= $max? 2: 1}]
6592 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6594 foreach f $treediff {
6595 if {[path_filter $vfilelimit($curview) $f]} {
6599 set treediffs($ids) $flist
6601 set treediffs($ids) $treediff
6604 if {$cmitmode eq "tree"} {
6606 } elseif {$ids != $diffids} {
6607 if {![info exists diffmergeid]} {
6608 gettreediffs $diffids
6616 # empty string or positive integer
6617 proc diffcontextvalidate {v} {
6618 return [regexp {^(|[1-9][0-9]*)$} $v]
6621 proc diffcontextchange {n1 n2 op} {
6622 global diffcontextstring diffcontext
6624 if {[string is integer -strict $diffcontextstring]} {
6625 if {$diffcontextstring > 0} {
6626 set diffcontext $diffcontextstring
6632 proc changeignorespace {} {
6636 proc getblobdiffs {ids} {
6637 global blobdifffd diffids env
6638 global diffinhdr treediffs
6641 global limitdiffs vfilelimit curview
6644 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6648 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6649 set cmd [concat $cmd -- $vfilelimit($curview)]
6651 if {[catch {set bdf [open $cmd r]} err]} {
6652 puts "error getting diffs: $err"
6656 set diffencoding [get_path_encoding {}]
6657 fconfigure $bdf -blocking 0 -encoding binary
6658 set blobdifffd($ids) $bdf
6659 filerun $bdf [list getblobdiffline $bdf $diffids]
6662 proc setinlist {var i val} {
6665 while {[llength [set $var]] < $i} {
6668 if {[llength [set $var]] == $i} {
6675 proc makediffhdr {fname ids} {
6676 global ctext curdiffstart treediffs
6678 set i [lsearch -exact $treediffs($ids) $fname]
6680 setinlist difffilestart $i $curdiffstart
6682 set l [expr {(78 - [string length $fname]) / 2}]
6683 set pad [string range "----------------------------------------" 1 $l]
6684 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6687 proc getblobdiffline {bdf ids} {
6688 global diffids blobdifffd ctext curdiffstart
6689 global diffnexthead diffnextnote difffilestart
6690 global diffinhdr treediffs
6694 $ctext conf -state normal
6695 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6696 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6700 if {![string compare -length 11 "diff --git " $line]} {
6701 # trim off "diff --git "
6702 set line [string range $line 11 end]
6704 # start of a new file
6705 $ctext insert end "\n"
6706 set curdiffstart [$ctext index "end - 1c"]
6707 $ctext insert end "\n" filesep
6708 # If the name hasn't changed the length will be odd,
6709 # the middle char will be a space, and the two bits either
6710 # side will be a/name and b/name, or "a/name" and "b/name".
6711 # If the name has changed we'll get "rename from" and
6712 # "rename to" or "copy from" and "copy to" lines following this,
6713 # and we'll use them to get the filenames.
6714 # This complexity is necessary because spaces in the filename(s)
6715 # don't get escaped.
6716 set l [string length $line]
6717 set i [expr {$l / 2}]
6718 if {!(($l & 1) && [string index $line $i] eq " " &&
6719 [string range $line 2 [expr {$i - 1}]] eq \
6720 [string range $line [expr {$i + 3}] end])} {
6723 # unescape if quoted and chop off the a/ from the front
6724 if {[string index $line 0] eq "\""} {
6725 set fname [string range [lindex $line 0] 2 end]
6727 set fname [string range $line 2 [expr {$i - 1}]]
6729 set fname [encoding convertfrom $fname]
6730 set diffencoding [get_path_encoding $fname]
6731 makediffhdr $fname $ids
6733 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6734 $line match f1l f1c f2l f2c rest]} {
6735 set line [encoding convertfrom $diffencoding $line]
6736 $ctext insert end "$line\n" hunksep
6739 } elseif {$diffinhdr} {
6740 if {![string compare -length 12 "rename from " $line]} {
6741 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6742 if {[string index $fname 0] eq "\""} {
6743 set fname [lindex $fname 0]
6745 set fname [encoding convertfrom $fname]
6746 set i [lsearch -exact $treediffs($ids) $fname]
6748 setinlist difffilestart $i $curdiffstart
6750 } elseif {![string compare -length 10 $line "rename to "] ||
6751 ![string compare -length 8 $line "copy to "]} {
6752 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6753 if {[string index $fname 0] eq "\""} {
6754 set fname [lindex $fname 0]
6756 set fname [encoding convertfrom $fname]
6757 set diffencoding [get_path_encoding $fname]
6758 makediffhdr $fname $ids
6759 } elseif {[string compare -length 3 $line "---"] == 0} {
6762 } elseif {[string compare -length 3 $line "+++"] == 0} {
6766 $ctext insert end "$line\n" filesep
6769 set line [encoding convertfrom $diffencoding $line]
6770 set x [string range $line 0 0]
6771 if {$x == "-" || $x == "+"} {
6772 set tag [expr {$x == "+"}]
6773 $ctext insert end "$line\n" d$tag
6774 } elseif {$x == " "} {
6775 $ctext insert end "$line\n"
6777 # "\ No newline at end of file",
6778 # or something else we don't recognize
6779 $ctext insert end "$line\n" hunksep
6783 $ctext conf -state disabled
6788 return [expr {$nr >= 1000? 2: 1}]
6791 proc changediffdisp {} {
6792 global ctext diffelide
6794 $ctext tag conf d0 -elide [lindex $diffelide 0]
6795 $ctext tag conf d1 -elide [lindex $diffelide 1]
6798 proc highlightfile {loc cline} {
6799 global ctext cflist cflist_top
6802 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6803 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6804 $cflist see $cline.0
6805 set cflist_top $cline
6809 global difffilestart ctext cmitmode
6811 if {$cmitmode eq "tree"} return
6814 set here [$ctext index @0,0]
6815 foreach loc $difffilestart {
6816 if {[$ctext compare $loc >= $here]} {
6817 highlightfile $prev $prevline
6823 highlightfile $prev $prevline
6827 global difffilestart ctext cmitmode
6829 if {$cmitmode eq "tree"} return
6830 set here [$ctext index @0,0]
6832 foreach loc $difffilestart {
6834 if {[$ctext compare $loc > $here]} {
6835 highlightfile $loc $line
6841 proc clear_ctext {{first 1.0}} {
6842 global ctext smarktop smarkbot
6845 set l [lindex [split $first .] 0]
6846 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6849 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6852 $ctext delete $first end
6853 if {$first eq "1.0"} {
6854 catch {unset pendinglinks}
6858 proc settabs {{firstab {}}} {
6859 global firsttabstop tabstop ctext have_tk85
6861 if {$firstab ne {} && $have_tk85} {
6862 set firsttabstop $firstab
6864 set w [font measure textfont "0"]
6865 if {$firsttabstop != 0} {
6866 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6867 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6868 } elseif {$have_tk85 || $tabstop != 8} {
6869 $ctext conf -tabs [expr {$tabstop * $w}]
6871 $ctext conf -tabs {}
6875 proc incrsearch {name ix op} {
6876 global ctext searchstring searchdirn
6878 $ctext tag remove found 1.0 end
6879 if {[catch {$ctext index anchor}]} {
6880 # no anchor set, use start of selection, or of visible area
6881 set sel [$ctext tag ranges sel]
6883 $ctext mark set anchor [lindex $sel 0]
6884 } elseif {$searchdirn eq "-forwards"} {
6885 $ctext mark set anchor @0,0
6887 $ctext mark set anchor @0,[winfo height $ctext]
6890 if {$searchstring ne {}} {
6891 set here [$ctext search $searchdirn -- $searchstring anchor]
6900 global sstring ctext searchstring searchdirn
6903 $sstring icursor end
6904 set searchdirn -forwards
6905 if {$searchstring ne {}} {
6906 set sel [$ctext tag ranges sel]
6908 set start "[lindex $sel 0] + 1c"
6909 } elseif {[catch {set start [$ctext index anchor]}]} {
6912 set match [$ctext search -count mlen -- $searchstring $start]
6913 $ctext tag remove sel 1.0 end
6919 set mend "$match + $mlen c"
6920 $ctext tag add sel $match $mend
6921 $ctext mark unset anchor
6925 proc dosearchback {} {
6926 global sstring ctext searchstring searchdirn
6929 $sstring icursor end
6930 set searchdirn -backwards
6931 if {$searchstring ne {}} {
6932 set sel [$ctext tag ranges sel]
6934 set start [lindex $sel 0]
6935 } elseif {[catch {set start [$ctext index anchor]}]} {
6936 set start @0,[winfo height $ctext]
6938 set match [$ctext search -backwards -count ml -- $searchstring $start]
6939 $ctext tag remove sel 1.0 end
6945 set mend "$match + $ml c"
6946 $ctext tag add sel $match $mend
6947 $ctext mark unset anchor
6951 proc searchmark {first last} {
6952 global ctext searchstring
6956 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6957 if {$match eq {}} break
6958 set mend "$match + $mlen c"
6959 $ctext tag add found $match $mend
6963 proc searchmarkvisible {doall} {
6964 global ctext smarktop smarkbot
6966 set topline [lindex [split [$ctext index @0,0] .] 0]
6967 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6968 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6969 # no overlap with previous
6970 searchmark $topline $botline
6971 set smarktop $topline
6972 set smarkbot $botline
6974 if {$topline < $smarktop} {
6975 searchmark $topline [expr {$smarktop-1}]
6976 set smarktop $topline
6978 if {$botline > $smarkbot} {
6979 searchmark [expr {$smarkbot+1}] $botline
6980 set smarkbot $botline
6985 proc scrolltext {f0 f1} {
6988 .bleft.bottom.sb set $f0 $f1
6989 if {$searchstring ne {}} {
6995 global linespc charspc canvx0 canvy0
6996 global xspc1 xspc2 lthickness
6998 set linespc [font metrics mainfont -linespace]
6999 set charspc [font measure mainfont "m"]
7000 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7001 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7002 set lthickness [expr {int($linespc / 9) + 1}]
7003 set xspc1(0) $linespc
7011 set ymax [lindex [$canv cget -scrollregion] 3]
7012 if {$ymax eq {} || $ymax == 0} return
7013 set span [$canv yview]
7016 allcanvs yview moveto [lindex $span 0]
7018 if {$selectedline ne {}} {
7019 selectline $selectedline 0
7020 allcanvs yview moveto [lindex $span 0]
7024 proc parsefont {f n} {
7027 set fontattr($f,family) [lindex $n 0]
7029 if {$s eq {} || $s == 0} {
7032 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7034 set fontattr($f,size) $s
7035 set fontattr($f,weight) normal
7036 set fontattr($f,slant) roman
7037 foreach style [lrange $n 2 end] {
7040 "bold" {set fontattr($f,weight) $style}
7042 "italic" {set fontattr($f,slant) $style}
7047 proc fontflags {f {isbold 0}} {
7050 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7051 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7052 -slant $fontattr($f,slant)]
7058 set n [list $fontattr($f,family) $fontattr($f,size)]
7059 if {$fontattr($f,weight) eq "bold"} {
7062 if {$fontattr($f,slant) eq "italic"} {
7068 proc incrfont {inc} {
7069 global mainfont textfont ctext canv cflist showrefstop
7070 global stopped entries fontattr
7073 set s $fontattr(mainfont,size)
7078 set fontattr(mainfont,size) $s
7079 font config mainfont -size $s
7080 font config mainfontbold -size $s
7081 set mainfont [fontname mainfont]
7082 set s $fontattr(textfont,size)
7087 set fontattr(textfont,size) $s
7088 font config textfont -size $s
7089 font config textfontbold -size $s
7090 set textfont [fontname textfont]
7097 global sha1entry sha1string
7098 if {[string length $sha1string] == 40} {
7099 $sha1entry delete 0 end
7103 proc sha1change {n1 n2 op} {
7104 global sha1string currentid sha1but
7105 if {$sha1string == {}
7106 || ([info exists currentid] && $sha1string == $currentid)} {
7111 if {[$sha1but cget -state] == $state} return
7112 if {$state == "normal"} {
7113 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7115 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7119 proc gotocommit {} {
7120 global sha1string tagids headids curview varcid
7122 if {$sha1string == {}
7123 || ([info exists currentid] && $sha1string == $currentid)} return
7124 if {[info exists tagids($sha1string)]} {
7125 set id $tagids($sha1string)
7126 } elseif {[info exists headids($sha1string)]} {
7127 set id $headids($sha1string)
7129 set id [string tolower $sha1string]
7130 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7131 set matches [array names varcid "$curview,$id*"]
7132 if {$matches ne {}} {
7133 if {[llength $matches] > 1} {
7134 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7137 set id [lindex [split [lindex $matches 0] ","] 1]
7141 if {[commitinview $id $curview]} {
7142 selectline [rowofcommit $id] 1
7145 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7146 set msg [mc "SHA1 id %s is not known" $sha1string]
7148 set msg [mc "Tag/Head %s is not known" $sha1string]
7153 proc lineenter {x y id} {
7154 global hoverx hovery hoverid hovertimer
7155 global commitinfo canv
7157 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7161 if {[info exists hovertimer]} {
7162 after cancel $hovertimer
7164 set hovertimer [after 500 linehover]
7168 proc linemotion {x y id} {
7169 global hoverx hovery hoverid hovertimer
7171 if {[info exists hoverid] && $id == $hoverid} {
7174 if {[info exists hovertimer]} {
7175 after cancel $hovertimer
7177 set hovertimer [after 500 linehover]
7181 proc lineleave {id} {
7182 global hoverid hovertimer canv
7184 if {[info exists hoverid] && $id == $hoverid} {
7186 if {[info exists hovertimer]} {
7187 after cancel $hovertimer
7195 global hoverx hovery hoverid hovertimer
7196 global canv linespc lthickness
7199 set text [lindex $commitinfo($hoverid) 0]
7200 set ymax [lindex [$canv cget -scrollregion] 3]
7201 if {$ymax == {}} return
7202 set yfrac [lindex [$canv yview] 0]
7203 set x [expr {$hoverx + 2 * $linespc}]
7204 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7205 set x0 [expr {$x - 2 * $lthickness}]
7206 set y0 [expr {$y - 2 * $lthickness}]
7207 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7208 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7209 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7210 -fill \#ffff80 -outline black -width 1 -tags hover]
7212 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7217 proc clickisonarrow {id y} {
7220 set ranges [rowranges $id]
7221 set thresh [expr {2 * $lthickness + 6}]
7222 set n [expr {[llength $ranges] - 1}]
7223 for {set i 1} {$i < $n} {incr i} {
7224 set row [lindex $ranges $i]
7225 if {abs([yc $row] - $y) < $thresh} {
7232 proc arrowjump {id n y} {
7235 # 1 <-> 2, 3 <-> 4, etc...
7236 set n [expr {(($n - 1) ^ 1) + 1}]
7237 set row [lindex [rowranges $id] $n]
7239 set ymax [lindex [$canv cget -scrollregion] 3]
7240 if {$ymax eq {} || $ymax <= 0} return
7241 set view [$canv yview]
7242 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7243 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7247 allcanvs yview moveto $yfrac
7250 proc lineclick {x y id isnew} {
7251 global ctext commitinfo children canv thickerline curview
7253 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7258 # draw this line thicker than normal
7262 set ymax [lindex [$canv cget -scrollregion] 3]
7263 if {$ymax eq {}} return
7264 set yfrac [lindex [$canv yview] 0]
7265 set y [expr {$y + $yfrac * $ymax}]
7267 set dirn [clickisonarrow $id $y]
7269 arrowjump $id $dirn $y
7274 addtohistory [list lineclick $x $y $id 0]
7276 # fill the details pane with info about this line
7277 $ctext conf -state normal
7280 $ctext insert end "[mc "Parent"]:\t"
7281 $ctext insert end $id link0
7283 set info $commitinfo($id)
7284 $ctext insert end "\n\t[lindex $info 0]\n"
7285 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7286 set date [formatdate [lindex $info 2]]
7287 $ctext insert end "\t[mc "Date"]:\t$date\n"
7288 set kids $children($curview,$id)
7290 $ctext insert end "\n[mc "Children"]:"
7292 foreach child $kids {
7294 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7295 set info $commitinfo($child)
7296 $ctext insert end "\n\t"
7297 $ctext insert end $child link$i
7298 setlink $child link$i
7299 $ctext insert end "\n\t[lindex $info 0]"
7300 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7301 set date [formatdate [lindex $info 2]]
7302 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7305 $ctext conf -state disabled
7309 proc normalline {} {
7311 if {[info exists thickerline]} {
7320 if {[commitinview $id $curview]} {
7321 selectline [rowofcommit $id] 1
7327 if {![info exists startmstime]} {
7328 set startmstime [clock clicks -milliseconds]
7330 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7333 proc rowmenu {x y id} {
7334 global rowctxmenu selectedline rowmenuid curview
7335 global nullid nullid2 fakerowmenu mainhead
7339 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7344 if {$id ne $nullid && $id ne $nullid2} {
7345 set menu $rowctxmenu
7346 if {$mainhead ne {}} {
7347 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7349 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7352 set menu $fakerowmenu
7354 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7355 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7356 $menu entryconfigure [mca "Make patch"] -state $state
7357 tk_popup $menu $x $y
7360 proc diffvssel {dirn} {
7361 global rowmenuid selectedline
7363 if {$selectedline eq {}} return
7365 set oldid [commitonrow $selectedline]
7366 set newid $rowmenuid
7368 set oldid $rowmenuid
7369 set newid [commitonrow $selectedline]
7371 addtohistory [list doseldiff $oldid $newid]
7372 doseldiff $oldid $newid
7375 proc doseldiff {oldid newid} {
7379 $ctext conf -state normal
7381 init_flist [mc "Top"]
7382 $ctext insert end "[mc "From"] "
7383 $ctext insert end $oldid link0
7384 setlink $oldid link0
7385 $ctext insert end "\n "
7386 $ctext insert end [lindex $commitinfo($oldid) 0]
7387 $ctext insert end "\n\n[mc "To"] "
7388 $ctext insert end $newid link1
7389 setlink $newid link1
7390 $ctext insert end "\n "
7391 $ctext insert end [lindex $commitinfo($newid) 0]
7392 $ctext insert end "\n"
7393 $ctext conf -state disabled
7394 $ctext tag remove found 1.0 end
7395 startdiff [list $oldid $newid]
7399 global rowmenuid currentid commitinfo patchtop patchnum
7401 if {![info exists currentid]} return
7402 set oldid $currentid
7403 set oldhead [lindex $commitinfo($oldid) 0]
7404 set newid $rowmenuid
7405 set newhead [lindex $commitinfo($newid) 0]
7408 catch {destroy $top}
7410 label $top.title -text [mc "Generate patch"]
7411 grid $top.title - -pady 10
7412 label $top.from -text [mc "From:"]
7413 entry $top.fromsha1 -width 40 -relief flat
7414 $top.fromsha1 insert 0 $oldid
7415 $top.fromsha1 conf -state readonly
7416 grid $top.from $top.fromsha1 -sticky w
7417 entry $top.fromhead -width 60 -relief flat
7418 $top.fromhead insert 0 $oldhead
7419 $top.fromhead conf -state readonly
7420 grid x $top.fromhead -sticky w
7421 label $top.to -text [mc "To:"]
7422 entry $top.tosha1 -width 40 -relief flat
7423 $top.tosha1 insert 0 $newid
7424 $top.tosha1 conf -state readonly
7425 grid $top.to $top.tosha1 -sticky w
7426 entry $top.tohead -width 60 -relief flat
7427 $top.tohead insert 0 $newhead
7428 $top.tohead conf -state readonly
7429 grid x $top.tohead -sticky w
7430 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7431 grid $top.rev x -pady 10
7432 label $top.flab -text [mc "Output file:"]
7433 entry $top.fname -width 60
7434 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7436 grid $top.flab $top.fname -sticky w
7438 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7439 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7440 grid $top.buts.gen $top.buts.can
7441 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7442 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7443 grid $top.buts - -pady 10 -sticky ew
7447 proc mkpatchrev {} {
7450 set oldid [$patchtop.fromsha1 get]
7451 set oldhead [$patchtop.fromhead get]
7452 set newid [$patchtop.tosha1 get]
7453 set newhead [$patchtop.tohead get]
7454 foreach e [list fromsha1 fromhead tosha1 tohead] \
7455 v [list $newid $newhead $oldid $oldhead] {
7456 $patchtop.$e conf -state normal
7457 $patchtop.$e delete 0 end
7458 $patchtop.$e insert 0 $v
7459 $patchtop.$e conf -state readonly
7464 global patchtop nullid nullid2
7466 set oldid [$patchtop.fromsha1 get]
7467 set newid [$patchtop.tosha1 get]
7468 set fname [$patchtop.fname get]
7469 set cmd [diffcmd [list $oldid $newid] -p]
7470 # trim off the initial "|"
7471 set cmd [lrange $cmd 1 end]
7472 lappend cmd >$fname &
7473 if {[catch {eval exec $cmd} err]} {
7474 error_popup "[mc "Error creating patch:"] $err"
7476 catch {destroy $patchtop}
7480 proc mkpatchcan {} {
7483 catch {destroy $patchtop}
7488 global rowmenuid mktagtop commitinfo
7492 catch {destroy $top}
7494 label $top.title -text [mc "Create tag"]
7495 grid $top.title - -pady 10
7496 label $top.id -text [mc "ID:"]
7497 entry $top.sha1 -width 40 -relief flat
7498 $top.sha1 insert 0 $rowmenuid
7499 $top.sha1 conf -state readonly
7500 grid $top.id $top.sha1 -sticky w
7501 entry $top.head -width 60 -relief flat
7502 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7503 $top.head conf -state readonly
7504 grid x $top.head -sticky w
7505 label $top.tlab -text [mc "Tag name:"]
7506 entry $top.tag -width 60
7507 grid $top.tlab $top.tag -sticky w
7509 button $top.buts.gen -text [mc "Create"] -command mktaggo
7510 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7511 grid $top.buts.gen $top.buts.can
7512 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7513 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7514 grid $top.buts - -pady 10 -sticky ew
7519 global mktagtop env tagids idtags
7521 set id [$mktagtop.sha1 get]
7522 set tag [$mktagtop.tag get]
7524 error_popup [mc "No tag name specified"]
7527 if {[info exists tagids($tag)]} {
7528 error_popup [mc "Tag \"%s\" already exists" $tag]
7532 exec git tag $tag $id
7534 error_popup "[mc "Error creating tag:"] $err"
7538 set tagids($tag) $id
7539 lappend idtags($id) $tag
7546 proc redrawtags {id} {
7547 global canv linehtag idpos currentid curview cmitlisted
7548 global canvxmax iddrawn circleitem mainheadid circlecolors
7550 if {![commitinview $id $curview]} return
7551 if {![info exists iddrawn($id)]} return
7552 set row [rowofcommit $id]
7553 if {$id eq $mainheadid} {
7556 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7558 $canv itemconf $circleitem($row) -fill $ofill
7559 $canv delete tag.$id
7560 set xt [eval drawtags $id $idpos($id)]
7561 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7562 set text [$canv itemcget $linehtag($row) -text]
7563 set font [$canv itemcget $linehtag($row) -font]
7564 set xr [expr {$xt + [font measure $font $text]}]
7565 if {$xr > $canvxmax} {
7569 if {[info exists currentid] && $currentid == $id} {
7577 catch {destroy $mktagtop}
7586 proc writecommit {} {
7587 global rowmenuid wrcomtop commitinfo wrcomcmd
7589 set top .writecommit
7591 catch {destroy $top}
7593 label $top.title -text [mc "Write commit to file"]
7594 grid $top.title - -pady 10
7595 label $top.id -text [mc "ID:"]
7596 entry $top.sha1 -width 40 -relief flat
7597 $top.sha1 insert 0 $rowmenuid
7598 $top.sha1 conf -state readonly
7599 grid $top.id $top.sha1 -sticky w
7600 entry $top.head -width 60 -relief flat
7601 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7602 $top.head conf -state readonly
7603 grid x $top.head -sticky w
7604 label $top.clab -text [mc "Command:"]
7605 entry $top.cmd -width 60 -textvariable wrcomcmd
7606 grid $top.clab $top.cmd -sticky w -pady 10
7607 label $top.flab -text [mc "Output file:"]
7608 entry $top.fname -width 60
7609 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7610 grid $top.flab $top.fname -sticky w
7612 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7613 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7614 grid $top.buts.gen $top.buts.can
7615 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7616 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7617 grid $top.buts - -pady 10 -sticky ew
7624 set id [$wrcomtop.sha1 get]
7625 set cmd "echo $id | [$wrcomtop.cmd get]"
7626 set fname [$wrcomtop.fname get]
7627 if {[catch {exec sh -c $cmd >$fname &} err]} {
7628 error_popup "[mc "Error writing commit:"] $err"
7630 catch {destroy $wrcomtop}
7637 catch {destroy $wrcomtop}
7642 global rowmenuid mkbrtop
7645 catch {destroy $top}
7647 label $top.title -text [mc "Create new branch"]
7648 grid $top.title - -pady 10
7649 label $top.id -text [mc "ID:"]
7650 entry $top.sha1 -width 40 -relief flat
7651 $top.sha1 insert 0 $rowmenuid
7652 $top.sha1 conf -state readonly
7653 grid $top.id $top.sha1 -sticky w
7654 label $top.nlab -text [mc "Name:"]
7655 entry $top.name -width 40
7656 bind $top.name <Key-Return> "[list mkbrgo $top]"
7657 grid $top.nlab $top.name -sticky w
7659 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7660 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7661 grid $top.buts.go $top.buts.can
7662 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7663 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7664 grid $top.buts - -pady 10 -sticky ew
7669 global headids idheads
7671 set name [$top.name get]
7672 set id [$top.sha1 get]
7674 error_popup [mc "Please specify a name for the new branch"]
7677 catch {destroy $top}
7681 exec git branch $name $id
7686 set headids($name) $id
7687 lappend idheads($id) $name
7696 proc cherrypick {} {
7697 global rowmenuid curview
7698 global mainhead mainheadid
7700 set oldhead [exec git rev-parse HEAD]
7701 set dheads [descheads $rowmenuid]
7702 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7703 set ok [confirm_popup [mc "Commit %s is already\
7704 included in branch %s -- really re-apply it?" \
7705 [string range $rowmenuid 0 7] $mainhead]]
7708 nowbusy cherrypick [mc "Cherry-picking"]
7710 # Unfortunately git-cherry-pick writes stuff to stderr even when
7711 # no error occurs, and exec takes that as an indication of error...
7712 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7717 set newhead [exec git rev-parse HEAD]
7718 if {$newhead eq $oldhead} {
7720 error_popup [mc "No changes committed"]
7723 addnewchild $newhead $oldhead
7724 if {[commitinview $oldhead $curview]} {
7725 insertrow $newhead $oldhead $curview
7726 if {$mainhead ne {}} {
7727 movehead $newhead $mainhead
7728 movedhead $newhead $mainhead
7730 set mainheadid $newhead
7739 global mainhead rowmenuid confirm_ok resettype
7742 set w ".confirmreset"
7745 wm title $w [mc "Confirm reset"]
7746 message $w.m -text \
7747 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7748 -justify center -aspect 1000
7749 pack $w.m -side top -fill x -padx 20 -pady 20
7750 frame $w.f -relief sunken -border 2
7751 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7752 grid $w.f.rt -sticky w
7754 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7755 -text [mc "Soft: Leave working tree and index untouched"]
7756 grid $w.f.soft -sticky w
7757 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7758 -text [mc "Mixed: Leave working tree untouched, reset index"]
7759 grid $w.f.mixed -sticky w
7760 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7761 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7762 grid $w.f.hard -sticky w
7763 pack $w.f -side top -fill x
7764 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7765 pack $w.ok -side left -fill x -padx 20 -pady 20
7766 button $w.cancel -text [mc Cancel] -command "destroy $w"
7767 pack $w.cancel -side right -fill x -padx 20 -pady 20
7768 bind $w <Visibility> "grab $w; focus $w"
7770 if {!$confirm_ok} return
7771 if {[catch {set fd [open \
7772 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7776 filerun $fd [list readresetstat $fd]
7777 nowbusy reset [mc "Resetting"]
7782 proc readresetstat {fd} {
7783 global mainhead mainheadid showlocalchanges rprogcoord
7785 if {[gets $fd line] >= 0} {
7786 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7787 set rprogcoord [expr {1.0 * $m / $n}]
7795 if {[catch {close $fd} err]} {
7798 set oldhead $mainheadid
7799 set newhead [exec git rev-parse HEAD]
7800 if {$newhead ne $oldhead} {
7801 movehead $newhead $mainhead
7802 movedhead $newhead $mainhead
7803 set mainheadid $newhead
7807 if {$showlocalchanges} {
7813 # context menu for a head
7814 proc headmenu {x y id head} {
7815 global headmenuid headmenuhead headctxmenu mainhead
7819 set headmenuhead $head
7821 if {$head eq $mainhead} {
7824 $headctxmenu entryconfigure 0 -state $state
7825 $headctxmenu entryconfigure 1 -state $state
7826 tk_popup $headctxmenu $x $y
7830 global headmenuid headmenuhead headids
7831 global showlocalchanges mainheadid
7833 # check the tree is clean first??
7834 nowbusy checkout [mc "Checking out"]
7838 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7842 if {$showlocalchanges} {
7846 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7850 proc readcheckoutstat {fd newhead newheadid} {
7851 global mainhead mainheadid headids showlocalchanges progresscoords
7853 if {[gets $fd line] >= 0} {
7854 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7855 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7860 set progresscoords {0 0}
7863 if {[catch {close $fd} err]} {
7866 set oldmainid $mainheadid
7867 set mainhead $newhead
7868 set mainheadid $newheadid
7869 redrawtags $oldmainid
7870 redrawtags $newheadid
7872 if {$showlocalchanges} {
7878 global headmenuid headmenuhead mainhead
7881 set head $headmenuhead
7883 # this check shouldn't be needed any more...
7884 if {$head eq $mainhead} {
7885 error_popup [mc "Cannot delete the currently checked-out branch"]
7888 set dheads [descheads $id]
7889 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7890 # the stuff on this branch isn't on any other branch
7891 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7892 branch.\nReally delete branch %s?" $head $head]]} return
7896 if {[catch {exec git branch -D $head} err]} {
7901 removehead $id $head
7902 removedhead $id $head
7909 # Display a list of tags and heads
7911 global showrefstop bgcolor fgcolor selectbgcolor
7912 global bglist fglist reflistfilter reflist maincursor
7915 set showrefstop $top
7916 if {[winfo exists $top]} {
7922 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7923 text $top.list -background $bgcolor -foreground $fgcolor \
7924 -selectbackground $selectbgcolor -font mainfont \
7925 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7926 -width 30 -height 20 -cursor $maincursor \
7927 -spacing1 1 -spacing3 1 -state disabled
7928 $top.list tag configure highlight -background $selectbgcolor
7929 lappend bglist $top.list
7930 lappend fglist $top.list
7931 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7932 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7933 grid $top.list $top.ysb -sticky nsew
7934 grid $top.xsb x -sticky ew
7936 label $top.f.l -text "[mc "Filter"]: "
7937 entry $top.f.e -width 20 -textvariable reflistfilter
7938 set reflistfilter "*"
7939 trace add variable reflistfilter write reflistfilter_change
7940 pack $top.f.e -side right -fill x -expand 1
7941 pack $top.f.l -side left
7942 grid $top.f - -sticky ew -pady 2
7943 button $top.close -command [list destroy $top] -text [mc "Close"]
7945 grid columnconfigure $top 0 -weight 1
7946 grid rowconfigure $top 0 -weight 1
7947 bind $top.list <1> {break}
7948 bind $top.list <B1-Motion> {break}
7949 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7954 proc sel_reflist {w x y} {
7955 global showrefstop reflist headids tagids otherrefids
7957 if {![winfo exists $showrefstop]} return
7958 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7959 set ref [lindex $reflist [expr {$l-1}]]
7960 set n [lindex $ref 0]
7961 switch -- [lindex $ref 1] {
7962 "H" {selbyid $headids($n)}
7963 "T" {selbyid $tagids($n)}
7964 "o" {selbyid $otherrefids($n)}
7966 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7969 proc unsel_reflist {} {
7972 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7973 $showrefstop.list tag remove highlight 0.0 end
7976 proc reflistfilter_change {n1 n2 op} {
7977 global reflistfilter
7979 after cancel refill_reflist
7980 after 200 refill_reflist
7983 proc refill_reflist {} {
7984 global reflist reflistfilter showrefstop headids tagids otherrefids
7985 global curview commitinterest
7987 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7989 foreach n [array names headids] {
7990 if {[string match $reflistfilter $n]} {
7991 if {[commitinview $headids($n) $curview]} {
7992 lappend refs [list $n H]
7994 set commitinterest($headids($n)) {run refill_reflist}
7998 foreach n [array names tagids] {
7999 if {[string match $reflistfilter $n]} {
8000 if {[commitinview $tagids($n) $curview]} {
8001 lappend refs [list $n T]
8003 set commitinterest($tagids($n)) {run refill_reflist}
8007 foreach n [array names otherrefids] {
8008 if {[string match $reflistfilter $n]} {
8009 if {[commitinview $otherrefids($n) $curview]} {
8010 lappend refs [list $n o]
8012 set commitinterest($otherrefids($n)) {run refill_reflist}
8016 set refs [lsort -index 0 $refs]
8017 if {$refs eq $reflist} return
8019 # Update the contents of $showrefstop.list according to the
8020 # differences between $reflist (old) and $refs (new)
8021 $showrefstop.list conf -state normal
8022 $showrefstop.list insert end "\n"
8025 while {$i < [llength $reflist] || $j < [llength $refs]} {
8026 if {$i < [llength $reflist]} {
8027 if {$j < [llength $refs]} {
8028 set cmp [string compare [lindex $reflist $i 0] \
8029 [lindex $refs $j 0]]
8031 set cmp [string compare [lindex $reflist $i 1] \
8032 [lindex $refs $j 1]]
8042 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8050 set l [expr {$j + 1}]
8051 $showrefstop.list image create $l.0 -align baseline \
8052 -image reficon-[lindex $refs $j 1] -padx 2
8053 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8059 # delete last newline
8060 $showrefstop.list delete end-2c end-1c
8061 $showrefstop.list conf -state disabled
8064 # Stuff for finding nearby tags
8065 proc getallcommits {} {
8066 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8067 global idheads idtags idotherrefs allparents tagobjid
8069 if {![info exists allcommits]} {
8075 set allccache [file join [gitdir] "gitk.cache"]
8077 set f [open $allccache r]
8086 set cmd [list | git rev-list --parents]
8087 set allcupdate [expr {$seeds ne {}}]
8091 set refs [concat [array names idheads] [array names idtags] \
8092 [array names idotherrefs]]
8095 foreach name [array names tagobjid] {
8096 lappend tagobjs $tagobjid($name)
8098 foreach id [lsort -unique $refs] {
8099 if {![info exists allparents($id)] &&
8100 [lsearch -exact $tagobjs $id] < 0} {
8111 set fd [open [concat $cmd $ids] r]
8112 fconfigure $fd -blocking 0
8115 filerun $fd [list getallclines $fd]
8121 # Since most commits have 1 parent and 1 child, we group strings of
8122 # such commits into "arcs" joining branch/merge points (BMPs), which
8123 # are commits that either don't have 1 parent or don't have 1 child.
8125 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8126 # arcout(id) - outgoing arcs for BMP
8127 # arcids(a) - list of IDs on arc including end but not start
8128 # arcstart(a) - BMP ID at start of arc
8129 # arcend(a) - BMP ID at end of arc
8130 # growing(a) - arc a is still growing
8131 # arctags(a) - IDs out of arcids (excluding end) that have tags
8132 # archeads(a) - IDs out of arcids (excluding end) that have heads
8133 # The start of an arc is at the descendent end, so "incoming" means
8134 # coming from descendents, and "outgoing" means going towards ancestors.
8136 proc getallclines {fd} {
8137 global allparents allchildren idtags idheads nextarc
8138 global arcnos arcids arctags arcout arcend arcstart archeads growing
8139 global seeds allcommits cachedarcs allcupdate
8142 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8143 set id [lindex $line 0]
8144 if {[info exists allparents($id)]} {
8149 set olds [lrange $line 1 end]
8150 set allparents($id) $olds
8151 if {![info exists allchildren($id)]} {
8152 set allchildren($id) {}
8157 if {[llength $olds] == 1 && [llength $a] == 1} {
8158 lappend arcids($a) $id
8159 if {[info exists idtags($id)]} {
8160 lappend arctags($a) $id
8162 if {[info exists idheads($id)]} {
8163 lappend archeads($a) $id
8165 if {[info exists allparents($olds)]} {
8166 # seen parent already
8167 if {![info exists arcout($olds)]} {
8170 lappend arcids($a) $olds
8171 set arcend($a) $olds
8174 lappend allchildren($olds) $id
8175 lappend arcnos($olds) $a
8179 foreach a $arcnos($id) {
8180 lappend arcids($a) $id
8187 lappend allchildren($p) $id
8188 set a [incr nextarc]
8189 set arcstart($a) $id
8196 if {[info exists allparents($p)]} {
8197 # seen it already, may need to make a new branch
8198 if {![info exists arcout($p)]} {
8201 lappend arcids($a) $p
8205 lappend arcnos($p) $a
8210 global cached_dheads cached_dtags cached_atags
8211 catch {unset cached_dheads}
8212 catch {unset cached_dtags}
8213 catch {unset cached_atags}
8216 return [expr {$nid >= 1000? 2: 1}]
8220 fconfigure $fd -blocking 1
8223 # got an error reading the list of commits
8224 # if we were updating, try rereading the whole thing again
8230 error_popup "[mc "Error reading commit topology information;\
8231 branch and preceding/following tag information\
8232 will be incomplete."]\n($err)"
8235 if {[incr allcommits -1] == 0} {
8245 proc recalcarc {a} {
8246 global arctags archeads arcids idtags idheads
8250 foreach id [lrange $arcids($a) 0 end-1] {
8251 if {[info exists idtags($id)]} {
8254 if {[info exists idheads($id)]} {
8259 set archeads($a) $ah
8263 global arcnos arcids nextarc arctags archeads idtags idheads
8264 global arcstart arcend arcout allparents growing
8267 if {[llength $a] != 1} {
8268 puts "oops splitarc called but [llength $a] arcs already"
8272 set i [lsearch -exact $arcids($a) $p]
8274 puts "oops splitarc $p not in arc $a"
8277 set na [incr nextarc]
8278 if {[info exists arcend($a)]} {
8279 set arcend($na) $arcend($a)
8281 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8282 set j [lsearch -exact $arcnos($l) $a]
8283 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8285 set tail [lrange $arcids($a) [expr {$i+1}] end]
8286 set arcids($a) [lrange $arcids($a) 0 $i]
8288 set arcstart($na) $p
8290 set arcids($na) $tail
8291 if {[info exists growing($a)]} {
8297 if {[llength $arcnos($id)] == 1} {
8300 set j [lsearch -exact $arcnos($id) $a]
8301 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8305 # reconstruct tags and heads lists
8306 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8311 set archeads($na) {}
8315 # Update things for a new commit added that is a child of one
8316 # existing commit. Used when cherry-picking.
8317 proc addnewchild {id p} {
8318 global allparents allchildren idtags nextarc
8319 global arcnos arcids arctags arcout arcend arcstart archeads growing
8320 global seeds allcommits
8322 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8323 set allparents($id) [list $p]
8324 set allchildren($id) {}
8327 lappend allchildren($p) $id
8328 set a [incr nextarc]
8329 set arcstart($a) $id
8332 set arcids($a) [list $p]
8334 if {![info exists arcout($p)]} {
8337 lappend arcnos($p) $a
8338 set arcout($id) [list $a]
8341 # This implements a cache for the topology information.
8342 # The cache saves, for each arc, the start and end of the arc,
8343 # the ids on the arc, and the outgoing arcs from the end.
8344 proc readcache {f} {
8345 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8346 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8351 if {$lim - $a > 500} {
8352 set lim [expr {$a + 500}]
8356 # finish reading the cache and setting up arctags, etc.
8358 if {$line ne "1"} {error "bad final version"}
8360 foreach id [array names idtags] {
8361 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8362 [llength $allparents($id)] == 1} {
8363 set a [lindex $arcnos($id) 0]
8364 if {$arctags($a) eq {}} {
8369 foreach id [array names idheads] {
8370 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8371 [llength $allparents($id)] == 1} {
8372 set a [lindex $arcnos($id) 0]
8373 if {$archeads($a) eq {}} {
8378 foreach id [lsort -unique $possible_seeds] {
8379 if {$arcnos($id) eq {}} {
8385 while {[incr a] <= $lim} {
8387 if {[llength $line] != 3} {error "bad line"}
8388 set s [lindex $line 0]
8390 lappend arcout($s) $a
8391 if {![info exists arcnos($s)]} {
8392 lappend possible_seeds $s
8395 set e [lindex $line 1]
8400 if {![info exists arcout($e)]} {
8404 set arcids($a) [lindex $line 2]
8405 foreach id $arcids($a) {
8406 lappend allparents($s) $id
8408 lappend arcnos($id) $a
8410 if {![info exists allparents($s)]} {
8411 set allparents($s) {}
8416 set nextarc [expr {$a - 1}]
8429 global nextarc cachedarcs possible_seeds
8433 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8434 # make sure it's an integer
8435 set cachedarcs [expr {int([lindex $line 1])}]
8436 if {$cachedarcs < 0} {error "bad number of arcs"}
8438 set possible_seeds {}
8446 proc dropcache {err} {
8447 global allcwait nextarc cachedarcs seeds
8449 #puts "dropping cache ($err)"
8450 foreach v {arcnos arcout arcids arcstart arcend growing \
8451 arctags archeads allparents allchildren} {
8462 proc writecache {f} {
8463 global cachearc cachedarcs allccache
8464 global arcstart arcend arcnos arcids arcout
8468 if {$lim - $a > 1000} {
8469 set lim [expr {$a + 1000}]
8472 while {[incr a] <= $lim} {
8473 if {[info exists arcend($a)]} {
8474 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8476 puts $f [list $arcstart($a) {} $arcids($a)]
8481 catch {file delete $allccache}
8482 #puts "writing cache failed ($err)"
8485 set cachearc [expr {$a - 1}]
8486 if {$a > $cachedarcs} {
8495 global nextarc cachedarcs cachearc allccache
8497 if {$nextarc == $cachedarcs} return
8499 set cachedarcs $nextarc
8501 set f [open $allccache w]
8502 puts $f [list 1 $cachedarcs]
8507 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8508 # or 0 if neither is true.
8509 proc anc_or_desc {a b} {
8510 global arcout arcstart arcend arcnos cached_isanc
8512 if {$arcnos($a) eq $arcnos($b)} {
8513 # Both are on the same arc(s); either both are the same BMP,
8514 # or if one is not a BMP, the other is also not a BMP or is
8515 # the BMP at end of the arc (and it only has 1 incoming arc).
8516 # Or both can be BMPs with no incoming arcs.
8517 if {$a eq $b || $arcnos($a) eq {}} {
8520 # assert {[llength $arcnos($a)] == 1}
8521 set arc [lindex $arcnos($a) 0]
8522 set i [lsearch -exact $arcids($arc) $a]
8523 set j [lsearch -exact $arcids($arc) $b]
8524 if {$i < 0 || $i > $j} {
8531 if {![info exists arcout($a)]} {
8532 set arc [lindex $arcnos($a) 0]
8533 if {[info exists arcend($arc)]} {
8534 set aend $arcend($arc)
8538 set a $arcstart($arc)
8542 if {![info exists arcout($b)]} {
8543 set arc [lindex $arcnos($b) 0]
8544 if {[info exists arcend($arc)]} {
8545 set bend $arcend($arc)
8549 set b $arcstart($arc)
8559 if {[info exists cached_isanc($a,$bend)]} {
8560 if {$cached_isanc($a,$bend)} {
8564 if {[info exists cached_isanc($b,$aend)]} {
8565 if {$cached_isanc($b,$aend)} {
8568 if {[info exists cached_isanc($a,$bend)]} {
8573 set todo [list $a $b]
8576 for {set i 0} {$i < [llength $todo]} {incr i} {
8577 set x [lindex $todo $i]
8578 if {$anc($x) eq {}} {
8581 foreach arc $arcnos($x) {
8582 set xd $arcstart($arc)
8584 set cached_isanc($a,$bend) 1
8585 set cached_isanc($b,$aend) 0
8587 } elseif {$xd eq $aend} {
8588 set cached_isanc($b,$aend) 1
8589 set cached_isanc($a,$bend) 0
8592 if {![info exists anc($xd)]} {
8593 set anc($xd) $anc($x)
8595 } elseif {$anc($xd) ne $anc($x)} {
8600 set cached_isanc($a,$bend) 0
8601 set cached_isanc($b,$aend) 0
8605 # This identifies whether $desc has an ancestor that is
8606 # a growing tip of the graph and which is not an ancestor of $anc
8607 # and returns 0 if so and 1 if not.
8608 # If we subsequently discover a tag on such a growing tip, and that
8609 # turns out to be a descendent of $anc (which it could, since we
8610 # don't necessarily see children before parents), then $desc
8611 # isn't a good choice to display as a descendent tag of
8612 # $anc (since it is the descendent of another tag which is
8613 # a descendent of $anc). Similarly, $anc isn't a good choice to
8614 # display as a ancestor tag of $desc.
8616 proc is_certain {desc anc} {
8617 global arcnos arcout arcstart arcend growing problems
8620 if {[llength $arcnos($anc)] == 1} {
8621 # tags on the same arc are certain
8622 if {$arcnos($desc) eq $arcnos($anc)} {
8625 if {![info exists arcout($anc)]} {
8626 # if $anc is partway along an arc, use the start of the arc instead
8627 set a [lindex $arcnos($anc) 0]
8628 set anc $arcstart($a)
8631 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8634 set a [lindex $arcnos($desc) 0]
8640 set anclist [list $x]
8644 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8645 set x [lindex $anclist $i]
8650 foreach a $arcout($x) {
8651 if {[info exists growing($a)]} {
8652 if {![info exists growanc($x)] && $dl($x)} {
8658 if {[info exists dl($y)]} {
8662 if {![info exists done($y)]} {
8665 if {[info exists growanc($x)]} {
8669 for {set k 0} {$k < [llength $xl]} {incr k} {
8670 set z [lindex $xl $k]
8671 foreach c $arcout($z) {
8672 if {[info exists arcend($c)]} {
8674 if {[info exists dl($v)] && $dl($v)} {
8676 if {![info exists done($v)]} {
8679 if {[info exists growanc($v)]} {
8689 } elseif {$y eq $anc || !$dl($x)} {
8700 foreach x [array names growanc] {
8709 proc validate_arctags {a} {
8710 global arctags idtags
8714 foreach id $arctags($a) {
8716 if {![info exists idtags($id)]} {
8717 set na [lreplace $na $i $i]
8724 proc validate_archeads {a} {
8725 global archeads idheads
8728 set na $archeads($a)
8729 foreach id $archeads($a) {
8731 if {![info exists idheads($id)]} {
8732 set na [lreplace $na $i $i]
8736 set archeads($a) $na
8739 # Return the list of IDs that have tags that are descendents of id,
8740 # ignoring IDs that are descendents of IDs already reported.
8741 proc desctags {id} {
8742 global arcnos arcstart arcids arctags idtags allparents
8743 global growing cached_dtags
8745 if {![info exists allparents($id)]} {
8748 set t1 [clock clicks -milliseconds]
8750 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8751 # part-way along an arc; check that arc first
8752 set a [lindex $arcnos($id) 0]
8753 if {$arctags($a) ne {}} {
8755 set i [lsearch -exact $arcids($a) $id]
8757 foreach t $arctags($a) {
8758 set j [lsearch -exact $arcids($a) $t]
8766 set id $arcstart($a)
8767 if {[info exists idtags($id)]} {
8771 if {[info exists cached_dtags($id)]} {
8772 return $cached_dtags($id)
8779 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8780 set id [lindex $todo $i]
8782 set ta [info exists hastaggedancestor($id)]
8786 # ignore tags on starting node
8787 if {!$ta && $i > 0} {
8788 if {[info exists idtags($id)]} {
8791 } elseif {[info exists cached_dtags($id)]} {
8792 set tagloc($id) $cached_dtags($id)
8796 foreach a $arcnos($id) {
8798 if {!$ta && $arctags($a) ne {}} {
8800 if {$arctags($a) ne {}} {
8801 lappend tagloc($id) [lindex $arctags($a) end]
8804 if {$ta || $arctags($a) ne {}} {
8805 set tomark [list $d]
8806 for {set j 0} {$j < [llength $tomark]} {incr j} {
8807 set dd [lindex $tomark $j]
8808 if {![info exists hastaggedancestor($dd)]} {
8809 if {[info exists done($dd)]} {
8810 foreach b $arcnos($dd) {
8811 lappend tomark $arcstart($b)
8813 if {[info exists tagloc($dd)]} {
8816 } elseif {[info exists queued($dd)]} {
8819 set hastaggedancestor($dd) 1
8823 if {![info exists queued($d)]} {
8826 if {![info exists hastaggedancestor($d)]} {
8833 foreach id [array names tagloc] {
8834 if {![info exists hastaggedancestor($id)]} {
8835 foreach t $tagloc($id) {
8836 if {[lsearch -exact $tags $t] < 0} {
8842 set t2 [clock clicks -milliseconds]
8845 # remove tags that are descendents of other tags
8846 for {set i 0} {$i < [llength $tags]} {incr i} {
8847 set a [lindex $tags $i]
8848 for {set j 0} {$j < $i} {incr j} {
8849 set b [lindex $tags $j]
8850 set r [anc_or_desc $a $b]
8852 set tags [lreplace $tags $j $j]
8855 } elseif {$r == -1} {
8856 set tags [lreplace $tags $i $i]
8863 if {[array names growing] ne {}} {
8864 # graph isn't finished, need to check if any tag could get
8865 # eclipsed by another tag coming later. Simply ignore any
8866 # tags that could later get eclipsed.
8869 if {[is_certain $t $origid]} {
8873 if {$tags eq $ctags} {
8874 set cached_dtags($origid) $tags
8879 set cached_dtags($origid) $tags
8881 set t3 [clock clicks -milliseconds]
8882 if {0 && $t3 - $t1 >= 100} {
8883 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8884 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8890 global arcnos arcids arcout arcend arctags idtags allparents
8891 global growing cached_atags
8893 if {![info exists allparents($id)]} {
8896 set t1 [clock clicks -milliseconds]
8898 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8899 # part-way along an arc; check that arc first
8900 set a [lindex $arcnos($id) 0]
8901 if {$arctags($a) ne {}} {
8903 set i [lsearch -exact $arcids($a) $id]
8904 foreach t $arctags($a) {
8905 set j [lsearch -exact $arcids($a) $t]
8911 if {![info exists arcend($a)]} {
8915 if {[info exists idtags($id)]} {
8919 if {[info exists cached_atags($id)]} {
8920 return $cached_atags($id)
8928 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8929 set id [lindex $todo $i]
8931 set td [info exists hastaggeddescendent($id)]
8935 # ignore tags on starting node
8936 if {!$td && $i > 0} {
8937 if {[info exists idtags($id)]} {
8940 } elseif {[info exists cached_atags($id)]} {
8941 set tagloc($id) $cached_atags($id)
8945 foreach a $arcout($id) {
8946 if {!$td && $arctags($a) ne {}} {
8948 if {$arctags($a) ne {}} {
8949 lappend tagloc($id) [lindex $arctags($a) 0]
8952 if {![info exists arcend($a)]} continue
8954 if {$td || $arctags($a) ne {}} {
8955 set tomark [list $d]
8956 for {set j 0} {$j < [llength $tomark]} {incr j} {
8957 set dd [lindex $tomark $j]
8958 if {![info exists hastaggeddescendent($dd)]} {
8959 if {[info exists done($dd)]} {
8960 foreach b $arcout($dd) {
8961 if {[info exists arcend($b)]} {
8962 lappend tomark $arcend($b)
8965 if {[info exists tagloc($dd)]} {
8968 } elseif {[info exists queued($dd)]} {
8971 set hastaggeddescendent($dd) 1
8975 if {![info exists queued($d)]} {
8978 if {![info exists hastaggeddescendent($d)]} {
8984 set t2 [clock clicks -milliseconds]
8987 foreach id [array names tagloc] {
8988 if {![info exists hastaggeddescendent($id)]} {
8989 foreach t $tagloc($id) {
8990 if {[lsearch -exact $tags $t] < 0} {
8997 # remove tags that are ancestors of other tags
8998 for {set i 0} {$i < [llength $tags]} {incr i} {
8999 set a [lindex $tags $i]
9000 for {set j 0} {$j < $i} {incr j} {
9001 set b [lindex $tags $j]
9002 set r [anc_or_desc $a $b]
9004 set tags [lreplace $tags $j $j]
9007 } elseif {$r == 1} {
9008 set tags [lreplace $tags $i $i]
9015 if {[array names growing] ne {}} {
9016 # graph isn't finished, need to check if any tag could get
9017 # eclipsed by another tag coming later. Simply ignore any
9018 # tags that could later get eclipsed.
9021 if {[is_certain $origid $t]} {
9025 if {$tags eq $ctags} {
9026 set cached_atags($origid) $tags
9031 set cached_atags($origid) $tags
9033 set t3 [clock clicks -milliseconds]
9034 if {0 && $t3 - $t1 >= 100} {
9035 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9036 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9041 # Return the list of IDs that have heads that are descendents of id,
9042 # including id itself if it has a head.
9043 proc descheads {id} {
9044 global arcnos arcstart arcids archeads idheads cached_dheads
9047 if {![info exists allparents($id)]} {
9051 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9052 # part-way along an arc; check it first
9053 set a [lindex $arcnos($id) 0]
9054 if {$archeads($a) ne {}} {
9055 validate_archeads $a
9056 set i [lsearch -exact $arcids($a) $id]
9057 foreach t $archeads($a) {
9058 set j [lsearch -exact $arcids($a) $t]
9063 set id $arcstart($a)
9069 for {set i 0} {$i < [llength $todo]} {incr i} {
9070 set id [lindex $todo $i]
9071 if {[info exists cached_dheads($id)]} {
9072 set ret [concat $ret $cached_dheads($id)]
9074 if {[info exists idheads($id)]} {
9077 foreach a $arcnos($id) {
9078 if {$archeads($a) ne {}} {
9079 validate_archeads $a
9080 if {$archeads($a) ne {}} {
9081 set ret [concat $ret $archeads($a)]
9085 if {![info exists seen($d)]} {
9092 set ret [lsort -unique $ret]
9093 set cached_dheads($origid) $ret
9094 return [concat $ret $aret]
9097 proc addedtag {id} {
9098 global arcnos arcout cached_dtags cached_atags
9100 if {![info exists arcnos($id)]} return
9101 if {![info exists arcout($id)]} {
9102 recalcarc [lindex $arcnos($id) 0]
9104 catch {unset cached_dtags}
9105 catch {unset cached_atags}
9108 proc addedhead {hid head} {
9109 global arcnos arcout cached_dheads
9111 if {![info exists arcnos($hid)]} return
9112 if {![info exists arcout($hid)]} {
9113 recalcarc [lindex $arcnos($hid) 0]
9115 catch {unset cached_dheads}
9118 proc removedhead {hid head} {
9119 global cached_dheads
9121 catch {unset cached_dheads}
9124 proc movedhead {hid head} {
9125 global arcnos arcout cached_dheads
9127 if {![info exists arcnos($hid)]} return
9128 if {![info exists arcout($hid)]} {
9129 recalcarc [lindex $arcnos($hid) 0]
9131 catch {unset cached_dheads}
9134 proc changedrefs {} {
9135 global cached_dheads cached_dtags cached_atags
9136 global arctags archeads arcnos arcout idheads idtags
9138 foreach id [concat [array names idheads] [array names idtags]] {
9139 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9140 set a [lindex $arcnos($id) 0]
9141 if {![info exists donearc($a)]} {
9147 catch {unset cached_dtags}
9148 catch {unset cached_atags}
9149 catch {unset cached_dheads}
9152 proc rereadrefs {} {
9153 global idtags idheads idotherrefs mainheadid
9155 set refids [concat [array names idtags] \
9156 [array names idheads] [array names idotherrefs]]
9157 foreach id $refids {
9158 if {![info exists ref($id)]} {
9159 set ref($id) [listrefs $id]
9162 set oldmainhead $mainheadid
9165 set refids [lsort -unique [concat $refids [array names idtags] \
9166 [array names idheads] [array names idotherrefs]]]
9167 foreach id $refids {
9168 set v [listrefs $id]
9169 if {![info exists ref($id)] || $ref($id) != $v} {
9173 if {$oldmainhead ne $mainheadid} {
9174 redrawtags $oldmainhead
9175 redrawtags $mainheadid
9180 proc listrefs {id} {
9181 global idtags idheads idotherrefs
9184 if {[info exists idtags($id)]} {
9188 if {[info exists idheads($id)]} {
9192 if {[info exists idotherrefs($id)]} {
9193 set z $idotherrefs($id)
9195 return [list $x $y $z]
9198 proc showtag {tag isnew} {
9199 global ctext tagcontents tagids linknum tagobjid
9202 addtohistory [list showtag $tag 0]
9204 $ctext conf -state normal
9208 if {![info exists tagcontents($tag)]} {
9210 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9213 if {[info exists tagcontents($tag)]} {
9214 set text $tagcontents($tag)
9216 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9218 appendwithlinks $text {}
9219 $ctext conf -state disabled
9231 if {[info exists gitktmpdir]} {
9232 catch {file delete -force $gitktmpdir}
9236 proc mkfontdisp {font top which} {
9237 global fontattr fontpref $font
9239 set fontpref($font) [set $font]
9240 button $top.${font}but -text $which -font optionfont \
9241 -command [list choosefont $font $which]
9242 label $top.$font -relief flat -font $font \
9243 -text $fontattr($font,family) -justify left
9244 grid x $top.${font}but $top.$font -sticky w
9247 proc choosefont {font which} {
9248 global fontparam fontlist fonttop fontattr
9250 set fontparam(which) $which
9251 set fontparam(font) $font
9252 set fontparam(family) [font actual $font -family]
9253 set fontparam(size) $fontattr($font,size)
9254 set fontparam(weight) $fontattr($font,weight)
9255 set fontparam(slant) $fontattr($font,slant)
9258 if {![winfo exists $top]} {
9260 eval font config sample [font actual $font]
9262 wm title $top [mc "Gitk font chooser"]
9263 label $top.l -textvariable fontparam(which)
9264 pack $top.l -side top
9265 set fontlist [lsort [font families]]
9267 listbox $top.f.fam -listvariable fontlist \
9268 -yscrollcommand [list $top.f.sb set]
9269 bind $top.f.fam <<ListboxSelect>> selfontfam
9270 scrollbar $top.f.sb -command [list $top.f.fam yview]
9271 pack $top.f.sb -side right -fill y
9272 pack $top.f.fam -side left -fill both -expand 1
9273 pack $top.f -side top -fill both -expand 1
9275 spinbox $top.g.size -from 4 -to 40 -width 4 \
9276 -textvariable fontparam(size) \
9277 -validatecommand {string is integer -strict %s}
9278 checkbutton $top.g.bold -padx 5 \
9279 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9280 -variable fontparam(weight) -onvalue bold -offvalue normal
9281 checkbutton $top.g.ital -padx 5 \
9282 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9283 -variable fontparam(slant) -onvalue italic -offvalue roman
9284 pack $top.g.size $top.g.bold $top.g.ital -side left
9285 pack $top.g -side top
9286 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9288 $top.c create text 100 25 -anchor center -text $which -font sample \
9289 -fill black -tags text
9290 bind $top.c <Configure> [list centertext $top.c]
9291 pack $top.c -side top -fill x
9293 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9294 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9295 grid $top.buts.ok $top.buts.can
9296 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9297 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9298 pack $top.buts -side bottom -fill x
9299 trace add variable fontparam write chg_fontparam
9302 $top.c itemconf text -text $which
9304 set i [lsearch -exact $fontlist $fontparam(family)]
9306 $top.f.fam selection set $i
9311 proc centertext {w} {
9312 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9316 global fontparam fontpref prefstop
9318 set f $fontparam(font)
9319 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9320 if {$fontparam(weight) eq "bold"} {
9321 lappend fontpref($f) "bold"
9323 if {$fontparam(slant) eq "italic"} {
9324 lappend fontpref($f) "italic"
9327 $w conf -text $fontparam(family) -font $fontpref($f)
9333 global fonttop fontparam
9335 if {[info exists fonttop]} {
9336 catch {destroy $fonttop}
9337 catch {font delete sample}
9343 proc selfontfam {} {
9344 global fonttop fontparam
9346 set i [$fonttop.f.fam curselection]
9348 set fontparam(family) [$fonttop.f.fam get $i]
9352 proc chg_fontparam {v sub op} {
9355 font config sample -$sub $fontparam($sub)
9359 global maxwidth maxgraphpct
9360 global oldprefs prefstop showneartags showlocalchanges
9361 global bgcolor fgcolor ctext diffcolors selectbgcolor
9362 global tabstop limitdiffs autoselect extdifftool perfile_attrs
9366 if {[winfo exists $top]} {
9370 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9371 limitdiffs tabstop perfile_attrs} {
9372 set oldprefs($v) [set $v]
9375 wm title $top [mc "Gitk preferences"]
9376 label $top.ldisp -text [mc "Commit list display options"]
9377 grid $top.ldisp - -sticky w -pady 10
9378 label $top.spacer -text " "
9379 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9381 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9382 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9383 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9385 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9386 grid x $top.maxpctl $top.maxpct -sticky w
9387 frame $top.showlocal
9388 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9389 checkbutton $top.showlocal.b -variable showlocalchanges
9390 pack $top.showlocal.b $top.showlocal.l -side left
9391 grid x $top.showlocal -sticky w
9392 frame $top.autoselect
9393 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9394 checkbutton $top.autoselect.b -variable autoselect
9395 pack $top.autoselect.b $top.autoselect.l -side left
9396 grid x $top.autoselect -sticky w
9398 label $top.ddisp -text [mc "Diff display options"]
9399 grid $top.ddisp - -sticky w -pady 10
9400 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9401 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9402 grid x $top.tabstopl $top.tabstop -sticky w
9404 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9405 checkbutton $top.ntag.b -variable showneartags
9406 pack $top.ntag.b $top.ntag.l -side left
9407 grid x $top.ntag -sticky w
9409 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9410 checkbutton $top.ldiff.b -variable limitdiffs
9411 pack $top.ldiff.b $top.ldiff.l -side left
9412 grid x $top.ldiff -sticky w
9414 label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
9415 checkbutton $top.lattr.b -variable perfile_attrs
9416 pack $top.lattr.b $top.lattr.l -side left
9417 grid x $top.lattr -sticky w
9419 entry $top.extdifft -textvariable extdifftool
9421 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9423 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9424 -command choose_extdiff
9425 pack $top.extdifff.l $top.extdifff.b -side left
9426 grid x $top.extdifff $top.extdifft -sticky w
9428 label $top.cdisp -text [mc "Colors: press to choose"]
9429 grid $top.cdisp - -sticky w -pady 10
9430 label $top.bg -padx 40 -relief sunk -background $bgcolor
9431 button $top.bgbut -text [mc "Background"] -font optionfont \
9432 -command [list choosecolor bgcolor {} $top.bg background setbg]
9433 grid x $top.bgbut $top.bg -sticky w
9434 label $top.fg -padx 40 -relief sunk -background $fgcolor
9435 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9436 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9437 grid x $top.fgbut $top.fg -sticky w
9438 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9439 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9440 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9441 [list $ctext tag conf d0 -foreground]]
9442 grid x $top.diffoldbut $top.diffold -sticky w
9443 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9444 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9445 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9446 [list $ctext tag conf d1 -foreground]]
9447 grid x $top.diffnewbut $top.diffnew -sticky w
9448 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9449 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9450 -command [list choosecolor diffcolors 2 $top.hunksep \
9451 "diff hunk header" \
9452 [list $ctext tag conf hunksep -foreground]]
9453 grid x $top.hunksepbut $top.hunksep -sticky w
9454 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9455 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9456 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9457 grid x $top.selbgbut $top.selbgsep -sticky w
9459 label $top.cfont -text [mc "Fonts: press to choose"]
9460 grid $top.cfont - -sticky w -pady 10
9461 mkfontdisp mainfont $top [mc "Main font"]
9462 mkfontdisp textfont $top [mc "Diff display font"]
9463 mkfontdisp uifont $top [mc "User interface font"]
9466 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9467 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9468 grid $top.buts.ok $top.buts.can
9469 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9470 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9471 grid $top.buts - - -pady 10 -sticky ew
9472 bind $top <Visibility> "focus $top.buts.ok"
9475 proc choose_extdiff {} {
9478 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9480 set extdifftool $prog
9484 proc choosecolor {v vi w x cmd} {
9487 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9488 -title [mc "Gitk: choose color for %s" $x]]
9489 if {$c eq {}} return
9490 $w conf -background $c
9496 global bglist cflist
9498 $w configure -selectbackground $c
9500 $cflist tag configure highlight \
9501 -background [$cflist cget -selectbackground]
9502 allcanvs itemconf secsel -fill $c
9509 $w conf -background $c
9517 $w conf -foreground $c
9519 allcanvs itemconf text -fill $c
9520 $canv itemconf circle -outline $c
9524 global oldprefs prefstop
9526 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9527 limitdiffs tabstop perfile_attrs} {
9529 set $v $oldprefs($v)
9531 catch {destroy $prefstop}
9537 global maxwidth maxgraphpct
9538 global oldprefs prefstop showneartags showlocalchanges
9539 global fontpref mainfont textfont uifont
9540 global limitdiffs treediffs perfile_attrs
9542 catch {destroy $prefstop}
9546 if {$mainfont ne $fontpref(mainfont)} {
9547 set mainfont $fontpref(mainfont)
9548 parsefont mainfont $mainfont
9549 eval font configure mainfont [fontflags mainfont]
9550 eval font configure mainfontbold [fontflags mainfont 1]
9554 if {$textfont ne $fontpref(textfont)} {
9555 set textfont $fontpref(textfont)
9556 parsefont textfont $textfont
9557 eval font configure textfont [fontflags textfont]
9558 eval font configure textfontbold [fontflags textfont 1]
9560 if {$uifont ne $fontpref(uifont)} {
9561 set uifont $fontpref(uifont)
9562 parsefont uifont $uifont
9563 eval font configure uifont [fontflags uifont]
9566 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9567 if {$showlocalchanges} {
9573 if {$limitdiffs != $oldprefs(limitdiffs) ||
9574 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
9575 # treediffs elements are limited by path;
9576 # won't have encodings cached if perfile_attrs was just turned on
9577 catch {unset treediffs}
9579 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9580 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9582 } elseif {$showneartags != $oldprefs(showneartags) ||
9583 $limitdiffs != $oldprefs(limitdiffs)} {
9588 proc formatdate {d} {
9589 global datetimeformat
9591 set d [clock format $d -format $datetimeformat]
9596 # This list of encoding names and aliases is distilled from
9597 # http://www.iana.org/assignments/character-sets.
9598 # Not all of them are supported by Tcl.
9599 set encoding_aliases {
9600 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9601 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9602 { ISO-10646-UTF-1 csISO10646UTF1 }
9603 { ISO_646.basic:1983 ref csISO646basic1983 }
9604 { INVARIANT csINVARIANT }
9605 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9606 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9607 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9608 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9609 { NATS-DANO iso-ir-9-1 csNATSDANO }
9610 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9611 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9612 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9613 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9614 { ISO-2022-KR csISO2022KR }
9616 { ISO-2022-JP csISO2022JP }
9617 { ISO-2022-JP-2 csISO2022JP2 }
9618 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9620 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9621 { IT iso-ir-15 ISO646-IT csISO15Italian }
9622 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9623 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9624 { greek7-old iso-ir-18 csISO18Greek7Old }
9625 { latin-greek iso-ir-19 csISO19LatinGreek }
9626 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9627 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9628 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9629 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9630 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9631 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9632 { INIS iso-ir-49 csISO49INIS }
9633 { INIS-8 iso-ir-50 csISO50INIS8 }
9634 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9635 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9636 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9637 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9638 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9639 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9641 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9642 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9643 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9644 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9645 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9646 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9647 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9648 { greek7 iso-ir-88 csISO88Greek7 }
9649 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9650 { iso-ir-90 csISO90 }
9651 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9652 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9653 csISO92JISC62991984b }
9654 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9655 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9656 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9657 csISO95JIS62291984handadd }
9658 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9659 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9660 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9661 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9663 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9664 { T.61-7bit iso-ir-102 csISO102T617bit }
9665 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9666 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9667 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9668 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9669 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9670 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9671 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9672 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9673 arabic csISOLatinArabic }
9674 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9675 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9676 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9677 greek greek8 csISOLatinGreek }
9678 { T.101-G2 iso-ir-128 csISO128T101G2 }
9679 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9681 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9682 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9683 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9684 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9685 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9686 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9687 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9688 csISOLatinCyrillic }
9689 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9690 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9691 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9692 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9693 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9694 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9695 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9696 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9697 { ISO_10367-box iso-ir-155 csISO10367Box }
9698 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9699 { latin-lap lap iso-ir-158 csISO158Lap }
9700 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9701 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9704 { JIS_X0201 X0201 csHalfWidthKatakana }
9705 { KSC5636 ISO646-KR csKSC5636 }
9706 { ISO-10646-UCS-2 csUnicode }
9707 { ISO-10646-UCS-4 csUCS4 }
9708 { DEC-MCS dec csDECMCS }
9709 { hp-roman8 roman8 r8 csHPRoman8 }
9710 { macintosh mac csMacintosh }
9711 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9713 { IBM038 EBCDIC-INT cp038 csIBM038 }
9714 { IBM273 CP273 csIBM273 }
9715 { IBM274 EBCDIC-BE CP274 csIBM274 }
9716 { IBM275 EBCDIC-BR cp275 csIBM275 }
9717 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9718 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9719 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9720 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9721 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9722 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9723 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9724 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9725 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9726 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9727 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9728 { IBM437 cp437 437 csPC8CodePage437 }
9729 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9730 { IBM775 cp775 csPC775Baltic }
9731 { IBM850 cp850 850 csPC850Multilingual }
9732 { IBM851 cp851 851 csIBM851 }
9733 { IBM852 cp852 852 csPCp852 }
9734 { IBM855 cp855 855 csIBM855 }
9735 { IBM857 cp857 857 csIBM857 }
9736 { IBM860 cp860 860 csIBM860 }
9737 { IBM861 cp861 861 cp-is csIBM861 }
9738 { IBM862 cp862 862 csPC862LatinHebrew }
9739 { IBM863 cp863 863 csIBM863 }
9740 { IBM864 cp864 csIBM864 }
9741 { IBM865 cp865 865 csIBM865 }
9742 { IBM866 cp866 866 csIBM866 }
9743 { IBM868 CP868 cp-ar csIBM868 }
9744 { IBM869 cp869 869 cp-gr csIBM869 }
9745 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9746 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9747 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9748 { IBM891 cp891 csIBM891 }
9749 { IBM903 cp903 csIBM903 }
9750 { IBM904 cp904 904 csIBBM904 }
9751 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9752 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9753 { IBM1026 CP1026 csIBM1026 }
9754 { EBCDIC-AT-DE csIBMEBCDICATDE }
9755 { EBCDIC-AT-DE-A csEBCDICATDEA }
9756 { EBCDIC-CA-FR csEBCDICCAFR }
9757 { EBCDIC-DK-NO csEBCDICDKNO }
9758 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9759 { EBCDIC-FI-SE csEBCDICFISE }
9760 { EBCDIC-FI-SE-A csEBCDICFISEA }
9761 { EBCDIC-FR csEBCDICFR }
9762 { EBCDIC-IT csEBCDICIT }
9763 { EBCDIC-PT csEBCDICPT }
9764 { EBCDIC-ES csEBCDICES }
9765 { EBCDIC-ES-A csEBCDICESA }
9766 { EBCDIC-ES-S csEBCDICESS }
9767 { EBCDIC-UK csEBCDICUK }
9768 { EBCDIC-US csEBCDICUS }
9769 { UNKNOWN-8BIT csUnknown8BiT }
9770 { MNEMONIC csMnemonic }
9775 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9776 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9777 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9778 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9779 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9780 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9781 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9782 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9783 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9784 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9785 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9786 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9787 { IBM1047 IBM-1047 }
9788 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9789 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9790 { UNICODE-1-1 csUnicode11 }
9793 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9794 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9796 { ISO-8859-15 ISO_8859-15 Latin-9 }
9797 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9798 { GBK CP936 MS936 windows-936 }
9799 { JIS_Encoding csJISEncoding }
9800 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
9801 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9803 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9804 { ISO-10646-UCS-Basic csUnicodeASCII }
9805 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9806 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9807 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9808 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9809 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9810 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9811 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9812 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9813 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9814 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9815 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9816 { Ventura-US csVenturaUS }
9817 { Ventura-International csVenturaInternational }
9818 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9819 { PC8-Turkish csPC8Turkish }
9820 { IBM-Symbols csIBMSymbols }
9821 { IBM-Thai csIBMThai }
9822 { HP-Legal csHPLegal }
9823 { HP-Pi-font csHPPiFont }
9824 { HP-Math8 csHPMath8 }
9825 { Adobe-Symbol-Encoding csHPPSMath }
9826 { HP-DeskTop csHPDesktop }
9827 { Ventura-Math csVenturaMath }
9828 { Microsoft-Publishing csMicrosoftPublishing }
9829 { Windows-31J csWindows31J }
9834 proc tcl_encoding {enc} {
9835 global encoding_aliases tcl_encoding_cache
9836 if {[info exists tcl_encoding_cache($enc)]} {
9837 return $tcl_encoding_cache($enc)
9839 set names [encoding names]
9840 set lcnames [string tolower $names]
9841 set enc [string tolower $enc]
9842 set i [lsearch -exact $lcnames $enc]
9844 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9845 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
9846 set i [lsearch -exact $lcnames $encx]
9850 foreach l $encoding_aliases {
9851 set ll [string tolower $l]
9852 if {[lsearch -exact $ll $enc] < 0} continue
9853 # look through the aliases for one that tcl knows about
9855 set i [lsearch -exact $lcnames $e]
9857 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
9858 set i [lsearch -exact $lcnames $ex]
9868 set tclenc [lindex $names $i]
9870 set tcl_encoding_cache($enc) $tclenc
9874 proc gitattr {path attr default} {
9875 global path_attr_cache
9876 if {[info exists path_attr_cache($attr,$path)]} {
9877 set r $path_attr_cache($attr,$path)
9880 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
9881 regexp "(.*): encoding: (.*)" $line m f r
9883 set path_attr_cache($attr,$path) $r
9885 if {$r eq "unspecified"} {
9891 proc cache_gitattr {attr pathlist} {
9892 global path_attr_cache
9894 foreach path $pathlist {
9895 if {![info exists path_attr_cache($attr,$path)]} {
9896 lappend newlist $path
9900 if {[tk windowingsystem] == "win32"} {
9901 # windows has a 32k limit on the arguments to a command...
9904 while {$newlist ne {}} {
9905 set head [lrange $newlist 0 [expr {$lim - 1}]]
9906 set newlist [lrange $newlist $lim end]
9907 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
9908 foreach row [split $rlist "\n"] {
9909 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
9910 if {[string index $path 0] eq "\""} {
9911 set path [encoding convertfrom [lindex $path 0]]
9913 set path_attr_cache($attr,$path) $value
9920 proc get_path_encoding {path} {
9921 global gui_encoding perfile_attrs
9922 set tcl_enc $gui_encoding
9923 if {$path ne {} && $perfile_attrs} {
9924 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
9932 # First check that Tcl/Tk is recent enough
9933 if {[catch {package require Tk 8.4} err]} {
9934 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9935 Gitk requires at least Tcl/Tk 8.4."]
9940 set wrcomcmd "git diff-tree --stdin -p --pretty"
9944 set gitencoding [exec git config --get i18n.commitencoding]
9946 if {$gitencoding == ""} {
9947 set gitencoding "utf-8"
9949 set tclencoding [tcl_encoding $gitencoding]
9950 if {$tclencoding == {}} {
9951 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9954 set gui_encoding [encoding system]
9956 set enc [exec git config --get gui.encoding]
9958 set tclenc [tcl_encoding $enc]
9959 if {$tclenc ne {}} {
9960 set gui_encoding $tclenc
9962 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
9967 set mainfont {Helvetica 9}
9968 set textfont {Courier 9}
9969 set uifont {Helvetica 9 bold}
9971 set findmergefiles 0
9979 set cmitmode "patch"
9980 set wrapcomment "none"
9984 set showlocalchanges 1
9986 set datetimeformat "%Y-%m-%d %H:%M:%S"
9990 set extdifftool "meld"
9992 set colors {green red blue magenta darkgrey brown orange}
9995 set diffcolors {red "#00a000" blue}
9998 set selectbgcolor gray85
10000 set circlecolors {white blue gray blue blue}
10002 # button for popping up context menus
10003 if {[tk windowingsystem] eq "aqua"} {
10004 set ctxbut <Button-2>
10006 set ctxbut <Button-3>
10009 ## For msgcat loading, first locate the installation location.
10010 if { [info exists ::env(GITK_MSGSDIR)] } {
10011 ## Msgsdir was manually set in the environment.
10012 set gitk_msgsdir $::env(GITK_MSGSDIR)
10014 ## Let's guess the prefix from argv0.
10015 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10016 set gitk_libdir [file join $gitk_prefix share gitk lib]
10017 set gitk_msgsdir [file join $gitk_libdir msgs]
10021 ## Internationalization (i18n) through msgcat and gettext. See
10022 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10023 package require msgcat
10024 namespace import ::msgcat::mc
10025 ## And eventually load the actual message catalog
10026 ::msgcat::mcload $gitk_msgsdir
10028 catch {source ~/.gitk}
10030 font create optionfont -family sans-serif -size -12
10032 parsefont mainfont $mainfont
10033 eval font create mainfont [fontflags mainfont]
10034 eval font create mainfontbold [fontflags mainfont 1]
10036 parsefont textfont $textfont
10037 eval font create textfont [fontflags textfont]
10038 eval font create textfontbold [fontflags textfont 1]
10040 parsefont uifont $uifont
10041 eval font create uifont [fontflags uifont]
10045 # check that we can find a .git directory somewhere...
10046 if {[catch {set gitdir [gitdir]}]} {
10047 show_error {} . [mc "Cannot find a git repository here."]
10050 if {![file isdirectory $gitdir]} {
10051 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10056 set selectheadid {}
10059 set cmdline_files {}
10061 set revtreeargscmd {}
10062 foreach arg $argv {
10063 switch -glob -- $arg {
10066 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10069 "--select-commit=*" {
10070 set selecthead [string range $arg 16 end]
10073 set revtreeargscmd [string range $arg 10 end]
10076 lappend revtreeargs $arg
10082 if {$selecthead eq "HEAD"} {
10086 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10087 # no -- on command line, but some arguments (other than --argscmd)
10089 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10090 set cmdline_files [split $f "\n"]
10091 set n [llength $cmdline_files]
10092 set revtreeargs [lrange $revtreeargs 0 end-$n]
10093 # Unfortunately git rev-parse doesn't produce an error when
10094 # something is both a revision and a filename. To be consistent
10095 # with git log and git rev-list, check revtreeargs for filenames.
10096 foreach arg $revtreeargs {
10097 if {[file exists $arg]} {
10098 show_error {} . [mc "Ambiguous argument '%s': both revision\
10099 and filename" $arg]
10104 # unfortunately we get both stdout and stderr in $err,
10105 # so look for "fatal:".
10106 set i [string first "fatal:" $err]
10108 set err [string range $err [expr {$i + 6}] end]
10110 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10115 set nullid "0000000000000000000000000000000000000000"
10116 set nullid2 "0000000000000000000000000000000000000001"
10117 set nullfile "/dev/null"
10119 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10126 set highlight_paths {}
10128 set searchdirn -forwards
10130 set boldnamerows {}
10131 set diffelide {0 0}
10132 set markingmatches 0
10133 set linkentercount 0
10134 set need_redisplay 0
10141 set selectedhlview [mc "None"]
10142 set highlight_related [mc "None"]
10143 set highlight_files {}
10144 set viewfiles(0) {}
10147 set viewargscmd(0) {}
10149 set selectedline {}
10157 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10160 # wait for the window to become visible
10161 tkwait visibility .
10162 wm title . "[file tail $argv0]: [file tail [pwd]]"
10165 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10166 # create a view for the files/dirs specified on the command line
10170 set viewname(1) [mc "Command line"]
10171 set viewfiles(1) $cmdline_files
10172 set viewargs(1) $revtreeargs
10173 set viewargscmd(1) $revtreeargscmd
10177 .bar.view entryconf [mca "Edit view..."] -state normal
10178 .bar.view entryconf [mca "Delete view"] -state normal
10181 if {[info exists permviews]} {
10182 foreach v $permviews {
10185 set viewname($n) [lindex $v 0]
10186 set viewfiles($n) [lindex $v 1]
10187 set viewargs($n) [lindex $v 2]
10188 set viewargscmd($n) [lindex $v 3]