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
"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
"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
424 set pending_select
$selid
426 set pending_select
$mainheadid
430 proc getcommits
{selid
} {
431 global canv curview need_redisplay viewactive
434 if {[start_rev_list
$curview]} {
435 reset_pending_select
$selid
436 show_status
[mc
"Reading commits..."]
439 show_status
[mc
"No commits selected"]
443 proc updatecommits
{} {
444 global curview vcanopt vorigargs vfilelimit viewinstances
445 global viewactive viewcomplete tclencoding
446 global startmsecs showneartags showlocalchanges
447 global mainheadid pending_select
449 global varcid vposids vnegids vflags vrevs
451 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
452 set oldmainid
$mainheadid
454 if {$showlocalchanges} {
455 if {$mainheadid ne
$oldmainid} {
458 if {[commitinview
$mainheadid $curview]} {
463 if {$vcanopt($view)} {
464 set oldpos
$vposids($view)
465 set oldneg
$vnegids($view)
466 set revs
[parseviewrevs
$view $vrevs($view)]
470 # note: getting the delta when negative refs change is hard,
471 # and could require multiple git log invocations, so in that
472 # case we ask git log for all the commits (not just the delta)
473 if {$oldneg eq
$vnegids($view)} {
476 # take out positive refs that we asked for before or
477 # that we have already seen
479 if {[string length
$rev] == 40} {
480 if {[lsearch
-exact $oldpos $rev] < 0
481 && ![info exists varcid
($view,$rev)]} {
486 lappend
$newrevs $rev
489 if {$npos == 0} return
491 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
493 set args
[concat
$vflags($view) $revs --not $oldpos]
495 set args
$vorigargs($view)
498 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
499 --boundary $args "--" $vfilelimit($view)] r
]
501 error_popup
"Error executing git log: $err"
504 if {$viewactive($view) == 0} {
505 set startmsecs
[clock clicks
-milliseconds]
507 set i
[reg_instance
$fd]
508 lappend viewinstances
($view) $i
509 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
510 if {$tclencoding != {}} {
511 fconfigure
$fd -encoding $tclencoding
513 filerun
$fd [list getcommitlines
$fd $i $view 1]
514 incr viewactive
($view)
515 set viewcomplete
($view) 0
516 reset_pending_select
{}
517 nowbusy
$view "Reading"
523 proc reloadcommits
{} {
524 global curview viewcomplete selectedline currentid thickerline
525 global showneartags treediffs commitinterest cached_commitrow
529 if {$selectedline ne
{}} {
533 if {!$viewcomplete($curview)} {
534 stop_rev_list
$curview
538 catch
{unset currentid
}
539 catch
{unset thickerline
}
540 catch
{unset treediffs
}
547 catch
{unset commitinterest
}
548 catch
{unset cached_commitrow
}
549 catch
{unset targetid
}
555 # This makes a string representation of a positive integer which
556 # sorts as a string in numerical order
559 return [format
"%x" $n]
560 } elseif
{$n < 256} {
561 return [format
"x%.2x" $n]
562 } elseif
{$n < 65536} {
563 return [format
"y%.4x" $n]
565 return [format
"z%.8x" $n]
568 # Procedures used in reordering commits from git log (without
569 # --topo-order) into the order for display.
571 proc varcinit
{view
} {
572 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
573 global vtokmod varcmod vrowmod varcix vlastins
575 set varcstart
($view) {{}}
576 set vupptr
($view) {0}
577 set vdownptr
($view) {0}
578 set vleftptr
($view) {0}
579 set vbackptr
($view) {0}
580 set varctok
($view) {{}}
581 set varcrow
($view) {{}}
582 set vtokmod
($view) {}
585 set varcix
($view) {{}}
586 set vlastins
($view) {0}
589 proc resetvarcs
{view
} {
590 global varcid varccommits parents children vseedcount ordertok
592 foreach vid
[array names varcid
$view,*] {
597 # some commits might have children but haven't been seen yet
598 foreach vid
[array names children
$view,*] {
601 foreach va
[array names varccommits
$view,*] {
602 unset varccommits
($va)
604 foreach vd
[array names vseedcount
$view,*] {
605 unset vseedcount
($vd)
607 catch
{unset ordertok
}
610 # returns a list of the commits with no children
612 global vdownptr vleftptr varcstart
615 set a
[lindex
$vdownptr($v) 0]
617 lappend ret
[lindex
$varcstart($v) $a]
618 set a
[lindex
$vleftptr($v) $a]
623 proc newvarc
{view id
} {
624 global varcid varctok parents children vdatemode
625 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
626 global commitdata commitinfo vseedcount varccommits vlastins
628 set a
[llength
$varctok($view)]
630 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
631 if {![info exists commitinfo
($id)]} {
632 parsecommit
$id $commitdata($id) 1
634 set cdate
[lindex
$commitinfo($id) 4]
635 if {![string is integer
-strict $cdate]} {
638 if {![info exists vseedcount
($view,$cdate)]} {
639 set vseedcount
($view,$cdate) -1
641 set c
[incr vseedcount
($view,$cdate)]
642 set cdate
[expr {$cdate ^
0xffffffff}]
643 set tok
"s[strrep $cdate][strrep $c]"
648 if {[llength
$children($vid)] > 0} {
649 set kid
[lindex
$children($vid) end
]
650 set k
$varcid($view,$kid)
651 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
654 set tok
[lindex
$varctok($view) $k]
658 set i
[lsearch
-exact $parents($view,$ki) $id]
659 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
660 append tok
[strrep
$j]
662 set c
[lindex
$vlastins($view) $ka]
663 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
665 set b
[lindex
$vdownptr($view) $ka]
667 set b
[lindex
$vleftptr($view) $c]
669 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
671 set b
[lindex
$vleftptr($view) $c]
674 lset vdownptr
($view) $ka $a
675 lappend vbackptr
($view) 0
677 lset vleftptr
($view) $c $a
678 lappend vbackptr
($view) $c
680 lset vlastins
($view) $ka $a
681 lappend vupptr
($view) $ka
682 lappend vleftptr
($view) $b
684 lset vbackptr
($view) $b $a
686 lappend varctok
($view) $tok
687 lappend varcstart
($view) $id
688 lappend vdownptr
($view) 0
689 lappend varcrow
($view) {}
690 lappend varcix
($view) {}
691 set varccommits
($view,$a) {}
692 lappend vlastins
($view) 0
696 proc splitvarc
{p v
} {
697 global varcid varcstart varccommits varctok
698 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
700 set oa
$varcid($v,$p)
701 set ac
$varccommits($v,$oa)
702 set i
[lsearch
-exact $varccommits($v,$oa) $p]
704 set na
[llength
$varctok($v)]
705 # "%" sorts before "0"...
706 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
707 lappend varctok
($v) $tok
708 lappend varcrow
($v) {}
709 lappend varcix
($v) {}
710 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
711 set varccommits
($v,$na) [lrange
$ac $i end
]
712 lappend varcstart
($v) $p
713 foreach id
$varccommits($v,$na) {
714 set varcid
($v,$id) $na
716 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
717 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
718 lset vdownptr
($v) $oa $na
719 lset vlastins
($v) $oa 0
720 lappend vupptr
($v) $oa
721 lappend vleftptr
($v) 0
722 lappend vbackptr
($v) 0
723 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
724 lset vupptr
($v) $b $na
728 proc renumbervarc
{a v
} {
729 global parents children varctok varcstart varccommits
730 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
732 set t1
[clock clicks
-milliseconds]
738 if {[info exists isrelated
($a)]} {
740 set id
[lindex
$varccommits($v,$a) end
]
741 foreach p
$parents($v,$id) {
742 if {[info exists varcid
($v,$p)]} {
743 set isrelated
($varcid($v,$p)) 1
748 set b
[lindex
$vdownptr($v) $a]
751 set b
[lindex
$vleftptr($v) $a]
753 set a
[lindex
$vupptr($v) $a]
759 if {![info exists kidchanged
($a)]} continue
760 set id
[lindex
$varcstart($v) $a]
761 if {[llength
$children($v,$id)] > 1} {
762 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
765 set oldtok
[lindex
$varctok($v) $a]
766 if {!$vdatemode($v)} {
772 set kid
[last_real_child
$v,$id]
774 set k
$varcid($v,$kid)
775 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
778 set tok
[lindex
$varctok($v) $k]
782 set i
[lsearch
-exact $parents($v,$ki) $id]
783 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
784 append tok
[strrep
$j]
786 if {$tok eq
$oldtok} {
789 set id
[lindex
$varccommits($v,$a) end
]
790 foreach p
$parents($v,$id) {
791 if {[info exists varcid
($v,$p)]} {
792 set kidchanged
($varcid($v,$p)) 1
797 lset varctok
($v) $a $tok
798 set b
[lindex
$vupptr($v) $a]
800 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
803 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
806 set c
[lindex
$vbackptr($v) $a]
807 set d
[lindex
$vleftptr($v) $a]
809 lset vdownptr
($v) $b $d
811 lset vleftptr
($v) $c $d
814 lset vbackptr
($v) $d $c
816 if {[lindex
$vlastins($v) $b] == $a} {
817 lset vlastins
($v) $b $c
819 lset vupptr
($v) $a $ka
820 set c
[lindex
$vlastins($v) $ka]
822 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
824 set b
[lindex
$vdownptr($v) $ka]
826 set b
[lindex
$vleftptr($v) $c]
829 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
831 set b
[lindex
$vleftptr($v) $c]
834 lset vdownptr
($v) $ka $a
835 lset vbackptr
($v) $a 0
837 lset vleftptr
($v) $c $a
838 lset vbackptr
($v) $a $c
840 lset vleftptr
($v) $a $b
842 lset vbackptr
($v) $b $a
844 lset vlastins
($v) $ka $a
847 foreach id
[array names sortkids
] {
848 if {[llength
$children($v,$id)] > 1} {
849 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
853 set t2
[clock clicks
-milliseconds]
854 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
857 # Fix up the graph after we have found out that in view $v,
858 # $p (a commit that we have already seen) is actually the parent
859 # of the last commit in arc $a.
860 proc fix_reversal
{p a v
} {
861 global varcid varcstart varctok vupptr
863 set pa
$varcid($v,$p)
864 if {$p ne
[lindex
$varcstart($v) $pa]} {
866 set pa
$varcid($v,$p)
868 # seeds always need to be renumbered
869 if {[lindex
$vupptr($v) $pa] == 0 ||
870 [string compare
[lindex
$varctok($v) $a] \
871 [lindex
$varctok($v) $pa]] > 0} {
876 proc insertrow
{id p v
} {
877 global cmitlisted children parents varcid varctok vtokmod
878 global varccommits ordertok commitidx numcommits curview
879 global targetid targetrow
883 set cmitlisted
($vid) 1
884 set children
($vid) {}
885 set parents
($vid) [list
$p]
886 set a
[newvarc
$v $id]
888 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
891 lappend varccommits
($v,$a) $id
893 if {[llength
[lappend children
($vp) $id]] > 1} {
894 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
895 catch
{unset ordertok
}
897 fix_reversal
$p $a $v
899 if {$v == $curview} {
900 set numcommits
$commitidx($v)
902 if {[info exists targetid
]} {
903 if {![comes_before
$targetid $p]} {
910 proc insertfakerow
{id p
} {
911 global varcid varccommits parents children cmitlisted
912 global commitidx varctok vtokmod targetid targetrow curview numcommits
916 set i
[lsearch
-exact $varccommits($v,$a) $p]
918 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
921 set children
($v,$id) {}
922 set parents
($v,$id) [list
$p]
923 set varcid
($v,$id) $a
924 lappend children
($v,$p) $id
925 set cmitlisted
($v,$id) 1
926 set numcommits
[incr commitidx
($v)]
927 # note we deliberately don't update varcstart($v) even if $i == 0
928 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
930 if {[info exists targetid
]} {
931 if {![comes_before
$targetid $p]} {
939 proc removefakerow
{id
} {
940 global varcid varccommits parents children commitidx
941 global varctok vtokmod cmitlisted currentid selectedline
942 global targetid curview numcommits
945 if {[llength
$parents($v,$id)] != 1} {
946 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
949 set p
[lindex
$parents($v,$id) 0]
950 set a
$varcid($v,$id)
951 set i
[lsearch
-exact $varccommits($v,$a) $id]
953 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
957 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
958 unset parents
($v,$id)
959 unset children
($v,$id)
960 unset cmitlisted
($v,$id)
961 set numcommits
[incr commitidx
($v) -1]
962 set j
[lsearch
-exact $children($v,$p) $id]
964 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
967 if {[info exist currentid
] && $id eq
$currentid} {
971 if {[info exists targetid
] && $targetid eq
$id} {
978 proc first_real_child
{vp
} {
979 global children nullid nullid2
981 foreach id
$children($vp) {
982 if {$id ne
$nullid && $id ne
$nullid2} {
989 proc last_real_child
{vp
} {
990 global children nullid nullid2
992 set kids
$children($vp)
993 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
994 set id
[lindex
$kids $i]
995 if {$id ne
$nullid && $id ne
$nullid2} {
1002 proc vtokcmp
{v a b
} {
1003 global varctok varcid
1005 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1006 [lindex
$varctok($v) $varcid($v,$b)]]
1009 # This assumes that if lim is not given, the caller has checked that
1010 # arc a's token is less than $vtokmod($v)
1011 proc modify_arc
{v a
{lim
{}}} {
1012 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1015 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
1018 set r
[lindex
$varcrow($v) $a]
1019 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
1022 set vtokmod
($v) [lindex
$varctok($v) $a]
1024 if {$v == $curview} {
1025 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
1026 set a
[lindex
$vupptr($v) $a]
1032 set lim
[llength
$varccommits($v,$a)]
1034 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1041 proc update_arcrows
{v
} {
1042 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1043 global varcid vrownum varcorder varcix varccommits
1044 global vupptr vdownptr vleftptr varctok
1045 global displayorder parentlist curview cached_commitrow
1047 if {$vrowmod($v) == $commitidx($v)} return
1048 if {$v == $curview} {
1049 if {[llength
$displayorder] > $vrowmod($v)} {
1050 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1051 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1053 catch
{unset cached_commitrow
}
1055 set narctot
[expr {[llength
$varctok($v)] - 1}]
1057 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1058 # go up the tree until we find something that has a row number,
1059 # or we get to a seed
1060 set a
[lindex
$vupptr($v) $a]
1063 set a
[lindex
$vdownptr($v) 0]
1066 set varcorder
($v) [list
$a]
1067 lset varcix
($v) $a 0
1068 lset varcrow
($v) $a 0
1072 set arcn
[lindex
$varcix($v) $a]
1073 if {[llength
$vrownum($v)] > $arcn + 1} {
1074 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1075 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1077 set row
[lindex
$varcrow($v) $a]
1081 incr row
[llength
$varccommits($v,$a)]
1082 # go down if possible
1083 set b
[lindex
$vdownptr($v) $a]
1085 # if not, go left, or go up until we can go left
1087 set b
[lindex
$vleftptr($v) $a]
1089 set a
[lindex
$vupptr($v) $a]
1095 lappend vrownum
($v) $row
1096 lappend varcorder
($v) $a
1097 lset varcix
($v) $a $arcn
1098 lset varcrow
($v) $a $row
1100 set vtokmod
($v) [lindex
$varctok($v) $p]
1102 set vrowmod
($v) $row
1103 if {[info exists currentid
]} {
1104 set selectedline
[rowofcommit
$currentid]
1108 # Test whether view $v contains commit $id
1109 proc commitinview
{id v
} {
1112 return [info exists varcid
($v,$id)]
1115 # Return the row number for commit $id in the current view
1116 proc rowofcommit
{id
} {
1117 global varcid varccommits varcrow curview cached_commitrow
1118 global varctok vtokmod
1121 if {![info exists varcid
($v,$id)]} {
1122 puts
"oops rowofcommit no arc for [shortids $id]"
1125 set a
$varcid($v,$id)
1126 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1129 if {[info exists cached_commitrow
($id)]} {
1130 return $cached_commitrow($id)
1132 set i
[lsearch
-exact $varccommits($v,$a) $id]
1134 puts
"oops didn't find commit [shortids $id] in arc $a"
1137 incr i
[lindex
$varcrow($v) $a]
1138 set cached_commitrow
($id) $i
1142 # Returns 1 if a is on an earlier row than b, otherwise 0
1143 proc comes_before
{a b
} {
1144 global varcid varctok curview
1147 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1148 ![info exists varcid
($v,$b)]} {
1151 if {$varcid($v,$a) != $varcid($v,$b)} {
1152 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1153 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1155 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1158 proc bsearch
{l elt
} {
1159 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1164 while {$hi - $lo > 1} {
1165 set mid
[expr {int
(($lo + $hi) / 2)}]
1166 set t
[lindex
$l $mid]
1169 } elseif
{$elt > $t} {
1178 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1179 proc make_disporder
{start end
} {
1180 global vrownum curview commitidx displayorder parentlist
1181 global varccommits varcorder parents vrowmod varcrow
1182 global d_valid_start d_valid_end
1184 if {$end > $vrowmod($curview)} {
1185 update_arcrows
$curview
1187 set ai
[bsearch
$vrownum($curview) $start]
1188 set start
[lindex
$vrownum($curview) $ai]
1189 set narc
[llength
$vrownum($curview)]
1190 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1191 set a
[lindex
$varcorder($curview) $ai]
1192 set l
[llength
$displayorder]
1193 set al
[llength
$varccommits($curview,$a)]
1194 if {$l < $r + $al} {
1196 set pad
[ntimes
[expr {$r - $l}] {}]
1197 set displayorder
[concat
$displayorder $pad]
1198 set parentlist
[concat
$parentlist $pad]
1199 } elseif
{$l > $r} {
1200 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1201 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1203 foreach id
$varccommits($curview,$a) {
1204 lappend displayorder
$id
1205 lappend parentlist
$parents($curview,$id)
1207 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1209 foreach id
$varccommits($curview,$a) {
1210 lset displayorder
$i $id
1211 lset parentlist
$i $parents($curview,$id)
1219 proc commitonrow
{row
} {
1222 set id
[lindex
$displayorder $row]
1224 make_disporder
$row [expr {$row + 1}]
1225 set id
[lindex
$displayorder $row]
1230 proc closevarcs
{v
} {
1231 global varctok varccommits varcid parents children
1232 global cmitlisted commitidx commitinterest vtokmod
1234 set missing_parents
0
1236 set narcs
[llength
$varctok($v)]
1237 for {set a
1} {$a < $narcs} {incr a
} {
1238 set id
[lindex
$varccommits($v,$a) end
]
1239 foreach p
$parents($v,$id) {
1240 if {[info exists varcid
($v,$p)]} continue
1241 # add p as a new commit
1242 incr missing_parents
1243 set cmitlisted
($v,$p) 0
1244 set parents
($v,$p) {}
1245 if {[llength
$children($v,$p)] == 1 &&
1246 [llength
$parents($v,$id)] == 1} {
1249 set b
[newvarc
$v $p]
1251 set varcid
($v,$p) $b
1252 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1255 lappend varccommits
($v,$b) $p
1257 if {[info exists commitinterest
($p)]} {
1258 foreach
script $commitinterest($p) {
1259 lappend scripts
[string map
[list
"%I" $p] $script]
1261 unset commitinterest
($id)
1265 if {$missing_parents > 0} {
1266 foreach s
$scripts {
1272 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1273 # Assumes we already have an arc for $rwid.
1274 proc rewrite_commit
{v id rwid
} {
1275 global children parents varcid varctok vtokmod varccommits
1277 foreach ch
$children($v,$id) {
1278 # make $rwid be $ch's parent in place of $id
1279 set i
[lsearch
-exact $parents($v,$ch) $id]
1281 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1283 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1284 # add $ch to $rwid's children and sort the list if necessary
1285 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1286 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1287 $children($v,$rwid)]
1289 # fix the graph after joining $id to $rwid
1290 set a
$varcid($v,$ch)
1291 fix_reversal
$rwid $a $v
1292 # parentlist is wrong for the last element of arc $a
1293 # even if displayorder is right, hence the 3rd arg here
1294 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1298 proc getcommitlines
{fd inst view updating
} {
1299 global cmitlisted commitinterest leftover
1300 global commitidx commitdata vdatemode
1301 global parents children curview hlview
1302 global idpending ordertok
1303 global varccommits varcid varctok vtokmod vfilelimit
1305 set stuff
[read $fd 500000]
1306 # git log doesn't terminate the last commit with a null...
1307 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1314 global commfd viewcomplete viewactive viewname
1315 global viewinstances
1317 set i
[lsearch
-exact $viewinstances($view) $inst]
1319 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1321 # set it blocking so we wait for the process to terminate
1322 fconfigure
$fd -blocking 1
1323 if {[catch
{close
$fd} err
]} {
1325 if {$view != $curview} {
1326 set fv
" for the \"$viewname($view)\" view"
1328 if {[string range
$err 0 4] == "usage"} {
1329 set err
"Gitk: error reading commits$fv:\
1330 bad arguments to git log."
1331 if {$viewname($view) eq
"Command line"} {
1333 " (Note: arguments to gitk are passed to git log\
1334 to allow selection of commits to be displayed.)"
1337 set err
"Error reading commits$fv: $err"
1341 if {[incr viewactive
($view) -1] <= 0} {
1342 set viewcomplete
($view) 1
1343 # Check if we have seen any ids listed as parents that haven't
1344 # appeared in the list
1348 if {$view == $curview} {
1357 set i
[string first
"\0" $stuff $start]
1359 append leftover
($inst) [string range
$stuff $start end
]
1363 set cmit
$leftover($inst)
1364 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1365 set leftover
($inst) {}
1367 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1369 set start
[expr {$i + 1}]
1370 set j
[string first
"\n" $cmit]
1373 if {$j >= 0 && [string match
"commit *" $cmit]} {
1374 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1375 if {[string match
{[-^
<>]*} $ids]} {
1376 switch
-- [string index
$ids 0] {
1382 set ids
[string range
$ids 1 end
]
1386 if {[string length
$id] != 40} {
1394 if {[string length
$shortcmit] > 80} {
1395 set shortcmit
"[string range $shortcmit 0 80]..."
1397 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1400 set id [lindex $ids 0]
1403 if {!$listed && $updating && ![info exists varcid($vid)] &&
1404 $vfilelimit($view) ne {}} {
1405 # git log doesn't rewrite parents
for unlisted commits
1406 # when doing path limiting, so work around that here
1407 # by working out the rewritten parent with git rev-list
1408 # and if we already know about it, using the rewritten
1409 # parent as a substitute parent for $id's children.
1411 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1412 $id -- $vfilelimit($view)]
1414 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1415 # use $rwid in place of $id
1416 rewrite_commit
$view $id $rwid
1423 if {[info exists varcid
($vid)]} {
1424 if {$cmitlisted($vid) ||
!$listed} continue
1428 set olds
[lrange
$ids 1 end
]
1432 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1433 set cmitlisted
($vid) $listed
1434 set parents
($vid) $olds
1435 if {![info exists children
($vid)]} {
1436 set children
($vid) {}
1437 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1438 set k
[lindex
$children($vid) 0]
1439 if {[llength
$parents($view,$k)] == 1 &&
1440 (!$vdatemode($view) ||
1441 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1442 set a
$varcid($view,$k)
1447 set a
[newvarc
$view $id]
1449 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1452 if {![info exists varcid
($vid)]} {
1454 lappend varccommits
($view,$a) $id
1455 incr commitidx
($view)
1460 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1462 if {[llength
[lappend children
($vp) $id]] > 1 &&
1463 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1464 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1466 catch
{unset ordertok
}
1468 if {[info exists varcid
($view,$p)]} {
1469 fix_reversal
$p $a $view
1475 if {[info exists commitinterest
($id)]} {
1476 foreach
script $commitinterest($id) {
1477 lappend scripts
[string map
[list
"%I" $id] $script]
1479 unset commitinterest
($id)
1484 global numcommits hlview
1486 if {$view == $curview} {
1487 set numcommits
$commitidx($view)
1490 if {[info exists hlview
] && $view == $hlview} {
1491 # we never actually get here...
1494 foreach s
$scripts {
1501 proc chewcommits
{} {
1502 global curview hlview viewcomplete
1503 global pending_select
1506 if {$viewcomplete($curview)} {
1507 global commitidx varctok
1508 global numcommits startmsecs
1510 if {[info exists pending_select
]} {
1512 reset_pending_select
{}
1514 if {[commitinview
$pending_select $curview]} {
1515 selectline
[rowofcommit
$pending_select] 1
1517 set row
[first_real_row
]
1521 if {$commitidx($curview) > 0} {
1522 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1523 #puts "overall $ms ms for $numcommits commits"
1524 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1526 show_status
[mc
"No commits selected"]
1533 proc readcommit
{id
} {
1534 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1535 parsecommit
$id $contents 0
1538 proc parsecommit
{id contents listed
} {
1539 global commitinfo cdate
1548 set hdrend
[string first
"\n\n" $contents]
1550 # should never happen...
1551 set hdrend
[string length
$contents]
1553 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1554 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1555 foreach line
[split $header "\n"] {
1556 set tag
[lindex
$line 0]
1557 if {$tag == "author"} {
1558 set audate
[lindex
$line end-1
]
1559 set auname
[lrange
$line 1 end-2
]
1560 } elseif
{$tag == "committer"} {
1561 set comdate
[lindex
$line end-1
]
1562 set comname
[lrange
$line 1 end-2
]
1566 # take the first non-blank line of the comment as the headline
1567 set headline
[string trimleft
$comment]
1568 set i
[string first
"\n" $headline]
1570 set headline
[string range
$headline 0 $i]
1572 set headline
[string trimright
$headline]
1573 set i
[string first
"\r" $headline]
1575 set headline
[string trimright
[string range
$headline 0 $i]]
1578 # git log indents the comment by 4 spaces;
1579 # if we got this via git cat-file, add the indentation
1581 foreach line
[split $comment "\n"] {
1582 append newcomment
" "
1583 append newcomment
$line
1584 append newcomment
"\n"
1586 set comment
$newcomment
1588 if {$comdate != {}} {
1589 set cdate
($id) $comdate
1591 set commitinfo
($id) [list
$headline $auname $audate \
1592 $comname $comdate $comment]
1595 proc getcommit
{id
} {
1596 global commitdata commitinfo
1598 if {[info exists commitdata
($id)]} {
1599 parsecommit
$id $commitdata($id) 1
1602 if {![info exists commitinfo
($id)]} {
1603 set commitinfo
($id) [list
[mc
"No commit information available"]]
1610 global tagids idtags headids idheads tagobjid
1611 global otherrefids idotherrefs mainhead mainheadid
1613 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1616 set refd
[open
[list | git show-ref
-d] r
]
1617 while {[gets
$refd line
] >= 0} {
1618 if {[string index
$line 40] ne
" "} continue
1619 set id
[string range
$line 0 39]
1620 set ref
[string range
$line 41 end
]
1621 if {![string match
"refs/*" $ref]} continue
1622 set name
[string range
$ref 5 end
]
1623 if {[string match
"remotes/*" $name]} {
1624 if {![string match
"*/HEAD" $name]} {
1625 set headids
($name) $id
1626 lappend idheads
($id) $name
1628 } elseif
{[string match
"heads/*" $name]} {
1629 set name
[string range
$name 6 end
]
1630 set headids
($name) $id
1631 lappend idheads
($id) $name
1632 } elseif
{[string match
"tags/*" $name]} {
1633 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1634 # which is what we want since the former is the commit ID
1635 set name
[string range
$name 5 end
]
1636 if {[string match
"*^{}" $name]} {
1637 set name
[string range
$name 0 end-3
]
1639 set tagobjid
($name) $id
1641 set tagids
($name) $id
1642 lappend idtags
($id) $name
1644 set otherrefids
($name) $id
1645 lappend idotherrefs
($id) $name
1652 set mainheadid
[exec git rev-parse HEAD
]
1653 set thehead
[exec git symbolic-ref HEAD
]
1654 if {[string match
"refs/heads/*" $thehead]} {
1655 set mainhead
[string range
$thehead 11 end
]
1660 # skip over fake commits
1661 proc first_real_row
{} {
1662 global nullid nullid2 numcommits
1664 for {set row
0} {$row < $numcommits} {incr row
} {
1665 set id
[commitonrow
$row]
1666 if {$id ne
$nullid && $id ne
$nullid2} {
1673 # update things for a head moved to a child of its previous location
1674 proc movehead
{id name
} {
1675 global headids idheads
1677 removehead
$headids($name) $name
1678 set headids
($name) $id
1679 lappend idheads
($id) $name
1682 # update things when a head has been removed
1683 proc removehead
{id name
} {
1684 global headids idheads
1686 if {$idheads($id) eq
$name} {
1689 set i
[lsearch
-exact $idheads($id) $name]
1691 set idheads
($id) [lreplace
$idheads($id) $i $i]
1694 unset headids
($name)
1697 proc show_error
{w top msg
} {
1698 message
$w.m
-text $msg -justify center
-aspect 400
1699 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1700 button
$w.ok
-text [mc OK
] -command "destroy $top"
1701 pack
$w.ok
-side bottom
-fill x
1702 bind $top <Visibility
> "grab $top; focus $top"
1703 bind $top <Key-Return
> "destroy $top"
1707 proc error_popup msg
{
1711 show_error
$w $w $msg
1714 proc confirm_popup msg
{
1720 message
$w.m
-text $msg -justify center
-aspect 400
1721 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1722 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1723 pack
$w.ok
-side left
-fill x
1724 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1725 pack
$w.cancel
-side right
-fill x
1726 bind $w <Visibility
> "grab $w; focus $w"
1731 proc setoptions
{} {
1732 option add
*Panedwindow.showHandle
1 startupFile
1733 option add
*Panedwindow.sashRelief raised startupFile
1734 option add
*Button.font uifont startupFile
1735 option add
*Checkbutton.font uifont startupFile
1736 option add
*Radiobutton.font uifont startupFile
1737 option add
*Menu.font uifont startupFile
1738 option add
*Menubutton.font uifont startupFile
1739 option add
*Label.font uifont startupFile
1740 option add
*Message.font uifont startupFile
1741 option add
*Entry.font uifont startupFile
1744 proc makewindow
{} {
1745 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1747 global findtype findtypemenu findloc findstring fstring geometry
1748 global entries sha1entry sha1string sha1but
1749 global diffcontextstring diffcontext
1751 global maincursor textcursor curtextcursor
1752 global rowctxmenu fakerowmenu mergemax wrapcomment
1753 global highlight_files gdttype
1754 global searchstring sstring
1755 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1756 global headctxmenu progresscanv progressitem progresscoords statusw
1757 global fprogitem fprogcoord lastprogupdate progupdatepending
1758 global rprogitem rprogcoord rownumsel numcommits
1762 .bar add cascade
-label [mc
"File"] -menu .bar.
file
1764 .bar.
file add
command -label [mc
"Update"] -command updatecommits
1765 .bar.
file add
command -label [mc
"Reload"] -command reloadcommits
1766 .bar.
file add
command -label [mc
"Reread references"] -command rereadrefs
1767 .bar.
file add
command -label [mc
"List references"] -command showrefs
1768 .bar.
file add
command -label [mc
"Quit"] -command doquit
1770 .bar add cascade
-label [mc
"Edit"] -menu .bar.edit
1771 .bar.edit add
command -label [mc
"Preferences"] -command doprefs
1774 .bar add cascade
-label [mc
"View"] -menu .bar.view
1775 .bar.view add
command -label [mc
"New view..."] -command {newview
0}
1776 .bar.view add
command -label [mc
"Edit view..."] -command editview \
1778 .bar.view add
command -label [mc
"Delete view"] -command delview
-state disabled
1779 .bar.view add separator
1780 .bar.view add radiobutton
-label [mc
"All files"] -command {showview
0} \
1781 -variable selectedview
-value 0
1784 .bar add cascade
-label [mc
"Help"] -menu .bar.
help
1785 .bar.
help add
command -label [mc
"About gitk"] -command about
1786 .bar.
help add
command -label [mc
"Key bindings"] -command keys
1788 . configure
-menu .bar
1790 # the gui has upper and lower half, parts of a paned window.
1791 panedwindow .ctop
-orient vertical
1793 # possibly use assumed geometry
1794 if {![info exists geometry
(pwsash0
)]} {
1795 set geometry
(topheight
) [expr {15 * $linespc}]
1796 set geometry
(topwidth
) [expr {80 * $charspc}]
1797 set geometry
(botheight
) [expr {15 * $linespc}]
1798 set geometry
(botwidth
) [expr {50 * $charspc}]
1799 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1800 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1803 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1804 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1806 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1808 # create three canvases
1809 set cscroll .tf.histframe.csb
1810 set canv .tf.histframe.pwclist.canv
1812 -selectbackground $selectbgcolor \
1813 -background $bgcolor -bd 0 \
1814 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1815 .tf.histframe.pwclist add
$canv
1816 set canv2 .tf.histframe.pwclist.canv2
1818 -selectbackground $selectbgcolor \
1819 -background $bgcolor -bd 0 -yscrollincr $linespc
1820 .tf.histframe.pwclist add
$canv2
1821 set canv3 .tf.histframe.pwclist.canv3
1823 -selectbackground $selectbgcolor \
1824 -background $bgcolor -bd 0 -yscrollincr $linespc
1825 .tf.histframe.pwclist add
$canv3
1826 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1827 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1829 # a scroll bar to rule them
1830 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1831 pack
$cscroll -side right
-fill y
1832 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1833 lappend bglist
$canv $canv2 $canv3
1834 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1836 # we have two button bars at bottom of top frame. Bar 1
1838 frame .tf.lbar
-height 15
1840 set sha1entry .tf.bar.sha1
1841 set entries
$sha1entry
1842 set sha1but .tf.bar.sha1label
1843 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
1844 -command gotocommit
-width 8
1845 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1846 pack .tf.bar.sha1label
-side left
1847 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1848 trace add variable sha1string
write sha1change
1849 pack
$sha1entry -side left
-pady 2
1851 image create bitmap bm-left
-data {
1852 #define left_width 16
1853 #define left_height 16
1854 static unsigned char left_bits
[] = {
1855 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1856 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1857 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1859 image create bitmap bm-right
-data {
1860 #define right_width 16
1861 #define right_height 16
1862 static unsigned char right_bits
[] = {
1863 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1864 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1865 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1867 button .tf.bar.leftbut
-image bm-left
-command goback \
1868 -state disabled
-width 26
1869 pack .tf.bar.leftbut
-side left
-fill y
1870 button .tf.bar.rightbut
-image bm-right
-command goforw \
1871 -state disabled
-width 26
1872 pack .tf.bar.rightbut
-side left
-fill y
1874 label .tf.bar.rowlabel
-text [mc
"Row"]
1876 label .tf.bar.rownum
-width 7 -font textfont
-textvariable rownumsel \
1877 -relief sunken
-anchor e
1878 label .tf.bar.rowlabel2
-text "/"
1879 label .tf.bar.numcommits
-width 7 -font textfont
-textvariable numcommits \
1880 -relief sunken
-anchor e
1881 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1884 trace add variable selectedline
write selectedline_change
1886 # Status label and progress bar
1887 set statusw .tf.bar.status
1888 label
$statusw -width 15 -relief sunken
1889 pack
$statusw -side left
-padx 5
1890 set h
[expr {[font metrics uifont
-linespace] + 2}]
1891 set progresscanv .tf.bar.progress
1892 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1893 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1894 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1895 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1896 pack
$progresscanv -side right
-expand 1 -fill x
1897 set progresscoords
{0 0}
1900 bind $progresscanv <Configure
> adjustprogress
1901 set lastprogupdate
[clock clicks
-milliseconds]
1902 set progupdatepending
0
1904 # build up the bottom bar of upper window
1905 label .tf.lbar.flabel
-text "[mc "Find
"] "
1906 button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
1907 button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
1908 label .tf.lbar.flab2
-text " [mc "commit
"] "
1909 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1911 set gdttype
[mc
"containing:"]
1912 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1913 [mc
"containing:"] \
1914 [mc
"touching paths:"] \
1915 [mc
"adding/removing string:"]]
1916 trace add variable gdttype
write gdttype_change
1917 pack .tf.lbar.gdttype
-side left
-fill y
1920 set fstring .tf.lbar.findstring
1921 lappend entries
$fstring
1922 entry
$fstring -width 30 -font textfont
-textvariable findstring
1923 trace add variable findstring
write find_change
1924 set findtype
[mc
"Exact"]
1925 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1926 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
1927 trace add variable findtype
write findcom_change
1928 set findloc
[mc
"All fields"]
1929 tk_optionMenu .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
1930 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
1931 trace add variable findloc
write find_change
1932 pack .tf.lbar.findloc
-side right
1933 pack .tf.lbar.findtype
-side right
1934 pack
$fstring -side left
-expand 1 -fill x
1936 # Finish putting the upper half of the viewer together
1937 pack .tf.lbar
-in .tf
-side bottom
-fill x
1938 pack .tf.bar
-in .tf
-side bottom
-fill x
1939 pack .tf.histframe
-fill both
-side top
-expand 1
1941 .ctop paneconfigure .tf
-height $geometry(topheight
)
1942 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1944 # now build up the bottom
1945 panedwindow .pwbottom
-orient horizontal
1947 # lower left, a text box over search bar, scroll bar to the right
1948 # if we know window height, then that will set the lower text height, otherwise
1949 # we set lower text height which will drive window height
1950 if {[info exists geometry
(main
)]} {
1951 frame .bleft
-width $geometry(botwidth
)
1953 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
1959 button .bleft.top.search
-text [mc
"Search"] -command dosearch
1960 pack .bleft.top.search
-side left
-padx 5
1961 set sstring .bleft.top.sstring
1962 entry
$sstring -width 20 -font textfont
-textvariable searchstring
1963 lappend entries
$sstring
1964 trace add variable searchstring
write incrsearch
1965 pack
$sstring -side left
-expand 1 -fill x
1966 radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
1967 -command changediffdisp
-variable diffelide
-value {0 0}
1968 radiobutton .bleft.mid.old
-text [mc
"Old version"] \
1969 -command changediffdisp
-variable diffelide
-value {0 1}
1970 radiobutton .bleft.mid.new
-text [mc
"New version"] \
1971 -command changediffdisp
-variable diffelide
-value {1 0}
1972 label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
1973 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
1974 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
1975 -from 1 -increment 1 -to 10000000 \
1976 -validate all
-validatecommand "diffcontextvalidate %P" \
1977 -textvariable diffcontextstring
1978 .bleft.mid.diffcontext
set $diffcontext
1979 trace add variable diffcontextstring
write diffcontextchange
1980 lappend entries .bleft.mid.diffcontext
1981 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
1982 checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
1983 -command changeignorespace
-variable ignorespace
1984 pack .bleft.mid.ignspace
-side left
-padx 5
1985 set ctext .bleft.bottom.ctext
1986 text
$ctext -background $bgcolor -foreground $fgcolor \
1987 -state disabled
-font textfont \
1988 -yscrollcommand scrolltext
-wrap none \
1989 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1991 $ctext conf
-tabstyle wordprocessor
1993 scrollbar .bleft.bottom.sb
-command "$ctext yview"
1994 scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h \
1996 pack .bleft.top
-side top
-fill x
1997 pack .bleft.mid
-side top
-fill x
1998 grid
$ctext .bleft.bottom.sb
-sticky nsew
1999 grid .bleft.bottom.sbhorizontal
-sticky ew
2000 grid columnconfigure .bleft.bottom
0 -weight 1
2001 grid rowconfigure .bleft.bottom
0 -weight 1
2002 grid rowconfigure .bleft.bottom
1 -weight 0
2003 pack .bleft.bottom
-side top
-fill both
-expand 1
2004 lappend bglist
$ctext
2005 lappend fglist
$ctext
2007 $ctext tag conf comment
-wrap $wrapcomment
2008 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
2009 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
2010 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
2011 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
2012 $ctext tag conf m0
-fore red
2013 $ctext tag conf m1
-fore blue
2014 $ctext tag conf m2
-fore green
2015 $ctext tag conf m3
-fore purple
2016 $ctext tag conf
m4 -fore brown
2017 $ctext tag conf m5
-fore "#009090"
2018 $ctext tag conf m6
-fore magenta
2019 $ctext tag conf m7
-fore "#808000"
2020 $ctext tag conf m8
-fore "#009000"
2021 $ctext tag conf m9
-fore "#ff0080"
2022 $ctext tag conf m10
-fore cyan
2023 $ctext tag conf m11
-fore "#b07070"
2024 $ctext tag conf m12
-fore "#70b0f0"
2025 $ctext tag conf m13
-fore "#70f0b0"
2026 $ctext tag conf m14
-fore "#f0b070"
2027 $ctext tag conf m15
-fore "#ff70b0"
2028 $ctext tag conf mmax
-fore darkgrey
2030 $ctext tag conf mresult
-font textfontbold
2031 $ctext tag conf msep
-font textfontbold
2032 $ctext tag conf found
-back yellow
2034 .pwbottom add .bleft
2035 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2040 radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2041 -command reselectline
-variable cmitmode
-value "patch"
2042 radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2043 -command reselectline
-variable cmitmode
-value "tree"
2044 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2045 pack .bright.mode
-side top
-fill x
2046 set cflist .bright.cfiles
2047 set indent
[font measure mainfont
"nn"]
2049 -selectbackground $selectbgcolor \
2050 -background $bgcolor -foreground $fgcolor \
2052 -tabs [list
$indent [expr {2 * $indent}]] \
2053 -yscrollcommand ".bright.sb set" \
2054 -cursor [. cget
-cursor] \
2055 -spacing1 1 -spacing3 1
2056 lappend bglist
$cflist
2057 lappend fglist
$cflist
2058 scrollbar .bright.sb
-command "$cflist yview"
2059 pack .bright.sb
-side right
-fill y
2060 pack
$cflist -side left
-fill both
-expand 1
2061 $cflist tag configure highlight \
2062 -background [$cflist cget
-selectbackground]
2063 $cflist tag configure bold
-font mainfontbold
2065 .pwbottom add .bright
2068 # restore window width & height if known
2069 if {[info exists geometry
(main
)]} {
2070 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2071 if {$w > [winfo screenwidth .
]} {
2072 set w
[winfo screenwidth .
]
2074 if {$h > [winfo screenheight .
]} {
2075 set h
[winfo screenheight .
]
2077 wm geometry .
"${w}x$h"
2081 if {[tk windowingsystem
] eq
{aqua
}} {
2087 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2088 pack .ctop
-fill both
-expand 1
2089 bindall
<1> {selcanvline
%W
%x
%y
}
2090 #bindall <B1-Motion> {selcanvline %W %x %y}
2091 if {[tk windowingsystem
] == "win32"} {
2092 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2093 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2095 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2096 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2097 if {[tk windowingsystem
] eq
"aqua"} {
2098 bindall
<MouseWheel
> {
2099 set delta
[expr {- (%D
)}]
2100 allcanvs yview scroll
$delta units
2104 bindall
<2> "canvscan mark %W %x %y"
2105 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
2106 bindkey
<Home
> selfirstline
2107 bindkey
<End
> sellastline
2108 bind .
<Key-Up
> "selnextline -1"
2109 bind .
<Key-Down
> "selnextline 1"
2110 bind .
<Shift-Key-Up
> "dofind -1 0"
2111 bind .
<Shift-Key-Down
> "dofind 1 0"
2112 bindkey
<Key-Right
> "goforw"
2113 bindkey
<Key-Left
> "goback"
2114 bind .
<Key-Prior
> "selnextpage -1"
2115 bind .
<Key-Next
> "selnextpage 1"
2116 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2117 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2118 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2119 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2120 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2121 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2122 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2123 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2124 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2125 bindkey p
"selnextline -1"
2126 bindkey n
"selnextline 1"
2129 bindkey i
"selnextline -1"
2130 bindkey k
"selnextline 1"
2134 bindkey d
"$ctext yview scroll 18 units"
2135 bindkey u
"$ctext yview scroll -18 units"
2136 bindkey
/ {dofind
1 1}
2137 bindkey
<Key-Return
> {dofind
1 1}
2138 bindkey ?
{dofind
-1 1}
2140 bindkey
<F5
> updatecommits
2141 bind .
<$M1B-q> doquit
2142 bind .
<$M1B-f> {dofind
1 1}
2143 bind .
<$M1B-g> {dofind
1 0}
2144 bind .
<$M1B-r> dosearchback
2145 bind .
<$M1B-s> dosearch
2146 bind .
<$M1B-equal> {incrfont
1}
2147 bind .
<$M1B-plus> {incrfont
1}
2148 bind .
<$M1B-KP_Add> {incrfont
1}
2149 bind .
<$M1B-minus> {incrfont
-1}
2150 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2151 wm protocol . WM_DELETE_WINDOW doquit
2152 bind .
<Destroy
> {stop_backends
}
2153 bind .
<Button-1
> "click %W"
2154 bind $fstring <Key-Return
> {dofind
1 1}
2155 bind $sha1entry <Key-Return
> gotocommit
2156 bind $sha1entry <<PasteSelection>> clearsha1
2157 bind $cflist <1> {sel_flist %W %x %y; break}
2158 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2159 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2160 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
2162 set maincursor [. cget -cursor]
2163 set textcursor [$ctext cget -cursor]
2164 set curtextcursor $textcursor
2166 set rowctxmenu .rowctxmenu
2167 menu $rowctxmenu -tearoff 0
2168 $rowctxmenu add command -label [mc "Diff this -> selected"] \
2169 -command {diffvssel 0}
2170 $rowctxmenu add command -label [mc "Diff selected -> this"] \
2171 -command {diffvssel 1}
2172 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2173 $rowctxmenu add command -label [mc "Create tag"] -command mktag
2174 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2175 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2176 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2178 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2181 set fakerowmenu .fakerowmenu
2182 menu $fakerowmenu -tearoff 0
2183 $fakerowmenu add command -label [mc "Diff this -> selected"] \
2184 -command {diffvssel 0}
2185 $fakerowmenu add command -label [mc "Diff selected -> this"] \
2186 -command {diffvssel 1}
2187 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2188 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2189 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2190 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2192 set headctxmenu .headctxmenu
2193 menu $headctxmenu -tearoff 0
2194 $headctxmenu add command -label [mc "Check out this branch"] \
2196 $headctxmenu add command -label [mc "Remove this branch"] \
2200 set flist_menu .flistctxmenu
2201 menu $flist_menu -tearoff 0
2202 $flist_menu add command -label [mc "Highlight this too"] \
2203 -command {flist_hl 0}
2204 $flist_menu add command -label [mc "Highlight this only"] \
2205 -command {flist_hl 1}
2206 $flist_menu add command -label [mc "External diff"] \
2207 -command {external_diff}
2210 # Windows sends all mouse wheel events to the current focused window, not
2211 # the one where the mouse hovers, so bind those events here and redirect
2212 # to the correct window
2213 proc windows_mousewheel_redirector {W X Y D} {
2214 global canv canv2 canv3
2215 set w [winfo containing -displayof $W $X $Y]
2217 set u [expr {$D < 0 ? 5 : -5}]
2218 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2219 allcanvs yview scroll $u units
2222 $w yview scroll $u units
2228 # Update row number label when selectedline changes
2229 proc selectedline_change {n1 n2 op} {
2230 global selectedline rownumsel
2232 if {$selectedline eq {}} {
2235 set rownumsel [expr {$selectedline + 1}]
2239 # mouse-2 makes all windows scan vertically, but only the one
2240 # the cursor is in scans horizontally
2241 proc canvscan {op w x y} {
2242 global canv canv2 canv3
2243 foreach c [list $canv $canv2 $canv3] {
2252 proc scrollcanv {cscroll f0 f1} {
2253 $cscroll set $f0 $f1
2258 # when we make a key binding for the toplevel, make sure
2259 # it doesn't get triggered when that key is pressed in the
2260 # find string entry widget.
2261 proc bindkey {ev script} {
2264 set escript [bind Entry $ev]
2265 if {$escript == {}} {
2266 set escript [bind Entry <Key>]
2268 foreach e $entries {
2269 bind $e $ev "$escript; break"
2273 # set the focus back to the toplevel for any click outside
2276 global ctext entries
2277 foreach e [concat $entries $ctext] {
2278 if {$w == $e} return
2283 # Adjust the progress bar for a change in requested extent or canvas size
2284 proc adjustprogress {} {
2285 global progresscanv progressitem progresscoords
2286 global fprogitem fprogcoord lastprogupdate progupdatepending
2287 global rprogitem rprogcoord
2289 set w [expr {[winfo width $progresscanv] - 4}]
2290 set x0 [expr {$w * [lindex $progresscoords 0]}]
2291 set x1 [expr {$w * [lindex $progresscoords 1]}]
2292 set h [winfo height $progresscanv]
2293 $progresscanv coords $progressitem $x0 0 $x1 $h
2294 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2295 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2296 set now [clock clicks -milliseconds]
2297 if {$now >= $lastprogupdate + 100} {
2298 set progupdatepending 0
2300 } elseif {!$progupdatepending} {
2301 set progupdatepending 1
2302 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2306 proc doprogupdate {} {
2307 global lastprogupdate progupdatepending
2309 if {$progupdatepending} {
2310 set progupdatepending 0
2311 set lastprogupdate [clock clicks -milliseconds]
2316 proc savestuff {w} {
2317 global canv canv2 canv3 mainfont textfont uifont tabstop
2318 global stuffsaved findmergefiles maxgraphpct
2319 global maxwidth showneartags showlocalchanges
2320 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2321 global cmitmode wrapcomment datetimeformat limitdiffs
2322 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2323 global autoselect extdifftool
2325 if {$stuffsaved} return
2326 if {![winfo viewable .]} return
2328 set f [open "~/.gitk-new" w]
2329 puts $f [list set mainfont $mainfont]
2330 puts $f [list set textfont $textfont]
2331 puts $f [list set uifont $uifont]
2332 puts $f [list set tabstop $tabstop]
2333 puts $f [list set findmergefiles $findmergefiles]
2334 puts $f [list set maxgraphpct $maxgraphpct]
2335 puts $f [list set maxwidth $maxwidth]
2336 puts $f [list set cmitmode $cmitmode]
2337 puts $f [list set wrapcomment $wrapcomment]
2338 puts $f [list set autoselect $autoselect]
2339 puts $f [list set showneartags $showneartags]
2340 puts $f [list set showlocalchanges $showlocalchanges]
2341 puts $f [list set datetimeformat $datetimeformat]
2342 puts $f [list set limitdiffs $limitdiffs]
2343 puts $f [list set bgcolor $bgcolor]
2344 puts $f [list set fgcolor $fgcolor]
2345 puts $f [list set colors $colors]
2346 puts $f [list set diffcolors $diffcolors]
2347 puts $f [list set diffcontext $diffcontext]
2348 puts $f [list set selectbgcolor $selectbgcolor]
2349 puts $f [list set extdifftool $extdifftool]
2351 puts $f "set geometry(main) [wm geometry .]"
2352 puts $f "set geometry(topwidth) [winfo width .tf]"
2353 puts $f "set geometry(topheight) [winfo height .tf]"
2354 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2355 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2356 puts $f "set geometry(botwidth) [winfo width .bleft]"
2357 puts $f "set geometry(botheight) [winfo height .bleft]"
2359 puts -nonewline $f "set permviews {"
2360 for {set v 0} {$v < $nextviewnum} {incr v} {
2361 if {$viewperm($v)} {
2362 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2367 file rename -force "~/.gitk-new" "~/.gitk"
2372 proc resizeclistpanes {win w} {
2374 if {[info exists oldwidth($win)]} {
2375 set s0 [$win sash coord 0]
2376 set s1 [$win sash coord 1]
2378 set sash0 [expr {int($w/2 - 2)}]
2379 set sash1 [expr {int($w*5/6 - 2)}]
2381 set factor [expr {1.0 * $w / $oldwidth($win)}]
2382 set sash0 [expr {int($factor * [lindex $s0 0])}]
2383 set sash1 [expr {int($factor * [lindex $s1 0])}]
2387 if {$sash1 < $sash0 + 20} {
2388 set sash1 [expr {$sash0 + 20}]
2390 if {$sash1 > $w - 10} {
2391 set sash1 [expr {$w - 10}]
2392 if {$sash0 > $sash1 - 20} {
2393 set sash0 [expr {$sash1 - 20}]
2397 $win sash place 0 $sash0 [lindex $s0 1]
2398 $win sash place 1 $sash1 [lindex $s1 1]
2400 set oldwidth($win) $w
2403 proc resizecdetpanes {win w} {
2405 if {[info exists oldwidth($win)]} {
2406 set s0 [$win sash coord 0]
2408 set sash0 [expr {int($w*3/4 - 2)}]
2410 set factor [expr {1.0 * $w / $oldwidth($win)}]
2411 set sash0 [expr {int($factor * [lindex $s0 0])}]
2415 if {$sash0 > $w - 15} {
2416 set sash0 [expr {$w - 15}]
2419 $win sash place 0 $sash0 [lindex $s0 1]
2421 set oldwidth($win) $w
2424 proc allcanvs args {
2425 global canv canv2 canv3
2431 proc bindall {event action} {
2432 global canv canv2 canv3
2433 bind $canv $event $action
2434 bind $canv2 $event $action
2435 bind $canv3 $event $action
2441 if {[winfo exists $w]} {
2446 wm title $w [mc "About gitk"]
2447 message $w.m -text [mc "
2448 Gitk - a commit viewer for git
2450 Copyright © 2005-2008 Paul Mackerras
2452 Use and redistribute under the terms of the GNU General Public License"] \
2453 -justify center -aspect 400 -border 2 -bg white -relief groove
2454 pack $w.m -side top -fill x -padx 2 -pady 2
2455 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2456 pack $w.ok -side bottom
2457 bind $w <Visibility> "focus $w.ok"
2458 bind $w <Key-Escape> "destroy $w"
2459 bind $w <Key-Return> "destroy $w"
2464 if {[winfo exists $w]} {
2468 if {[tk windowingsystem] eq {aqua}} {
2474 wm title $w [mc "Gitk key bindings"]
2475 message $w.m -text "
2476 [mc "Gitk key bindings:"]
2478 [mc "<%s-Q> Quit" $M1T]
2479 [mc "<Home> Move to first commit"]
2480 [mc "<End> Move to last commit"]
2481 [mc "<Up>, p, i Move up one commit"]
2482 [mc "<Down>, n, k Move down one commit"]
2483 [mc "<Left>, z, j Go back in history list"]
2484 [mc "<Right>, x, l Go forward in history list"]
2485 [mc "<PageUp> Move up one page in commit list"]
2486 [mc "<PageDown> Move down one page in commit list"]
2487 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2488 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2489 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2490 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2491 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2492 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2493 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2494 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2495 [mc "<Delete>, b Scroll diff view up one page"]
2496 [mc "<Backspace> Scroll diff view up one page"]
2497 [mc "<Space> Scroll diff view down one page"]
2498 [mc "u Scroll diff view up 18 lines"]
2499 [mc "d Scroll diff view down 18 lines"]
2500 [mc "<%s-F> Find" $M1T]
2501 [mc "<%s-G> Move to next find hit" $M1T]
2502 [mc "<Return> Move to next find hit"]
2503 [mc "/ Move to next find hit, or redo find"]
2504 [mc "? Move to previous find hit"]
2505 [mc "f Scroll diff view to next file"]
2506 [mc "<%s-S> Search for next hit in diff view" $M1T]
2507 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2508 [mc "<%s-KP+> Increase font size" $M1T]
2509 [mc "<%s-plus> Increase font size" $M1T]
2510 [mc "<%s-KP-> Decrease font size" $M1T]
2511 [mc "<%s-minus> Decrease font size" $M1T]
2514 -justify left -bg white -border 2 -relief groove
2515 pack $w.m -side top -fill both -padx 2 -pady 2
2516 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2517 pack $w.ok -side bottom
2518 bind $w <Visibility> "focus $w.ok"
2519 bind $w <Key-Escape> "destroy $w"
2520 bind $w <Key-Return> "destroy $w"
2523 # Procedures for manipulating the file list window at the
2524 # bottom right of the overall window.
2526 proc treeview {w l openlevs} {
2527 global treecontents treediropen treeheight treeparent treeindex
2537 set treecontents() {}
2538 $w conf -state normal
2540 while {[string range $f 0 $prefixend] ne $prefix} {
2541 if {$lev <= $openlevs} {
2542 $w mark set e:$treeindex($prefix) "end -1c"
2543 $w mark gravity e:$treeindex($prefix) left
2545 set treeheight($prefix) $ht
2546 incr ht [lindex $htstack end]
2547 set htstack [lreplace $htstack end end]
2548 set prefixend [lindex $prefendstack end]
2549 set prefendstack [lreplace $prefendstack end end]
2550 set prefix [string range $prefix 0 $prefixend]
2553 set tail [string range $f [expr {$prefixend+1}] end]
2554 while {[set slash [string first "/" $tail]] >= 0} {
2557 lappend prefendstack $prefixend
2558 incr prefixend [expr {$slash + 1}]
2559 set d [string range $tail 0 $slash]
2560 lappend treecontents($prefix) $d
2561 set oldprefix $prefix
2563 set treecontents($prefix) {}
2564 set treeindex($prefix) [incr ix]
2565 set treeparent($prefix) $oldprefix
2566 set tail [string range $tail [expr {$slash+1}] end]
2567 if {$lev <= $openlevs} {
2569 set treediropen($prefix) [expr {$lev < $openlevs}]
2570 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2571 $w mark set d:$ix "end -1c"
2572 $w mark gravity d:$ix left
2574 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2576 $w image create end -align center -image $bm -padx 1 \
2578 $w insert end $d [highlight_tag $prefix]
2579 $w mark set s:$ix "end -1c"
2580 $w mark gravity s:$ix left
2585 if {$lev <= $openlevs} {
2588 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2590 $w insert end $tail [highlight_tag $f]
2592 lappend treecontents($prefix) $tail
2595 while {$htstack ne {}} {
2596 set treeheight($prefix) $ht
2597 incr ht [lindex $htstack end]
2598 set htstack [lreplace $htstack end end]
2599 set prefixend [lindex $prefendstack end]
2600 set prefendstack [lreplace $prefendstack end end]
2601 set prefix [string range $prefix 0 $prefixend]
2603 $w conf -state disabled
2606 proc linetoelt {l} {
2607 global treeheight treecontents
2612 foreach e $treecontents($prefix) {
2617 if {[string index $e end] eq "/"} {
2618 set n $treeheight($prefix$e)
2630 proc highlight_tree {y prefix} {
2631 global treeheight treecontents cflist
2633 foreach e $treecontents($prefix) {
2635 if {[highlight_tag $path] ne {}} {
2636 $cflist tag add bold $y.0 "$y.0 lineend"
2639 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2640 set y [highlight_tree $y $path]
2646 proc treeclosedir {w dir} {
2647 global treediropen treeheight treeparent treeindex
2649 set ix $treeindex($dir)
2650 $w conf -state normal
2651 $w delete s:$ix e:$ix
2652 set treediropen($dir) 0
2653 $w image configure a:$ix -image tri-rt
2654 $w conf -state disabled
2655 set n [expr {1 - $treeheight($dir)}]
2656 while {$dir ne {}} {
2657 incr treeheight($dir) $n
2658 set dir $treeparent($dir)
2662 proc treeopendir {w dir} {
2663 global treediropen treeheight treeparent treecontents treeindex
2665 set ix $treeindex($dir)
2666 $w conf -state normal
2667 $w image configure a:$ix -image tri-dn
2668 $w mark set e:$ix s:$ix
2669 $w mark gravity e:$ix right
2672 set n [llength $treecontents($dir)]
2673 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2676 incr treeheight($x) $n
2678 foreach e $treecontents($dir) {
2680 if {[string index $e end] eq "/"} {
2681 set iy $treeindex($de)
2682 $w mark set d:$iy e:$ix
2683 $w mark gravity d:$iy left
2684 $w insert e:$ix $str
2685 set treediropen($de) 0
2686 $w image create e:$ix -align center -image tri-rt -padx 1 \
2688 $w insert e:$ix $e [highlight_tag $de]
2689 $w mark set s:$iy e:$ix
2690 $w mark gravity s:$iy left
2691 set treeheight($de) 1
2693 $w insert e:$ix $str
2694 $w insert e:$ix $e [highlight_tag $de]
2697 $w mark gravity e:$ix left
2698 $w conf -state disabled
2699 set treediropen($dir) 1
2700 set top [lindex [split [$w index @0,0] .] 0]
2701 set ht [$w cget -height]
2702 set l [lindex [split [$w index s:$ix] .] 0]
2705 } elseif {$l + $n + 1 > $top + $ht} {
2706 set top [expr {$l + $n + 2 - $ht}]
2714 proc treeclick {w x y} {
2715 global treediropen cmitmode ctext cflist cflist_top
2717 if {$cmitmode ne "tree"} return
2718 if {![info exists cflist_top]} return
2719 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2720 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2721 $cflist tag add highlight $l.0 "$l.0 lineend"
2727 set e [linetoelt $l]
2728 if {[string index $e end] ne "/"} {
2730 } elseif {$treediropen($e)} {
2737 proc setfilelist {id} {
2738 global treefilelist cflist
2740 treeview $cflist $treefilelist($id) 0
2743 image create bitmap tri-rt -background black -foreground blue -data {
2744 #define tri-rt_width 13
2745 #define tri-rt_height 13
2746 static unsigned char tri-rt_bits[] = {
2747 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2748 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2751 #define tri-rt-mask_width 13
2752 #define tri-rt-mask_height 13
2753 static unsigned char tri-rt-mask_bits[] = {
2754 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2755 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2758 image create bitmap tri-dn -background black -foreground blue -data {
2759 #define tri-dn_width 13
2760 #define tri-dn_height 13
2761 static unsigned char tri-dn_bits[] = {
2762 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2763 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2766 #define tri-dn-mask_width 13
2767 #define tri-dn-mask_height 13
2768 static unsigned char tri-dn-mask_bits[] = {
2769 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2770 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2774 image create bitmap reficon-T -background black -foreground yellow -data {
2775 #define tagicon_width 13
2776 #define tagicon_height 9
2777 static unsigned char tagicon_bits[] = {
2778 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2779 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2781 #define tagicon-mask_width 13
2782 #define tagicon-mask_height 9
2783 static unsigned char tagicon-mask_bits[] = {
2784 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2785 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2788 #define headicon_width 13
2789 #define headicon_height 9
2790 static unsigned char headicon_bits[] = {
2791 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2792 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2795 #define headicon-mask_width 13
2796 #define headicon-mask_height 9
2797 static unsigned char headicon-mask_bits[] = {
2798 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2799 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2801 image create bitmap reficon-H -background black -foreground green \
2802 -data $rectdata -maskdata $rectmask
2803 image create bitmap reficon-o -background black -foreground "#ddddff" \
2804 -data $rectdata -maskdata $rectmask
2806 proc init_flist {first} {
2807 global cflist cflist_top difffilestart
2809 $cflist conf -state normal
2810 $cflist delete 0.0 end
2812 $cflist insert end $first
2814 $cflist tag add highlight 1.0 "1.0 lineend"
2816 catch {unset cflist_top}
2818 $cflist conf -state disabled
2819 set difffilestart {}
2822 proc highlight_tag {f} {
2823 global highlight_paths
2825 foreach p $highlight_paths {
2826 if {[string match $p $f]} {
2833 proc highlight_filelist {} {
2834 global cmitmode cflist
2836 $cflist conf -state normal
2837 if {$cmitmode ne "tree"} {
2838 set end [lindex [split [$cflist index end] .] 0]
2839 for {set l 2} {$l < $end} {incr l} {
2840 set line [$cflist get $l.0 "$l.0 lineend"]
2841 if {[highlight_tag $line] ne {}} {
2842 $cflist tag add bold $l.0 "$l.0 lineend"
2848 $cflist conf -state disabled
2851 proc unhighlight_filelist {} {
2854 $cflist conf -state normal
2855 $cflist tag remove bold 1.0 end
2856 $cflist conf -state disabled
2859 proc add_flist {fl} {
2862 $cflist conf -state normal
2864 $cflist insert end "\n"
2865 $cflist insert end $f [highlight_tag $f]
2867 $cflist conf -state disabled
2870 proc sel_flist {w x y} {
2871 global ctext difffilestart cflist cflist_top cmitmode
2873 if {$cmitmode eq "tree"} return
2874 if {![info exists cflist_top]} return
2875 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2876 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2877 $cflist tag add highlight $l.0 "$l.0 lineend"
2882 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2886 proc pop_flist_menu {w X Y x y} {
2887 global ctext cflist cmitmode flist_menu flist_menu_file
2888 global treediffs diffids
2891 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2893 if {$cmitmode eq "tree"} {
2894 set e [linetoelt $l]
2895 if {[string index $e end] eq "/"} return
2897 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2899 set flist_menu_file $e
2900 set xdiffstate "normal"
2901 if {$cmitmode eq "tree"} {
2902 set xdiffstate "disabled"
2904 # Disable "External diff" item in tree mode
2905 $flist_menu entryconf 2 -state $xdiffstate
2906 tk_popup $flist_menu $X $Y
2909 proc flist_hl {only} {
2910 global flist_menu_file findstring gdttype
2912 set x [shellquote $flist_menu_file]
2913 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2916 append findstring " " $x
2918 set gdttype [mc "touching paths:"]
2921 proc save_file_from_commit {filename output what} {
2924 if {[catch {exec git show $filename -- > $output} err]} {
2925 if {[string match "fatal: bad revision *" $err]} {
2928 error_popup "Error getting \"$filename\" from $what: $err"
2934 proc external_diff_get_one_file {diffid filename diffdir} {
2935 global nullid nullid2 nullfile
2938 if {$diffid == $nullid} {
2939 set difffile [file join [file dirname $gitdir] $filename]
2940 if {[file exists $difffile]} {
2945 if {$diffid == $nullid2} {
2946 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2947 return [save_file_from_commit :$filename $difffile index]
2949 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2950 return [save_file_from_commit $diffid:$filename $difffile \
2954 proc external_diff {} {
2955 global gitktmpdir nullid nullid2
2956 global flist_menu_file
2959 global gitdir extdifftool
2961 if {[llength $diffids] == 1} {
2962 # no reference commit given
2963 set diffidto [lindex $diffids 0]
2964 if {$diffidto eq $nullid} {
2965 # diffing working copy with index
2966 set diffidfrom $nullid2
2967 } elseif {$diffidto eq $nullid2} {
2968 # diffing index with HEAD
2969 set diffidfrom "HEAD"
2971 # use first parent commit
2972 global parentlist selectedline
2973 set diffidfrom [lindex $parentlist $selectedline 0]
2976 set diffidfrom [lindex $diffids 0]
2977 set diffidto [lindex $diffids 1]
2980 # make sure that several diffs wont collide
2981 if {![info exists gitktmpdir]} {
2982 set gitktmpdir [file join [file dirname $gitdir] \
2983 [format ".gitk-tmp.%s" [pid]]]
2984 if {[catch {file mkdir $gitktmpdir} err]} {
2985 error_popup "Error creating temporary directory $gitktmpdir: $err"
2992 set diffdir [file join $gitktmpdir $diffnum]
2993 if {[catch {file mkdir $diffdir} err]} {
2994 error_popup "Error creating temporary directory $diffdir: $err"
2998 # gather files to diff
2999 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3000 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3002 if {$difffromfile ne {} && $difftofile ne {}} {
3003 set cmd [concat | [shellsplit $extdifftool] \
3004 [list $difffromfile $difftofile]]
3005 if {[catch {set fl [open $cmd r]} err]} {
3006 file delete -force $diffdir
3007 error_popup [mc "$extdifftool: command failed: $err"]
3009 fconfigure $fl -blocking 0
3010 filerun $fl [list delete_at_eof $fl $diffdir]
3015 # delete $dir when we see eof on $f (presumably because the child has exited)
3016 proc delete_at_eof {f dir} {
3017 while {[gets $f line] >= 0} {}
3019 if {[catch {close $f} err]} {
3020 error_popup "External diff viewer failed: $err"
3022 file delete -force $dir
3028 # Functions for adding and removing shell-type quoting
3030 proc shellquote {str} {
3031 if {![string match "*\['\"\\ \t]*" $str]} {
3034 if {![string match "*\['\"\\]*" $str]} {
3037 if {![string match "*'*" $str]} {
3040 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3043 proc shellarglist {l} {
3049 append str [shellquote $a]
3054 proc shelldequote {str} {
3059 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3060 append ret [string range $str $used end]
3061 set used [string length $str]
3064 set first [lindex $first 0]
3065 set ch [string index $str $first]
3066 if {$first > $used} {
3067 append ret [string range $str $used [expr {$first - 1}]]
3070 if {$ch eq " " || $ch eq "\t"} break
3073 set first [string first "'" $str $used]
3075 error "unmatched single-quote"
3077 append ret [string range $str $used [expr {$first - 1}]]
3082 if {$used >= [string length $str]} {
3083 error "trailing backslash"
3085 append ret [string index $str $used]
3090 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3091 error "unmatched double-quote"
3093 set first [lindex $first 0]
3094 set ch [string index $str $first]
3095 if {$first > $used} {
3096 append ret [string range $str $used [expr {$first - 1}]]
3099 if {$ch eq "\""} break
3101 append ret [string index $str $used]
3105 return [list $used $ret]
3108 proc shellsplit {str} {
3111 set str [string trimleft $str]
3112 if {$str eq {}} break
3113 set dq [shelldequote $str]
3114 set n [lindex $dq 0]
3115 set word [lindex $dq 1]
3116 set str [string range $str $n end]
3122 # Code to implement multiple views
3124 proc newview {ishighlight} {
3125 global nextviewnum newviewname newviewperm newishighlight
3126 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3128 set newishighlight $ishighlight
3130 if {[winfo exists $top]} {
3134 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3135 set newviewperm($nextviewnum) 0
3136 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3137 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3138 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3143 global viewname viewperm newviewname newviewperm
3144 global viewargs newviewargs viewargscmd newviewargscmd
3146 set top .gitkvedit-$curview
3147 if {[winfo exists $top]} {
3151 set newviewname($curview) $viewname($curview)
3152 set newviewperm($curview) $viewperm($curview)
3153 set newviewargs($curview) [shellarglist $viewargs($curview)]
3154 set newviewargscmd($curview) $viewargscmd($curview)
3155 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3158 proc vieweditor {top n title} {
3159 global newviewname newviewperm viewfiles bgcolor
3162 wm title $top $title
3163 label $top.nl -text [mc "Name"]
3164 entry $top.name -width 20 -textvariable newviewname($n)
3165 grid $top.nl $top.name -sticky w -pady 5
3166 checkbutton $top.perm -text [mc "Remember this view"] \
3167 -variable newviewperm($n)
3168 grid $top.perm - -pady 5 -sticky w
3169 message $top.al -aspect 1000 \
3170 -text [mc "Commits to include (arguments to git log):"]
3171 grid $top.al - -sticky w -pady 5
3172 entry $top.args -width 50 -textvariable newviewargs($n) \
3173 -background $bgcolor
3174 grid $top.args - -sticky ew -padx 5
3176 message $top.ac -aspect 1000 \
3177 -text [mc "Command to generate more commits to include:"]
3178 grid $top.ac - -sticky w -pady 5
3179 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3181 grid $top.argscmd - -sticky ew -padx 5
3183 message $top.l -aspect 1000 \
3184 -text [mc "Enter files and directories to include, one per line:"]
3185 grid $top.l - -sticky w
3186 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3187 if {[info exists viewfiles($n)]} {
3188 foreach f $viewfiles($n) {
3189 $top.t insert end $f
3190 $top.t insert end "\n"
3192 $top.t delete {end - 1c} end
3193 $top.t mark set insert 0.0
3195 grid $top.t - -sticky ew -padx 5
3197 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3198 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3199 grid $top.buts.ok $top.buts.can
3200 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3201 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3202 grid $top.buts - -pady 10 -sticky ew
3206 proc doviewmenu {m first cmd op argv} {
3207 set nmenu [$m index end]
3208 for {set i $first} {$i <= $nmenu} {incr i} {
3209 if {[$m entrycget $i -command] eq $cmd} {
3210 eval $m $op $i $argv
3216 proc allviewmenus {n op args} {
3219 doviewmenu .bar.view 5 [list showview $n] $op $args
3220 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3223 proc newviewok {top n} {
3224 global nextviewnum newviewperm newviewname newishighlight
3225 global viewname viewfiles viewperm selectedview curview
3226 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3229 set newargs [shellsplit $newviewargs($n)]
3231 error_popup "[mc "Error in commit selection arguments:"] $err"
3237 foreach f [split [$top.t get 0.0 end] "\n"] {
3238 set ft [string trim $f]
3243 if {![info exists viewfiles($n)]} {
3244 # creating a new view
3246 set viewname($n) $newviewname($n)
3247 set viewperm($n) $newviewperm($n)
3248 set viewfiles($n) $files
3249 set viewargs($n) $newargs
3250 set viewargscmd($n) $newviewargscmd($n)
3252 if {!$newishighlight} {
3255 run addvhighlight $n
3258 # editing an existing view
3259 set viewperm($n) $newviewperm($n)
3260 if {$newviewname($n) ne $viewname($n)} {
3261 set viewname($n) $newviewname($n)
3262 doviewmenu .bar.view 5 [list showview $n] \
3263 entryconf [list -label $viewname($n)]
3264 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3265 # entryconf [list -label $viewname($n) -value $viewname($n)]
3267 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3268 $newviewargscmd($n) ne $viewargscmd($n)} {
3269 set viewfiles($n) $files
3270 set viewargs($n) $newargs
3271 set viewargscmd($n) $newviewargscmd($n)
3272 if {$curview == $n} {
3277 catch {destroy $top}
3281 global curview viewperm hlview selectedhlview
3283 if {$curview == 0} return
3284 if {[info exists hlview] && $hlview == $curview} {
3285 set selectedhlview [mc "None"]
3288 allviewmenus $curview delete
3289 set viewperm($curview) 0
3293 proc addviewmenu {n} {
3294 global viewname viewhlmenu
3296 .bar.view add radiobutton -label $viewname($n) \
3297 -command [list showview $n] -variable selectedview -value $n
3298 #$viewhlmenu add radiobutton -label $viewname($n) \
3299 # -command [list addvhighlight $n] -variable selectedhlview
3303 global curview cached_commitrow ordertok
3304 global displayorder parentlist rowidlist rowisopt rowfinal
3305 global colormap rowtextx nextcolor canvxmax
3306 global numcommits viewcomplete
3307 global selectedline currentid canv canvy0
3309 global pending_select mainheadid
3312 global hlview selectedhlview commitinterest
3314 if {$n == $curview} return
3316 set ymax [lindex [$canv cget -scrollregion] 3]
3317 set span [$canv yview]
3318 set ytop [expr {[lindex $span 0] * $ymax}]
3319 set ybot [expr {[lindex $span 1] * $ymax}]
3320 set yscreen [expr {($ybot - $ytop) / 2}]
3321 if {$selectedline ne {}} {
3322 set selid $currentid
3323 set y [yc $selectedline]
3324 if {$ytop < $y && $y < $ybot} {
3325 set yscreen [expr {$y - $ytop}]
3327 } elseif {[info exists pending_select]} {
3328 set selid $pending_select
3329 unset pending_select
3333 catch {unset treediffs}
3335 if {[info exists hlview] && $hlview == $n} {
3337 set selectedhlview [mc "None"]
3339 catch {unset commitinterest}
3340 catch {unset cached_commitrow}
3341 catch {unset ordertok}
3345 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3346 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3349 if {![info exists viewcomplete($n)]} {
3359 set numcommits $commitidx($n)
3361 catch {unset colormap}
3362 catch {unset rowtextx}
3364 set canvxmax [$canv cget -width]
3370 if {$selid ne {} && [commitinview $selid $n]} {
3371 set row [rowofcommit $selid]
3372 # try to get the selected row in the same position on the screen
3373 set ymax [lindex [$canv cget -scrollregion] 3]
3374 set ytop [expr {[yc $row] - $yscreen}]
3378 set yf [expr {$ytop * 1.0 / $ymax}]
3380 allcanvs yview moveto $yf
3384 } elseif {!$viewcomplete($n)} {
3385 reset_pending_select $selid
3387 reset_pending_select {}
3389 if {[commitinview $pending_select $curview]} {
3390 selectline [rowofcommit $pending_select] 1
3392 set row [first_real_row]
3393 if {$row < $numcommits} {
3398 if {!$viewcomplete($n)} {
3399 if {$numcommits == 0} {
3400 show_status [mc "Reading commits..."]
3402 } elseif {$numcommits == 0} {
3403 show_status [mc "No commits selected"]
3407 # Stuff relating to the highlighting facility
3409 proc ishighlighted {id} {
3410 global vhighlights fhighlights nhighlights rhighlights
3412 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3413 return $nhighlights($id)
3415 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3416 return $vhighlights($id)
3418 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3419 return $fhighlights($id)
3421 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3422 return $rhighlights($id)
3427 proc bolden {row font} {
3428 global canv linehtag selectedline boldrows
3430 lappend boldrows $row
3431 $canv itemconf $linehtag($row) -font $font
3432 if {$row == $selectedline} {
3434 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3435 -outline {{}} -tags secsel \
3436 -fill [$canv cget -selectbackground]]
3441 proc bolden_name {row font} {
3442 global canv2 linentag selectedline boldnamerows
3444 lappend boldnamerows $row
3445 $canv2 itemconf $linentag($row) -font $font
3446 if {$row == $selectedline} {
3447 $canv2 delete secsel
3448 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3449 -outline {{}} -tags secsel \
3450 -fill [$canv2 cget -selectbackground]]
3459 foreach row $boldrows {
3460 if {![ishighlighted [commitonrow $row]]} {
3461 bolden $row mainfont
3463 lappend stillbold $row
3466 set boldrows $stillbold
3469 proc addvhighlight {n} {
3470 global hlview viewcomplete curview vhl_done commitidx
3472 if {[info exists hlview]} {
3476 if {$n != $curview && ![info exists viewcomplete($n)]} {
3479 set vhl_done $commitidx($hlview)
3480 if {$vhl_done > 0} {
3485 proc delvhighlight {} {
3486 global hlview vhighlights
3488 if {![info exists hlview]} return
3490 catch {unset vhighlights}
3494 proc vhighlightmore {} {
3495 global hlview vhl_done commitidx vhighlights curview
3497 set max $commitidx($hlview)
3498 set vr [visiblerows]
3499 set r0 [lindex $vr 0]
3500 set r1 [lindex $vr 1]
3501 for {set i $vhl_done} {$i < $max} {incr i} {
3502 set id [commitonrow $i $hlview]
3503 if {[commitinview $id $curview]} {
3504 set row [rowofcommit $id]
3505 if {$r0 <= $row && $row <= $r1} {
3506 if {![highlighted $row]} {
3507 bolden $row mainfontbold
3509 set vhighlights($id) 1
3517 proc askvhighlight {row id} {
3518 global hlview vhighlights iddrawn
3520 if {[commitinview $id $hlview]} {
3521 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3522 bolden $row mainfontbold
3524 set vhighlights($id) 1
3526 set vhighlights($id) 0
3530 proc hfiles_change {} {
3531 global highlight_files filehighlight fhighlights fh_serial
3532 global highlight_paths gdttype
3534 if {[info exists filehighlight]} {
3535 # delete previous highlights
3536 catch {close $filehighlight}
3538 catch {unset fhighlights}
3540 unhighlight_filelist
3542 set highlight_paths {}
3543 after cancel do_file_hl $fh_serial
3545 if {$highlight_files ne {}} {
3546 after 300 do_file_hl $fh_serial
3550 proc gdttype_change {name ix op} {
3551 global gdttype highlight_files findstring findpattern
3554 if {$findstring ne {}} {
3555 if {$gdttype eq [mc "containing:"]} {
3556 if {$highlight_files ne {}} {
3557 set highlight_files {}
3562 if {$findpattern ne {}} {
3566 set highlight_files $findstring
3571 # enable/disable findtype/findloc menus too
3574 proc find_change {name ix op} {
3575 global gdttype findstring highlight_files
3578 if {$gdttype eq [mc "containing:"]} {
3581 if {$highlight_files ne $findstring} {
3582 set highlight_files $findstring
3589 proc findcom_change args {
3590 global nhighlights boldnamerows
3591 global findpattern findtype findstring gdttype
3594 # delete previous highlights, if any
3595 foreach row $boldnamerows {
3596 bolden_name $row mainfont
3599 catch {unset nhighlights}
3602 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3604 } elseif {$findtype eq [mc "Regexp"]} {
3605 set findpattern $findstring
3607 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3609 set findpattern "*$e*"
3613 proc makepatterns {l} {
3616 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3617 if {[string index $ee end] eq "/"} {
3627 proc do_file_hl {serial} {
3628 global highlight_files filehighlight highlight_paths gdttype fhl_list
3630 if {$gdttype eq [mc "touching paths:"]} {
3631 if {[catch {set paths [shellsplit $highlight_files]}]} return
3632 set highlight_paths [makepatterns $paths]
3634 set gdtargs [concat -- $paths]
3635 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3636 set gdtargs [list "-S$highlight_files"]
3638 # must be "containing:", i.e. we're searching commit info
3641 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3642 set filehighlight [open $cmd r+]
3643 fconfigure $filehighlight -blocking 0
3644 filerun $filehighlight readfhighlight
3650 proc flushhighlights {} {
3651 global filehighlight fhl_list
3653 if {[info exists filehighlight]} {
3655 puts $filehighlight ""
3656 flush $filehighlight
3660 proc askfilehighlight {row id} {
3661 global filehighlight fhighlights fhl_list
3663 lappend fhl_list $id
3664 set fhighlights($id) -1
3665 puts $filehighlight $id
3668 proc readfhighlight {} {
3669 global filehighlight fhighlights curview iddrawn
3670 global fhl_list find_dirn
3672 if {![info exists filehighlight]} {
3676 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3677 set line [string trim $line]
3678 set i [lsearch -exact $fhl_list $line]
3679 if {$i < 0} continue
3680 for {set j 0} {$j < $i} {incr j} {
3681 set id [lindex $fhl_list $j]
3682 set fhighlights($id) 0
3684 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3685 if {$line eq {}} continue
3686 if {![commitinview $line $curview]} continue
3687 set row [rowofcommit $line]
3688 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3689 bolden $row mainfontbold
3691 set fhighlights($line) 1
3693 if {[eof $filehighlight]} {
3695 puts "oops, git diff-tree died"
3696 catch {close $filehighlight}
3700 if {[info exists find_dirn]} {
3706 proc doesmatch {f} {
3707 global findtype findpattern
3709 if {$findtype eq [mc "Regexp"]} {
3710 return [regexp $findpattern $f]
3711 } elseif {$findtype eq [mc "IgnCase"]} {
3712 return [string match -nocase $findpattern $f]
3714 return [string match $findpattern $f]
3718 proc askfindhighlight {row id} {
3719 global nhighlights commitinfo iddrawn
3721 global markingmatches
3723 if {![info exists commitinfo($id)]} {
3726 set info $commitinfo($id)
3728 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3729 foreach f $info ty $fldtypes {
3730 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3732 if {$ty eq [mc "Author"]} {
3739 if {$isbold && [info exists iddrawn($id)]} {
3740 if {![ishighlighted $id]} {
3741 bolden $row mainfontbold
3743 bolden_name $row mainfontbold
3746 if {$markingmatches} {
3747 markrowmatches $row $id
3750 set nhighlights($id) $isbold
3753 proc markrowmatches {row id} {
3754 global canv canv2 linehtag linentag commitinfo findloc
3756 set headline [lindex $commitinfo($id) 0]
3757 set author [lindex $commitinfo($id) 1]
3758 $canv delete match$row
3759 $canv2 delete match$row
3760 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3761 set m [findmatches $headline]
3763 markmatches $canv $row $headline $linehtag($row) $m \
3764 [$canv itemcget $linehtag($row) -font] $row
3767 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3768 set m [findmatches $author]
3770 markmatches $canv2 $row $author $linentag($row) $m \
3771 [$canv2 itemcget $linentag($row) -font] $row
3776 proc vrel_change {name ix op} {
3777 global highlight_related
3780 if {$highlight_related ne [mc "None"]} {
3785 # prepare for testing whether commits are descendents or ancestors of a
3786 proc rhighlight_sel {a} {
3787 global descendent desc_todo ancestor anc_todo
3788 global highlight_related
3790 catch {unset descendent}
3791 set desc_todo [list $a]
3792 catch {unset ancestor}
3793 set anc_todo [list $a]
3794 if {$highlight_related ne [mc "None"]} {
3800 proc rhighlight_none {} {
3803 catch {unset rhighlights}
3807 proc is_descendent {a} {
3808 global curview children descendent desc_todo
3811 set la [rowofcommit $a]
3815 for {set i 0} {$i < [llength $todo]} {incr i} {
3816 set do [lindex $todo $i]
3817 if {[rowofcommit $do] < $la} {
3818 lappend leftover $do
3821 foreach nk $children($v,$do) {
3822 if {![info exists descendent($nk)]} {
3823 set descendent($nk) 1
3831 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3835 set descendent($a) 0
3836 set desc_todo $leftover
3839 proc is_ancestor {a} {
3840 global curview parents ancestor anc_todo
3843 set la [rowofcommit $a]
3847 for {set i 0} {$i < [llength $todo]} {incr i} {
3848 set do [lindex $todo $i]
3849 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3850 lappend leftover $do
3853 foreach np $parents($v,$do) {
3854 if {![info exists ancestor($np)]} {
3863 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3868 set anc_todo $leftover
3871 proc askrelhighlight {row id} {
3872 global descendent highlight_related iddrawn rhighlights
3873 global selectedline ancestor
3875 if {$selectedline eq {}} return
3877 if {$highlight_related eq [mc "Descendant"] ||
3878 $highlight_related eq [mc "Not descendant"]} {
3879 if {![info exists descendent($id)]} {
3882 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3885 } elseif {$highlight_related eq [mc "Ancestor"] ||
3886 $highlight_related eq [mc "Not ancestor"]} {
3887 if {![info exists ancestor($id)]} {
3890 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3894 if {[info exists iddrawn($id)]} {
3895 if {$isbold && ![ishighlighted $id]} {
3896 bolden $row mainfontbold
3899 set rhighlights($id) $isbold
3902 # Graph layout functions
3904 proc shortids {ids} {
3907 if {[llength $id] > 1} {
3908 lappend res [shortids $id]
3909 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3910 lappend res [string range $id 0 7]
3921 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3922 if {($n & $mask) != 0} {
3923 set ret [concat $ret $o]
3925 set o [concat $o $o]
3930 proc ordertoken {id} {
3931 global ordertok curview varcid varcstart varctok curview parents children
3932 global nullid nullid2
3934 if {[info exists ordertok($id)]} {
3935 return $ordertok($id)
3940 if {[info exists varcid($curview,$id)]} {
3941 set a $varcid($curview,$id)
3942 set p [lindex $varcstart($curview) $a]
3944 set p [lindex $children($curview,$id) 0]
3946 if {[info exists ordertok($p)]} {
3947 set tok $ordertok($p)
3950 set id [first_real_child $curview,$p]
3953 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3956 if {[llength $parents($curview,$id)] == 1} {
3957 lappend todo [list $p {}]
3959 set j [lsearch -exact $parents($curview,$id) $p]
3961 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3963 lappend todo [list $p [strrep $j]]
3966 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3967 set p [lindex $todo $i 0]
3968 append tok [lindex $todo $i 1]
3969 set ordertok($p) $tok
3971 set ordertok($origid) $tok
3975 # Work out where id should go in idlist so that order-token
3976 # values increase from left to right
3977 proc idcol {idlist id {i 0}} {
3978 set t [ordertoken $id]
3982 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3983 if {$i > [llength $idlist]} {
3984 set i [llength $idlist]
3986 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3989 if {$t > [ordertoken [lindex $idlist $i]]} {
3990 while {[incr i] < [llength $idlist] &&
3991 $t >= [ordertoken [lindex $idlist $i]]} {}
3997 proc initlayout {} {
3998 global rowidlist rowisopt rowfinal displayorder parentlist
3999 global numcommits canvxmax canv
4001 global colormap rowtextx
4010 set canvxmax [$canv cget -width]
4011 catch {unset colormap}
4012 catch {unset rowtextx}
4016 proc setcanvscroll {} {
4017 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4018 global lastscrollset lastscrollrows
4020 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4021 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4022 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4023 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4024 set lastscrollset [clock clicks -milliseconds]
4025 set lastscrollrows $numcommits
4028 proc visiblerows {} {
4029 global canv numcommits linespc
4031 set ymax [lindex [$canv cget -scrollregion] 3]
4032 if {$ymax eq {} || $ymax == 0} return
4034 set y0 [expr {int([lindex $f 0] * $ymax)}]
4035 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4039 set y1 [expr {int([lindex $f 1] * $ymax)}]
4040 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4041 if {$r1 >= $numcommits} {
4042 set r1 [expr {$numcommits - 1}]
4044 return [list $r0 $r1]
4047 proc layoutmore {} {
4048 global commitidx viewcomplete curview
4049 global numcommits pending_select curview
4050 global lastscrollset lastscrollrows commitinterest
4052 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4053 [clock clicks -milliseconds] - $lastscrollset > 500} {
4056 if {[info exists pending_select] &&
4057 [commitinview $pending_select $curview]} {
4059 selectline [rowofcommit $pending_select] 1
4064 proc doshowlocalchanges {} {
4065 global curview mainheadid
4067 if {$mainheadid eq {}} return
4068 if {[commitinview $mainheadid $curview]} {
4071 lappend commitinterest($mainheadid) {dodiffindex}
4075 proc dohidelocalchanges {} {
4076 global nullid nullid2 lserial curview
4078 if {[commitinview $nullid $curview]} {
4079 removefakerow $nullid
4081 if {[commitinview $nullid2 $curview]} {
4082 removefakerow $nullid2
4087 # spawn off a process to do git diff-index --cached HEAD
4088 proc dodiffindex {} {
4089 global lserial showlocalchanges
4092 if {!$showlocalchanges || !$isworktree} return
4094 set fd [open "|git diff-index --cached HEAD" r]
4095 fconfigure $fd -blocking 0
4096 set i [reg_instance $fd]
4097 filerun $fd [list readdiffindex $fd $lserial $i]
4100 proc readdiffindex {fd serial inst} {
4101 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4104 if {[gets $fd line] < 0} {
4110 # we only need to see one line and we don't really care what it says...
4113 if {$serial != $lserial} {
4117 # now see if there are any local changes not checked in to the index
4118 set fd [open "|git diff-files" r]
4119 fconfigure $fd -blocking 0
4120 set i [reg_instance $fd]
4121 filerun $fd [list readdifffiles $fd $serial $i]
4123 if {$isdiff && ![commitinview $nullid2 $curview]} {
4124 # add the line for the changes in the index to the graph
4125 set hl [mc "Local changes checked in to index but not committed"]
4126 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4127 set commitdata($nullid2) "\n $hl\n"
4128 if {[commitinview $nullid $curview]} {
4129 removefakerow $nullid
4131 insertfakerow $nullid2 $mainheadid
4132 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4133 removefakerow $nullid2
4138 proc readdifffiles {fd serial inst} {
4139 global mainheadid nullid nullid2 curview
4140 global commitinfo commitdata lserial
4143 if {[gets $fd line] < 0} {
4149 # we only need to see one line and we don't really care what it says...
4152 if {$serial != $lserial} {
4156 if {$isdiff && ![commitinview $nullid $curview]} {
4157 # add the line for the local diff to the graph
4158 set hl [mc "Local uncommitted changes, not checked in to index"]
4159 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4160 set commitdata($nullid) "\n $hl\n"
4161 if {[commitinview $nullid2 $curview]} {
4166 insertfakerow $nullid $p
4167 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4168 removefakerow $nullid
4173 proc nextuse {id row} {
4174 global curview children
4176 if {[info exists children($curview,$id)]} {
4177 foreach kid $children($curview,$id) {
4178 if {![commitinview $kid $curview]} {
4181 if {[rowofcommit $kid] > $row} {
4182 return [rowofcommit $kid]
4186 if {[commitinview $id $curview]} {
4187 return [rowofcommit $id]
4192 proc prevuse {id row} {
4193 global curview children
4196 if {[info exists children($curview,$id)]} {
4197 foreach kid $children($curview,$id) {
4198 if {![commitinview $kid $curview]} break
4199 if {[rowofcommit $kid] < $row} {
4200 set ret [rowofcommit $kid]
4207 proc make_idlist {row} {
4208 global displayorder parentlist uparrowlen downarrowlen mingaplen
4209 global commitidx curview children
4211 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4215 set ra [expr {$row - $downarrowlen}]
4219 set rb [expr {$row + $uparrowlen}]
4220 if {$rb > $commitidx($curview)} {
4221 set rb $commitidx($curview)
4223 make_disporder $r [expr {$rb + 1}]
4225 for {} {$r < $ra} {incr r} {
4226 set nextid [lindex $displayorder [expr {$r + 1}]]
4227 foreach p [lindex $parentlist $r] {
4228 if {$p eq $nextid} continue
4229 set rn [nextuse $p $r]
4231 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4232 lappend ids [list [ordertoken $p] $p]
4236 for {} {$r < $row} {incr r} {
4237 set nextid [lindex $displayorder [expr {$r + 1}]]
4238 foreach p [lindex $parentlist $r] {
4239 if {$p eq $nextid} continue
4240 set rn [nextuse $p $r]
4241 if {$rn < 0 || $rn >= $row} {
4242 lappend ids [list [ordertoken $p] $p]
4246 set id [lindex $displayorder $row]
4247 lappend ids [list [ordertoken $id] $id]
4249 foreach p [lindex $parentlist $r] {
4250 set firstkid [lindex $children($curview,$p) 0]
4251 if {[rowofcommit $firstkid] < $row} {
4252 lappend ids [list [ordertoken $p] $p]
4256 set id [lindex $displayorder $r]
4258 set firstkid [lindex $children($curview,$id) 0]
4259 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4260 lappend ids [list [ordertoken $id] $id]
4265 foreach idx [lsort -unique $ids] {
4266 lappend idlist [lindex $idx 1]
4271 proc rowsequal {a b} {
4272 while {[set i [lsearch -exact $a {}]] >= 0} {
4273 set a [lreplace $a $i $i]
4275 while {[set i [lsearch -exact $b {}]] >= 0} {
4276 set b [lreplace $b $i $i]
4278 return [expr {$a eq $b}]
4281 proc makeupline {id row rend col} {
4282 global rowidlist uparrowlen downarrowlen mingaplen
4284 for {set r $rend} {1} {set r $rstart} {
4285 set rstart [prevuse $id $r]
4286 if {$rstart < 0} return
4287 if {$rstart < $row} break
4289 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4290 set rstart [expr {$rend - $uparrowlen - 1}]
4292 for {set r $rstart} {[incr r] <= $row} {} {
4293 set idlist [lindex $rowidlist $r]
4294 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4295 set col [idcol $idlist $id $col]
4296 lset rowidlist $r [linsert $idlist $col $id]
4302 proc layoutrows {row endrow} {
4303 global rowidlist rowisopt rowfinal displayorder
4304 global uparrowlen downarrowlen maxwidth mingaplen
4305 global children parentlist
4306 global commitidx viewcomplete curview
4308 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4311 set rm1 [expr {$row - 1}]
4312 foreach id [lindex $rowidlist $rm1] {
4317 set final [lindex $rowfinal $rm1]
4319 for {} {$row < $endrow} {incr row} {
4320 set rm1 [expr {$row - 1}]
4321 if {$rm1 < 0 || $idlist eq {}} {
4322 set idlist [make_idlist $row]
4325 set id [lindex $displayorder $rm1]
4326 set col [lsearch -exact $idlist $id]
4327 set idlist [lreplace $idlist $col $col]
4328 foreach p [lindex $parentlist $rm1] {
4329 if {[lsearch -exact $idlist $p] < 0} {
4330 set col [idcol $idlist $p $col]
4331 set idlist [linsert $idlist $col $p]
4332 # if not the first child, we have to insert a line going up
4333 if {$id ne [lindex $children($curview,$p) 0]} {
4334 makeupline $p $rm1 $row $col
4338 set id [lindex $displayorder $row]
4339 if {$row > $downarrowlen} {
4340 set termrow [expr {$row - $downarrowlen - 1}]
4341 foreach p [lindex $parentlist $termrow] {
4342 set i [lsearch -exact $idlist $p]
4343 if {$i < 0} continue
4344 set nr [nextuse $p $termrow]
4345 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4346 set idlist [lreplace $idlist $i $i]
4350 set col [lsearch -exact $idlist $id]
4352 set col [idcol $idlist $id]
4353 set idlist [linsert $idlist $col $id]
4354 if {$children($curview,$id) ne {}} {
4355 makeupline $id $rm1 $row $col
4358 set r [expr {$row + $uparrowlen - 1}]
4359 if {$r < $commitidx($curview)} {
4361 foreach p [lindex $parentlist $r] {
4362 if {[lsearch -exact $idlist $p] >= 0} continue
4363 set fk [lindex $children($curview,$p) 0]
4364 if {[rowofcommit $fk] < $row} {
4365 set x [idcol $idlist $p $x]
4366 set idlist [linsert $idlist $x $p]
4369 if {[incr r] < $commitidx($curview)} {
4370 set p [lindex $displayorder $r]
4371 if {[lsearch -exact $idlist $p] < 0} {
4372 set fk [lindex $children($curview,$p) 0]
4373 if {$fk ne {} && [rowofcommit $fk] < $row} {
4374 set x [idcol $idlist $p $x]
4375 set idlist [linsert $idlist $x $p]
4381 if {$final && !$viewcomplete($curview) &&
4382 $row + $uparrowlen + $mingaplen + $downarrowlen
4383 >= $commitidx($curview)} {
4386 set l [llength $rowidlist]
4388 lappend rowidlist $idlist
4390 lappend rowfinal $final
4391 } elseif {$row < $l} {
4392 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4393 lset rowidlist $row $idlist
4396 lset rowfinal $row $final
4398 set pad [ntimes [expr {$row - $l}] {}]
4399 set rowidlist [concat $rowidlist $pad]
4400 lappend rowidlist $idlist
4401 set rowfinal [concat $rowfinal $pad]
4402 lappend rowfinal $final
4403 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4409 proc changedrow {row} {
4410 global displayorder iddrawn rowisopt need_redisplay
4412 set l [llength $rowisopt]
4414 lset rowisopt $row 0
4415 if {$row + 1 < $l} {
4416 lset rowisopt [expr {$row + 1}] 0
4417 if {$row + 2 < $l} {
4418 lset rowisopt [expr {$row + 2}] 0
4422 set id [lindex $displayorder $row]
4423 if {[info exists iddrawn($id)]} {
4424 set need_redisplay 1
4428 proc insert_pad {row col npad} {
4431 set pad [ntimes $npad {}]
4432 set idlist [lindex $rowidlist $row]
4433 set bef [lrange $idlist 0 [expr {$col - 1}]]
4434 set aft [lrange $idlist $col end]
4435 set i [lsearch -exact $aft {}]
4437 set aft [lreplace $aft $i $i]
4439 lset rowidlist $row [concat $bef $pad $aft]
4443 proc optimize_rows {row col endrow} {
4444 global rowidlist rowisopt displayorder curview children
4449 for {} {$row < $endrow} {incr row; set col 0} {
4450 if {[lindex $rowisopt $row]} continue
4452 set y0 [expr {$row - 1}]
4453 set ym [expr {$row - 2}]
4454 set idlist [lindex $rowidlist $row]
4455 set previdlist [lindex $rowidlist $y0]
4456 if {$idlist eq {} || $previdlist eq {}} continue
4458 set pprevidlist [lindex $rowidlist $ym]
4459 if {$pprevidlist eq {}} continue
4465 for {} {$col < [llength $idlist]} {incr col} {
4466 set id [lindex $idlist $col]
4467 if {[lindex $previdlist $col] eq $id} continue
4472 set x0 [lsearch -exact $previdlist $id]
4473 if {$x0 < 0} continue
4474 set z [expr {$x0 - $col}]
4478 set xm [lsearch -exact $pprevidlist $id]
4480 set z0 [expr {$xm - $x0}]
4484 # if row y0 is the first child of $id then it's not an arrow
4485 if {[lindex $children($curview,$id) 0] ne
4486 [lindex $displayorder $y0]} {
4490 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4491 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4494 # Looking at lines from this row to the previous row,
4495 # make them go straight up if they end in an arrow on
4496 # the previous row; otherwise make them go straight up
4498 if {$z < -1 || ($z < 0 && $isarrow)} {
4499 # Line currently goes left too much;
4500 # insert pads in the previous row, then optimize it
4501 set npad [expr {-1 - $z + $isarrow}]
4502 insert_pad $y0 $x0 $npad
4504 optimize_rows $y0 $x0 $row
4506 set previdlist [lindex $rowidlist $y0]
4507 set x0 [lsearch -exact $previdlist $id]
4508 set z [expr {$x0 - $col}]
4510 set pprevidlist [lindex $rowidlist $ym]
4511 set xm [lsearch -exact $pprevidlist $id]
4512 set z0 [expr {$xm - $x0}]
4514 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4515 # Line currently goes right too much;
4516 # insert pads in this line
4517 set npad [expr {$z - 1 + $isarrow}]
4518 insert_pad $row $col $npad
4519 set idlist [lindex $rowidlist $row]
4521 set z [expr {$x0 - $col}]
4524 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4525 # this line links to its first child on row $row-2
4526 set id [lindex $displayorder $ym]
4527 set xc [lsearch -exact $pprevidlist $id]
4529 set z0 [expr {$xc - $x0}]
4532 # avoid lines jigging left then immediately right
4533 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4534 insert_pad $y0 $x0 1
4536 optimize_rows $y0 $x0 $row
4537 set previdlist [lindex $rowidlist $y0]
4541 # Find the first column that doesn't have a line going right
4542 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4543 set id [lindex $idlist $col]
4544 if {$id eq {}} break
4545 set x0 [lsearch -exact $previdlist $id]
4547 # check if this is the link to the first child
4548 set kid [lindex $displayorder $y0]
4549 if {[lindex $children($curview,$id) 0] eq $kid} {
4550 # it is, work out offset to child
4551 set x0 [lsearch -exact $previdlist $kid]
4554 if {$x0 <= $col} break
4556 # Insert a pad at that column as long as it has a line and
4557 # isn't the last column
4558 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4559 set idlist [linsert $idlist $col {}]
4560 lset rowidlist $row $idlist
4568 global canvx0 linespc
4569 return [expr {$canvx0 + $col * $linespc}]
4573 global canvy0 linespc
4574 return [expr {$canvy0 + $row * $linespc}]
4577 proc linewidth {id} {
4578 global thickerline lthickness
4581 if {[info exists thickerline] && $id eq $thickerline} {
4582 set wid [expr {2 * $lthickness}]
4587 proc rowranges {id} {
4588 global curview children uparrowlen downarrowlen
4591 set kids $children($curview,$id)
4597 foreach child $kids {
4598 if {![commitinview $child $curview]} break
4599 set row [rowofcommit $child]
4600 if {![info exists prev]} {
4601 lappend ret [expr {$row + 1}]
4603 if {$row <= $prevrow} {
4604 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4606 # see if the line extends the whole way from prevrow to row
4607 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4608 [lsearch -exact [lindex $rowidlist \
4609 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4610 # it doesn't, see where it ends
4611 set r [expr {$prevrow + $downarrowlen}]
4612 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4613 while {[incr r -1] > $prevrow &&
4614 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4616 while {[incr r] <= $row &&
4617 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4621 # see where it starts up again
4622 set r [expr {$row - $uparrowlen}]
4623 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4624 while {[incr r] < $row &&
4625 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4627 while {[incr r -1] >= $prevrow &&
4628 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4634 if {$child eq $id} {
4643 proc drawlineseg {id row endrow arrowlow} {
4644 global rowidlist displayorder iddrawn linesegs
4645 global canv colormap linespc curview maxlinelen parentlist
4647 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4648 set le [expr {$row + 1}]
4651 set c [lsearch -exact [lindex $rowidlist $le] $id]
4657 set x [lindex $displayorder $le]
4662 if {[info exists iddrawn($x)] || $le == $endrow} {
4663 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4679 if {[info exists linesegs($id)]} {
4680 set lines $linesegs($id)
4682 set r0 [lindex $li 0]
4684 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4694 set li [lindex $lines [expr {$i-1}]]
4695 set r1 [lindex $li 1]
4696 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4701 set x [lindex $cols [expr {$le - $row}]]
4702 set xp [lindex $cols [expr {$le - 1 - $row}]]
4703 set dir [expr {$xp - $x}]
4705 set ith [lindex $lines $i 2]
4706 set coords [$canv coords $ith]
4707 set ah [$canv itemcget $ith -arrow]
4708 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4709 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4710 if {$x2 ne {} && $x - $x2 == $dir} {
4711 set coords [lrange $coords 0 end-2]
4714 set coords [list [xc $le $x] [yc $le]]
4717 set itl [lindex $lines [expr {$i-1}] 2]
4718 set al [$canv itemcget $itl -arrow]
4719 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4720 } elseif {$arrowlow} {
4721 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4722 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4726 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4727 for {set y $le} {[incr y -1] > $row} {} {
4729 set xp [lindex $cols [expr {$y - 1 - $row}]]
4730 set ndir [expr {$xp - $x}]
4731 if {$dir != $ndir || $xp < 0} {
4732 lappend coords [xc $y $x] [yc $y]
4738 # join parent line to first child
4739 set ch [lindex $displayorder $row]
4740 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4742 puts "oops: drawlineseg: child $ch not on row $row"
4743 } elseif {$xc != $x} {
4744 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4745 set d [expr {int(0.5 * $linespc)}]
4748 set x2 [expr {$x1 - $d}]
4750 set x2 [expr {$x1 + $d}]
4753 set y1 [expr {$y2 + $d}]
4754 lappend coords $x1 $y1 $x2 $y2
4755 } elseif {$xc < $x - 1} {
4756 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4757 } elseif {$xc > $x + 1} {
4758 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4762 lappend coords [xc $row $x] [yc $row]
4764 set xn [xc $row $xp]
4766 lappend coords $xn $yn
4770 set t [$canv create line $coords -width [linewidth $id] \
4771 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4774 set lines [linsert $lines $i [list $row $le $t]]
4776 $canv coords $ith $coords
4777 if {$arrow ne $ah} {
4778 $canv itemconf $ith -arrow $arrow
4780 lset lines $i 0 $row
4783 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4784 set ndir [expr {$xo - $xp}]
4785 set clow [$canv coords $itl]
4786 if {$dir == $ndir} {
4787 set clow [lrange $clow 2 end]
4789 set coords [concat $coords $clow]
4791 lset lines [expr {$i-1}] 1 $le
4793 # coalesce two pieces
4795 set b [lindex $lines [expr {$i-1}] 0]
4796 set e [lindex $lines $i 1]
4797 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4799 $canv coords $itl $coords
4800 if {$arrow ne $al} {
4801 $canv itemconf $itl -arrow $arrow
4805 set linesegs($id) $lines
4809 proc drawparentlinks {id row} {
4810 global rowidlist canv colormap curview parentlist
4811 global idpos linespc
4813 set rowids [lindex $rowidlist $row]
4814 set col [lsearch -exact $rowids $id]
4815 if {$col < 0} return
4816 set olds [lindex $parentlist $row]
4817 set row2 [expr {$row + 1}]
4818 set x [xc $row $col]
4821 set d [expr {int(0.5 * $linespc)}]
4822 set ymid [expr {$y + $d}]
4823 set ids [lindex $rowidlist $row2]
4824 # rmx = right-most X coord used
4827 set i [lsearch -exact $ids $p]
4829 puts "oops, parent $p of $id not in list"
4832 set x2 [xc $row2 $i]
4836 set j [lsearch -exact $rowids $p]
4838 # drawlineseg will do this one for us
4842 # should handle duplicated parents here...
4843 set coords [list $x $y]
4845 # if attaching to a vertical segment, draw a smaller
4846 # slant for visual distinctness
4849 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4851 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4853 } elseif {$i < $col && $i < $j} {
4854 # segment slants towards us already
4855 lappend coords [xc $row $j] $y
4857 if {$i < $col - 1} {
4858 lappend coords [expr {$x2 + $linespc}] $y
4859 } elseif {$i > $col + 1} {
4860 lappend coords [expr {$x2 - $linespc}] $y
4862 lappend coords $x2 $y2
4865 lappend coords $x2 $y2
4867 set t [$canv create line $coords -width [linewidth $p] \
4868 -fill $colormap($p) -tags lines.$p]
4872 if {$rmx > [lindex $idpos($id) 1]} {
4873 lset idpos($id) 1 $rmx
4878 proc drawlines {id} {
4881 $canv itemconf lines.$id -width [linewidth $id]
4884 proc drawcmittext {id row col} {
4885 global linespc canv canv2 canv3 fgcolor curview
4886 global cmitlisted commitinfo rowidlist parentlist
4887 global rowtextx idpos idtags idheads idotherrefs
4888 global linehtag linentag linedtag selectedline
4889 global canvxmax boldrows boldnamerows fgcolor
4890 global mainheadid nullid nullid2 circleitem circlecolors
4892 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4893 set listed $cmitlisted($curview,$id)
4894 if {$id eq $nullid} {
4896 } elseif {$id eq $nullid2} {
4898 } elseif {$id eq $mainheadid} {
4901 set ofill [lindex $circlecolors $listed]
4903 set x [xc $row $col]
4905 set orad [expr {$linespc / 3}]
4907 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4908 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4909 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4910 } elseif {$listed == 3} {
4911 # triangle pointing left for left-side commits
4912 set t [$canv create polygon \
4913 [expr {$x - $orad}] $y \
4914 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4915 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4916 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4918 # triangle pointing right for right-side commits
4919 set t [$canv create polygon \
4920 [expr {$x + $orad - 1}] $y \
4921 [expr {$x - $orad}] [expr {$y - $orad}] \
4922 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4923 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4925 set circleitem($row) $t
4927 $canv bind $t <1> {selcanvline {} %x %y}
4928 set rmx [llength [lindex $rowidlist $row]]
4929 set olds [lindex $parentlist $row]
4931 set nextids [lindex $rowidlist [expr {$row + 1}]]
4933 set i [lsearch -exact $nextids $p]
4939 set xt [xc $row $rmx]
4940 set rowtextx($row) $xt
4941 set idpos($id) [list $x $xt $y]
4942 if {[info exists idtags($id)] || [info exists idheads($id)]
4943 || [info exists idotherrefs($id)]} {
4944 set xt [drawtags $id $x $xt $y]
4946 set headline [lindex $commitinfo($id) 0]
4947 set name [lindex $commitinfo($id) 1]
4948 set date [lindex $commitinfo($id) 2]
4949 set date [formatdate $date]
4952 set isbold [ishighlighted $id]
4954 lappend boldrows $row
4955 set font mainfontbold
4957 lappend boldnamerows $row
4958 set nfont mainfontbold
4961 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4962 -text $headline -font $font -tags text]
4963 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4964 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4965 -text $name -font $nfont -tags text]
4966 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4967 -text $date -font mainfont -tags text]
4968 if {$selectedline == $row} {
4971 set xr [expr {$xt + [font measure $font $headline]}]
4972 if {$xr > $canvxmax} {
4978 proc drawcmitrow {row} {
4979 global displayorder rowidlist nrows_drawn
4980 global iddrawn markingmatches
4981 global commitinfo numcommits
4982 global filehighlight fhighlights findpattern nhighlights
4983 global hlview vhighlights
4984 global highlight_related rhighlights
4986 if {$row >= $numcommits} return
4988 set id [lindex $displayorder $row]
4989 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4990 askvhighlight $row $id
4992 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4993 askfilehighlight $row $id
4995 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4996 askfindhighlight $row $id
4998 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4999 askrelhighlight $row $id
5001 if {![info exists iddrawn($id)]} {
5002 set col [lsearch -exact [lindex $rowidlist $row] $id]
5004 puts "oops, row $row id $id not in list"
5007 if {![info exists commitinfo($id)]} {
5011 drawcmittext $id $row $col
5015 if {$markingmatches} {
5016 markrowmatches $row $id
5020 proc drawcommits {row {endrow {}}} {
5021 global numcommits iddrawn displayorder curview need_redisplay
5022 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5027 if {$endrow eq {}} {
5030 if {$endrow >= $numcommits} {
5031 set endrow [expr {$numcommits - 1}]
5034 set rl1 [expr {$row - $downarrowlen - 3}]
5038 set ro1 [expr {$row - 3}]
5042 set r2 [expr {$endrow + $uparrowlen + 3}]
5043 if {$r2 > $numcommits} {
5046 for {set r $rl1} {$r < $r2} {incr r} {
5047 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5051 set rl1 [expr {$r + 1}]
5057 optimize_rows $ro1 0 $r2
5058 if {$need_redisplay || $nrows_drawn > 2000} {
5063 # make the lines join to already-drawn rows either side
5064 set r [expr {$row - 1}]
5065 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5068 set er [expr {$endrow + 1}]
5069 if {$er >= $numcommits ||
5070 ![info exists iddrawn([lindex $displayorder $er])]} {
5073 for {} {$r <= $er} {incr r} {
5074 set id [lindex $displayorder $r]
5075 set wasdrawn [info exists iddrawn($id)]
5077 if {$r == $er} break
5078 set nextid [lindex $displayorder [expr {$r + 1}]]
5079 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5080 drawparentlinks $id $r
5082 set rowids [lindex $rowidlist $r]
5083 foreach lid $rowids {
5084 if {$lid eq {}} continue
5085 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5087 # see if this is the first child of any of its parents
5088 foreach p [lindex $parentlist $r] {
5089 if {[lsearch -exact $rowids $p] < 0} {
5090 # make this line extend up to the child
5091 set lineend($p) [drawlineseg $p $r $er 0]
5095 set lineend($lid) [drawlineseg $lid $r $er 1]
5101 proc undolayout {row} {
5102 global uparrowlen mingaplen downarrowlen
5103 global rowidlist rowisopt rowfinal need_redisplay
5105 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5109 if {[llength $rowidlist] > $r} {
5111 set rowidlist [lrange $rowidlist 0 $r]
5112 set rowfinal [lrange $rowfinal 0 $r]
5113 set rowisopt [lrange $rowisopt 0 $r]
5114 set need_redisplay 1
5119 proc drawvisible {} {
5120 global canv linespc curview vrowmod selectedline targetrow targetid
5121 global need_redisplay cscroll numcommits
5123 set fs [$canv yview]
5124 set ymax [lindex [$canv cget -scrollregion] 3]
5125 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5126 set f0 [lindex $fs 0]
5127 set f1 [lindex $fs 1]
5128 set y0 [expr {int($f0 * $ymax)}]
5129 set y1 [expr {int($f1 * $ymax)}]
5131 if {[info exists targetid]} {
5132 if {[commitinview $targetid $curview]} {
5133 set r [rowofcommit $targetid]
5134 if {$r != $targetrow} {
5135 # Fix up the scrollregion and change the scrolling position
5136 # now that our target row has moved.
5137 set diff [expr {($r - $targetrow) * $linespc}]
5140 set ymax [lindex [$canv cget -scrollregion] 3]
5143 set f0 [expr {$y0 / $ymax}]
5144 set f1 [expr {$y1 / $ymax}]
5145 allcanvs yview moveto $f0
5146 $cscroll set $f0 $f1
5147 set need_redisplay 1
5154 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5155 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5156 if {$endrow >= $vrowmod($curview)} {
5157 update_arcrows $curview
5159 if {$selectedline ne {} &&
5160 $row <= $selectedline && $selectedline <= $endrow} {
5161 set targetrow $selectedline
5162 } elseif {[info exists targetid]} {
5163 set targetrow [expr {int(($row + $endrow) / 2)}]
5165 if {[info exists targetrow]} {
5166 if {$targetrow >= $numcommits} {
5167 set targetrow [expr {$numcommits - 1}]
5169 set targetid [commitonrow $targetrow]
5171 drawcommits $row $endrow
5174 proc clear_display {} {
5175 global iddrawn linesegs need_redisplay nrows_drawn
5176 global vhighlights fhighlights nhighlights rhighlights
5177 global linehtag linentag linedtag boldrows boldnamerows
5180 catch {unset iddrawn}
5181 catch {unset linesegs}
5182 catch {unset linehtag}
5183 catch {unset linentag}
5184 catch {unset linedtag}
5187 catch {unset vhighlights}
5188 catch {unset fhighlights}
5189 catch {unset nhighlights}
5190 catch {unset rhighlights}
5191 set need_redisplay 0
5195 proc findcrossings {id} {
5196 global rowidlist parentlist numcommits displayorder
5200 foreach {s e} [rowranges $id] {
5201 if {$e >= $numcommits} {
5202 set e [expr {$numcommits - 1}]
5204 if {$e <= $s} continue
5205 for {set row $e} {[incr row -1] >= $s} {} {
5206 set x [lsearch -exact [lindex $rowidlist $row] $id]
5208 set olds [lindex $parentlist $row]
5209 set kid [lindex $displayorder $row]
5210 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5211 if {$kidx < 0} continue
5212 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5214 set px [lsearch -exact $nextrow $p]
5215 if {$px < 0} continue
5216 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5217 if {[lsearch -exact $ccross $p] >= 0} continue
5218 if {$x == $px + ($kidx < $px? -1: 1)} {
5220 } elseif {[lsearch -exact $cross $p] < 0} {
5227 return [concat $ccross {{}} $cross]
5230 proc assigncolor {id} {
5231 global colormap colors nextcolor
5232 global parents children children curview
5234 if {[info exists colormap($id)]} return
5235 set ncolors [llength $colors]
5236 if {[info exists children($curview,$id)]} {
5237 set kids $children($curview,$id)
5241 if {[llength $kids] == 1} {
5242 set child [lindex $kids 0]
5243 if {[info exists colormap($child)]
5244 && [llength $parents($curview,$child)] == 1} {
5245 set colormap($id) $colormap($child)
5251 foreach x [findcrossings $id] {
5253 # delimiter between corner crossings and other crossings
5254 if {[llength $badcolors] >= $ncolors - 1} break
5255 set origbad $badcolors
5257 if {[info exists colormap($x)]
5258 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5259 lappend badcolors $colormap($x)
5262 if {[llength $badcolors] >= $ncolors} {
5263 set badcolors $origbad
5265 set origbad $badcolors
5266 if {[llength $badcolors] < $ncolors - 1} {
5267 foreach child $kids {
5268 if {[info exists colormap($child)]
5269 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5270 lappend badcolors $colormap($child)
5272 foreach p $parents($curview,$child) {
5273 if {[info exists colormap($p)]
5274 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5275 lappend badcolors $colormap($p)
5279 if {[llength $badcolors] >= $ncolors} {
5280 set badcolors $origbad
5283 for {set i 0} {$i <= $ncolors} {incr i} {
5284 set c [lindex $colors $nextcolor]
5285 if {[incr nextcolor] >= $ncolors} {
5288 if {[lsearch -exact $badcolors $c]} break
5290 set colormap($id) $c
5293 proc bindline {t id} {
5296 $canv bind $t <Enter> "lineenter %x %y $id"
5297 $canv bind $t <Motion> "linemotion %x %y $id"
5298 $canv bind $t <Leave> "lineleave $id"
5299 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5302 proc drawtags {id x xt y1} {
5303 global idtags idheads idotherrefs mainhead
5304 global linespc lthickness
5305 global canv rowtextx curview fgcolor bgcolor
5310 if {[info exists idtags($id)]} {
5311 set marks $idtags($id)
5312 set ntags [llength $marks]
5314 if {[info exists idheads($id)]} {
5315 set marks [concat $marks $idheads($id)]
5316 set nheads [llength $idheads($id)]
5318 if {[info exists idotherrefs($id)]} {
5319 set marks [concat $marks $idotherrefs($id)]
5325 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5326 set yt [expr {$y1 - 0.5 * $linespc}]
5327 set yb [expr {$yt + $linespc - 1}]
5331 foreach tag $marks {
5333 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5334 set wid [font measure mainfontbold $tag]
5336 set wid [font measure mainfont $tag]
5340 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5342 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5343 -width $lthickness -fill black -tags tag.$id]
5345 foreach tag $marks x $xvals wid $wvals {
5346 set xl [expr {$x + $delta}]
5347 set xr [expr {$x + $delta + $wid + $lthickness}]
5349 if {[incr ntags -1] >= 0} {
5351 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5352 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5353 -width 1 -outline black -fill yellow -tags tag.$id]
5354 $canv bind $t <1> [list showtag $tag 1]
5355 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5357 # draw a head or other ref
5358 if {[incr nheads -1] >= 0} {
5360 if {$tag eq $mainhead} {
5361 set font mainfontbold
5366 set xl [expr {$xl - $delta/2}]
5367 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5368 -width 1 -outline black -fill $col -tags tag.$id
5369 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5370 set rwid [font measure mainfont $remoteprefix]
5371 set xi [expr {$x + 1}]
5372 set yti [expr {$yt + 1}]
5373 set xri [expr {$x + $rwid}]
5374 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5375 -width 0 -fill "#ffddaa" -tags tag.$id
5378 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5379 -font $font -tags [list tag.$id text]]
5381 $canv bind $t <1> [list showtag $tag 1]
5382 } elseif {$nheads >= 0} {
5383 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5389 proc xcoord {i level ln} {
5390 global canvx0 xspc1 xspc2
5392 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5393 if {$i > 0 && $i == $level} {
5394 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5395 } elseif {$i > $level} {
5396 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5401 proc show_status {msg} {
5405 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5406 -tags text -fill $fgcolor
5409 # Don't change the text pane cursor if it is currently the hand cursor,
5410 # showing that we are over a sha1 ID link.
5411 proc settextcursor {c} {
5412 global ctext curtextcursor
5414 if {[$ctext cget -cursor] == $curtextcursor} {
5415 $ctext config -cursor $c
5417 set curtextcursor $c
5420 proc nowbusy {what {name {}}} {
5421 global isbusy busyname statusw
5423 if {[array names isbusy] eq {}} {
5424 . config -cursor watch
5428 set busyname($what) $name
5430 $statusw conf -text $name
5434 proc notbusy {what} {
5435 global isbusy maincursor textcursor busyname statusw
5439 if {$busyname($what) ne {} &&
5440 [$statusw cget -text] eq $busyname($what)} {
5441 $statusw conf -text {}
5444 if {[array names isbusy] eq {}} {
5445 . config -cursor $maincursor
5446 settextcursor $textcursor
5450 proc findmatches {f} {
5451 global findtype findstring
5452 if {$findtype == [mc "Regexp"]} {
5453 set matches [regexp -indices -all -inline $findstring $f]
5456 if {$findtype == [mc "IgnCase"]} {
5457 set f [string tolower $f]
5458 set fs [string tolower $fs]
5462 set l [string length $fs]
5463 while {[set j [string first $fs $f $i]] >= 0} {
5464 lappend matches [list $j [expr {$j+$l-1}]]
5465 set i [expr {$j + $l}]
5471 proc dofind {{dirn 1} {wrap 1}} {
5472 global findstring findstartline findcurline selectedline numcommits
5473 global gdttype filehighlight fh_serial find_dirn findallowwrap
5475 if {[info exists find_dirn]} {
5476 if {$find_dirn == $dirn} return
5480 if {$findstring eq {} || $numcommits == 0} return
5481 if {$selectedline eq {}} {
5482 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5484 set findstartline $selectedline
5486 set findcurline $findstartline
5487 nowbusy finding [mc "Searching"]
5488 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5489 after cancel do_file_hl $fh_serial
5490 do_file_hl $fh_serial
5493 set findallowwrap $wrap
5497 proc stopfinding {} {
5498 global find_dirn findcurline fprogcoord
5500 if {[info exists find_dirn]} {
5510 global commitdata commitinfo numcommits findpattern findloc
5511 global findstartline findcurline findallowwrap
5512 global find_dirn gdttype fhighlights fprogcoord
5513 global curview varcorder vrownum varccommits vrowmod
5515 if {![info exists find_dirn]} {
5518 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5521 if {$find_dirn > 0} {
5523 if {$l >= $numcommits} {
5526 if {$l <= $findstartline} {
5527 set lim [expr {$findstartline + 1}]
5530 set moretodo $findallowwrap
5537 if {$l >= $findstartline} {
5538 set lim [expr {$findstartline - 1}]
5541 set moretodo $findallowwrap
5544 set n [expr {($lim - $l) * $find_dirn}]
5549 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5550 update_arcrows $curview
5554 set ai [bsearch $vrownum($curview) $l]
5555 set a [lindex $varcorder($curview) $ai]
5556 set arow [lindex $vrownum($curview) $ai]
5557 set ids [lindex $varccommits($curview,$a)]
5558 set arowend [expr {$arow + [llength $ids]}]
5559 if {$gdttype eq [mc "containing:"]} {
5560 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5561 if {$l < $arow || $l >= $arowend} {
5563 set a [lindex $varcorder($curview) $ai]
5564 set arow [lindex $vrownum($curview) $ai]
5565 set ids [lindex $varccommits($curview,$a)]
5566 set arowend [expr {$arow + [llength $ids]}]
5568 set id [lindex $ids [expr {$l - $arow}]]
5569 # shouldn't happen unless git log doesn't give all the commits...
5570 if {![info exists commitdata($id)] ||
5571 ![doesmatch $commitdata($id)]} {
5574 if {![info exists commitinfo($id)]} {
5577 set info $commitinfo($id)
5578 foreach f $info ty $fldtypes {
5579 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5588 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5589 if {$l < $arow || $l >= $arowend} {
5591 set a [lindex $varcorder($curview) $ai]
5592 set arow [lindex $vrownum($curview) $ai]
5593 set ids [lindex $varccommits($curview,$a)]
5594 set arowend [expr {$arow + [llength $ids]}]
5596 set id [lindex $ids [expr {$l - $arow}]]
5597 if {![info exists fhighlights($id)]} {
5598 # this sets fhighlights($id) to -1
5599 askfilehighlight $l $id
5601 if {$fhighlights($id) > 0} {
5605 if {$fhighlights($id) < 0} {
5608 set findcurline [expr {$l - $find_dirn}]
5613 if {$found || ($domore && !$moretodo)} {
5629 set findcurline [expr {$l - $find_dirn}]
5631 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5635 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5640 proc findselectline {l} {
5641 global findloc commentend ctext findcurline markingmatches gdttype
5643 set markingmatches 1
5646 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5647 # highlight the matches in the comments
5648 set f [$ctext get 1.0 $commentend]
5649 set matches [findmatches $f]
5650 foreach match $matches {
5651 set start [lindex $match 0]
5652 set end [expr {[lindex $match 1] + 1}]
5653 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5659 # mark the bits of a headline or author that match a find string
5660 proc markmatches {canv l str tag matches font row} {
5663 set bbox [$canv bbox $tag]
5664 set x0 [lindex $bbox 0]
5665 set y0 [lindex $bbox 1]
5666 set y1 [lindex $bbox 3]
5667 foreach match $matches {
5668 set start [lindex $match 0]
5669 set end [lindex $match 1]
5670 if {$start > $end} continue
5671 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5672 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5673 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5674 [expr {$x0+$xlen+2}] $y1 \
5675 -outline {} -tags [list match$l matches] -fill yellow]
5677 if {$row == $selectedline} {
5678 $canv raise $t secsel
5683 proc unmarkmatches {} {
5684 global markingmatches
5686 allcanvs delete matches
5687 set markingmatches 0
5691 proc selcanvline {w x y} {
5692 global canv canvy0 ctext linespc
5694 set ymax [lindex [$canv cget -scrollregion] 3]
5695 if {$ymax == {}} return
5696 set yfrac [lindex [$canv yview] 0]
5697 set y [expr {$y + $yfrac * $ymax}]
5698 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5703 set xmax [lindex [$canv cget -scrollregion] 2]
5704 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5705 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5711 proc commit_descriptor {p} {
5713 if {![info exists commitinfo($p)]} {
5717 if {[llength $commitinfo($p)] > 1} {
5718 set l [lindex $commitinfo($p) 0]
5723 # append some text to the ctext widget, and make any SHA1 ID
5724 # that we know about be a clickable link.
5725 proc appendwithlinks {text tags} {
5726 global ctext linknum curview pendinglinks
5728 set start [$ctext index "end - 1c"]
5729 $ctext insert end $text $tags
5730 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5734 set linkid [string range $text $s $e]
5736 $ctext tag delete link$linknum
5737 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5738 setlink $linkid link$linknum
5743 proc setlink {id lk} {
5744 global curview ctext pendinglinks commitinterest
5746 if {[commitinview $id $curview]} {
5747 $ctext tag conf $lk -foreground blue -underline 1
5748 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5749 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5750 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5752 lappend pendinglinks($id) $lk
5753 lappend commitinterest($id) {makelink %I}
5757 proc makelink {id} {
5760 if {![info exists pendinglinks($id)]} return
5761 foreach lk $pendinglinks($id) {
5764 unset pendinglinks($id)
5767 proc linkcursor {w inc} {
5768 global linkentercount curtextcursor
5770 if {[incr linkentercount $inc] > 0} {
5771 $w configure -cursor hand2
5773 $w configure -cursor $curtextcursor
5774 if {$linkentercount < 0} {
5775 set linkentercount 0
5780 proc viewnextline {dir} {
5784 set ymax [lindex [$canv cget -scrollregion] 3]
5785 set wnow [$canv yview]
5786 set wtop [expr {[lindex $wnow 0] * $ymax}]
5787 set newtop [expr {$wtop + $dir * $linespc}]
5790 } elseif {$newtop > $ymax} {
5793 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5796 # add a list of tag or branch names at position pos
5797 # returns the number of names inserted
5798 proc appendrefs {pos ids var} {
5799 global ctext linknum curview $var maxrefs
5801 if {[catch {$ctext index $pos}]} {
5804 $ctext conf -state normal
5805 $ctext delete $pos "$pos lineend"
5808 foreach tag [set $var\($id\)] {
5809 lappend tags [list $tag $id]
5812 if {[llength $tags] > $maxrefs} {
5813 $ctext insert $pos "many ([llength $tags])"
5815 set tags [lsort -index 0 -decreasing $tags]
5818 set id [lindex $ti 1]
5821 $ctext tag delete $lk
5822 $ctext insert $pos $sep
5823 $ctext insert $pos [lindex $ti 0] $lk
5828 $ctext conf -state disabled
5829 return [llength $tags]
5832 # called when we have finished computing the nearby tags
5833 proc dispneartags {delay} {
5834 global selectedline currentid showneartags tagphase
5836 if {$selectedline eq {} || !$showneartags} return
5837 after cancel dispnexttag
5839 after 200 dispnexttag
5842 after idle dispnexttag
5847 proc dispnexttag {} {
5848 global selectedline currentid showneartags tagphase ctext
5850 if {$selectedline eq {} || !$showneartags} return
5851 switch -- $tagphase {
5853 set dtags [desctags $currentid]
5855 appendrefs precedes $dtags idtags
5859 set atags [anctags $currentid]
5861 appendrefs follows $atags idtags
5865 set dheads [descheads $currentid]
5866 if {$dheads ne {}} {
5867 if {[appendrefs branch $dheads idheads] > 1
5868 && [$ctext get "branch -3c"] eq "h"} {
5869 # turn "Branch" into "Branches"
5870 $ctext conf -state normal
5871 $ctext insert "branch -2c" "es"
5872 $ctext conf -state disabled
5877 if {[incr tagphase] <= 2} {
5878 after idle dispnexttag
5882 proc make_secsel {l} {
5883 global linehtag linentag linedtag canv canv2 canv3
5885 if {![info exists linehtag($l)]} return
5887 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5888 -tags secsel -fill [$canv cget -selectbackground]]
5890 $canv2 delete secsel
5891 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5892 -tags secsel -fill [$canv2 cget -selectbackground]]
5894 $canv3 delete secsel
5895 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5896 -tags secsel -fill [$canv3 cget -selectbackground]]
5900 proc selectline {l isnew} {
5901 global canv ctext commitinfo selectedline
5902 global canvy0 linespc parents children curview
5903 global currentid sha1entry
5904 global commentend idtags linknum
5905 global mergemax numcommits pending_select
5906 global cmitmode showneartags allcommits
5907 global targetrow targetid lastscrollrows
5910 catch {unset pending_select}
5915 if {$l < 0 || $l >= $numcommits} return
5916 set id [commitonrow $l]
5921 if {$lastscrollrows < $numcommits} {
5925 set y [expr {$canvy0 + $l * $linespc}]
5926 set ymax [lindex [$canv cget -scrollregion] 3]
5927 set ytop [expr {$y - $linespc - 1}]
5928 set ybot [expr {$y + $linespc + 1}]
5929 set wnow [$canv yview]
5930 set wtop [expr {[lindex $wnow 0] * $ymax}]
5931 set wbot [expr {[lindex $wnow 1] * $ymax}]
5932 set wh [expr {$wbot - $wtop}]
5934 if {$ytop < $wtop} {
5935 if {$ybot < $wtop} {
5936 set newtop [expr {$y - $wh / 2.0}]
5939 if {$newtop > $wtop - $linespc} {
5940 set newtop [expr {$wtop - $linespc}]
5943 } elseif {$ybot > $wbot} {
5944 if {$ytop > $wbot} {
5945 set newtop [expr {$y - $wh / 2.0}]
5947 set newtop [expr {$ybot - $wh}]
5948 if {$newtop < $wtop + $linespc} {
5949 set newtop [expr {$wtop + $linespc}]
5953 if {$newtop != $wtop} {
5957 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5964 addtohistory [list selbyid $id]
5967 $sha1entry delete 0 end
5968 $sha1entry insert 0 $id
5970 $sha1entry selection from 0
5971 $sha1entry selection to end
5975 $ctext conf -state normal
5978 if {![info exists commitinfo($id)]} {
5981 set info $commitinfo($id)
5982 set date [formatdate [lindex $info 2]]
5983 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5984 set date [formatdate [lindex $info 4]]
5985 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5986 if {[info exists idtags($id)]} {
5987 $ctext insert end [mc "Tags:"]
5988 foreach tag $idtags($id) {
5989 $ctext insert end " $tag"
5991 $ctext insert end "\n"
5995 set olds $parents($curview,$id)
5996 if {[llength $olds] > 1} {
5999 if {$np >= $mergemax} {
6004 $ctext insert end "[mc "Parent"]: " $tag
6005 appendwithlinks [commit_descriptor $p] {}
6010 append headers "[mc "Parent"]: [commit_descriptor $p]"
6014 foreach c $children($curview,$id) {
6015 append headers "[mc "Child"]: [commit_descriptor $c]"
6018 # make anything that looks like a SHA1 ID be a clickable link
6019 appendwithlinks $headers {}
6020 if {$showneartags} {
6021 if {![info exists allcommits]} {
6024 $ctext insert end "[mc "Branch"]: "
6025 $ctext mark set branch "end -1c"
6026 $ctext mark gravity branch left
6027 $ctext insert end "\n[mc "Follows"]: "
6028 $ctext mark set follows "end -1c"
6029 $ctext mark gravity follows left
6030 $ctext insert end "\n[mc "Precedes"]: "
6031 $ctext mark set precedes "end -1c"
6032 $ctext mark gravity precedes left
6033 $ctext insert end "\n"
6036 $ctext insert end "\n"
6037 set comment [lindex $info 5]
6038 if {[string first "\r" $comment] >= 0} {
6039 set comment [string map {"\r" "\n "} $comment]
6041 appendwithlinks $comment {comment}
6043 $ctext tag remove found 1.0 end
6044 $ctext conf -state disabled
6045 set commentend [$ctext index "end - 1c"]
6047 init_flist [mc "Comments"]
6048 if {$cmitmode eq "tree"} {
6050 } elseif {[llength $olds] <= 1} {
6057 proc selfirstline {} {
6062 proc sellastline {} {
6065 set l [expr {$numcommits - 1}]
6069 proc selnextline {dir} {
6072 if {$selectedline eq {}} return
6073 set l [expr {$selectedline + $dir}]
6078 proc selnextpage {dir} {
6079 global canv linespc selectedline numcommits
6081 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6085 allcanvs yview scroll [expr {$dir * $lpp}] units
6087 if {$selectedline eq {}} return
6088 set l [expr {$selectedline + $dir * $lpp}]
6091 } elseif {$l >= $numcommits} {
6092 set l [expr $numcommits - 1]
6098 proc unselectline {} {
6099 global selectedline currentid
6102 catch {unset currentid}
6103 allcanvs delete secsel
6107 proc reselectline {} {
6110 if {$selectedline ne {}} {
6111 selectline $selectedline 0
6115 proc addtohistory {cmd} {
6116 global history historyindex curview
6118 set elt [list $curview $cmd]
6119 if {$historyindex > 0
6120 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6124 if {$historyindex < [llength $history]} {
6125 set history [lreplace $history $historyindex end $elt]
6127 lappend history $elt
6130 if {$historyindex > 1} {
6131 .tf.bar.leftbut conf -state normal
6133 .tf.bar.leftbut conf -state disabled
6135 .tf.bar.rightbut conf -state disabled
6141 set view [lindex $elt 0]
6142 set cmd [lindex $elt 1]
6143 if {$curview != $view} {
6150 global history historyindex
6153 if {$historyindex > 1} {
6154 incr historyindex -1
6155 godo [lindex $history [expr {$historyindex - 1}]]
6156 .tf.bar.rightbut conf -state normal
6158 if {$historyindex <= 1} {
6159 .tf.bar.leftbut conf -state disabled
6164 global history historyindex
6167 if {$historyindex < [llength $history]} {
6168 set cmd [lindex $history $historyindex]
6171 .tf.bar.leftbut conf -state normal
6173 if {$historyindex >= [llength $history]} {
6174 .tf.bar.rightbut conf -state disabled
6179 global treefilelist treeidlist diffids diffmergeid treepending
6180 global nullid nullid2
6183 catch {unset diffmergeid}
6184 if {![info exists treefilelist($id)]} {
6185 if {![info exists treepending]} {
6186 if {$id eq $nullid} {
6187 set cmd [list | git ls-files]
6188 } elseif {$id eq $nullid2} {
6189 set cmd [list | git ls-files --stage -t]
6191 set cmd [list | git ls-tree -r $id]
6193 if {[catch {set gtf [open $cmd r]}]} {
6197 set treefilelist($id) {}
6198 set treeidlist($id) {}
6199 fconfigure $gtf -blocking 0
6200 filerun $gtf [list gettreeline $gtf $id]
6207 proc gettreeline {gtf id} {
6208 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6211 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6212 if {$diffids eq $nullid} {
6215 set i [string first "\t" $line]
6216 if {$i < 0} continue
6217 set fname [string range $line [expr {$i+1}] end]
6218 set line [string range $line 0 [expr {$i-1}]]
6219 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6220 set sha1 [lindex $line 2]
6221 if {[string index $fname 0] eq "\""} {
6222 set fname [lindex $fname 0]
6224 lappend treeidlist($id) $sha1
6226 lappend treefilelist($id) $fname
6229 return [expr {$nl >= 1000? 2: 1}]
6233 if {$cmitmode ne "tree"} {
6234 if {![info exists diffmergeid]} {
6235 gettreediffs $diffids
6237 } elseif {$id ne $diffids} {
6246 global treefilelist treeidlist diffids nullid nullid2
6247 global ctext commentend
6249 set i [lsearch -exact $treefilelist($diffids) $f]
6251 puts "oops, $f not in list for id $diffids"
6254 if {$diffids eq $nullid} {
6255 if {[catch {set bf [open $f r]} err]} {
6256 puts "oops, can't read $f: $err"
6260 set blob [lindex $treeidlist($diffids) $i]
6261 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6262 puts "oops, error reading blob $blob: $err"
6266 fconfigure $bf -blocking 0
6267 filerun $bf [list getblobline $bf $diffids]
6268 $ctext config -state normal
6269 clear_ctext $commentend
6270 $ctext insert end "\n"
6271 $ctext insert end "$f\n" filesep
6272 $ctext config -state disabled
6273 $ctext yview $commentend
6277 proc getblobline {bf id} {
6278 global diffids cmitmode ctext
6280 if {$id ne $diffids || $cmitmode ne "tree"} {
6284 $ctext config -state normal
6286 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6287 $ctext insert end "$line\n"
6290 # delete last newline
6291 $ctext delete "end - 2c" "end - 1c"
6295 $ctext config -state disabled
6296 return [expr {$nl >= 1000? 2: 1}]
6299 proc mergediff {id} {
6300 global diffmergeid mdifffd
6304 global limitdiffs vfilelimit curview
6308 # this doesn't seem to actually affect anything...
6309 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6310 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6311 set cmd [concat $cmd -- $vfilelimit($curview)]
6313 if {[catch {set mdf [open $cmd r]} err]} {
6314 error_popup "[mc "Error getting merge diffs:"] $err"
6317 fconfigure $mdf -blocking 0
6318 set mdifffd($id) $mdf
6319 set np [llength $parents($curview,$id)]
6321 filerun $mdf [list getmergediffline $mdf $id $np]
6324 proc getmergediffline {mdf id np} {
6325 global diffmergeid ctext cflist mergemax
6326 global difffilestart mdifffd
6328 $ctext conf -state normal
6330 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6331 if {![info exists diffmergeid] || $id != $diffmergeid
6332 || $mdf != $mdifffd($id)} {
6336 if {[regexp {^diff --cc (.*)} $line match fname]} {
6337 # start of a new file
6338 $ctext insert end "\n"
6339 set here [$ctext index "end - 1c"]
6340 lappend difffilestart $here
6341 add_flist [list $fname]
6342 set l [expr {(78 - [string length $fname]) / 2}]
6343 set pad [string range "----------------------------------------" 1 $l]
6344 $ctext insert end "$pad $fname $pad\n" filesep
6345 } elseif {[regexp {^@@} $line]} {
6346 $ctext insert end "$line\n" hunksep
6347 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6350 # parse the prefix - one ' ', '-' or '+' for each parent
6355 for {set j 0} {$j < $np} {incr j} {
6356 set c [string range $line $j $j]
6359 } elseif {$c == "-"} {
6361 } elseif {$c == "+"} {
6370 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6371 # line doesn't appear in result, parents in $minuses have the line
6372 set num [lindex $minuses 0]
6373 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6374 # line appears in result, parents in $pluses don't have the line
6375 lappend tags mresult
6376 set num [lindex $spaces 0]
6379 if {$num >= $mergemax} {
6384 $ctext insert end "$line\n" $tags
6387 $ctext conf -state disabled
6392 return [expr {$nr >= 1000? 2: 1}]
6395 proc startdiff {ids} {
6396 global treediffs diffids treepending diffmergeid nullid nullid2
6400 catch {unset diffmergeid}
6401 if {![info exists treediffs($ids)] ||
6402 [lsearch -exact $ids $nullid] >= 0 ||
6403 [lsearch -exact $ids $nullid2] >= 0} {
6404 if {![info exists treepending]} {
6412 proc path_filter {filter name} {
6414 set l [string length $p]
6415 if {[string index $p end] eq "/"} {
6416 if {[string compare -length $l $p $name] == 0} {
6420 if {[string compare -length $l $p $name] == 0 &&
6421 ([string length $name] == $l ||
6422 [string index $name $l] eq "/")} {
6430 proc addtocflist {ids} {
6433 add_flist $treediffs($ids)
6437 proc diffcmd {ids flags} {
6438 global nullid nullid2
6440 set i [lsearch -exact $ids $nullid]
6441 set j [lsearch -exact $ids $nullid2]
6443 if {[llength $ids] > 1 && $j < 0} {
6444 # comparing working directory with some specific revision
6445 set cmd [concat | git diff-index $flags]
6447 lappend cmd -R [lindex $ids 1]
6449 lappend cmd [lindex $ids 0]
6452 # comparing working directory with index
6453 set cmd [concat | git diff-files $flags]
6458 } elseif {$j >= 0} {
6459 set cmd [concat | git diff-index --cached $flags]
6460 if {[llength $ids] > 1} {
6461 # comparing index with specific revision
6463 lappend cmd -R [lindex $ids 1]
6465 lappend cmd [lindex $ids 0]
6468 # comparing index with HEAD
6472 set cmd [concat | git diff-tree -r $flags $ids]
6477 proc gettreediffs {ids} {
6478 global treediff treepending
6480 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6482 set treepending $ids
6484 fconfigure $gdtf -blocking 0
6485 filerun $gdtf [list gettreediffline $gdtf $ids]
6488 proc gettreediffline {gdtf ids} {
6489 global treediff treediffs treepending diffids diffmergeid
6490 global cmitmode vfilelimit curview limitdiffs
6493 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6494 set i [string first "\t" $line]
6496 set file [string range $line [expr {$i+1}] end]
6497 if {[string index $file 0] eq "\""} {
6498 set file [lindex $file 0]
6500 lappend treediff $file
6504 return [expr {$nr >= 1000? 2: 1}]
6507 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6509 foreach f $treediff {
6510 if {[path_filter $vfilelimit($curview) $f]} {
6514 set treediffs($ids) $flist
6516 set treediffs($ids) $treediff
6519 if {$cmitmode eq "tree"} {
6521 } elseif {$ids != $diffids} {
6522 if {![info exists diffmergeid]} {
6523 gettreediffs $diffids
6531 # empty string or positive integer
6532 proc diffcontextvalidate {v} {
6533 return [regexp {^(|[1-9][0-9]*)$} $v]
6536 proc diffcontextchange {n1 n2 op} {
6537 global diffcontextstring diffcontext
6539 if {[string is integer -strict $diffcontextstring]} {
6540 if {$diffcontextstring > 0} {
6541 set diffcontext $diffcontextstring
6547 proc changeignorespace {} {
6551 proc getblobdiffs {ids} {
6552 global blobdifffd diffids env
6553 global diffinhdr treediffs
6556 global limitdiffs vfilelimit curview
6558 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6562 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6563 set cmd [concat $cmd -- $vfilelimit($curview)]
6565 if {[catch {set bdf [open $cmd r]} err]} {
6566 puts "error getting diffs: $err"
6570 fconfigure $bdf -blocking 0
6571 set blobdifffd($ids) $bdf
6572 filerun $bdf [list getblobdiffline $bdf $diffids]
6575 proc setinlist {var i val} {
6578 while {[llength [set $var]] < $i} {
6581 if {[llength [set $var]] == $i} {
6588 proc makediffhdr {fname ids} {
6589 global ctext curdiffstart treediffs
6591 set i [lsearch -exact $treediffs($ids) $fname]
6593 setinlist difffilestart $i $curdiffstart
6595 set l [expr {(78 - [string length $fname]) / 2}]
6596 set pad [string range "----------------------------------------" 1 $l]
6597 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6600 proc getblobdiffline {bdf ids} {
6601 global diffids blobdifffd ctext curdiffstart
6602 global diffnexthead diffnextnote difffilestart
6603 global diffinhdr treediffs
6606 $ctext conf -state normal
6607 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6608 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6612 if {![string compare -length 11 "diff --git " $line]} {
6613 # trim off "diff --git "
6614 set line [string range $line 11 end]
6616 # start of a new file
6617 $ctext insert end "\n"
6618 set curdiffstart [$ctext index "end - 1c"]
6619 $ctext insert end "\n" filesep
6620 # If the name hasn't changed the length will be odd,
6621 # the middle char will be a space, and the two bits either
6622 # side will be a/name and b/name, or "a/name" and "b/name".
6623 # If the name has changed we'll get "rename from" and
6624 # "rename to" or "copy from" and "copy to" lines following this,
6625 # and we'll use them to get the filenames.
6626 # This complexity is necessary because spaces in the filename(s)
6627 # don't get escaped.
6628 set l [string length $line]
6629 set i [expr {$l / 2}]
6630 if {!(($l & 1) && [string index $line $i] eq " " &&
6631 [string range $line 2 [expr {$i - 1}]] eq \
6632 [string range $line [expr {$i + 3}] end])} {
6635 # unescape if quoted and chop off the a/ from the front
6636 if {[string index $line 0] eq "\""} {
6637 set fname [string range [lindex $line 0] 2 end]
6639 set fname [string range $line 2 [expr {$i - 1}]]
6641 makediffhdr $fname $ids
6643 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6644 $line match f1l f1c f2l f2c rest]} {
6645 $ctext insert end "$line\n" hunksep
6648 } elseif {$diffinhdr} {
6649 if {![string compare -length 12 "rename from " $line]} {
6650 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6651 if {[string index $fname 0] eq "\""} {
6652 set fname [lindex $fname 0]
6654 set i [lsearch -exact $treediffs($ids) $fname]
6656 setinlist difffilestart $i $curdiffstart
6658 } elseif {![string compare -length 10 $line "rename to "] ||
6659 ![string compare -length 8 $line "copy to "]} {
6660 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6661 if {[string index $fname 0] eq "\""} {
6662 set fname [lindex $fname 0]
6664 makediffhdr $fname $ids
6665 } elseif {[string compare -length 3 $line "---"] == 0} {
6668 } elseif {[string compare -length 3 $line "+++"] == 0} {
6672 $ctext insert end "$line\n" filesep
6675 set x [string range $line 0 0]
6676 if {$x == "-" || $x == "+"} {
6677 set tag [expr {$x == "+"}]
6678 $ctext insert end "$line\n" d$tag
6679 } elseif {$x == " "} {
6680 $ctext insert end "$line\n"
6682 # "\ No newline at end of file",
6683 # or something else we don't recognize
6684 $ctext insert end "$line\n" hunksep
6688 $ctext conf -state disabled
6693 return [expr {$nr >= 1000? 2: 1}]
6696 proc changediffdisp {} {
6697 global ctext diffelide
6699 $ctext tag conf d0 -elide [lindex $diffelide 0]
6700 $ctext tag conf d1 -elide [lindex $diffelide 1]
6703 proc highlightfile {loc cline} {
6704 global ctext cflist cflist_top
6707 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6708 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6709 $cflist see $cline.0
6710 set cflist_top $cline
6714 global difffilestart ctext cmitmode
6716 if {$cmitmode eq "tree"} return
6719 set here [$ctext index @0,0]
6720 foreach loc $difffilestart {
6721 if {[$ctext compare $loc >= $here]} {
6722 highlightfile $prev $prevline
6728 highlightfile $prev $prevline
6732 global difffilestart ctext cmitmode
6734 if {$cmitmode eq "tree"} return
6735 set here [$ctext index @0,0]
6737 foreach loc $difffilestart {
6739 if {[$ctext compare $loc > $here]} {
6740 highlightfile $loc $line
6746 proc clear_ctext {{first 1.0}} {
6747 global ctext smarktop smarkbot
6750 set l [lindex [split $first .] 0]
6751 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6754 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6757 $ctext delete $first end
6758 if {$first eq "1.0"} {
6759 catch {unset pendinglinks}
6763 proc settabs {{firstab {}}} {
6764 global firsttabstop tabstop ctext have_tk85
6766 if {$firstab ne {} && $have_tk85} {
6767 set firsttabstop $firstab
6769 set w [font measure textfont "0"]
6770 if {$firsttabstop != 0} {
6771 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6772 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6773 } elseif {$have_tk85 || $tabstop != 8} {
6774 $ctext conf -tabs [expr {$tabstop * $w}]
6776 $ctext conf -tabs {}
6780 proc incrsearch {name ix op} {
6781 global ctext searchstring searchdirn
6783 $ctext tag remove found 1.0 end
6784 if {[catch {$ctext index anchor}]} {
6785 # no anchor set, use start of selection, or of visible area
6786 set sel [$ctext tag ranges sel]
6788 $ctext mark set anchor [lindex $sel 0]
6789 } elseif {$searchdirn eq "-forwards"} {
6790 $ctext mark set anchor @0,0
6792 $ctext mark set anchor @0,[winfo height $ctext]
6795 if {$searchstring ne {}} {
6796 set here [$ctext search $searchdirn -- $searchstring anchor]
6805 global sstring ctext searchstring searchdirn
6808 $sstring icursor end
6809 set searchdirn -forwards
6810 if {$searchstring ne {}} {
6811 set sel [$ctext tag ranges sel]
6813 set start "[lindex $sel 0] + 1c"
6814 } elseif {[catch {set start [$ctext index anchor]}]} {
6817 set match [$ctext search -count mlen -- $searchstring $start]
6818 $ctext tag remove sel 1.0 end
6824 set mend "$match + $mlen c"
6825 $ctext tag add sel $match $mend
6826 $ctext mark unset anchor
6830 proc dosearchback {} {
6831 global sstring ctext searchstring searchdirn
6834 $sstring icursor end
6835 set searchdirn -backwards
6836 if {$searchstring ne {}} {
6837 set sel [$ctext tag ranges sel]
6839 set start [lindex $sel 0]
6840 } elseif {[catch {set start [$ctext index anchor]}]} {
6841 set start @0,[winfo height $ctext]
6843 set match [$ctext search -backwards -count ml -- $searchstring $start]
6844 $ctext tag remove sel 1.0 end
6850 set mend "$match + $ml c"
6851 $ctext tag add sel $match $mend
6852 $ctext mark unset anchor
6856 proc searchmark {first last} {
6857 global ctext searchstring
6861 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6862 if {$match eq {}} break
6863 set mend "$match + $mlen c"
6864 $ctext tag add found $match $mend
6868 proc searchmarkvisible {doall} {
6869 global ctext smarktop smarkbot
6871 set topline [lindex [split [$ctext index @0,0] .] 0]
6872 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6873 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6874 # no overlap with previous
6875 searchmark $topline $botline
6876 set smarktop $topline
6877 set smarkbot $botline
6879 if {$topline < $smarktop} {
6880 searchmark $topline [expr {$smarktop-1}]
6881 set smarktop $topline
6883 if {$botline > $smarkbot} {
6884 searchmark [expr {$smarkbot+1}] $botline
6885 set smarkbot $botline
6890 proc scrolltext {f0 f1} {
6893 .bleft.bottom.sb set $f0 $f1
6894 if {$searchstring ne {}} {
6900 global linespc charspc canvx0 canvy0
6901 global xspc1 xspc2 lthickness
6903 set linespc [font metrics mainfont -linespace]
6904 set charspc [font measure mainfont "m"]
6905 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6906 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6907 set lthickness [expr {int($linespc / 9) + 1}]
6908 set xspc1(0) $linespc
6916 set ymax [lindex [$canv cget -scrollregion] 3]
6917 if {$ymax eq {} || $ymax == 0} return
6918 set span [$canv yview]
6921 allcanvs yview moveto [lindex $span 0]
6923 if {$selectedline ne {}} {
6924 selectline $selectedline 0
6925 allcanvs yview moveto [lindex $span 0]
6929 proc parsefont {f n} {
6932 set fontattr($f,family) [lindex $n 0]
6934 if {$s eq {} || $s == 0} {
6937 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6939 set fontattr($f,size) $s
6940 set fontattr($f,weight) normal
6941 set fontattr($f,slant) roman
6942 foreach style [lrange $n 2 end] {
6945 "bold" {set fontattr($f,weight) $style}
6947 "italic" {set fontattr($f,slant) $style}
6952 proc fontflags {f {isbold 0}} {
6955 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6956 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6957 -slant $fontattr($f,slant)]
6963 set n [list $fontattr($f,family) $fontattr($f,size)]
6964 if {$fontattr($f,weight) eq "bold"} {
6967 if {$fontattr($f,slant) eq "italic"} {
6973 proc incrfont {inc} {
6974 global mainfont textfont ctext canv cflist showrefstop
6975 global stopped entries fontattr
6978 set s $fontattr(mainfont,size)
6983 set fontattr(mainfont,size) $s
6984 font config mainfont -size $s
6985 font config mainfontbold -size $s
6986 set mainfont [fontname mainfont]
6987 set s $fontattr(textfont,size)
6992 set fontattr(textfont,size) $s
6993 font config textfont -size $s
6994 font config textfontbold -size $s
6995 set textfont [fontname textfont]
7002 global sha1entry sha1string
7003 if {[string length $sha1string] == 40} {
7004 $sha1entry delete 0 end
7008 proc sha1change {n1 n2 op} {
7009 global sha1string currentid sha1but
7010 if {$sha1string == {}
7011 || ([info exists currentid] && $sha1string == $currentid)} {
7016 if {[$sha1but cget -state] == $state} return
7017 if {$state == "normal"} {
7018 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7020 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7024 proc gotocommit {} {
7025 global sha1string tagids headids curview varcid
7027 if {$sha1string == {}
7028 || ([info exists currentid] && $sha1string == $currentid)} return
7029 if {[info exists tagids($sha1string)]} {
7030 set id $tagids($sha1string)
7031 } elseif {[info exists headids($sha1string)]} {
7032 set id $headids($sha1string)
7034 set id [string tolower $sha1string]
7035 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7036 set matches [array names varcid "$curview,$id*"]
7037 if {$matches ne {}} {
7038 if {[llength $matches] > 1} {
7039 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7042 set id [lindex [split [lindex $matches 0] ","] 1]
7046 if {[commitinview $id $curview]} {
7047 selectline [rowofcommit $id] 1
7050 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7051 set msg [mc "SHA1 id %s is not known" $sha1string]
7053 set msg [mc "Tag/Head %s is not known" $sha1string]
7058 proc lineenter {x y id} {
7059 global hoverx hovery hoverid hovertimer
7060 global commitinfo canv
7062 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7066 if {[info exists hovertimer]} {
7067 after cancel $hovertimer
7069 set hovertimer [after 500 linehover]
7073 proc linemotion {x y id} {
7074 global hoverx hovery hoverid hovertimer
7076 if {[info exists hoverid] && $id == $hoverid} {
7079 if {[info exists hovertimer]} {
7080 after cancel $hovertimer
7082 set hovertimer [after 500 linehover]
7086 proc lineleave {id} {
7087 global hoverid hovertimer canv
7089 if {[info exists hoverid] && $id == $hoverid} {
7091 if {[info exists hovertimer]} {
7092 after cancel $hovertimer
7100 global hoverx hovery hoverid hovertimer
7101 global canv linespc lthickness
7104 set text [lindex $commitinfo($hoverid) 0]
7105 set ymax [lindex [$canv cget -scrollregion] 3]
7106 if {$ymax == {}} return
7107 set yfrac [lindex [$canv yview] 0]
7108 set x [expr {$hoverx + 2 * $linespc}]
7109 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7110 set x0 [expr {$x - 2 * $lthickness}]
7111 set y0 [expr {$y - 2 * $lthickness}]
7112 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7113 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7114 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7115 -fill \#ffff80 -outline black -width 1 -tags hover]
7117 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7122 proc clickisonarrow {id y} {
7125 set ranges [rowranges $id]
7126 set thresh [expr {2 * $lthickness + 6}]
7127 set n [expr {[llength $ranges] - 1}]
7128 for {set i 1} {$i < $n} {incr i} {
7129 set row [lindex $ranges $i]
7130 if {abs([yc $row] - $y) < $thresh} {
7137 proc arrowjump {id n y} {
7140 # 1 <-> 2, 3 <-> 4, etc...
7141 set n [expr {(($n - 1) ^ 1) + 1}]
7142 set row [lindex [rowranges $id] $n]
7144 set ymax [lindex [$canv cget -scrollregion] 3]
7145 if {$ymax eq {} || $ymax <= 0} return
7146 set view [$canv yview]
7147 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7148 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7152 allcanvs yview moveto $yfrac
7155 proc lineclick {x y id isnew} {
7156 global ctext commitinfo children canv thickerline curview
7158 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7163 # draw this line thicker than normal
7167 set ymax [lindex [$canv cget -scrollregion] 3]
7168 if {$ymax eq {}} return
7169 set yfrac [lindex [$canv yview] 0]
7170 set y [expr {$y + $yfrac * $ymax}]
7172 set dirn [clickisonarrow $id $y]
7174 arrowjump $id $dirn $y
7179 addtohistory [list lineclick $x $y $id 0]
7181 # fill the details pane with info about this line
7182 $ctext conf -state normal
7185 $ctext insert end "[mc "Parent"]:\t"
7186 $ctext insert end $id link0
7188 set info $commitinfo($id)
7189 $ctext insert end "\n\t[lindex $info 0]\n"
7190 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7191 set date [formatdate [lindex $info 2]]
7192 $ctext insert end "\t[mc "Date"]:\t$date\n"
7193 set kids $children($curview,$id)
7195 $ctext insert end "\n[mc "Children"]:"
7197 foreach child $kids {
7199 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7200 set info $commitinfo($child)
7201 $ctext insert end "\n\t"
7202 $ctext insert end $child link$i
7203 setlink $child link$i
7204 $ctext insert end "\n\t[lindex $info 0]"
7205 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7206 set date [formatdate [lindex $info 2]]
7207 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7210 $ctext conf -state disabled
7214 proc normalline {} {
7216 if {[info exists thickerline]} {
7225 if {[commitinview $id $curview]} {
7226 selectline [rowofcommit $id] 1
7232 if {![info exists startmstime]} {
7233 set startmstime [clock clicks -milliseconds]
7235 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7238 proc rowmenu {x y id} {
7239 global rowctxmenu selectedline rowmenuid curview
7240 global nullid nullid2 fakerowmenu mainhead
7244 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7249 if {$id ne $nullid && $id ne $nullid2} {
7250 set menu $rowctxmenu
7251 if {$mainhead ne {}} {
7252 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7254 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7257 set menu $fakerowmenu
7259 $menu entryconfigure [mc "Diff this -> selected"] -state $state
7260 $menu entryconfigure [mc "Diff selected -> this"] -state $state
7261 $menu entryconfigure [mc "Make patch"] -state $state
7262 tk_popup $menu $x $y
7265 proc diffvssel {dirn} {
7266 global rowmenuid selectedline
7268 if {$selectedline eq {}} return
7270 set oldid [commitonrow $selectedline]
7271 set newid $rowmenuid
7273 set oldid $rowmenuid
7274 set newid [commitonrow $selectedline]
7276 addtohistory [list doseldiff $oldid $newid]
7277 doseldiff $oldid $newid
7280 proc doseldiff {oldid newid} {
7284 $ctext conf -state normal
7286 init_flist [mc "Top"]
7287 $ctext insert end "[mc "From"] "
7288 $ctext insert end $oldid link0
7289 setlink $oldid link0
7290 $ctext insert end "\n "
7291 $ctext insert end [lindex $commitinfo($oldid) 0]
7292 $ctext insert end "\n\n[mc "To"] "
7293 $ctext insert end $newid link1
7294 setlink $newid link1
7295 $ctext insert end "\n "
7296 $ctext insert end [lindex $commitinfo($newid) 0]
7297 $ctext insert end "\n"
7298 $ctext conf -state disabled
7299 $ctext tag remove found 1.0 end
7300 startdiff [list $oldid $newid]
7304 global rowmenuid currentid commitinfo patchtop patchnum
7306 if {![info exists currentid]} return
7307 set oldid $currentid
7308 set oldhead [lindex $commitinfo($oldid) 0]
7309 set newid $rowmenuid
7310 set newhead [lindex $commitinfo($newid) 0]
7313 catch {destroy $top}
7315 label $top.title -text [mc "Generate patch"]
7316 grid $top.title - -pady 10
7317 label $top.from -text [mc "From:"]
7318 entry $top.fromsha1 -width 40 -relief flat
7319 $top.fromsha1 insert 0 $oldid
7320 $top.fromsha1 conf -state readonly
7321 grid $top.from $top.fromsha1 -sticky w
7322 entry $top.fromhead -width 60 -relief flat
7323 $top.fromhead insert 0 $oldhead
7324 $top.fromhead conf -state readonly
7325 grid x $top.fromhead -sticky w
7326 label $top.to -text [mc "To:"]
7327 entry $top.tosha1 -width 40 -relief flat
7328 $top.tosha1 insert 0 $newid
7329 $top.tosha1 conf -state readonly
7330 grid $top.to $top.tosha1 -sticky w
7331 entry $top.tohead -width 60 -relief flat
7332 $top.tohead insert 0 $newhead
7333 $top.tohead conf -state readonly
7334 grid x $top.tohead -sticky w
7335 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7336 grid $top.rev x -pady 10
7337 label $top.flab -text [mc "Output file:"]
7338 entry $top.fname -width 60
7339 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7341 grid $top.flab $top.fname -sticky w
7343 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7344 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7345 grid $top.buts.gen $top.buts.can
7346 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7347 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7348 grid $top.buts - -pady 10 -sticky ew
7352 proc mkpatchrev {} {
7355 set oldid [$patchtop.fromsha1 get]
7356 set oldhead [$patchtop.fromhead get]
7357 set newid [$patchtop.tosha1 get]
7358 set newhead [$patchtop.tohead get]
7359 foreach e [list fromsha1 fromhead tosha1 tohead] \
7360 v [list $newid $newhead $oldid $oldhead] {
7361 $patchtop.$e conf -state normal
7362 $patchtop.$e delete 0 end
7363 $patchtop.$e insert 0 $v
7364 $patchtop.$e conf -state readonly
7369 global patchtop nullid nullid2
7371 set oldid [$patchtop.fromsha1 get]
7372 set newid [$patchtop.tosha1 get]
7373 set fname [$patchtop.fname get]
7374 set cmd [diffcmd [list $oldid $newid] -p]
7375 # trim off the initial "|"
7376 set cmd [lrange $cmd 1 end]
7377 lappend cmd >$fname &
7378 if {[catch {eval exec $cmd} err]} {
7379 error_popup "[mc "Error creating patch:"] $err"
7381 catch {destroy $patchtop}
7385 proc mkpatchcan {} {
7388 catch {destroy $patchtop}
7393 global rowmenuid mktagtop commitinfo
7397 catch {destroy $top}
7399 label $top.title -text [mc "Create tag"]
7400 grid $top.title - -pady 10
7401 label $top.id -text [mc "ID:"]
7402 entry $top.sha1 -width 40 -relief flat
7403 $top.sha1 insert 0 $rowmenuid
7404 $top.sha1 conf -state readonly
7405 grid $top.id $top.sha1 -sticky w
7406 entry $top.head -width 60 -relief flat
7407 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7408 $top.head conf -state readonly
7409 grid x $top.head -sticky w
7410 label $top.tlab -text [mc "Tag name:"]
7411 entry $top.tag -width 60
7412 grid $top.tlab $top.tag -sticky w
7414 button $top.buts.gen -text [mc "Create"] -command mktaggo
7415 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7416 grid $top.buts.gen $top.buts.can
7417 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7418 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7419 grid $top.buts - -pady 10 -sticky ew
7424 global mktagtop env tagids idtags
7426 set id [$mktagtop.sha1 get]
7427 set tag [$mktagtop.tag get]
7429 error_popup [mc "No tag name specified"]
7432 if {[info exists tagids($tag)]} {
7433 error_popup [mc "Tag \"%s\" already exists" $tag]
7437 exec git tag $tag $id
7439 error_popup "[mc "Error creating tag:"] $err"
7443 set tagids($tag) $id
7444 lappend idtags($id) $tag
7451 proc redrawtags {id} {
7452 global canv linehtag idpos currentid curview cmitlisted
7453 global canvxmax iddrawn circleitem mainheadid circlecolors
7455 if {![commitinview $id $curview]} return
7456 if {![info exists iddrawn($id)]} return
7457 set row [rowofcommit $id]
7458 if {$id eq $mainheadid} {
7461 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7463 $canv itemconf $circleitem($row) -fill $ofill
7464 $canv delete tag.$id
7465 set xt [eval drawtags $id $idpos($id)]
7466 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7467 set text [$canv itemcget $linehtag($row) -text]
7468 set font [$canv itemcget $linehtag($row) -font]
7469 set xr [expr {$xt + [font measure $font $text]}]
7470 if {$xr > $canvxmax} {
7474 if {[info exists currentid] && $currentid == $id} {
7482 catch {destroy $mktagtop}
7491 proc writecommit {} {
7492 global rowmenuid wrcomtop commitinfo wrcomcmd
7494 set top .writecommit
7496 catch {destroy $top}
7498 label $top.title -text [mc "Write commit to file"]
7499 grid $top.title - -pady 10
7500 label $top.id -text [mc "ID:"]
7501 entry $top.sha1 -width 40 -relief flat
7502 $top.sha1 insert 0 $rowmenuid
7503 $top.sha1 conf -state readonly
7504 grid $top.id $top.sha1 -sticky w
7505 entry $top.head -width 60 -relief flat
7506 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7507 $top.head conf -state readonly
7508 grid x $top.head -sticky w
7509 label $top.clab -text [mc "Command:"]
7510 entry $top.cmd -width 60 -textvariable wrcomcmd
7511 grid $top.clab $top.cmd -sticky w -pady 10
7512 label $top.flab -text [mc "Output file:"]
7513 entry $top.fname -width 60
7514 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7515 grid $top.flab $top.fname -sticky w
7517 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7518 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7519 grid $top.buts.gen $top.buts.can
7520 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7521 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7522 grid $top.buts - -pady 10 -sticky ew
7529 set id [$wrcomtop.sha1 get]
7530 set cmd "echo $id | [$wrcomtop.cmd get]"
7531 set fname [$wrcomtop.fname get]
7532 if {[catch {exec sh -c $cmd >$fname &} err]} {
7533 error_popup "[mc "Error writing commit:"] $err"
7535 catch {destroy $wrcomtop}
7542 catch {destroy $wrcomtop}
7547 global rowmenuid mkbrtop
7550 catch {destroy $top}
7552 label $top.title -text [mc "Create new branch"]
7553 grid $top.title - -pady 10
7554 label $top.id -text [mc "ID:"]
7555 entry $top.sha1 -width 40 -relief flat
7556 $top.sha1 insert 0 $rowmenuid
7557 $top.sha1 conf -state readonly
7558 grid $top.id $top.sha1 -sticky w
7559 label $top.nlab -text [mc "Name:"]
7560 entry $top.name -width 40
7561 grid $top.nlab $top.name -sticky w
7563 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7564 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7565 grid $top.buts.go $top.buts.can
7566 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7567 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7568 grid $top.buts - -pady 10 -sticky ew
7573 global headids idheads
7575 set name [$top.name get]
7576 set id [$top.sha1 get]
7578 error_popup [mc "Please specify a name for the new branch"]
7581 catch {destroy $top}
7585 exec git branch $name $id
7590 set headids($name) $id
7591 lappend idheads($id) $name
7600 proc cherrypick {} {
7601 global rowmenuid curview
7602 global mainhead mainheadid
7604 set oldhead [exec git rev-parse HEAD]
7605 set dheads [descheads $rowmenuid]
7606 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7607 set ok [confirm_popup [mc "Commit %s is already\
7608 included in branch %s -- really re-apply it?" \
7609 [string range $rowmenuid 0 7] $mainhead]]
7612 nowbusy cherrypick [mc "Cherry-picking"]
7614 # Unfortunately git-cherry-pick writes stuff to stderr even when
7615 # no error occurs, and exec takes that as an indication of error...
7616 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7621 set newhead [exec git rev-parse HEAD]
7622 if {$newhead eq $oldhead} {
7624 error_popup [mc "No changes committed"]
7627 addnewchild $newhead $oldhead
7628 if {[commitinview $oldhead $curview]} {
7629 insertrow $newhead $oldhead $curview
7630 if {$mainhead ne {}} {
7631 movehead $newhead $mainhead
7632 movedhead $newhead $mainhead
7634 set mainheadid $newhead
7643 global mainhead rowmenuid confirm_ok resettype
7646 set w ".confirmreset"
7649 wm title $w [mc "Confirm reset"]
7650 message $w.m -text \
7651 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7652 -justify center -aspect 1000
7653 pack $w.m -side top -fill x -padx 20 -pady 20
7654 frame $w.f -relief sunken -border 2
7655 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7656 grid $w.f.rt -sticky w
7658 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7659 -text [mc "Soft: Leave working tree and index untouched"]
7660 grid $w.f.soft -sticky w
7661 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7662 -text [mc "Mixed: Leave working tree untouched, reset index"]
7663 grid $w.f.mixed -sticky w
7664 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7665 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7666 grid $w.f.hard -sticky w
7667 pack $w.f -side top -fill x
7668 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7669 pack $w.ok -side left -fill x -padx 20 -pady 20
7670 button $w.cancel -text [mc Cancel] -command "destroy $w"
7671 pack $w.cancel -side right -fill x -padx 20 -pady 20
7672 bind $w <Visibility> "grab $w; focus $w"
7674 if {!$confirm_ok} return
7675 if {[catch {set fd [open \
7676 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7680 filerun $fd [list readresetstat $fd]
7681 nowbusy reset [mc "Resetting"]
7686 proc readresetstat {fd} {
7687 global mainhead mainheadid showlocalchanges rprogcoord
7689 if {[gets $fd line] >= 0} {
7690 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7691 set rprogcoord [expr {1.0 * $m / $n}]
7699 if {[catch {close $fd} err]} {
7702 set oldhead $mainheadid
7703 set newhead [exec git rev-parse HEAD]
7704 if {$newhead ne $oldhead} {
7705 movehead $newhead $mainhead
7706 movedhead $newhead $mainhead
7707 set mainheadid $newhead
7711 if {$showlocalchanges} {
7717 # context menu for a head
7718 proc headmenu {x y id head} {
7719 global headmenuid headmenuhead headctxmenu mainhead
7723 set headmenuhead $head
7725 if {$head eq $mainhead} {
7728 $headctxmenu entryconfigure 0 -state $state
7729 $headctxmenu entryconfigure 1 -state $state
7730 tk_popup $headctxmenu $x $y
7734 global headmenuid headmenuhead headids
7735 global showlocalchanges mainheadid
7737 # check the tree is clean first??
7738 nowbusy checkout [mc "Checking out"]
7742 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7746 if {$showlocalchanges} {
7750 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7754 proc readcheckoutstat {fd newhead newheadid} {
7755 global mainhead mainheadid headids showlocalchanges progresscoords
7757 if {[gets $fd line] >= 0} {
7758 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7759 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7764 set progresscoords {0 0}
7767 if {[catch {close $fd} err]} {
7770 set oldmainid $mainheadid
7771 set mainhead $newhead
7772 set mainheadid $newheadid
7773 redrawtags $oldmainid
7774 redrawtags $newheadid
7776 if {$showlocalchanges} {
7782 global headmenuid headmenuhead mainhead
7785 set head $headmenuhead
7787 # this check shouldn't be needed any more...
7788 if {$head eq $mainhead} {
7789 error_popup [mc "Cannot delete the currently checked-out branch"]
7792 set dheads [descheads $id]
7793 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7794 # the stuff on this branch isn't on any other branch
7795 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7796 branch.\nReally delete branch %s?" $head $head]]} return
7800 if {[catch {exec git branch -D $head} err]} {
7805 removehead $id $head
7806 removedhead $id $head
7813 # Display a list of tags and heads
7815 global showrefstop bgcolor fgcolor selectbgcolor
7816 global bglist fglist reflistfilter reflist maincursor
7819 set showrefstop $top
7820 if {[winfo exists $top]} {
7826 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7827 text $top.list -background $bgcolor -foreground $fgcolor \
7828 -selectbackground $selectbgcolor -font mainfont \
7829 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7830 -width 30 -height 20 -cursor $maincursor \
7831 -spacing1 1 -spacing3 1 -state disabled
7832 $top.list tag configure highlight -background $selectbgcolor
7833 lappend bglist $top.list
7834 lappend fglist $top.list
7835 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7836 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7837 grid $top.list $top.ysb -sticky nsew
7838 grid $top.xsb x -sticky ew
7840 label $top.f.l -text "[mc "Filter"]: "
7841 entry $top.f.e -width 20 -textvariable reflistfilter
7842 set reflistfilter "*"
7843 trace add variable reflistfilter write reflistfilter_change
7844 pack $top.f.e -side right -fill x -expand 1
7845 pack $top.f.l -side left
7846 grid $top.f - -sticky ew -pady 2
7847 button $top.close -command [list destroy $top] -text [mc "Close"]
7849 grid columnconfigure $top 0 -weight 1
7850 grid rowconfigure $top 0 -weight 1
7851 bind $top.list <1> {break}
7852 bind $top.list <B1-Motion> {break}
7853 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7858 proc sel_reflist {w x y} {
7859 global showrefstop reflist headids tagids otherrefids
7861 if {![winfo exists $showrefstop]} return
7862 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7863 set ref [lindex $reflist [expr {$l-1}]]
7864 set n [lindex $ref 0]
7865 switch -- [lindex $ref 1] {
7866 "H" {selbyid $headids($n)}
7867 "T" {selbyid $tagids($n)}
7868 "o" {selbyid $otherrefids($n)}
7870 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7873 proc unsel_reflist {} {
7876 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7877 $showrefstop.list tag remove highlight 0.0 end
7880 proc reflistfilter_change {n1 n2 op} {
7881 global reflistfilter
7883 after cancel refill_reflist
7884 after 200 refill_reflist
7887 proc refill_reflist {} {
7888 global reflist reflistfilter showrefstop headids tagids otherrefids
7889 global curview commitinterest
7891 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7893 foreach n [array names headids] {
7894 if {[string match $reflistfilter $n]} {
7895 if {[commitinview $headids($n) $curview]} {
7896 lappend refs [list $n H]
7898 set commitinterest($headids($n)) {run refill_reflist}
7902 foreach n [array names tagids] {
7903 if {[string match $reflistfilter $n]} {
7904 if {[commitinview $tagids($n) $curview]} {
7905 lappend refs [list $n T]
7907 set commitinterest($tagids($n)) {run refill_reflist}
7911 foreach n [array names otherrefids] {
7912 if {[string match $reflistfilter $n]} {
7913 if {[commitinview $otherrefids($n) $curview]} {
7914 lappend refs [list $n o]
7916 set commitinterest($otherrefids($n)) {run refill_reflist}
7920 set refs [lsort -index 0 $refs]
7921 if {$refs eq $reflist} return
7923 # Update the contents of $showrefstop.list according to the
7924 # differences between $reflist (old) and $refs (new)
7925 $showrefstop.list conf -state normal
7926 $showrefstop.list insert end "\n"
7929 while {$i < [llength $reflist] || $j < [llength $refs]} {
7930 if {$i < [llength $reflist]} {
7931 if {$j < [llength $refs]} {
7932 set cmp [string compare [lindex $reflist $i 0] \
7933 [lindex $refs $j 0]]
7935 set cmp [string compare [lindex $reflist $i 1] \
7936 [lindex $refs $j 1]]
7946 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7954 set l [expr {$j + 1}]
7955 $showrefstop.list image create $l.0 -align baseline \
7956 -image reficon-[lindex $refs $j 1] -padx 2
7957 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7963 # delete last newline
7964 $showrefstop.list delete end-2c end-1c
7965 $showrefstop.list conf -state disabled
7968 # Stuff for finding nearby tags
7969 proc getallcommits {} {
7970 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7971 global idheads idtags idotherrefs allparents tagobjid
7973 if {![info exists allcommits]} {
7979 set allccache [file join [gitdir] "gitk.cache"]
7981 set f [open $allccache r]
7990 set cmd [list | git rev-list --parents]
7991 set allcupdate [expr {$seeds ne {}}]
7995 set refs [concat [array names idheads] [array names idtags] \
7996 [array names idotherrefs]]
7999 foreach name [array names tagobjid] {
8000 lappend tagobjs $tagobjid($name)
8002 foreach id [lsort -unique $refs] {
8003 if {![info exists allparents($id)] &&
8004 [lsearch -exact $tagobjs $id] < 0} {
8015 set fd [open [concat $cmd $ids] r]
8016 fconfigure $fd -blocking 0
8019 filerun $fd [list getallclines $fd]
8025 # Since most commits have 1 parent and 1 child, we group strings of
8026 # such commits into "arcs" joining branch/merge points (BMPs), which
8027 # are commits that either don't have 1 parent or don't have 1 child.
8029 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8030 # arcout(id) - outgoing arcs for BMP
8031 # arcids(a) - list of IDs on arc including end but not start
8032 # arcstart(a) - BMP ID at start of arc
8033 # arcend(a) - BMP ID at end of arc
8034 # growing(a) - arc a is still growing
8035 # arctags(a) - IDs out of arcids (excluding end) that have tags
8036 # archeads(a) - IDs out of arcids (excluding end) that have heads
8037 # The start of an arc is at the descendent end, so "incoming" means
8038 # coming from descendents, and "outgoing" means going towards ancestors.
8040 proc getallclines {fd} {
8041 global allparents allchildren idtags idheads nextarc
8042 global arcnos arcids arctags arcout arcend arcstart archeads growing
8043 global seeds allcommits cachedarcs allcupdate
8046 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8047 set id [lindex $line 0]
8048 if {[info exists allparents($id)]} {
8053 set olds [lrange $line 1 end]
8054 set allparents($id) $olds
8055 if {![info exists allchildren($id)]} {
8056 set allchildren($id) {}
8061 if {[llength $olds] == 1 && [llength $a] == 1} {
8062 lappend arcids($a) $id
8063 if {[info exists idtags($id)]} {
8064 lappend arctags($a) $id
8066 if {[info exists idheads($id)]} {
8067 lappend archeads($a) $id
8069 if {[info exists allparents($olds)]} {
8070 # seen parent already
8071 if {![info exists arcout($olds)]} {
8074 lappend arcids($a) $olds
8075 set arcend($a) $olds
8078 lappend allchildren($olds) $id
8079 lappend arcnos($olds) $a
8083 foreach a $arcnos($id) {
8084 lappend arcids($a) $id
8091 lappend allchildren($p) $id
8092 set a [incr nextarc]
8093 set arcstart($a) $id
8100 if {[info exists allparents($p)]} {
8101 # seen it already, may need to make a new branch
8102 if {![info exists arcout($p)]} {
8105 lappend arcids($a) $p
8109 lappend arcnos($p) $a
8114 global cached_dheads cached_dtags cached_atags
8115 catch {unset cached_dheads}
8116 catch {unset cached_dtags}
8117 catch {unset cached_atags}
8120 return [expr {$nid >= 1000? 2: 1}]
8124 fconfigure $fd -blocking 1
8127 # got an error reading the list of commits
8128 # if we were updating, try rereading the whole thing again
8134 error_popup "[mc "Error reading commit topology information;\
8135 branch and preceding/following tag information\
8136 will be incomplete."]\n($err)"
8139 if {[incr allcommits -1] == 0} {
8149 proc recalcarc {a} {
8150 global arctags archeads arcids idtags idheads
8154 foreach id [lrange $arcids($a) 0 end-1] {
8155 if {[info exists idtags($id)]} {
8158 if {[info exists idheads($id)]} {
8163 set archeads($a) $ah
8167 global arcnos arcids nextarc arctags archeads idtags idheads
8168 global arcstart arcend arcout allparents growing
8171 if {[llength $a] != 1} {
8172 puts "oops splitarc called but [llength $a] arcs already"
8176 set i [lsearch -exact $arcids($a) $p]
8178 puts "oops splitarc $p not in arc $a"
8181 set na [incr nextarc]
8182 if {[info exists arcend($a)]} {
8183 set arcend($na) $arcend($a)
8185 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8186 set j [lsearch -exact $arcnos($l) $a]
8187 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8189 set tail [lrange $arcids($a) [expr {$i+1}] end]
8190 set arcids($a) [lrange $arcids($a) 0 $i]
8192 set arcstart($na) $p
8194 set arcids($na) $tail
8195 if {[info exists growing($a)]} {
8201 if {[llength $arcnos($id)] == 1} {
8204 set j [lsearch -exact $arcnos($id) $a]
8205 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8209 # reconstruct tags and heads lists
8210 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8215 set archeads($na) {}
8219 # Update things for a new commit added that is a child of one
8220 # existing commit. Used when cherry-picking.
8221 proc addnewchild {id p} {
8222 global allparents allchildren idtags nextarc
8223 global arcnos arcids arctags arcout arcend arcstart archeads growing
8224 global seeds allcommits
8226 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8227 set allparents($id) [list $p]
8228 set allchildren($id) {}
8231 lappend allchildren($p) $id
8232 set a [incr nextarc]
8233 set arcstart($a) $id
8236 set arcids($a) [list $p]
8238 if {![info exists arcout($p)]} {
8241 lappend arcnos($p) $a
8242 set arcout($id) [list $a]
8245 # This implements a cache for the topology information.
8246 # The cache saves, for each arc, the start and end of the arc,
8247 # the ids on the arc, and the outgoing arcs from the end.
8248 proc readcache {f} {
8249 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8250 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8255 if {$lim - $a > 500} {
8256 set lim [expr {$a + 500}]
8260 # finish reading the cache and setting up arctags, etc.
8262 if {$line ne "1"} {error "bad final version"}
8264 foreach id [array names idtags] {
8265 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8266 [llength $allparents($id)] == 1} {
8267 set a [lindex $arcnos($id) 0]
8268 if {$arctags($a) eq {}} {
8273 foreach id [array names idheads] {
8274 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8275 [llength $allparents($id)] == 1} {
8276 set a [lindex $arcnos($id) 0]
8277 if {$archeads($a) eq {}} {
8282 foreach id [lsort -unique $possible_seeds] {
8283 if {$arcnos($id) eq {}} {
8289 while {[incr a] <= $lim} {
8291 if {[llength $line] != 3} {error "bad line"}
8292 set s [lindex $line 0]
8294 lappend arcout($s) $a
8295 if {![info exists arcnos($s)]} {
8296 lappend possible_seeds $s
8299 set e [lindex $line 1]
8304 if {![info exists arcout($e)]} {
8308 set arcids($a) [lindex $line 2]
8309 foreach id $arcids($a) {
8310 lappend allparents($s) $id
8312 lappend arcnos($id) $a
8314 if {![info exists allparents($s)]} {
8315 set allparents($s) {}
8320 set nextarc [expr {$a - 1}]
8333 global nextarc cachedarcs possible_seeds
8337 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8338 # make sure it's an integer
8339 set cachedarcs [expr {int([lindex $line 1])}]
8340 if {$cachedarcs < 0} {error "bad number of arcs"}
8342 set possible_seeds {}
8350 proc dropcache {err} {
8351 global allcwait nextarc cachedarcs seeds
8353 #puts "dropping cache ($err)"
8354 foreach v {arcnos arcout arcids arcstart arcend growing \
8355 arctags archeads allparents allchildren} {
8366 proc writecache {f} {
8367 global cachearc cachedarcs allccache
8368 global arcstart arcend arcnos arcids arcout
8372 if {$lim - $a > 1000} {
8373 set lim [expr {$a + 1000}]
8376 while {[incr a] <= $lim} {
8377 if {[info exists arcend($a)]} {
8378 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8380 puts $f [list $arcstart($a) {} $arcids($a)]
8385 catch {file delete $allccache}
8386 #puts "writing cache failed ($err)"
8389 set cachearc [expr {$a - 1}]
8390 if {$a > $cachedarcs} {
8399 global nextarc cachedarcs cachearc allccache
8401 if {$nextarc == $cachedarcs} return
8403 set cachedarcs $nextarc
8405 set f [open $allccache w]
8406 puts $f [list 1 $cachedarcs]
8411 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8412 # or 0 if neither is true.
8413 proc anc_or_desc {a b} {
8414 global arcout arcstart arcend arcnos cached_isanc
8416 if {$arcnos($a) eq $arcnos($b)} {
8417 # Both are on the same arc(s); either both are the same BMP,
8418 # or if one is not a BMP, the other is also not a BMP or is
8419 # the BMP at end of the arc (and it only has 1 incoming arc).
8420 # Or both can be BMPs with no incoming arcs.
8421 if {$a eq $b || $arcnos($a) eq {}} {
8424 # assert {[llength $arcnos($a)] == 1}
8425 set arc [lindex $arcnos($a) 0]
8426 set i [lsearch -exact $arcids($arc) $a]
8427 set j [lsearch -exact $arcids($arc) $b]
8428 if {$i < 0 || $i > $j} {
8435 if {![info exists arcout($a)]} {
8436 set arc [lindex $arcnos($a) 0]
8437 if {[info exists arcend($arc)]} {
8438 set aend $arcend($arc)
8442 set a $arcstart($arc)
8446 if {![info exists arcout($b)]} {
8447 set arc [lindex $arcnos($b) 0]
8448 if {[info exists arcend($arc)]} {
8449 set bend $arcend($arc)
8453 set b $arcstart($arc)
8463 if {[info exists cached_isanc($a,$bend)]} {
8464 if {$cached_isanc($a,$bend)} {
8468 if {[info exists cached_isanc($b,$aend)]} {
8469 if {$cached_isanc($b,$aend)} {
8472 if {[info exists cached_isanc($a,$bend)]} {
8477 set todo [list $a $b]
8480 for {set i 0} {$i < [llength $todo]} {incr i} {
8481 set x [lindex $todo $i]
8482 if {$anc($x) eq {}} {
8485 foreach arc $arcnos($x) {
8486 set xd $arcstart($arc)
8488 set cached_isanc($a,$bend) 1
8489 set cached_isanc($b,$aend) 0
8491 } elseif {$xd eq $aend} {
8492 set cached_isanc($b,$aend) 1
8493 set cached_isanc($a,$bend) 0
8496 if {![info exists anc($xd)]} {
8497 set anc($xd) $anc($x)
8499 } elseif {$anc($xd) ne $anc($x)} {
8504 set cached_isanc($a,$bend) 0
8505 set cached_isanc($b,$aend) 0
8509 # This identifies whether $desc has an ancestor that is
8510 # a growing tip of the graph and which is not an ancestor of $anc
8511 # and returns 0 if so and 1 if not.
8512 # If we subsequently discover a tag on such a growing tip, and that
8513 # turns out to be a descendent of $anc (which it could, since we
8514 # don't necessarily see children before parents), then $desc
8515 # isn't a good choice to display as a descendent tag of
8516 # $anc (since it is the descendent of another tag which is
8517 # a descendent of $anc). Similarly, $anc isn't a good choice to
8518 # display as a ancestor tag of $desc.
8520 proc is_certain {desc anc} {
8521 global arcnos arcout arcstart arcend growing problems
8524 if {[llength $arcnos($anc)] == 1} {
8525 # tags on the same arc are certain
8526 if {$arcnos($desc) eq $arcnos($anc)} {
8529 if {![info exists arcout($anc)]} {
8530 # if $anc is partway along an arc, use the start of the arc instead
8531 set a [lindex $arcnos($anc) 0]
8532 set anc $arcstart($a)
8535 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8538 set a [lindex $arcnos($desc) 0]
8544 set anclist [list $x]
8548 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8549 set x [lindex $anclist $i]
8554 foreach a $arcout($x) {
8555 if {[info exists growing($a)]} {
8556 if {![info exists growanc($x)] && $dl($x)} {
8562 if {[info exists dl($y)]} {
8566 if {![info exists done($y)]} {
8569 if {[info exists growanc($x)]} {
8573 for {set k 0} {$k < [llength $xl]} {incr k} {
8574 set z [lindex $xl $k]
8575 foreach c $arcout($z) {
8576 if {[info exists arcend($c)]} {
8578 if {[info exists dl($v)] && $dl($v)} {
8580 if {![info exists done($v)]} {
8583 if {[info exists growanc($v)]} {
8593 } elseif {$y eq $anc || !$dl($x)} {
8604 foreach x [array names growanc] {
8613 proc validate_arctags {a} {
8614 global arctags idtags
8618 foreach id $arctags($a) {
8620 if {![info exists idtags($id)]} {
8621 set na [lreplace $na $i $i]
8628 proc validate_archeads {a} {
8629 global archeads idheads
8632 set na $archeads($a)
8633 foreach id $archeads($a) {
8635 if {![info exists idheads($id)]} {
8636 set na [lreplace $na $i $i]
8640 set archeads($a) $na
8643 # Return the list of IDs that have tags that are descendents of id,
8644 # ignoring IDs that are descendents of IDs already reported.
8645 proc desctags {id} {
8646 global arcnos arcstart arcids arctags idtags allparents
8647 global growing cached_dtags
8649 if {![info exists allparents($id)]} {
8652 set t1 [clock clicks -milliseconds]
8654 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8655 # part-way along an arc; check that arc first
8656 set a [lindex $arcnos($id) 0]
8657 if {$arctags($a) ne {}} {
8659 set i [lsearch -exact $arcids($a) $id]
8661 foreach t $arctags($a) {
8662 set j [lsearch -exact $arcids($a) $t]
8670 set id $arcstart($a)
8671 if {[info exists idtags($id)]} {
8675 if {[info exists cached_dtags($id)]} {
8676 return $cached_dtags($id)
8683 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8684 set id [lindex $todo $i]
8686 set ta [info exists hastaggedancestor($id)]
8690 # ignore tags on starting node
8691 if {!$ta && $i > 0} {
8692 if {[info exists idtags($id)]} {
8695 } elseif {[info exists cached_dtags($id)]} {
8696 set tagloc($id) $cached_dtags($id)
8700 foreach a $arcnos($id) {
8702 if {!$ta && $arctags($a) ne {}} {
8704 if {$arctags($a) ne {}} {
8705 lappend tagloc($id) [lindex $arctags($a) end]
8708 if {$ta || $arctags($a) ne {}} {
8709 set tomark [list $d]
8710 for {set j 0} {$j < [llength $tomark]} {incr j} {
8711 set dd [lindex $tomark $j]
8712 if {![info exists hastaggedancestor($dd)]} {
8713 if {[info exists done($dd)]} {
8714 foreach b $arcnos($dd) {
8715 lappend tomark $arcstart($b)
8717 if {[info exists tagloc($dd)]} {
8720 } elseif {[info exists queued($dd)]} {
8723 set hastaggedancestor($dd) 1
8727 if {![info exists queued($d)]} {
8730 if {![info exists hastaggedancestor($d)]} {
8737 foreach id [array names tagloc] {
8738 if {![info exists hastaggedancestor($id)]} {
8739 foreach t $tagloc($id) {
8740 if {[lsearch -exact $tags $t] < 0} {
8746 set t2 [clock clicks -milliseconds]
8749 # remove tags that are descendents of other tags
8750 for {set i 0} {$i < [llength $tags]} {incr i} {
8751 set a [lindex $tags $i]
8752 for {set j 0} {$j < $i} {incr j} {
8753 set b [lindex $tags $j]
8754 set r [anc_or_desc $a $b]
8756 set tags [lreplace $tags $j $j]
8759 } elseif {$r == -1} {
8760 set tags [lreplace $tags $i $i]
8767 if {[array names growing] ne {}} {
8768 # graph isn't finished, need to check if any tag could get
8769 # eclipsed by another tag coming later. Simply ignore any
8770 # tags that could later get eclipsed.
8773 if {[is_certain $t $origid]} {
8777 if {$tags eq $ctags} {
8778 set cached_dtags($origid) $tags
8783 set cached_dtags($origid) $tags
8785 set t3 [clock clicks -milliseconds]
8786 if {0 && $t3 - $t1 >= 100} {
8787 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8788 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8794 global arcnos arcids arcout arcend arctags idtags allparents
8795 global growing cached_atags
8797 if {![info exists allparents($id)]} {
8800 set t1 [clock clicks -milliseconds]
8802 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8803 # part-way along an arc; check that arc first
8804 set a [lindex $arcnos($id) 0]
8805 if {$arctags($a) ne {}} {
8807 set i [lsearch -exact $arcids($a) $id]
8808 foreach t $arctags($a) {
8809 set j [lsearch -exact $arcids($a) $t]
8815 if {![info exists arcend($a)]} {
8819 if {[info exists idtags($id)]} {
8823 if {[info exists cached_atags($id)]} {
8824 return $cached_atags($id)
8832 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8833 set id [lindex $todo $i]
8835 set td [info exists hastaggeddescendent($id)]
8839 # ignore tags on starting node
8840 if {!$td && $i > 0} {
8841 if {[info exists idtags($id)]} {
8844 } elseif {[info exists cached_atags($id)]} {
8845 set tagloc($id) $cached_atags($id)
8849 foreach a $arcout($id) {
8850 if {!$td && $arctags($a) ne {}} {
8852 if {$arctags($a) ne {}} {
8853 lappend tagloc($id) [lindex $arctags($a) 0]
8856 if {![info exists arcend($a)]} continue
8858 if {$td || $arctags($a) ne {}} {
8859 set tomark [list $d]
8860 for {set j 0} {$j < [llength $tomark]} {incr j} {
8861 set dd [lindex $tomark $j]
8862 if {![info exists hastaggeddescendent($dd)]} {
8863 if {[info exists done($dd)]} {
8864 foreach b $arcout($dd) {
8865 if {[info exists arcend($b)]} {
8866 lappend tomark $arcend($b)
8869 if {[info exists tagloc($dd)]} {
8872 } elseif {[info exists queued($dd)]} {
8875 set hastaggeddescendent($dd) 1
8879 if {![info exists queued($d)]} {
8882 if {![info exists hastaggeddescendent($d)]} {
8888 set t2 [clock clicks -milliseconds]
8891 foreach id [array names tagloc] {
8892 if {![info exists hastaggeddescendent($id)]} {
8893 foreach t $tagloc($id) {
8894 if {[lsearch -exact $tags $t] < 0} {
8901 # remove tags that are ancestors of other tags
8902 for {set i 0} {$i < [llength $tags]} {incr i} {
8903 set a [lindex $tags $i]
8904 for {set j 0} {$j < $i} {incr j} {
8905 set b [lindex $tags $j]
8906 set r [anc_or_desc $a $b]
8908 set tags [lreplace $tags $j $j]
8911 } elseif {$r == 1} {
8912 set tags [lreplace $tags $i $i]
8919 if {[array names growing] ne {}} {
8920 # graph isn't finished, need to check if any tag could get
8921 # eclipsed by another tag coming later. Simply ignore any
8922 # tags that could later get eclipsed.
8925 if {[is_certain $origid $t]} {
8929 if {$tags eq $ctags} {
8930 set cached_atags($origid) $tags
8935 set cached_atags($origid) $tags
8937 set t3 [clock clicks -milliseconds]
8938 if {0 && $t3 - $t1 >= 100} {
8939 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8940 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8945 # Return the list of IDs that have heads that are descendents of id,
8946 # including id itself if it has a head.
8947 proc descheads {id} {
8948 global arcnos arcstart arcids archeads idheads cached_dheads
8951 if {![info exists allparents($id)]} {
8955 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8956 # part-way along an arc; check it first
8957 set a [lindex $arcnos($id) 0]
8958 if {$archeads($a) ne {}} {
8959 validate_archeads $a
8960 set i [lsearch -exact $arcids($a) $id]
8961 foreach t $archeads($a) {
8962 set j [lsearch -exact $arcids($a) $t]
8967 set id $arcstart($a)
8973 for {set i 0} {$i < [llength $todo]} {incr i} {
8974 set id [lindex $todo $i]
8975 if {[info exists cached_dheads($id)]} {
8976 set ret [concat $ret $cached_dheads($id)]
8978 if {[info exists idheads($id)]} {
8981 foreach a $arcnos($id) {
8982 if {$archeads($a) ne {}} {
8983 validate_archeads $a
8984 if {$archeads($a) ne {}} {
8985 set ret [concat $ret $archeads($a)]
8989 if {![info exists seen($d)]} {
8996 set ret [lsort -unique $ret]
8997 set cached_dheads($origid) $ret
8998 return [concat $ret $aret]
9001 proc addedtag {id} {
9002 global arcnos arcout cached_dtags cached_atags
9004 if {![info exists arcnos($id)]} return
9005 if {![info exists arcout($id)]} {
9006 recalcarc [lindex $arcnos($id) 0]
9008 catch {unset cached_dtags}
9009 catch {unset cached_atags}
9012 proc addedhead {hid head} {
9013 global arcnos arcout cached_dheads
9015 if {![info exists arcnos($hid)]} return
9016 if {![info exists arcout($hid)]} {
9017 recalcarc [lindex $arcnos($hid) 0]
9019 catch {unset cached_dheads}
9022 proc removedhead {hid head} {
9023 global cached_dheads
9025 catch {unset cached_dheads}
9028 proc movedhead {hid head} {
9029 global arcnos arcout cached_dheads
9031 if {![info exists arcnos($hid)]} return
9032 if {![info exists arcout($hid)]} {
9033 recalcarc [lindex $arcnos($hid) 0]
9035 catch {unset cached_dheads}
9038 proc changedrefs {} {
9039 global cached_dheads cached_dtags cached_atags
9040 global arctags archeads arcnos arcout idheads idtags
9042 foreach id [concat [array names idheads] [array names idtags]] {
9043 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9044 set a [lindex $arcnos($id) 0]
9045 if {![info exists donearc($a)]} {
9051 catch {unset cached_dtags}
9052 catch {unset cached_atags}
9053 catch {unset cached_dheads}
9056 proc rereadrefs {} {
9057 global idtags idheads idotherrefs mainheadid
9059 set refids [concat [array names idtags] \
9060 [array names idheads] [array names idotherrefs]]
9061 foreach id $refids {
9062 if {![info exists ref($id)]} {
9063 set ref($id) [listrefs $id]
9066 set oldmainhead $mainheadid
9069 set refids [lsort -unique [concat $refids [array names idtags] \
9070 [array names idheads] [array names idotherrefs]]]
9071 foreach id $refids {
9072 set v [listrefs $id]
9073 if {![info exists ref($id)] || $ref($id) != $v} {
9077 if {$oldmainhead ne $mainheadid} {
9078 redrawtags $oldmainhead
9079 redrawtags $mainheadid
9084 proc listrefs {id} {
9085 global idtags idheads idotherrefs
9088 if {[info exists idtags($id)]} {
9092 if {[info exists idheads($id)]} {
9096 if {[info exists idotherrefs($id)]} {
9097 set z $idotherrefs($id)
9099 return [list $x $y $z]
9102 proc showtag {tag isnew} {
9103 global ctext tagcontents tagids linknum tagobjid
9106 addtohistory [list showtag $tag 0]
9108 $ctext conf -state normal
9112 if {![info exists tagcontents($tag)]} {
9114 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9117 if {[info exists tagcontents($tag)]} {
9118 set text $tagcontents($tag)
9120 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9122 appendwithlinks $text {}
9123 $ctext conf -state disabled
9135 if {[info exists gitktmpdir]} {
9136 catch {file delete -force $gitktmpdir}
9140 proc mkfontdisp {font top which} {
9141 global fontattr fontpref $font
9143 set fontpref($font) [set $font]
9144 button $top.${font}but -text $which -font optionfont \
9145 -command [list choosefont $font $which]
9146 label $top.$font -relief flat -font $font \
9147 -text $fontattr($font,family) -justify left
9148 grid x $top.${font}but $top.$font -sticky w
9151 proc choosefont {font which} {
9152 global fontparam fontlist fonttop fontattr
9154 set fontparam(which) $which
9155 set fontparam(font) $font
9156 set fontparam(family) [font actual $font -family]
9157 set fontparam(size) $fontattr($font,size)
9158 set fontparam(weight) $fontattr($font,weight)
9159 set fontparam(slant) $fontattr($font,slant)
9162 if {![winfo exists $top]} {
9164 eval font config sample [font actual $font]
9166 wm title $top [mc "Gitk font chooser"]
9167 label $top.l -textvariable fontparam(which)
9168 pack $top.l -side top
9169 set fontlist [lsort [font families]]
9171 listbox $top.f.fam -listvariable fontlist \
9172 -yscrollcommand [list $top.f.sb set]
9173 bind $top.f.fam <<ListboxSelect>> selfontfam
9174 scrollbar $top.f.sb -command [list $top.f.fam yview]
9175 pack $top.f.sb -side right -fill y
9176 pack $top.f.fam -side left -fill both -expand 1
9177 pack $top.f -side top -fill both -expand 1
9179 spinbox $top.g.size -from 4 -to 40 -width 4 \
9180 -textvariable fontparam(size) \
9181 -validatecommand {string is integer -strict %s}
9182 checkbutton $top.g.bold -padx 5 \
9183 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9184 -variable fontparam(weight) -onvalue bold -offvalue normal
9185 checkbutton $top.g.ital -padx 5 \
9186 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9187 -variable fontparam(slant) -onvalue italic -offvalue roman
9188 pack $top.g.size $top.g.bold $top.g.ital -side left
9189 pack $top.g -side top
9190 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9192 $top.c create text 100 25 -anchor center -text $which -font sample \
9193 -fill black -tags text
9194 bind $top.c <Configure> [list centertext $top.c]
9195 pack $top.c -side top -fill x
9197 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9198 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9199 grid $top.buts.ok $top.buts.can
9200 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9201 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9202 pack $top.buts -side bottom -fill x
9203 trace add variable fontparam write chg_fontparam
9206 $top.c itemconf text -text $which
9208 set i [lsearch -exact $fontlist $fontparam(family)]
9210 $top.f.fam selection set $i
9215 proc centertext {w} {
9216 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9220 global fontparam fontpref prefstop
9222 set f $fontparam(font)
9223 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9224 if {$fontparam(weight) eq "bold"} {
9225 lappend fontpref($f) "bold"
9227 if {$fontparam(slant) eq "italic"} {
9228 lappend fontpref($f) "italic"
9231 $w conf -text $fontparam(family) -font $fontpref($f)
9237 global fonttop fontparam
9239 if {[info exists fonttop]} {
9240 catch {destroy $fonttop}
9241 catch {font delete sample}
9247 proc selfontfam {} {
9248 global fonttop fontparam
9250 set i [$fonttop.f.fam curselection]
9252 set fontparam(family) [$fonttop.f.fam get $i]
9256 proc chg_fontparam {v sub op} {
9259 font config sample -$sub $fontparam($sub)
9263 global maxwidth maxgraphpct
9264 global oldprefs prefstop showneartags showlocalchanges
9265 global bgcolor fgcolor ctext diffcolors selectbgcolor
9266 global tabstop limitdiffs autoselect extdifftool
9270 if {[winfo exists $top]} {
9274 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9275 limitdiffs tabstop} {
9276 set oldprefs($v) [set $v]
9279 wm title $top [mc "Gitk preferences"]
9280 label $top.ldisp -text [mc "Commit list display options"]
9281 grid $top.ldisp - -sticky w -pady 10
9282 label $top.spacer -text " "
9283 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9285 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9286 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9287 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9289 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9290 grid x $top.maxpctl $top.maxpct -sticky w
9291 frame $top.showlocal
9292 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9293 checkbutton $top.showlocal.b -variable showlocalchanges
9294 pack $top.showlocal.b $top.showlocal.l -side left
9295 grid x $top.showlocal -sticky w
9296 frame $top.autoselect
9297 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9298 checkbutton $top.autoselect.b -variable autoselect
9299 pack $top.autoselect.b $top.autoselect.l -side left
9300 grid x $top.autoselect -sticky w
9302 label $top.ddisp -text [mc "Diff display options"]
9303 grid $top.ddisp - -sticky w -pady 10
9304 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9305 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9306 grid x $top.tabstopl $top.tabstop -sticky w
9308 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9309 checkbutton $top.ntag.b -variable showneartags
9310 pack $top.ntag.b $top.ntag.l -side left
9311 grid x $top.ntag -sticky w
9313 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9314 checkbutton $top.ldiff.b -variable limitdiffs
9315 pack $top.ldiff.b $top.ldiff.l -side left
9316 grid x $top.ldiff -sticky w
9318 entry $top.extdifft -textvariable extdifftool
9320 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9322 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9323 -command choose_extdiff
9324 pack $top.extdifff.l $top.extdifff.b -side left
9325 grid x $top.extdifff $top.extdifft -sticky w
9327 label $top.cdisp -text [mc "Colors: press to choose"]
9328 grid $top.cdisp - -sticky w -pady 10
9329 label $top.bg -padx 40 -relief sunk -background $bgcolor
9330 button $top.bgbut -text [mc "Background"] -font optionfont \
9331 -command [list choosecolor bgcolor {} $top.bg background setbg]
9332 grid x $top.bgbut $top.bg -sticky w
9333 label $top.fg -padx 40 -relief sunk -background $fgcolor
9334 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9335 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9336 grid x $top.fgbut $top.fg -sticky w
9337 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9338 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9339 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9340 [list $ctext tag conf d0 -foreground]]
9341 grid x $top.diffoldbut $top.diffold -sticky w
9342 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9343 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9344 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9345 [list $ctext tag conf d1 -foreground]]
9346 grid x $top.diffnewbut $top.diffnew -sticky w
9347 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9348 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9349 -command [list choosecolor diffcolors 2 $top.hunksep \
9350 "diff hunk header" \
9351 [list $ctext tag conf hunksep -foreground]]
9352 grid x $top.hunksepbut $top.hunksep -sticky w
9353 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9354 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9355 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9356 grid x $top.selbgbut $top.selbgsep -sticky w
9358 label $top.cfont -text [mc "Fonts: press to choose"]
9359 grid $top.cfont - -sticky w -pady 10
9360 mkfontdisp mainfont $top [mc "Main font"]
9361 mkfontdisp textfont $top [mc "Diff display font"]
9362 mkfontdisp uifont $top [mc "User interface font"]
9365 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9366 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9367 grid $top.buts.ok $top.buts.can
9368 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9369 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9370 grid $top.buts - - -pady 10 -sticky ew
9371 bind $top <Visibility> "focus $top.buts.ok"
9374 proc choose_extdiff {} {
9377 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9379 set extdifftool $prog
9383 proc choosecolor {v vi w x cmd} {
9386 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9387 -title [mc "Gitk: choose color for %s" $x]]
9388 if {$c eq {}} return
9389 $w conf -background $c
9395 global bglist cflist
9397 $w configure -selectbackground $c
9399 $cflist tag configure highlight \
9400 -background [$cflist cget -selectbackground]
9401 allcanvs itemconf secsel -fill $c
9408 $w conf -background $c
9416 $w conf -foreground $c
9418 allcanvs itemconf text -fill $c
9419 $canv itemconf circle -outline $c
9423 global oldprefs prefstop
9425 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9426 limitdiffs tabstop} {
9428 set $v $oldprefs($v)
9430 catch {destroy $prefstop}
9436 global maxwidth maxgraphpct
9437 global oldprefs prefstop showneartags showlocalchanges
9438 global fontpref mainfont textfont uifont
9439 global limitdiffs treediffs
9441 catch {destroy $prefstop}
9445 if {$mainfont ne $fontpref(mainfont)} {
9446 set mainfont $fontpref(mainfont)
9447 parsefont mainfont $mainfont
9448 eval font configure mainfont [fontflags mainfont]
9449 eval font configure mainfontbold [fontflags mainfont 1]
9453 if {$textfont ne $fontpref(textfont)} {
9454 set textfont $fontpref(textfont)
9455 parsefont textfont $textfont
9456 eval font configure textfont [fontflags textfont]
9457 eval font configure textfontbold [fontflags textfont 1]
9459 if {$uifont ne $fontpref(uifont)} {
9460 set uifont $fontpref(uifont)
9461 parsefont uifont $uifont
9462 eval font configure uifont [fontflags uifont]
9465 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9466 if {$showlocalchanges} {
9472 if {$limitdiffs != $oldprefs(limitdiffs)} {
9473 # treediffs elements are limited by path
9474 catch {unset treediffs}
9476 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9477 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9479 } elseif {$showneartags != $oldprefs(showneartags) ||
9480 $limitdiffs != $oldprefs(limitdiffs)} {
9485 proc formatdate {d} {
9486 global datetimeformat
9488 set d [clock format $d -format $datetimeformat]
9493 # This list of encoding names and aliases is distilled from
9494 # http://www.iana.org/assignments/character-sets.
9495 # Not all of them are supported by Tcl.
9496 set encoding_aliases {
9497 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9498 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9499 { ISO-10646-UTF-1 csISO10646UTF1 }
9500 { ISO_646.basic:1983 ref csISO646basic1983 }
9501 { INVARIANT csINVARIANT }
9502 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9503 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9504 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9505 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9506 { NATS-DANO iso-ir-9-1 csNATSDANO }
9507 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9508 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9509 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9510 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9511 { ISO-2022-KR csISO2022KR }
9513 { ISO-2022-JP csISO2022JP }
9514 { ISO-2022-JP-2 csISO2022JP2 }
9515 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9517 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9518 { IT iso-ir-15 ISO646-IT csISO15Italian }
9519 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9520 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9521 { greek7-old iso-ir-18 csISO18Greek7Old }
9522 { latin-greek iso-ir-19 csISO19LatinGreek }
9523 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9524 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9525 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9526 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9527 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9528 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9529 { INIS iso-ir-49 csISO49INIS }
9530 { INIS-8 iso-ir-50 csISO50INIS8 }
9531 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9532 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9533 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9534 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9535 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9536 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9538 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9539 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9540 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9541 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9542 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9543 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9544 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9545 { greek7 iso-ir-88 csISO88Greek7 }
9546 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9547 { iso-ir-90 csISO90 }
9548 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9549 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9550 csISO92JISC62991984b }
9551 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9552 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9553 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9554 csISO95JIS62291984handadd }
9555 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9556 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9557 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9558 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9560 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9561 { T.61-7bit iso-ir-102 csISO102T617bit }
9562 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9563 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9564 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9565 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9566 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9567 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9568 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9569 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9570 arabic csISOLatinArabic }
9571 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9572 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9573 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9574 greek greek8 csISOLatinGreek }
9575 { T.101-G2 iso-ir-128 csISO128T101G2 }
9576 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9578 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9579 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9580 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9581 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9582 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9583 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9584 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9585 csISOLatinCyrillic }
9586 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9587 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9588 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9589 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9590 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9591 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9592 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9593 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9594 { ISO_10367-box iso-ir-155 csISO10367Box }
9595 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9596 { latin-lap lap iso-ir-158 csISO158Lap }
9597 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9598 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9601 { JIS_X0201 X0201 csHalfWidthKatakana }
9602 { KSC5636 ISO646-KR csKSC5636 }
9603 { ISO-10646-UCS-2 csUnicode }
9604 { ISO-10646-UCS-4 csUCS4 }
9605 { DEC-MCS dec csDECMCS }
9606 { hp-roman8 roman8 r8 csHPRoman8 }
9607 { macintosh mac csMacintosh }
9608 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9610 { IBM038 EBCDIC-INT cp038 csIBM038 }
9611 { IBM273 CP273 csIBM273 }
9612 { IBM274 EBCDIC-BE CP274 csIBM274 }
9613 { IBM275 EBCDIC-BR cp275 csIBM275 }
9614 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9615 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9616 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9617 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9618 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9619 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9620 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9621 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9622 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9623 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9624 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9625 { IBM437 cp437 437 csPC8CodePage437 }
9626 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9627 { IBM775 cp775 csPC775Baltic }
9628 { IBM850 cp850 850 csPC850Multilingual }
9629 { IBM851 cp851 851 csIBM851 }
9630 { IBM852 cp852 852 csPCp852 }
9631 { IBM855 cp855 855 csIBM855 }
9632 { IBM857 cp857 857 csIBM857 }
9633 { IBM860 cp860 860 csIBM860 }
9634 { IBM861 cp861 861 cp-is csIBM861 }
9635 { IBM862 cp862 862 csPC862LatinHebrew }
9636 { IBM863 cp863 863 csIBM863 }
9637 { IBM864 cp864 csIBM864 }
9638 { IBM865 cp865 865 csIBM865 }
9639 { IBM866 cp866 866 csIBM866 }
9640 { IBM868 CP868 cp-ar csIBM868 }
9641 { IBM869 cp869 869 cp-gr csIBM869 }
9642 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9643 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9644 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9645 { IBM891 cp891 csIBM891 }
9646 { IBM903 cp903 csIBM903 }
9647 { IBM904 cp904 904 csIBBM904 }
9648 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9649 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9650 { IBM1026 CP1026 csIBM1026 }
9651 { EBCDIC-AT-DE csIBMEBCDICATDE }
9652 { EBCDIC-AT-DE-A csEBCDICATDEA }
9653 { EBCDIC-CA-FR csEBCDICCAFR }
9654 { EBCDIC-DK-NO csEBCDICDKNO }
9655 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9656 { EBCDIC-FI-SE csEBCDICFISE }
9657 { EBCDIC-FI-SE-A csEBCDICFISEA }
9658 { EBCDIC-FR csEBCDICFR }
9659 { EBCDIC-IT csEBCDICIT }
9660 { EBCDIC-PT csEBCDICPT }
9661 { EBCDIC-ES csEBCDICES }
9662 { EBCDIC-ES-A csEBCDICESA }
9663 { EBCDIC-ES-S csEBCDICESS }
9664 { EBCDIC-UK csEBCDICUK }
9665 { EBCDIC-US csEBCDICUS }
9666 { UNKNOWN-8BIT csUnknown8BiT }
9667 { MNEMONIC csMnemonic }
9672 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9673 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9674 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9675 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9676 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9677 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9678 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9679 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9680 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9681 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9682 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9683 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9684 { IBM1047 IBM-1047 }
9685 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9686 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9687 { UNICODE-1-1 csUnicode11 }
9690 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9691 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9693 { ISO-8859-15 ISO_8859-15 Latin-9 }
9694 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9695 { GBK CP936 MS936 windows-936 }
9696 { JIS_Encoding csJISEncoding }
9697 { Shift_JIS MS_Kanji csShiftJIS }
9698 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9700 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9701 { ISO-10646-UCS-Basic csUnicodeASCII }
9702 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9703 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9704 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9705 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9706 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9707 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9708 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9709 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9710 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9711 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9712 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9713 { Ventura-US csVenturaUS }
9714 { Ventura-International csVenturaInternational }
9715 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9716 { PC8-Turkish csPC8Turkish }
9717 { IBM-Symbols csIBMSymbols }
9718 { IBM-Thai csIBMThai }
9719 { HP-Legal csHPLegal }
9720 { HP-Pi-font csHPPiFont }
9721 { HP-Math8 csHPMath8 }
9722 { Adobe-Symbol-Encoding csHPPSMath }
9723 { HP-DeskTop csHPDesktop }
9724 { Ventura-Math csVenturaMath }
9725 { Microsoft-Publishing csMicrosoftPublishing }
9726 { Windows-31J csWindows31J }
9731 proc tcl_encoding {enc} {
9732 global encoding_aliases
9733 set names [encoding names]
9734 set lcnames [string tolower $names]
9735 set enc [string tolower $enc]
9736 set i [lsearch -exact $lcnames $enc]
9738 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9739 if {[regsub {^iso[-_]} $enc iso encx]} {
9740 set i [lsearch -exact $lcnames $encx]
9744 foreach l $encoding_aliases {
9745 set ll [string tolower $l]
9746 if {[lsearch -exact $ll $enc] < 0} continue
9747 # look through the aliases for one that tcl knows about
9749 set i [lsearch -exact $lcnames $e]
9751 if {[regsub {^iso[-_]} $e iso ex]} {
9752 set i [lsearch -exact $lcnames $ex]
9761 return [lindex $names $i]
9766 # First check that Tcl/Tk is recent enough
9767 if {[catch {package require Tk 8.4} err]} {
9768 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9769 Gitk requires at least Tcl/Tk 8.4."]
9774 set wrcomcmd "git diff-tree --stdin -p --pretty"
9778 set gitencoding [exec git config --get i18n.commitencoding]
9780 if {$gitencoding == ""} {
9781 set gitencoding "utf-8"
9783 set tclencoding [tcl_encoding $gitencoding]
9784 if {$tclencoding == {}} {
9785 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9788 set mainfont {Helvetica 9}
9789 set textfont {Courier 9}
9790 set uifont {Helvetica 9 bold}
9792 set findmergefiles 0
9800 set cmitmode "patch"
9801 set wrapcomment "none"
9805 set showlocalchanges 1
9807 set datetimeformat "%Y-%m-%d %H:%M:%S"
9810 set extdifftool "meld"
9812 set colors {green red blue magenta darkgrey brown orange}
9815 set diffcolors {red "#00a000" blue}
9818 set selectbgcolor gray85
9820 set circlecolors {white blue gray blue blue}
9822 ## For msgcat loading, first locate the installation location.
9823 if { [info exists ::env(GITK_MSGSDIR)] } {
9824 ## Msgsdir was manually set in the environment.
9825 set gitk_msgsdir $::env(GITK_MSGSDIR)
9827 ## Let's guess the prefix from argv0.
9828 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9829 set gitk_libdir [file join $gitk_prefix share gitk lib]
9830 set gitk_msgsdir [file join $gitk_libdir msgs]
9834 ## Internationalization (i18n) through msgcat and gettext. See
9835 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9836 package require msgcat
9837 namespace import ::msgcat::mc
9838 ## And eventually load the actual message catalog
9839 ::msgcat::mcload $gitk_msgsdir
9841 catch {source ~/.gitk}
9843 font create optionfont -family sans-serif -size -12
9845 parsefont mainfont $mainfont
9846 eval font create mainfont [fontflags mainfont]
9847 eval font create mainfontbold [fontflags mainfont 1]
9849 parsefont textfont $textfont
9850 eval font create textfont [fontflags textfont]
9851 eval font create textfontbold [fontflags textfont 1]
9853 parsefont uifont $uifont
9854 eval font create uifont [fontflags uifont]
9858 # check that we can find a .git directory somewhere...
9859 if {[catch {set gitdir [gitdir]}]} {
9860 show_error {} . [mc "Cannot find a git repository here."]
9863 if {![file isdirectory $gitdir]} {
9864 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9869 set cmdline_files {}
9871 set revtreeargscmd {}
9873 switch -glob -- $arg {
9876 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9880 set revtreeargscmd [string range $arg 10 end]
9883 lappend revtreeargs $arg
9889 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9890 # no -- on command line, but some arguments (other than --argscmd)
9892 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9893 set cmdline_files [split $f "\n"]
9894 set n [llength $cmdline_files]
9895 set revtreeargs [lrange $revtreeargs 0 end-$n]
9896 # Unfortunately git rev-parse doesn't produce an error when
9897 # something is both a revision and a filename. To be consistent
9898 # with git log and git rev-list, check revtreeargs for filenames.
9899 foreach arg $revtreeargs {
9900 if {[file exists $arg]} {
9901 show_error {} . [mc "Ambiguous argument '%s': both revision\
9907 # unfortunately we get both stdout and stderr in $err,
9908 # so look for "fatal:".
9909 set i [string first "fatal:" $err]
9911 set err [string range $err [expr {$i + 6}] end]
9913 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9918 set nullid "0000000000000000000000000000000000000000"
9919 set nullid2 "0000000000000000000000000000000000000001"
9920 set nullfile "/dev/null"
9922 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9929 set highlight_paths {}
9931 set searchdirn -forwards
9935 set markingmatches 0
9936 set linkentercount 0
9937 set need_redisplay 0
9944 set selectedhlview [mc "None"]
9945 set highlight_related [mc "None"]
9946 set highlight_files {}
9950 set viewargscmd(0) {}
9960 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9963 # wait for the window to become visible
9965 wm title . "[file tail $argv0]: [file tail [pwd]]"
9968 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9969 # create a view for the files/dirs specified on the command line
9973 set viewname(1) [mc "Command line"]
9974 set viewfiles(1) $cmdline_files
9975 set viewargs(1) $revtreeargs
9976 set viewargscmd(1) $revtreeargscmd
9980 .bar.view entryconf [mc "Edit view..."] -state normal
9981 .bar.view entryconf [mc "Delete view"] -state normal
9984 if {[info exists permviews]} {
9985 foreach v $permviews {
9988 set viewname($n) [lindex $v 0]
9989 set viewfiles($n) [lindex $v 1]
9990 set viewargs($n) [lindex $v 2]
9991 set viewargscmd($n) [lindex $v 3]