2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
12 if {[info exists env
(GIT_DIR
)]} {
15 return [exec git rev-parse
--git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
25 global isonrunq runq currunq
28 if {[info exists isonrunq
($script)]} return
29 if {$runq eq
{} && ![info exists currunq
]} {
32 lappend runq
[list
{} $script]
33 set isonrunq
($script) 1
36 proc filerun
{fd
script} {
37 fileevent
$fd readable
[list filereadable
$fd $script]
40 proc filereadable
{fd
script} {
43 fileevent
$fd readable
{}
44 if {$runq eq
{} && ![info exists currunq
]} {
47 lappend runq
[list
$fd $script]
53 for {set i
0} {$i < [llength
$runq]} {} {
54 if {[lindex
$runq $i 0] eq
$fd} {
55 set runq
[lreplace
$runq $i $i]
63 global isonrunq runq currunq
65 set tstart
[clock clicks
-milliseconds]
67 while {[llength
$runq] > 0} {
68 set fd
[lindex
$runq 0 0]
69 set script [lindex
$runq 0 1]
70 set currunq
[lindex
$runq 0]
71 set runq
[lrange
$runq 1 end
]
72 set repeat
[eval $script]
74 set t1
[clock clicks
-milliseconds]
75 set t
[expr {$t1 - $t0}]
76 if {$repeat ne
{} && $repeat} {
77 if {$fd eq
{} ||
$repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq
[list
$fd $script]
82 fileevent
$fd readable
[list filereadable
$fd $script]
84 } elseif
{$fd eq
{}} {
85 unset isonrunq
($script)
88 if {$t1 - $tstart >= 80} break
95 proc reg_instance
{fd
} {
96 global commfd leftover loginstance
98 set i
[incr loginstance
]
104 proc unmerged_files
{files
} {
107 # find the list of unmerged files
111 set fd
[open
"| git ls-files -u" r
]
113 show_error
{} .
"[mc "Couldn
't get list of unmerged files:"] $err"
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
122 if {$files eq {} || [path_filter $files $fname]} {
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
139 set origargs $arglist
143 foreach arg $arglist {
150 switch -glob -- $arg {
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
159 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163 "--ignore-space-change" - "-U*" - "--unified=*" {
164 # These request or affect diff output, which we don't want.
165 # Some could be used to set our defaults for diff display.
166 lappend diffargs
$arg
168 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169 "--name-only" - "--name-status" - "--color" - "--color-words" -
170 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174 "--objects" - "--objects-edge" - "--reverse" {
175 # These cause our parsing of git log's output to fail, or else
176 # they're options we want to set ourselves, so ignore them.
178 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
179 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
180 "--full-history" - "--dense" - "--sparse" -
181 "--follow" - "--left-right" - "--encoding=*" {
182 # These are harmless, and some are even useful
185 "--diff-filter=*" - "--no-merges" - "--unpacked" -
186 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
187 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
188 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
189 "--remove-empty" - "--first-parent" - "--cherry-pick" -
190 "-S*" - "--pickaxe-all" - "--pickaxe-regex" {
191 # These mean that we get a subset of the commits
196 # This appears to be the only one that has a value as a
197 # separate word following it
203 set notflag
[expr {!$notflag}]
211 # git rev-parse doesn't understand --merge
212 lappend revargs
--gitk-symmetric-diff-marker MERGE_HEAD...HEAD
215 # 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
226 # Non-flag arguments specify commits or ranges of commits
227 if {[string match
"*...*" $arg]} {
228 lappend revargs
--gitk-symmetric-diff-marker
234 set vdflags
($n) $diffargs
235 set vflags
($n) $glflags
236 set vrevs
($n) $revargs
237 set vfiltered
($n) $filtered
238 set vorigargs
($n) $origargs
242 proc parseviewrevs
{view revs
} {
243 global vposids vnegids
248 if {[catch
{set ids
[eval exec git rev-parse
$revs]} err
]} {
249 # we get stdout followed by stderr in $err
250 # for an unknown rev, git rev-parse echoes it and then errors out
251 set errlines
[split $err "\n"]
253 for {set l
0} {$l < [llength
$errlines]} {incr l
} {
254 set line
[lindex
$errlines $l]
255 if {!([string length
$line] == 40 && [string is xdigit
$line])} {
256 if {[string match
"fatal:*" $line]} {
257 if {[string match
"fatal: ambiguous argument*" $line]
259 if {[llength
$badrev] == 1} {
260 set err
"unknown revision $badrev"
262 set err
"unknown revisions: [join $badrev ", "]"
265 set err
[join [lrange
$errlines $l end
] "\n"]
272 error_popup
"[mc "Error parsing revisions
:"] $err"
279 foreach id
[split $ids "\n"] {
280 if {$id eq
"--gitk-symmetric-diff-marker"} {
282 } elseif
{[string match
"^*" $id]} {
289 lappend neg
[string range
$id 1 end
]
294 lset ret end
[lindex
$ret end
]...
$id
300 set vposids
($view) $pos
301 set vnegids
($view) $neg
305 # Start off a git log process and arrange to read its output
306 proc start_rev_list
{view
} {
307 global startmsecs commitidx viewcomplete curview
309 global viewargs viewargscmd viewfiles vfilelimit
310 global showlocalchanges
311 global viewactive viewinstances vmergeonly
312 global mainheadid viewmainheadid viewmainheadid_orig
313 global vcanopt vflags vrevs vorigargs
315 set startmsecs
[clock clicks
-milliseconds]
316 set commitidx
($view) 0
317 # these are set this way for the error exits
318 set viewcomplete
($view) 1
319 set viewactive
($view) 0
322 set args
$viewargs($view)
323 if {$viewargscmd($view) ne
{}} {
325 set str
[exec sh
-c $viewargscmd($view)]
327 error_popup
"[mc "Error executing
--argscmd command:"] $err"
330 set args
[concat
$args [split $str "\n"]]
332 set vcanopt
($view) [parseviewargs
$view $args]
334 set files
$viewfiles($view)
335 if {$vmergeonly($view)} {
336 set files
[unmerged_files
$files]
339 if {$nr_unmerged == 0} {
340 error_popup
[mc
"No files selected: --merge specified but\
341 no files are unmerged."]
343 error_popup
[mc
"No files selected: --merge specified but\
344 no unmerged files are within file limit."]
349 set vfilelimit
($view) $files
351 if {$vcanopt($view)} {
352 set revs
[parseviewrevs
$view $vrevs($view)]
356 set args
[concat
$vflags($view) $revs]
358 set args
$vorigargs($view)
362 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
363 --boundary $args "--" $files] r
]
365 error_popup
"[mc "Error executing git log
:"] $err"
368 set i
[reg_instance
$fd]
369 set viewinstances
($view) [list
$i]
370 set viewmainheadid
($view) $mainheadid
371 set viewmainheadid_orig
($view) $mainheadid
372 if {$files ne
{} && $mainheadid ne
{}} {
373 get_viewmainhead
$view
375 if {$showlocalchanges && $viewmainheadid($view) ne
{}} {
376 interestedin
$viewmainheadid($view) dodiffindex
378 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
379 if {$tclencoding != {}} {
380 fconfigure
$fd -encoding $tclencoding
382 filerun
$fd [list getcommitlines
$fd $i $view 0]
383 nowbusy
$view [mc
"Reading"]
384 set viewcomplete
($view) 0
385 set viewactive
($view) 1
389 proc stop_instance
{inst
} {
390 global commfd leftover
392 set fd
$commfd($inst)
396 if {$
::tcl_platform
(platform
) eq
{windows
}} {
405 unset leftover
($inst)
408 proc stop_backends
{} {
411 foreach inst
[array names commfd
] {
416 proc stop_rev_list
{view
} {
419 foreach inst
$viewinstances($view) {
422 set viewinstances
($view) {}
425 proc reset_pending_select
{selid
} {
426 global pending_select mainheadid selectheadid
429 set pending_select
$selid
430 } elseif
{$selectheadid ne
{}} {
431 set pending_select
$selectheadid
433 set pending_select
$mainheadid
437 proc getcommits
{selid
} {
438 global canv curview need_redisplay viewactive
441 if {[start_rev_list
$curview]} {
442 reset_pending_select
$selid
443 show_status
[mc
"Reading commits..."]
446 show_status
[mc
"No commits selected"]
450 proc updatecommits
{} {
451 global curview vcanopt vorigargs vfilelimit viewinstances
452 global viewactive viewcomplete tclencoding
453 global startmsecs showneartags showlocalchanges
454 global mainheadid viewmainheadid viewmainheadid_orig pending_select
456 global varcid vposids vnegids vflags vrevs
458 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
461 if {$mainheadid ne
$viewmainheadid_orig($view)} {
462 if {$showlocalchanges} {
465 set viewmainheadid
($view) $mainheadid
466 set viewmainheadid_orig
($view) $mainheadid
467 if {$vfilelimit($view) ne
{}} {
468 get_viewmainhead
$view
471 if {$showlocalchanges} {
474 if {$vcanopt($view)} {
475 set oldpos
$vposids($view)
476 set oldneg
$vnegids($view)
477 set revs
[parseviewrevs
$view $vrevs($view)]
481 # note: getting the delta when negative refs change is hard,
482 # and could require multiple git log invocations, so in that
483 # case we ask git log for all the commits (not just the delta)
484 if {$oldneg eq
$vnegids($view)} {
487 # take out positive refs that we asked for before or
488 # that we have already seen
490 if {[string length
$rev] == 40} {
491 if {[lsearch
-exact $oldpos $rev] < 0
492 && ![info exists varcid
($view,$rev)]} {
497 lappend
$newrevs $rev
500 if {$npos == 0} return
502 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
504 set args
[concat
$vflags($view) $revs --not $oldpos]
506 set args
$vorigargs($view)
509 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
510 --boundary $args "--" $vfilelimit($view)] r
]
512 error_popup
"[mc "Error executing git log
:"] $err"
515 if {$viewactive($view) == 0} {
516 set startmsecs
[clock clicks
-milliseconds]
518 set i
[reg_instance
$fd]
519 lappend viewinstances
($view) $i
520 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
521 if {$tclencoding != {}} {
522 fconfigure
$fd -encoding $tclencoding
524 filerun
$fd [list getcommitlines
$fd $i $view 1]
525 incr viewactive
($view)
526 set viewcomplete
($view) 0
527 reset_pending_select
{}
528 nowbusy
$view "Reading"
534 proc reloadcommits
{} {
535 global curview viewcomplete selectedline currentid thickerline
536 global showneartags treediffs commitinterest cached_commitrow
540 if {$selectedline ne
{}} {
544 if {!$viewcomplete($curview)} {
545 stop_rev_list
$curview
549 catch
{unset currentid
}
550 catch
{unset thickerline
}
551 catch
{unset treediffs
}
558 catch
{unset commitinterest
}
559 catch
{unset cached_commitrow
}
560 catch
{unset targetid
}
566 # This makes a string representation of a positive integer which
567 # sorts as a string in numerical order
570 return [format
"%x" $n]
571 } elseif
{$n < 256} {
572 return [format
"x%.2x" $n]
573 } elseif
{$n < 65536} {
574 return [format
"y%.4x" $n]
576 return [format
"z%.8x" $n]
579 # Procedures used in reordering commits from git log (without
580 # --topo-order) into the order for display.
582 proc varcinit
{view
} {
583 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
584 global vtokmod varcmod vrowmod varcix vlastins
586 set varcstart
($view) {{}}
587 set vupptr
($view) {0}
588 set vdownptr
($view) {0}
589 set vleftptr
($view) {0}
590 set vbackptr
($view) {0}
591 set varctok
($view) {{}}
592 set varcrow
($view) {{}}
593 set vtokmod
($view) {}
596 set varcix
($view) {{}}
597 set vlastins
($view) {0}
600 proc resetvarcs
{view
} {
601 global varcid varccommits parents children vseedcount ordertok
603 foreach vid
[array names varcid
$view,*] {
608 # some commits might have children but haven't been seen yet
609 foreach vid
[array names children
$view,*] {
612 foreach va
[array names varccommits
$view,*] {
613 unset varccommits
($va)
615 foreach vd
[array names vseedcount
$view,*] {
616 unset vseedcount
($vd)
618 catch
{unset ordertok
}
621 # returns a list of the commits with no children
623 global vdownptr vleftptr varcstart
626 set a
[lindex
$vdownptr($v) 0]
628 lappend ret
[lindex
$varcstart($v) $a]
629 set a
[lindex
$vleftptr($v) $a]
634 proc newvarc
{view id
} {
635 global varcid varctok parents children vdatemode
636 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
637 global commitdata commitinfo vseedcount varccommits vlastins
639 set a
[llength
$varctok($view)]
641 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
642 if {![info exists commitinfo
($id)]} {
643 parsecommit
$id $commitdata($id) 1
645 set cdate
[lindex
$commitinfo($id) 4]
646 if {![string is integer
-strict $cdate]} {
649 if {![info exists vseedcount
($view,$cdate)]} {
650 set vseedcount
($view,$cdate) -1
652 set c
[incr vseedcount
($view,$cdate)]
653 set cdate
[expr {$cdate ^
0xffffffff}]
654 set tok
"s[strrep $cdate][strrep $c]"
659 if {[llength
$children($vid)] > 0} {
660 set kid
[lindex
$children($vid) end
]
661 set k
$varcid($view,$kid)
662 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
665 set tok
[lindex
$varctok($view) $k]
669 set i
[lsearch
-exact $parents($view,$ki) $id]
670 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
671 append tok
[strrep
$j]
673 set c
[lindex
$vlastins($view) $ka]
674 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
676 set b
[lindex
$vdownptr($view) $ka]
678 set b
[lindex
$vleftptr($view) $c]
680 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
682 set b
[lindex
$vleftptr($view) $c]
685 lset vdownptr
($view) $ka $a
686 lappend vbackptr
($view) 0
688 lset vleftptr
($view) $c $a
689 lappend vbackptr
($view) $c
691 lset vlastins
($view) $ka $a
692 lappend vupptr
($view) $ka
693 lappend vleftptr
($view) $b
695 lset vbackptr
($view) $b $a
697 lappend varctok
($view) $tok
698 lappend varcstart
($view) $id
699 lappend vdownptr
($view) 0
700 lappend varcrow
($view) {}
701 lappend varcix
($view) {}
702 set varccommits
($view,$a) {}
703 lappend vlastins
($view) 0
707 proc splitvarc
{p v
} {
708 global varcid varcstart varccommits varctok
709 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
711 set oa
$varcid($v,$p)
712 set ac
$varccommits($v,$oa)
713 set i
[lsearch
-exact $varccommits($v,$oa) $p]
715 set na
[llength
$varctok($v)]
716 # "%" sorts before "0"...
717 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
718 lappend varctok
($v) $tok
719 lappend varcrow
($v) {}
720 lappend varcix
($v) {}
721 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
722 set varccommits
($v,$na) [lrange
$ac $i end
]
723 lappend varcstart
($v) $p
724 foreach id
$varccommits($v,$na) {
725 set varcid
($v,$id) $na
727 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
728 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
729 lset vdownptr
($v) $oa $na
730 lset vlastins
($v) $oa 0
731 lappend vupptr
($v) $oa
732 lappend vleftptr
($v) 0
733 lappend vbackptr
($v) 0
734 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
735 lset vupptr
($v) $b $na
739 proc renumbervarc
{a v
} {
740 global parents children varctok varcstart varccommits
741 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
743 set t1
[clock clicks
-milliseconds]
749 if {[info exists isrelated
($a)]} {
751 set id
[lindex
$varccommits($v,$a) end
]
752 foreach p
$parents($v,$id) {
753 if {[info exists varcid
($v,$p)]} {
754 set isrelated
($varcid($v,$p)) 1
759 set b
[lindex
$vdownptr($v) $a]
762 set b
[lindex
$vleftptr($v) $a]
764 set a
[lindex
$vupptr($v) $a]
770 if {![info exists kidchanged
($a)]} continue
771 set id
[lindex
$varcstart($v) $a]
772 if {[llength
$children($v,$id)] > 1} {
773 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
776 set oldtok
[lindex
$varctok($v) $a]
777 if {!$vdatemode($v)} {
783 set kid
[last_real_child
$v,$id]
785 set k
$varcid($v,$kid)
786 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
789 set tok
[lindex
$varctok($v) $k]
793 set i
[lsearch
-exact $parents($v,$ki) $id]
794 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
795 append tok
[strrep
$j]
797 if {$tok eq
$oldtok} {
800 set id
[lindex
$varccommits($v,$a) end
]
801 foreach p
$parents($v,$id) {
802 if {[info exists varcid
($v,$p)]} {
803 set kidchanged
($varcid($v,$p)) 1
808 lset varctok
($v) $a $tok
809 set b
[lindex
$vupptr($v) $a]
811 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
814 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
817 set c
[lindex
$vbackptr($v) $a]
818 set d
[lindex
$vleftptr($v) $a]
820 lset vdownptr
($v) $b $d
822 lset vleftptr
($v) $c $d
825 lset vbackptr
($v) $d $c
827 if {[lindex
$vlastins($v) $b] == $a} {
828 lset vlastins
($v) $b $c
830 lset vupptr
($v) $a $ka
831 set c
[lindex
$vlastins($v) $ka]
833 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
835 set b
[lindex
$vdownptr($v) $ka]
837 set b
[lindex
$vleftptr($v) $c]
840 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
842 set b
[lindex
$vleftptr($v) $c]
845 lset vdownptr
($v) $ka $a
846 lset vbackptr
($v) $a 0
848 lset vleftptr
($v) $c $a
849 lset vbackptr
($v) $a $c
851 lset vleftptr
($v) $a $b
853 lset vbackptr
($v) $b $a
855 lset vlastins
($v) $ka $a
858 foreach id
[array names sortkids
] {
859 if {[llength
$children($v,$id)] > 1} {
860 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
864 set t2
[clock clicks
-milliseconds]
865 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
868 # Fix up the graph after we have found out that in view $v,
869 # $p (a commit that we have already seen) is actually the parent
870 # of the last commit in arc $a.
871 proc fix_reversal
{p a v
} {
872 global varcid varcstart varctok vupptr
874 set pa
$varcid($v,$p)
875 if {$p ne
[lindex
$varcstart($v) $pa]} {
877 set pa
$varcid($v,$p)
879 # seeds always need to be renumbered
880 if {[lindex
$vupptr($v) $pa] == 0 ||
881 [string compare
[lindex
$varctok($v) $a] \
882 [lindex
$varctok($v) $pa]] > 0} {
887 proc insertrow
{id p v
} {
888 global cmitlisted children parents varcid varctok vtokmod
889 global varccommits ordertok commitidx numcommits curview
890 global targetid targetrow
894 set cmitlisted
($vid) 1
895 set children
($vid) {}
896 set parents
($vid) [list
$p]
897 set a
[newvarc
$v $id]
899 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
902 lappend varccommits
($v,$a) $id
904 if {[llength
[lappend children
($vp) $id]] > 1} {
905 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
906 catch
{unset ordertok
}
908 fix_reversal
$p $a $v
910 if {$v == $curview} {
911 set numcommits
$commitidx($v)
913 if {[info exists targetid
]} {
914 if {![comes_before
$targetid $p]} {
921 proc insertfakerow
{id p
} {
922 global varcid varccommits parents children cmitlisted
923 global commitidx varctok vtokmod targetid targetrow curview numcommits
927 set i
[lsearch
-exact $varccommits($v,$a) $p]
929 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
932 set children
($v,$id) {}
933 set parents
($v,$id) [list
$p]
934 set varcid
($v,$id) $a
935 lappend children
($v,$p) $id
936 set cmitlisted
($v,$id) 1
937 set numcommits
[incr commitidx
($v)]
938 # note we deliberately don't update varcstart($v) even if $i == 0
939 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
941 if {[info exists targetid
]} {
942 if {![comes_before
$targetid $p]} {
950 proc removefakerow
{id
} {
951 global varcid varccommits parents children commitidx
952 global varctok vtokmod cmitlisted currentid selectedline
953 global targetid curview numcommits
956 if {[llength
$parents($v,$id)] != 1} {
957 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
960 set p
[lindex
$parents($v,$id) 0]
961 set a
$varcid($v,$id)
962 set i
[lsearch
-exact $varccommits($v,$a) $id]
964 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
968 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
969 unset parents
($v,$id)
970 unset children
($v,$id)
971 unset cmitlisted
($v,$id)
972 set numcommits
[incr commitidx
($v) -1]
973 set j
[lsearch
-exact $children($v,$p) $id]
975 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
978 if {[info exist currentid
] && $id eq
$currentid} {
982 if {[info exists targetid
] && $targetid eq
$id} {
989 proc first_real_child
{vp
} {
990 global children nullid nullid2
992 foreach id
$children($vp) {
993 if {$id ne
$nullid && $id ne
$nullid2} {
1000 proc last_real_child
{vp
} {
1001 global children nullid nullid2
1003 set kids
$children($vp)
1004 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
1005 set id
[lindex
$kids $i]
1006 if {$id ne
$nullid && $id ne
$nullid2} {
1013 proc vtokcmp
{v a b
} {
1014 global varctok varcid
1016 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1017 [lindex
$varctok($v) $varcid($v,$b)]]
1020 # This assumes that if lim is not given, the caller has checked that
1021 # arc a's token is less than $vtokmod($v)
1022 proc modify_arc
{v a
{lim
{}}} {
1023 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1026 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
1029 set r
[lindex
$varcrow($v) $a]
1030 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
1033 set vtokmod
($v) [lindex
$varctok($v) $a]
1035 if {$v == $curview} {
1036 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
1037 set a
[lindex
$vupptr($v) $a]
1043 set lim
[llength
$varccommits($v,$a)]
1045 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1052 proc update_arcrows
{v
} {
1053 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1054 global varcid vrownum varcorder varcix varccommits
1055 global vupptr vdownptr vleftptr varctok
1056 global displayorder parentlist curview cached_commitrow
1058 if {$vrowmod($v) == $commitidx($v)} return
1059 if {$v == $curview} {
1060 if {[llength
$displayorder] > $vrowmod($v)} {
1061 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1062 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1064 catch
{unset cached_commitrow
}
1066 set narctot
[expr {[llength
$varctok($v)] - 1}]
1068 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1069 # go up the tree until we find something that has a row number,
1070 # or we get to a seed
1071 set a
[lindex
$vupptr($v) $a]
1074 set a
[lindex
$vdownptr($v) 0]
1077 set varcorder
($v) [list
$a]
1078 lset varcix
($v) $a 0
1079 lset varcrow
($v) $a 0
1083 set arcn
[lindex
$varcix($v) $a]
1084 if {[llength
$vrownum($v)] > $arcn + 1} {
1085 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1086 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1088 set row
[lindex
$varcrow($v) $a]
1092 incr row
[llength
$varccommits($v,$a)]
1093 # go down if possible
1094 set b
[lindex
$vdownptr($v) $a]
1096 # if not, go left, or go up until we can go left
1098 set b
[lindex
$vleftptr($v) $a]
1100 set a
[lindex
$vupptr($v) $a]
1106 lappend vrownum
($v) $row
1107 lappend varcorder
($v) $a
1108 lset varcix
($v) $a $arcn
1109 lset varcrow
($v) $a $row
1111 set vtokmod
($v) [lindex
$varctok($v) $p]
1113 set vrowmod
($v) $row
1114 if {[info exists currentid
]} {
1115 set selectedline
[rowofcommit
$currentid]
1119 # Test whether view $v contains commit $id
1120 proc commitinview
{id v
} {
1123 return [info exists varcid
($v,$id)]
1126 # Return the row number for commit $id in the current view
1127 proc rowofcommit
{id
} {
1128 global varcid varccommits varcrow curview cached_commitrow
1129 global varctok vtokmod
1132 if {![info exists varcid
($v,$id)]} {
1133 puts
"oops rowofcommit no arc for [shortids $id]"
1136 set a
$varcid($v,$id)
1137 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1140 if {[info exists cached_commitrow
($id)]} {
1141 return $cached_commitrow($id)
1143 set i
[lsearch
-exact $varccommits($v,$a) $id]
1145 puts
"oops didn't find commit [shortids $id] in arc $a"
1148 incr i
[lindex
$varcrow($v) $a]
1149 set cached_commitrow
($id) $i
1153 # Returns 1 if a is on an earlier row than b, otherwise 0
1154 proc comes_before
{a b
} {
1155 global varcid varctok curview
1158 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1159 ![info exists varcid
($v,$b)]} {
1162 if {$varcid($v,$a) != $varcid($v,$b)} {
1163 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1164 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1166 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1169 proc bsearch
{l elt
} {
1170 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1175 while {$hi - $lo > 1} {
1176 set mid
[expr {int
(($lo + $hi) / 2)}]
1177 set t
[lindex
$l $mid]
1180 } elseif
{$elt > $t} {
1189 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1190 proc make_disporder
{start end
} {
1191 global vrownum curview commitidx displayorder parentlist
1192 global varccommits varcorder parents vrowmod varcrow
1193 global d_valid_start d_valid_end
1195 if {$end > $vrowmod($curview)} {
1196 update_arcrows
$curview
1198 set ai
[bsearch
$vrownum($curview) $start]
1199 set start
[lindex
$vrownum($curview) $ai]
1200 set narc
[llength
$vrownum($curview)]
1201 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1202 set a
[lindex
$varcorder($curview) $ai]
1203 set l
[llength
$displayorder]
1204 set al
[llength
$varccommits($curview,$a)]
1205 if {$l < $r + $al} {
1207 set pad
[ntimes
[expr {$r - $l}] {}]
1208 set displayorder
[concat
$displayorder $pad]
1209 set parentlist
[concat
$parentlist $pad]
1210 } elseif
{$l > $r} {
1211 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1212 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1214 foreach id
$varccommits($curview,$a) {
1215 lappend displayorder
$id
1216 lappend parentlist
$parents($curview,$id)
1218 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1220 foreach id
$varccommits($curview,$a) {
1221 lset displayorder
$i $id
1222 lset parentlist
$i $parents($curview,$id)
1230 proc commitonrow
{row
} {
1233 set id
[lindex
$displayorder $row]
1235 make_disporder
$row [expr {$row + 1}]
1236 set id
[lindex
$displayorder $row]
1241 proc closevarcs
{v
} {
1242 global varctok varccommits varcid parents children
1243 global cmitlisted commitidx vtokmod
1245 set missing_parents
0
1247 set narcs
[llength
$varctok($v)]
1248 for {set a
1} {$a < $narcs} {incr a
} {
1249 set id
[lindex
$varccommits($v,$a) end
]
1250 foreach p
$parents($v,$id) {
1251 if {[info exists varcid
($v,$p)]} continue
1252 # add p as a new commit
1253 incr missing_parents
1254 set cmitlisted
($v,$p) 0
1255 set parents
($v,$p) {}
1256 if {[llength
$children($v,$p)] == 1 &&
1257 [llength
$parents($v,$id)] == 1} {
1260 set b
[newvarc
$v $p]
1262 set varcid
($v,$p) $b
1263 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1266 lappend varccommits
($v,$b) $p
1268 set scripts
[check_interest
$p $scripts]
1271 if {$missing_parents > 0} {
1272 foreach s
$scripts {
1278 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1279 # Assumes we already have an arc for $rwid.
1280 proc rewrite_commit
{v id rwid
} {
1281 global children parents varcid varctok vtokmod varccommits
1283 foreach ch
$children($v,$id) {
1284 # make $rwid be $ch's parent in place of $id
1285 set i
[lsearch
-exact $parents($v,$ch) $id]
1287 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1289 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1290 # add $ch to $rwid's children and sort the list if necessary
1291 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1292 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1293 $children($v,$rwid)]
1295 # fix the graph after joining $id to $rwid
1296 set a
$varcid($v,$ch)
1297 fix_reversal
$rwid $a $v
1298 # parentlist is wrong for the last element of arc $a
1299 # even if displayorder is right, hence the 3rd arg here
1300 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1304 # Mechanism for registering a command to be executed when we come
1305 # across a particular commit. To handle the case when only the
1306 # prefix of the commit is known, the commitinterest array is now
1307 # indexed by the first 4 characters of the ID. Each element is a
1308 # list of id, cmd pairs.
1309 proc interestedin
{id cmd
} {
1310 global commitinterest
1312 lappend commitinterest
([string range
$id 0 3]) $id $cmd
1315 proc check_interest
{id scripts
} {
1316 global commitinterest
1318 set prefix
[string range
$id 0 3]
1319 if {[info exists commitinterest
($prefix)]} {
1321 foreach
{i
script} $commitinterest($prefix) {
1322 if {[string match
"$i*" $id]} {
1323 lappend scripts
[string map
[list
"%I" $id "%P" $i] $script]
1325 lappend newlist
$i $script
1328 if {$newlist ne
{}} {
1329 set commitinterest
($prefix) $newlist
1331 unset commitinterest
($prefix)
1337 proc getcommitlines
{fd inst view updating
} {
1338 global cmitlisted leftover
1339 global commitidx commitdata vdatemode
1340 global parents children curview hlview
1341 global idpending ordertok
1342 global varccommits varcid varctok vtokmod vfilelimit
1344 set stuff
[read $fd 500000]
1345 # git log doesn't terminate the last commit with a null...
1346 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1353 global commfd viewcomplete viewactive viewname
1354 global viewinstances
1356 set i
[lsearch
-exact $viewinstances($view) $inst]
1358 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1360 # set it blocking so we wait for the process to terminate
1361 fconfigure
$fd -blocking 1
1362 if {[catch
{close
$fd} err
]} {
1364 if {$view != $curview} {
1365 set fv
" for the \"$viewname($view)\" view"
1367 if {[string range
$err 0 4] == "usage"} {
1368 set err
"Gitk: error reading commits$fv:\
1369 bad arguments to git log."
1370 if {$viewname($view) eq
"Command line"} {
1372 " (Note: arguments to gitk are passed to git log\
1373 to allow selection of commits to be displayed.)"
1376 set err
"Error reading commits$fv: $err"
1380 if {[incr viewactive
($view) -1] <= 0} {
1381 set viewcomplete
($view) 1
1382 # Check if we have seen any ids listed as parents that haven't
1383 # appeared in the list
1387 if {$view == $curview} {
1396 set i
[string first
"\0" $stuff $start]
1398 append leftover
($inst) [string range
$stuff $start end
]
1402 set cmit
$leftover($inst)
1403 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1404 set leftover
($inst) {}
1406 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1408 set start
[expr {$i + 1}]
1409 set j
[string first
"\n" $cmit]
1412 if {$j >= 0 && [string match
"commit *" $cmit]} {
1413 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1414 if {[string match
{[-^
<>]*} $ids]} {
1415 switch
-- [string index
$ids 0] {
1421 set ids
[string range
$ids 1 end
]
1425 if {[string length
$id] != 40} {
1433 if {[string length
$shortcmit] > 80} {
1434 set shortcmit
"[string range $shortcmit 0 80]..."
1436 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1439 set id [lindex $ids 0]
1442 if {!$listed && $updating && ![info exists varcid($vid)] &&
1443 $vfilelimit($view) ne {}} {
1444 # git log doesn't rewrite parents
for unlisted commits
1445 # when doing path limiting, so work around that here
1446 # by working out the rewritten parent with git rev-list
1447 # and if we already know about it, using the rewritten
1448 # parent as a substitute parent for $id's children.
1450 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1451 $id -- $vfilelimit($view)]
1453 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1454 # use $rwid in place of $id
1455 rewrite_commit
$view $id $rwid
1462 if {[info exists varcid
($vid)]} {
1463 if {$cmitlisted($vid) ||
!$listed} continue
1467 set olds
[lrange
$ids 1 end
]
1471 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1472 set cmitlisted
($vid) $listed
1473 set parents
($vid) $olds
1474 if {![info exists children
($vid)]} {
1475 set children
($vid) {}
1476 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1477 set k
[lindex
$children($vid) 0]
1478 if {[llength
$parents($view,$k)] == 1 &&
1479 (!$vdatemode($view) ||
1480 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1481 set a
$varcid($view,$k)
1486 set a
[newvarc
$view $id]
1488 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1491 if {![info exists varcid
($vid)]} {
1493 lappend varccommits
($view,$a) $id
1494 incr commitidx
($view)
1499 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1501 if {[llength
[lappend children
($vp) $id]] > 1 &&
1502 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1503 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1505 catch
{unset ordertok
}
1507 if {[info exists varcid
($view,$p)]} {
1508 fix_reversal
$p $a $view
1514 set scripts
[check_interest
$id $scripts]
1518 global numcommits hlview
1520 if {$view == $curview} {
1521 set numcommits
$commitidx($view)
1524 if {[info exists hlview
] && $view == $hlview} {
1525 # we never actually get here...
1528 foreach s
$scripts {
1535 proc chewcommits
{} {
1536 global curview hlview viewcomplete
1537 global pending_select
1540 if {$viewcomplete($curview)} {
1541 global commitidx varctok
1542 global numcommits startmsecs
1544 if {[info exists pending_select
]} {
1546 reset_pending_select
{}
1548 if {[commitinview
$pending_select $curview]} {
1549 selectline
[rowofcommit
$pending_select] 1
1551 set row
[first_real_row
]
1555 if {$commitidx($curview) > 0} {
1556 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1557 #puts "overall $ms ms for $numcommits commits"
1558 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1560 show_status
[mc
"No commits selected"]
1567 proc do_readcommit
{id
} {
1570 # Invoke git-log to handle automatic encoding conversion
1571 set fd
[open
[concat | git log
--no-color --pretty=raw
-1 $id] r
]
1572 # Read the results using i18n.logoutputencoding
1573 fconfigure
$fd -translation lf
-eofchar {}
1574 if {$tclencoding != {}} {
1575 fconfigure
$fd -encoding $tclencoding
1577 set contents
[read $fd]
1579 # Remove the heading line
1580 regsub
{^commit
[0-9a-f]+\n} $contents {} contents
1585 proc readcommit
{id
} {
1586 if {[catch
{set contents
[do_readcommit
$id]}]} return
1587 parsecommit
$id $contents 1
1590 proc parsecommit
{id contents listed
} {
1591 global commitinfo cdate
1600 set hdrend
[string first
"\n\n" $contents]
1602 # should never happen...
1603 set hdrend
[string length
$contents]
1605 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1606 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1607 foreach line
[split $header "\n"] {
1608 set tag
[lindex
$line 0]
1609 if {$tag == "author"} {
1610 set audate
[lindex
$line end-1
]
1611 set auname
[lrange
$line 1 end-2
]
1612 } elseif
{$tag == "committer"} {
1613 set comdate
[lindex
$line end-1
]
1614 set comname
[lrange
$line 1 end-2
]
1618 # take the first non-blank line of the comment as the headline
1619 set headline
[string trimleft
$comment]
1620 set i
[string first
"\n" $headline]
1622 set headline
[string range
$headline 0 $i]
1624 set headline
[string trimright
$headline]
1625 set i
[string first
"\r" $headline]
1627 set headline
[string trimright
[string range
$headline 0 $i]]
1630 # git log indents the comment by 4 spaces;
1631 # if we got this via git cat-file, add the indentation
1633 foreach line
[split $comment "\n"] {
1634 append newcomment
" "
1635 append newcomment
$line
1636 append newcomment
"\n"
1638 set comment
$newcomment
1640 if {$comdate != {}} {
1641 set cdate
($id) $comdate
1643 set commitinfo
($id) [list
$headline $auname $audate \
1644 $comname $comdate $comment]
1647 proc getcommit
{id
} {
1648 global commitdata commitinfo
1650 if {[info exists commitdata
($id)]} {
1651 parsecommit
$id $commitdata($id) 1
1654 if {![info exists commitinfo
($id)]} {
1655 set commitinfo
($id) [list
[mc
"No commit information available"]]
1661 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1662 # and are present in the current view.
1663 # This is fairly slow...
1664 proc longid
{prefix
} {
1665 global varcid curview
1668 foreach match
[array names varcid
"$curview,$prefix*"] {
1669 lappend ids
[lindex
[split $match ","] 1]
1675 global tagids idtags headids idheads tagobjid
1676 global otherrefids idotherrefs mainhead mainheadid
1677 global selecthead selectheadid
1679 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1682 set refd
[open
[list | git show-ref
-d] r
]
1683 while {[gets
$refd line
] >= 0} {
1684 if {[string index
$line 40] ne
" "} continue
1685 set id
[string range
$line 0 39]
1686 set ref
[string range
$line 41 end
]
1687 if {![string match
"refs/*" $ref]} continue
1688 set name
[string range
$ref 5 end
]
1689 if {[string match
"remotes/*" $name]} {
1690 if {![string match
"*/HEAD" $name]} {
1691 set headids
($name) $id
1692 lappend idheads
($id) $name
1694 } elseif
{[string match
"heads/*" $name]} {
1695 set name
[string range
$name 6 end
]
1696 set headids
($name) $id
1697 lappend idheads
($id) $name
1698 } elseif
{[string match
"tags/*" $name]} {
1699 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1700 # which is what we want since the former is the commit ID
1701 set name
[string range
$name 5 end
]
1702 if {[string match
"*^{}" $name]} {
1703 set name
[string range
$name 0 end-3
]
1705 set tagobjid
($name) $id
1707 set tagids
($name) $id
1708 lappend idtags
($id) $name
1710 set otherrefids
($name) $id
1711 lappend idotherrefs
($id) $name
1718 set mainheadid
[exec git rev-parse HEAD
]
1719 set thehead
[exec git symbolic-ref HEAD
]
1720 if {[string match
"refs/heads/*" $thehead]} {
1721 set mainhead
[string range
$thehead 11 end
]
1725 if {$selecthead ne
{}} {
1727 set selectheadid
[exec git rev-parse
--verify $selecthead]
1732 # skip over fake commits
1733 proc first_real_row
{} {
1734 global nullid nullid2 numcommits
1736 for {set row
0} {$row < $numcommits} {incr row
} {
1737 set id
[commitonrow
$row]
1738 if {$id ne
$nullid && $id ne
$nullid2} {
1745 # update things for a head moved to a child of its previous location
1746 proc movehead
{id name
} {
1747 global headids idheads
1749 removehead
$headids($name) $name
1750 set headids
($name) $id
1751 lappend idheads
($id) $name
1754 # update things when a head has been removed
1755 proc removehead
{id name
} {
1756 global headids idheads
1758 if {$idheads($id) eq
$name} {
1761 set i
[lsearch
-exact $idheads($id) $name]
1763 set idheads
($id) [lreplace
$idheads($id) $i $i]
1766 unset headids
($name)
1769 proc make_transient
{window origin
} {
1772 # In MacOS Tk 8.4 transient appears to work by setting
1773 # overrideredirect, which is utterly useless, since the
1774 # windows get no border, and are not even kept above
1776 if {!$have_tk85 && [tk windowingsystem
] eq
{aqua
}} return
1778 wm transient
$window $origin
1780 # Windows fails to place transient windows normally, so
1781 # schedule a callback to center them on the parent.
1782 if {[tk windowingsystem
] eq
{win32
}} {
1783 after idle
[list tk
::PlaceWindow
$window widget
$origin]
1787 proc show_error
{w top msg
} {
1788 message
$w.m
-text $msg -justify center
-aspect 400
1789 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1790 button
$w.ok
-text [mc OK
] -command "destroy $top"
1791 pack
$w.ok
-side bottom
-fill x
1792 bind $top <Visibility
> "grab $top; focus $top"
1793 bind $top <Key-Return
> "destroy $top"
1794 bind $top <Key-space
> "destroy $top"
1795 bind $top <Key-Escape
> "destroy $top"
1799 proc error_popup
{msg
{owner .
}} {
1802 make_transient
$w $owner
1803 show_error
$w $w $msg
1806 proc confirm_popup
{msg
{owner .
}} {
1811 make_transient
$w $owner
1812 message
$w.m
-text $msg -justify center
-aspect 400
1813 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1814 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1815 pack
$w.ok
-side left
-fill x
1816 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1817 pack
$w.cancel
-side right
-fill x
1818 bind $w <Visibility
> "grab $w; focus $w"
1819 bind $w <Key-Return
> "set confirm_ok 1; destroy $w"
1820 bind $w <Key-space
> "set confirm_ok 1; destroy $w"
1821 bind $w <Key-Escape
> "destroy $w"
1826 proc setoptions
{} {
1827 option add
*Panedwindow.showHandle
1 startupFile
1828 option add
*Panedwindow.sashRelief raised startupFile
1829 option add
*Button.font uifont startupFile
1830 option add
*Checkbutton.font uifont startupFile
1831 option add
*Radiobutton.font uifont startupFile
1832 option add
*Menu.font uifont startupFile
1833 option add
*Menubutton.font uifont startupFile
1834 option add
*Label.font uifont startupFile
1835 option add
*Message.font uifont startupFile
1836 option add
*Entry.font uifont startupFile
1839 # Make a menu and submenus.
1840 # m is the window name for the menu, items is the list of menu items to add.
1841 # Each item is a list {mc label type description options...}
1842 # mc is ignored; it's so we can put mc there to alert xgettext
1843 # label is the string that appears in the menu
1844 # type is cascade, command or radiobutton (should add checkbutton)
1845 # description depends on type; it's the sublist for cascade, the
1846 # command to invoke for command, or {variable value} for radiobutton
1847 proc makemenu
{m items
} {
1849 if {[tk windowingsystem
] eq
{aqua
}} {
1855 set name
[mc
[lindex
$i 1]]
1856 set type [lindex
$i 2]
1857 set thing
[lindex
$i 3]
1858 set params
[list
$type]
1860 set u
[string first
"&" [string map
{&& x
} $name]]
1861 lappend params
-label [string map
{&& & & {}} $name]
1863 lappend params
-underline $u
1868 set submenu
[string tolower
[string map
{& ""} [lindex
$i 1]]]
1869 lappend params
-menu $m.
$submenu
1872 lappend params
-command $thing
1875 lappend params
-variable [lindex
$thing 0] \
1876 -value [lindex
$thing 1]
1879 set tail [lrange
$i 4 end
]
1880 regsub
-all {\yMeta1\y
} $tail $Meta1 tail
1881 eval $m add
$params $tail
1882 if {$type eq
"cascade"} {
1883 makemenu
$m.
$submenu $thing
1888 # translate string and remove ampersands
1890 return [string map
{&& & & {}} [mc
$str]]
1893 proc makewindow
{} {
1894 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1896 global findtype findtypemenu findloc findstring fstring geometry
1897 global entries sha1entry sha1string sha1but
1898 global diffcontextstring diffcontext
1900 global maincursor textcursor curtextcursor
1901 global rowctxmenu fakerowmenu mergemax wrapcomment
1902 global highlight_files gdttype
1903 global searchstring sstring
1904 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1905 global headctxmenu progresscanv progressitem progresscoords statusw
1906 global fprogitem fprogcoord lastprogupdate progupdatepending
1907 global rprogitem rprogcoord rownumsel numcommits
1910 # The "mc" arguments here are purely so that xgettext
1911 # sees the following string as needing to be translated
1913 {mc
"File" cascade
{
1914 {mc
"Update" command updatecommits
-accelerator F5
}
1915 {mc
"Reload" command reloadcommits
-accelerator Meta1-F5
}
1916 {mc
"Reread references" command rereadrefs
}
1917 {mc
"List references" command showrefs
-accelerator F2
}
1918 {mc
"Quit" command doquit
-accelerator Meta1-Q
}
1920 {mc
"Edit" cascade
{
1921 {mc
"Preferences" command doprefs
}
1923 {mc
"View" cascade
{
1924 {mc
"New view..." command {newview
0} -accelerator Shift-F4
}
1925 {mc
"Edit view..." command editview
-state disabled
-accelerator F4
}
1926 {mc
"Delete view" command delview
-state disabled
}
1928 {mc
"All files" radiobutton
{selectedview
0} -command {showview
0}}
1930 {mc
"Help" cascade
{
1931 {mc
"About gitk" command about
}
1932 {mc
"Key bindings" command keys
}
1935 . configure
-menu .bar
1937 # the gui has upper and lower half, parts of a paned window.
1938 panedwindow .ctop
-orient vertical
1940 # possibly use assumed geometry
1941 if {![info exists geometry
(pwsash0
)]} {
1942 set geometry
(topheight
) [expr {15 * $linespc}]
1943 set geometry
(topwidth
) [expr {80 * $charspc}]
1944 set geometry
(botheight
) [expr {15 * $linespc}]
1945 set geometry
(botwidth
) [expr {50 * $charspc}]
1946 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1947 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1950 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1951 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1953 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1955 # create three canvases
1956 set cscroll .tf.histframe.csb
1957 set canv .tf.histframe.pwclist.canv
1959 -selectbackground $selectbgcolor \
1960 -background $bgcolor -bd 0 \
1961 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1962 .tf.histframe.pwclist add
$canv
1963 set canv2 .tf.histframe.pwclist.canv2
1965 -selectbackground $selectbgcolor \
1966 -background $bgcolor -bd 0 -yscrollincr $linespc
1967 .tf.histframe.pwclist add
$canv2
1968 set canv3 .tf.histframe.pwclist.canv3
1970 -selectbackground $selectbgcolor \
1971 -background $bgcolor -bd 0 -yscrollincr $linespc
1972 .tf.histframe.pwclist add
$canv3
1973 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1974 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1976 # a scroll bar to rule them
1977 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1978 pack
$cscroll -side right
-fill y
1979 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1980 lappend bglist
$canv $canv2 $canv3
1981 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1983 # we have two button bars at bottom of top frame. Bar 1
1985 frame .tf.lbar
-height 15
1987 set sha1entry .tf.bar.sha1
1988 set entries
$sha1entry
1989 set sha1but .tf.bar.sha1label
1990 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
1991 -command gotocommit
-width 8
1992 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1993 pack .tf.bar.sha1label
-side left
1994 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1995 trace add variable sha1string
write sha1change
1996 pack
$sha1entry -side left
-pady 2
1998 image create bitmap bm-left
-data {
1999 #define left_width 16
2000 #define left_height 16
2001 static unsigned char left_bits
[] = {
2002 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2003 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2004 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2006 image create bitmap bm-right
-data {
2007 #define right_width 16
2008 #define right_height 16
2009 static unsigned char right_bits
[] = {
2010 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2011 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2012 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2014 button .tf.bar.leftbut
-image bm-left
-command goback \
2015 -state disabled
-width 26
2016 pack .tf.bar.leftbut
-side left
-fill y
2017 button .tf.bar.rightbut
-image bm-right
-command goforw \
2018 -state disabled
-width 26
2019 pack .tf.bar.rightbut
-side left
-fill y
2021 label .tf.bar.rowlabel
-text [mc
"Row"]
2023 label .tf.bar.rownum
-width 7 -font textfont
-textvariable rownumsel \
2024 -relief sunken
-anchor e
2025 label .tf.bar.rowlabel2
-text "/"
2026 label .tf.bar.numcommits
-width 7 -font textfont
-textvariable numcommits \
2027 -relief sunken
-anchor e
2028 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2031 trace add variable selectedline
write selectedline_change
2033 # Status label and progress bar
2034 set statusw .tf.bar.status
2035 label
$statusw -width 15 -relief sunken
2036 pack
$statusw -side left
-padx 5
2037 set h
[expr {[font metrics uifont
-linespace] + 2}]
2038 set progresscanv .tf.bar.progress
2039 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
2040 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
2041 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
2042 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
2043 pack
$progresscanv -side right
-expand 1 -fill x
2044 set progresscoords
{0 0}
2047 bind $progresscanv <Configure
> adjustprogress
2048 set lastprogupdate
[clock clicks
-milliseconds]
2049 set progupdatepending
0
2051 # build up the bottom bar of upper window
2052 label .tf.lbar.flabel
-text "[mc "Find
"] "
2053 button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
2054 button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
2055 label .tf.lbar.flab2
-text " [mc "commit
"] "
2056 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2058 set gdttype
[mc
"containing:"]
2059 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
2060 [mc
"containing:"] \
2061 [mc
"touching paths:"] \
2062 [mc
"adding/removing string:"]]
2063 trace add variable gdttype
write gdttype_change
2064 pack .tf.lbar.gdttype
-side left
-fill y
2067 set fstring .tf.lbar.findstring
2068 lappend entries
$fstring
2069 entry
$fstring -width 30 -font textfont
-textvariable findstring
2070 trace add variable findstring
write find_change
2071 set findtype
[mc
"Exact"]
2072 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
2073 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
2074 trace add variable findtype
write findcom_change
2075 set findloc
[mc
"All fields"]
2076 tk_optionMenu .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
2077 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
2078 trace add variable findloc
write find_change
2079 pack .tf.lbar.findloc
-side right
2080 pack .tf.lbar.findtype
-side right
2081 pack
$fstring -side left
-expand 1 -fill x
2083 # Finish putting the upper half of the viewer together
2084 pack .tf.lbar
-in .tf
-side bottom
-fill x
2085 pack .tf.bar
-in .tf
-side bottom
-fill x
2086 pack .tf.histframe
-fill both
-side top
-expand 1
2088 .ctop paneconfigure .tf
-height $geometry(topheight
)
2089 .ctop paneconfigure .tf
-width $geometry(topwidth
)
2091 # now build up the bottom
2092 panedwindow .pwbottom
-orient horizontal
2094 # lower left, a text box over search bar, scroll bar to the right
2095 # if we know window height, then that will set the lower text height, otherwise
2096 # we set lower text height which will drive window height
2097 if {[info exists geometry
(main
)]} {
2098 frame .bleft
-width $geometry(botwidth
)
2100 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
2106 button .bleft.top.search
-text [mc
"Search"] -command dosearch
2107 pack .bleft.top.search
-side left
-padx 5
2108 set sstring .bleft.top.sstring
2109 entry
$sstring -width 20 -font textfont
-textvariable searchstring
2110 lappend entries
$sstring
2111 trace add variable searchstring
write incrsearch
2112 pack
$sstring -side left
-expand 1 -fill x
2113 radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
2114 -command changediffdisp
-variable diffelide
-value {0 0}
2115 radiobutton .bleft.mid.old
-text [mc
"Old version"] \
2116 -command changediffdisp
-variable diffelide
-value {0 1}
2117 radiobutton .bleft.mid.new
-text [mc
"New version"] \
2118 -command changediffdisp
-variable diffelide
-value {1 0}
2119 label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
2120 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
2121 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
2122 -from 1 -increment 1 -to 10000000 \
2123 -validate all
-validatecommand "diffcontextvalidate %P" \
2124 -textvariable diffcontextstring
2125 .bleft.mid.diffcontext
set $diffcontext
2126 trace add variable diffcontextstring
write diffcontextchange
2127 lappend entries .bleft.mid.diffcontext
2128 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
2129 checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
2130 -command changeignorespace
-variable ignorespace
2131 pack .bleft.mid.ignspace
-side left
-padx 5
2132 set ctext .bleft.bottom.ctext
2133 text
$ctext -background $bgcolor -foreground $fgcolor \
2134 -state disabled
-font textfont \
2135 -yscrollcommand scrolltext
-wrap none \
2136 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2138 $ctext conf
-tabstyle wordprocessor
2140 scrollbar .bleft.bottom.sb
-command "$ctext yview"
2141 scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h \
2143 pack .bleft.top
-side top
-fill x
2144 pack .bleft.mid
-side top
-fill x
2145 grid
$ctext .bleft.bottom.sb
-sticky nsew
2146 grid .bleft.bottom.sbhorizontal
-sticky ew
2147 grid columnconfigure .bleft.bottom
0 -weight 1
2148 grid rowconfigure .bleft.bottom
0 -weight 1
2149 grid rowconfigure .bleft.bottom
1 -weight 0
2150 pack .bleft.bottom
-side top
-fill both
-expand 1
2151 lappend bglist
$ctext
2152 lappend fglist
$ctext
2154 $ctext tag conf comment
-wrap $wrapcomment
2155 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
2156 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
2157 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
2158 $ctext tag conf dresult
-fore [lindex
$diffcolors 1]
2159 $ctext tag conf m0
-fore red
2160 $ctext tag conf m1
-fore blue
2161 $ctext tag conf m2
-fore green
2162 $ctext tag conf m3
-fore purple
2163 $ctext tag conf
m4 -fore brown
2164 $ctext tag conf m5
-fore "#009090"
2165 $ctext tag conf m6
-fore magenta
2166 $ctext tag conf m7
-fore "#808000"
2167 $ctext tag conf m8
-fore "#009000"
2168 $ctext tag conf m9
-fore "#ff0080"
2169 $ctext tag conf m10
-fore cyan
2170 $ctext tag conf m11
-fore "#b07070"
2171 $ctext tag conf m12
-fore "#70b0f0"
2172 $ctext tag conf m13
-fore "#70f0b0"
2173 $ctext tag conf m14
-fore "#f0b070"
2174 $ctext tag conf m15
-fore "#ff70b0"
2175 $ctext tag conf mmax
-fore darkgrey
2177 $ctext tag conf mresult
-font textfontbold
2178 $ctext tag conf msep
-font textfontbold
2179 $ctext tag conf found
-back yellow
2181 .pwbottom add .bleft
2182 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2187 radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2188 -command reselectline
-variable cmitmode
-value "patch"
2189 radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2190 -command reselectline
-variable cmitmode
-value "tree"
2191 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2192 pack .bright.mode
-side top
-fill x
2193 set cflist .bright.cfiles
2194 set indent
[font measure mainfont
"nn"]
2196 -selectbackground $selectbgcolor \
2197 -background $bgcolor -foreground $fgcolor \
2199 -tabs [list
$indent [expr {2 * $indent}]] \
2200 -yscrollcommand ".bright.sb set" \
2201 -cursor [. cget
-cursor] \
2202 -spacing1 1 -spacing3 1
2203 lappend bglist
$cflist
2204 lappend fglist
$cflist
2205 scrollbar .bright.sb
-command "$cflist yview"
2206 pack .bright.sb
-side right
-fill y
2207 pack
$cflist -side left
-fill both
-expand 1
2208 $cflist tag configure highlight \
2209 -background [$cflist cget
-selectbackground]
2210 $cflist tag configure bold
-font mainfontbold
2212 .pwbottom add .bright
2215 # restore window width & height if known
2216 if {[info exists geometry
(main
)]} {
2217 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2218 if {$w > [winfo screenwidth .
]} {
2219 set w
[winfo screenwidth .
]
2221 if {$h > [winfo screenheight .
]} {
2222 set h
[winfo screenheight .
]
2224 wm geometry .
"${w}x$h"
2228 if {[tk windowingsystem
] eq
{aqua
}} {
2234 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2235 pack .ctop
-fill both
-expand 1
2236 bindall
<1> {selcanvline
%W
%x
%y
}
2237 #bindall <B1-Motion> {selcanvline %W %x %y}
2238 if {[tk windowingsystem
] == "win32"} {
2239 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2240 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2242 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2243 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2244 if {[tk windowingsystem
] eq
"aqua"} {
2245 bindall
<MouseWheel
> {
2246 set delta
[expr {- (%D
)}]
2247 allcanvs yview scroll
$delta units
2251 bindall
<2> "canvscan mark %W %x %y"
2252 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
2253 bindkey
<Home
> selfirstline
2254 bindkey
<End
> sellastline
2255 bind .
<Key-Up
> "selnextline -1"
2256 bind .
<Key-Down
> "selnextline 1"
2257 bind .
<Shift-Key-Up
> "dofind -1 0"
2258 bind .
<Shift-Key-Down
> "dofind 1 0"
2259 bindkey
<Key-Right
> "goforw"
2260 bindkey
<Key-Left
> "goback"
2261 bind .
<Key-Prior
> "selnextpage -1"
2262 bind .
<Key-Next
> "selnextpage 1"
2263 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2264 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2265 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2266 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2267 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2268 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2269 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2270 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2271 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2272 bindkey p
"selnextline -1"
2273 bindkey n
"selnextline 1"
2276 bindkey i
"selnextline -1"
2277 bindkey k
"selnextline 1"
2281 bindkey d
"$ctext yview scroll 18 units"
2282 bindkey u
"$ctext yview scroll -18 units"
2283 bindkey
/ {dofind
1 1}
2284 bindkey
<Key-Return
> {dofind
1 1}
2285 bindkey ?
{dofind
-1 1}
2287 bind .
<F5
> updatecommits
2288 bind .
<$M1B-F5> reloadcommits
2289 bind .
<F2
> showrefs
2290 bind .
<Shift-F4
> {newview
0}
2291 catch
{ bind .
<Shift-Key-XF86_Switch_VT_4
> {newview
0} }
2292 bind .
<F4
> edit_or_newview
2293 bind .
<$M1B-q> doquit
2294 bind .
<$M1B-f> {dofind
1 1}
2295 bind .
<$M1B-g> {dofind
1 0}
2296 bind .
<$M1B-r> dosearchback
2297 bind .
<$M1B-s> dosearch
2298 bind .
<$M1B-equal> {incrfont
1}
2299 bind .
<$M1B-plus> {incrfont
1}
2300 bind .
<$M1B-KP_Add> {incrfont
1}
2301 bind .
<$M1B-minus> {incrfont
-1}
2302 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2303 wm protocol . WM_DELETE_WINDOW doquit
2304 bind .
<Destroy
> {stop_backends
}
2305 bind .
<Button-1
> "click %W"
2306 bind $fstring <Key-Return
> {dofind
1 1}
2307 bind $sha1entry <Key-Return
> {gotocommit
; break}
2308 bind $sha1entry <<PasteSelection>> clearsha1
2309 bind $cflist <1> {sel_flist %W %x %y; break}
2310 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2311 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2313 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2314 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2316 set maincursor [. cget -cursor]
2317 set textcursor [$ctext cget -cursor]
2318 set curtextcursor $textcursor
2320 set rowctxmenu .rowctxmenu
2321 makemenu $rowctxmenu {
2322 {mc "Diff this -> selected" command {diffvssel 0}}
2323 {mc "Diff selected -> this" command {diffvssel 1}}
2324 {mc "Make patch" command mkpatch}
2325 {mc "Create tag" command mktag}
2326 {mc "Write commit to file" command writecommit}
2327 {mc "Create new branch" command mkbranch}
2328 {mc "Cherry-pick this commit" command cherrypick}
2329 {mc "Reset HEAD branch to here" command resethead}
2331 $rowctxmenu configure -tearoff 0
2333 set fakerowmenu .fakerowmenu
2334 makemenu $fakerowmenu {
2335 {mc "Diff this -> selected" command {diffvssel 0}}
2336 {mc "Diff selected -> this" command {diffvssel 1}}
2337 {mc "Make patch" command mkpatch}
2339 $fakerowmenu configure -tearoff 0
2341 set headctxmenu .headctxmenu
2342 makemenu $headctxmenu {
2343 {mc "Check out this branch" command cobranch}
2344 {mc "Remove this branch" command rmbranch}
2346 $headctxmenu configure -tearoff 0
2349 set flist_menu .flistctxmenu
2350 makemenu $flist_menu {
2351 {mc "Highlight this too" command {flist_hl 0}}
2352 {mc "Highlight this only" command {flist_hl 1}}
2353 {mc "External diff" command {external_diff}}
2354 {mc "Blame parent commit" command {external_blame 1}}
2356 $flist_menu configure -tearoff 0
2359 set diff_menu .diffctxmenu
2360 makemenu $diff_menu {
2361 {mc "Show origin of this line" command show_line_source}
2362 {mc "Run git gui blame on this line" command {external_blame_diff}}
2364 $diff_menu configure -tearoff 0
2367 # Windows sends all mouse wheel events to the current focused window, not
2368 # the one where the mouse hovers, so bind those events here and redirect
2369 # to the correct window
2370 proc windows_mousewheel_redirector {W X Y D} {
2371 global canv canv2 canv3
2372 set w [winfo containing -displayof $W $X $Y]
2374 set u [expr {$D < 0 ? 5 : -5}]
2375 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2376 allcanvs yview scroll $u units
2379 $w yview scroll $u units
2385 # Update row number label when selectedline changes
2386 proc selectedline_change {n1 n2 op} {
2387 global selectedline rownumsel
2389 if {$selectedline eq {}} {
2392 set rownumsel [expr {$selectedline + 1}]
2396 # mouse-2 makes all windows scan vertically, but only the one
2397 # the cursor is in scans horizontally
2398 proc canvscan {op w x y} {
2399 global canv canv2 canv3
2400 foreach c [list $canv $canv2 $canv3] {
2409 proc scrollcanv {cscroll f0 f1} {
2410 $cscroll set $f0 $f1
2415 # when we make a key binding for the toplevel, make sure
2416 # it doesn't get triggered when that key is pressed in the
2417 # find string entry widget.
2418 proc bindkey {ev script} {
2421 set escript [bind Entry $ev]
2422 if {$escript == {}} {
2423 set escript [bind Entry <Key>]
2425 foreach e $entries {
2426 bind $e $ev "$escript; break"
2430 # set the focus back to the toplevel for any click outside
2433 global ctext entries
2434 foreach e [concat $entries $ctext] {
2435 if {$w == $e} return
2440 # Adjust the progress bar for a change in requested extent or canvas size
2441 proc adjustprogress {} {
2442 global progresscanv progressitem progresscoords
2443 global fprogitem fprogcoord lastprogupdate progupdatepending
2444 global rprogitem rprogcoord
2446 set w [expr {[winfo width $progresscanv] - 4}]
2447 set x0 [expr {$w * [lindex $progresscoords 0]}]
2448 set x1 [expr {$w * [lindex $progresscoords 1]}]
2449 set h [winfo height $progresscanv]
2450 $progresscanv coords $progressitem $x0 0 $x1 $h
2451 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2452 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2453 set now [clock clicks -milliseconds]
2454 if {$now >= $lastprogupdate + 100} {
2455 set progupdatepending 0
2457 } elseif {!$progupdatepending} {
2458 set progupdatepending 1
2459 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2463 proc doprogupdate {} {
2464 global lastprogupdate progupdatepending
2466 if {$progupdatepending} {
2467 set progupdatepending 0
2468 set lastprogupdate [clock clicks -milliseconds]
2473 proc savestuff {w} {
2474 global canv canv2 canv3 mainfont textfont uifont tabstop
2475 global stuffsaved findmergefiles maxgraphpct
2476 global maxwidth showneartags showlocalchanges
2477 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2478 global cmitmode wrapcomment datetimeformat limitdiffs
2479 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2480 global autoselect extdifftool perfile_attrs markbgcolor
2482 if {$stuffsaved} return
2483 if {![winfo viewable .]} return
2485 set f [open "~/.gitk-new" w]
2486 puts $f [list set mainfont $mainfont]
2487 puts $f [list set textfont $textfont]
2488 puts $f [list set uifont $uifont]
2489 puts $f [list set tabstop $tabstop]
2490 puts $f [list set findmergefiles $findmergefiles]
2491 puts $f [list set maxgraphpct $maxgraphpct]
2492 puts $f [list set maxwidth $maxwidth]
2493 puts $f [list set cmitmode $cmitmode]
2494 puts $f [list set wrapcomment $wrapcomment]
2495 puts $f [list set autoselect $autoselect]
2496 puts $f [list set showneartags $showneartags]
2497 puts $f [list set showlocalchanges $showlocalchanges]
2498 puts $f [list set datetimeformat $datetimeformat]
2499 puts $f [list set limitdiffs $limitdiffs]
2500 puts $f [list set bgcolor $bgcolor]
2501 puts $f [list set fgcolor $fgcolor]
2502 puts $f [list set colors $colors]
2503 puts $f [list set diffcolors $diffcolors]
2504 puts $f [list set markbgcolor $markbgcolor]
2505 puts $f [list set diffcontext $diffcontext]
2506 puts $f [list set selectbgcolor $selectbgcolor]
2507 puts $f [list set extdifftool $extdifftool]
2508 puts $f [list set perfile_attrs $perfile_attrs]
2510 puts $f "set geometry(main) [wm geometry .]"
2511 puts $f "set geometry(topwidth) [winfo width .tf]"
2512 puts $f "set geometry(topheight) [winfo height .tf]"
2513 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2514 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2515 puts $f "set geometry(botwidth) [winfo width .bleft]"
2516 puts $f "set geometry(botheight) [winfo height .bleft]"
2518 puts -nonewline $f "set permviews {"
2519 for {set v 0} {$v < $nextviewnum} {incr v} {
2520 if {$viewperm($v)} {
2521 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2526 file rename -force "~/.gitk-new" "~/.gitk"
2531 proc resizeclistpanes {win w} {
2533 if {[info exists oldwidth($win)]} {
2534 set s0 [$win sash coord 0]
2535 set s1 [$win sash coord 1]
2537 set sash0 [expr {int($w/2 - 2)}]
2538 set sash1 [expr {int($w*5/6 - 2)}]
2540 set factor [expr {1.0 * $w / $oldwidth($win)}]
2541 set sash0 [expr {int($factor * [lindex $s0 0])}]
2542 set sash1 [expr {int($factor * [lindex $s1 0])}]
2546 if {$sash1 < $sash0 + 20} {
2547 set sash1 [expr {$sash0 + 20}]
2549 if {$sash1 > $w - 10} {
2550 set sash1 [expr {$w - 10}]
2551 if {$sash0 > $sash1 - 20} {
2552 set sash0 [expr {$sash1 - 20}]
2556 $win sash place 0 $sash0 [lindex $s0 1]
2557 $win sash place 1 $sash1 [lindex $s1 1]
2559 set oldwidth($win) $w
2562 proc resizecdetpanes {win w} {
2564 if {[info exists oldwidth($win)]} {
2565 set s0 [$win sash coord 0]
2567 set sash0 [expr {int($w*3/4 - 2)}]
2569 set factor [expr {1.0 * $w / $oldwidth($win)}]
2570 set sash0 [expr {int($factor * [lindex $s0 0])}]
2574 if {$sash0 > $w - 15} {
2575 set sash0 [expr {$w - 15}]
2578 $win sash place 0 $sash0 [lindex $s0 1]
2580 set oldwidth($win) $w
2583 proc allcanvs args {
2584 global canv canv2 canv3
2590 proc bindall {event action} {
2591 global canv canv2 canv3
2592 bind $canv $event $action
2593 bind $canv2 $event $action
2594 bind $canv3 $event $action
2600 if {[winfo exists $w]} {
2605 wm title $w [mc "About gitk"]
2607 message $w.m -text [mc "
2608 Gitk - a commit viewer for git
2610 Copyright © 2005-2008 Paul Mackerras
2612 Use and redistribute under the terms of the GNU General Public License"] \
2613 -justify center -aspect 400 -border 2 -bg white -relief groove
2614 pack $w.m -side top -fill x -padx 2 -pady 2
2615 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2616 pack $w.ok -side bottom
2617 bind $w <Visibility> "focus $w.ok"
2618 bind $w <Key-Escape> "destroy $w"
2619 bind $w <Key-Return> "destroy $w"
2624 if {[winfo exists $w]} {
2628 if {[tk windowingsystem] eq {aqua}} {
2634 wm title $w [mc "Gitk key bindings"]
2636 message $w.m -text "
2637 [mc "Gitk key bindings:"]
2639 [mc "<%s-Q> Quit" $M1T]
2640 [mc "<Home> Move to first commit"]
2641 [mc "<End> Move to last commit"]
2642 [mc "<Up>, p, i Move up one commit"]
2643 [mc "<Down>, n, k Move down one commit"]
2644 [mc "<Left>, z, j Go back in history list"]
2645 [mc "<Right>, x, l Go forward in history list"]
2646 [mc "<PageUp> Move up one page in commit list"]
2647 [mc "<PageDown> Move down one page in commit list"]
2648 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2649 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2650 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2651 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2652 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2653 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2654 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2655 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2656 [mc "<Delete>, b Scroll diff view up one page"]
2657 [mc "<Backspace> Scroll diff view up one page"]
2658 [mc "<Space> Scroll diff view down one page"]
2659 [mc "u Scroll diff view up 18 lines"]
2660 [mc "d Scroll diff view down 18 lines"]
2661 [mc "<%s-F> Find" $M1T]
2662 [mc "<%s-G> Move to next find hit" $M1T]
2663 [mc "<Return> Move to next find hit"]
2664 [mc "/ Move to next find hit, or redo find"]
2665 [mc "? Move to previous find hit"]
2666 [mc "f Scroll diff view to next file"]
2667 [mc "<%s-S> Search for next hit in diff view" $M1T]
2668 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2669 [mc "<%s-KP+> Increase font size" $M1T]
2670 [mc "<%s-plus> Increase font size" $M1T]
2671 [mc "<%s-KP-> Decrease font size" $M1T]
2672 [mc "<%s-minus> Decrease font size" $M1T]
2675 -justify left -bg white -border 2 -relief groove
2676 pack $w.m -side top -fill both -padx 2 -pady 2
2677 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2678 bind $w <Key-Escape> [list destroy $w]
2679 pack $w.ok -side bottom
2680 bind $w <Visibility> "focus $w.ok"
2681 bind $w <Key-Escape> "destroy $w"
2682 bind $w <Key-Return> "destroy $w"
2685 # Procedures for manipulating the file list window at the
2686 # bottom right of the overall window.
2688 proc treeview {w l openlevs} {
2689 global treecontents treediropen treeheight treeparent treeindex
2699 set treecontents() {}
2700 $w conf -state normal
2702 while {[string range $f 0 $prefixend] ne $prefix} {
2703 if {$lev <= $openlevs} {
2704 $w mark set e:$treeindex($prefix) "end -1c"
2705 $w mark gravity e:$treeindex($prefix) left
2707 set treeheight($prefix) $ht
2708 incr ht [lindex $htstack end]
2709 set htstack [lreplace $htstack end end]
2710 set prefixend [lindex $prefendstack end]
2711 set prefendstack [lreplace $prefendstack end end]
2712 set prefix [string range $prefix 0 $prefixend]
2715 set tail [string range $f [expr {$prefixend+1}] end]
2716 while {[set slash [string first "/" $tail]] >= 0} {
2719 lappend prefendstack $prefixend
2720 incr prefixend [expr {$slash + 1}]
2721 set d [string range $tail 0 $slash]
2722 lappend treecontents($prefix) $d
2723 set oldprefix $prefix
2725 set treecontents($prefix) {}
2726 set treeindex($prefix) [incr ix]
2727 set treeparent($prefix) $oldprefix
2728 set tail [string range $tail [expr {$slash+1}] end]
2729 if {$lev <= $openlevs} {
2731 set treediropen($prefix) [expr {$lev < $openlevs}]
2732 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2733 $w mark set d:$ix "end -1c"
2734 $w mark gravity d:$ix left
2736 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2738 $w image create end -align center -image $bm -padx 1 \
2740 $w insert end $d [highlight_tag $prefix]
2741 $w mark set s:$ix "end -1c"
2742 $w mark gravity s:$ix left
2747 if {$lev <= $openlevs} {
2750 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2752 $w insert end $tail [highlight_tag $f]
2754 lappend treecontents($prefix) $tail
2757 while {$htstack ne {}} {
2758 set treeheight($prefix) $ht
2759 incr ht [lindex $htstack end]
2760 set htstack [lreplace $htstack end end]
2761 set prefixend [lindex $prefendstack end]
2762 set prefendstack [lreplace $prefendstack end end]
2763 set prefix [string range $prefix 0 $prefixend]
2765 $w conf -state disabled
2768 proc linetoelt {l} {
2769 global treeheight treecontents
2774 foreach e $treecontents($prefix) {
2779 if {[string index $e end] eq "/"} {
2780 set n $treeheight($prefix$e)
2792 proc highlight_tree {y prefix} {
2793 global treeheight treecontents cflist
2795 foreach e $treecontents($prefix) {
2797 if {[highlight_tag $path] ne {}} {
2798 $cflist tag add bold $y.0 "$y.0 lineend"
2801 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2802 set y [highlight_tree $y $path]
2808 proc treeclosedir {w dir} {
2809 global treediropen treeheight treeparent treeindex
2811 set ix $treeindex($dir)
2812 $w conf -state normal
2813 $w delete s:$ix e:$ix
2814 set treediropen($dir) 0
2815 $w image configure a:$ix -image tri-rt
2816 $w conf -state disabled
2817 set n [expr {1 - $treeheight($dir)}]
2818 while {$dir ne {}} {
2819 incr treeheight($dir) $n
2820 set dir $treeparent($dir)
2824 proc treeopendir {w dir} {
2825 global treediropen treeheight treeparent treecontents treeindex
2827 set ix $treeindex($dir)
2828 $w conf -state normal
2829 $w image configure a:$ix -image tri-dn
2830 $w mark set e:$ix s:$ix
2831 $w mark gravity e:$ix right
2834 set n [llength $treecontents($dir)]
2835 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2838 incr treeheight($x) $n
2840 foreach e $treecontents($dir) {
2842 if {[string index $e end] eq "/"} {
2843 set iy $treeindex($de)
2844 $w mark set d:$iy e:$ix
2845 $w mark gravity d:$iy left
2846 $w insert e:$ix $str
2847 set treediropen($de) 0
2848 $w image create e:$ix -align center -image tri-rt -padx 1 \
2850 $w insert e:$ix $e [highlight_tag $de]
2851 $w mark set s:$iy e:$ix
2852 $w mark gravity s:$iy left
2853 set treeheight($de) 1
2855 $w insert e:$ix $str
2856 $w insert e:$ix $e [highlight_tag $de]
2859 $w mark gravity e:$ix right
2860 $w conf -state disabled
2861 set treediropen($dir) 1
2862 set top [lindex [split [$w index @0,0] .] 0]
2863 set ht [$w cget -height]
2864 set l [lindex [split [$w index s:$ix] .] 0]
2867 } elseif {$l + $n + 1 > $top + $ht} {
2868 set top [expr {$l + $n + 2 - $ht}]
2876 proc treeclick {w x y} {
2877 global treediropen cmitmode ctext cflist cflist_top
2879 if {$cmitmode ne "tree"} return
2880 if {![info exists cflist_top]} return
2881 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2882 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2883 $cflist tag add highlight $l.0 "$l.0 lineend"
2889 set e [linetoelt $l]
2890 if {[string index $e end] ne "/"} {
2892 } elseif {$treediropen($e)} {
2899 proc setfilelist {id} {
2900 global treefilelist cflist jump_to_here
2902 treeview $cflist $treefilelist($id) 0
2903 if {$jump_to_here ne {}} {
2904 set f [lindex $jump_to_here 0]
2905 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2911 image create bitmap tri-rt -background black -foreground blue -data {
2912 #define tri-rt_width 13
2913 #define tri-rt_height 13
2914 static unsigned char tri-rt_bits[] = {
2915 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2916 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2919 #define tri-rt-mask_width 13
2920 #define tri-rt-mask_height 13
2921 static unsigned char tri-rt-mask_bits[] = {
2922 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2923 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2926 image create bitmap tri-dn -background black -foreground blue -data {
2927 #define tri-dn_width 13
2928 #define tri-dn_height 13
2929 static unsigned char tri-dn_bits[] = {
2930 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2931 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2934 #define tri-dn-mask_width 13
2935 #define tri-dn-mask_height 13
2936 static unsigned char tri-dn-mask_bits[] = {
2937 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2938 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2942 image create bitmap reficon-T -background black -foreground yellow -data {
2943 #define tagicon_width 13
2944 #define tagicon_height 9
2945 static unsigned char tagicon_bits[] = {
2946 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2947 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2949 #define tagicon-mask_width 13
2950 #define tagicon-mask_height 9
2951 static unsigned char tagicon-mask_bits[] = {
2952 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2953 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2956 #define headicon_width 13
2957 #define headicon_height 9
2958 static unsigned char headicon_bits[] = {
2959 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2960 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2963 #define headicon-mask_width 13
2964 #define headicon-mask_height 9
2965 static unsigned char headicon-mask_bits[] = {
2966 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2967 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2969 image create bitmap reficon-H -background black -foreground green \
2970 -data $rectdata -maskdata $rectmask
2971 image create bitmap reficon-o -background black -foreground "#ddddff" \
2972 -data $rectdata -maskdata $rectmask
2974 proc init_flist {first} {
2975 global cflist cflist_top difffilestart
2977 $cflist conf -state normal
2978 $cflist delete 0.0 end
2980 $cflist insert end $first
2982 $cflist tag add highlight 1.0 "1.0 lineend"
2984 catch {unset cflist_top}
2986 $cflist conf -state disabled
2987 set difffilestart {}
2990 proc highlight_tag {f} {
2991 global highlight_paths
2993 foreach p $highlight_paths {
2994 if {[string match $p $f]} {
3001 proc highlight_filelist {} {
3002 global cmitmode cflist
3004 $cflist conf -state normal
3005 if {$cmitmode ne "tree"} {
3006 set end [lindex [split [$cflist index end] .] 0]
3007 for {set l 2} {$l < $end} {incr l} {
3008 set line [$cflist get $l.0 "$l.0 lineend"]
3009 if {[highlight_tag $line] ne {}} {
3010 $cflist tag add bold $l.0 "$l.0 lineend"
3016 $cflist conf -state disabled
3019 proc unhighlight_filelist {} {
3022 $cflist conf -state normal
3023 $cflist tag remove bold 1.0 end
3024 $cflist conf -state disabled
3027 proc add_flist {fl} {
3030 $cflist conf -state normal
3032 $cflist insert end "\n"
3033 $cflist insert end $f [highlight_tag $f]
3035 $cflist conf -state disabled
3038 proc sel_flist {w x y} {
3039 global ctext difffilestart cflist cflist_top cmitmode
3041 if {$cmitmode eq "tree"} return
3042 if {![info exists cflist_top]} return
3043 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3044 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3045 $cflist tag add highlight $l.0 "$l.0 lineend"
3050 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3054 proc pop_flist_menu {w X Y x y} {
3055 global ctext cflist cmitmode flist_menu flist_menu_file
3056 global treediffs diffids
3059 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3061 if {$cmitmode eq "tree"} {
3062 set e [linetoelt $l]
3063 if {[string index $e end] eq "/"} return
3065 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3067 set flist_menu_file $e
3068 set xdiffstate "normal"
3069 if {$cmitmode eq "tree"} {
3070 set xdiffstate "disabled"
3072 # Disable "External diff" item in tree mode
3073 $flist_menu entryconf 2 -state $xdiffstate
3074 tk_popup $flist_menu $X $Y
3077 proc find_ctext_fileinfo {line} {
3078 global ctext_file_names ctext_file_lines
3080 set ok [bsearch $ctext_file_lines $line]
3081 set tline [lindex $ctext_file_lines $ok]
3083 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3086 return [list [lindex $ctext_file_names $ok] $tline]
3090 proc pop_diff_menu {w X Y x y} {
3091 global ctext diff_menu flist_menu_file
3092 global diff_menu_txtpos diff_menu_line
3093 global diff_menu_filebase
3095 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3096 set diff_menu_line [lindex $diff_menu_txtpos 0]
3097 # don't pop up the menu on hunk-separator or file-separator lines
3098 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3102 set f [find_ctext_fileinfo $diff_menu_line]
3103 if {$f eq {}} return
3104 set flist_menu_file [lindex $f 0]
3105 set diff_menu_filebase [lindex $f 1]
3106 tk_popup $diff_menu $X $Y
3109 proc flist_hl {only} {
3110 global flist_menu_file findstring gdttype
3112 set x [shellquote $flist_menu_file]
3113 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3116 append findstring " " $x
3118 set gdttype [mc "touching paths:"]
3121 proc save_file_from_commit {filename output what} {
3124 if {[catch {exec git show $filename -- > $output} err]} {
3125 if {[string match "fatal: bad revision *" $err]} {
3128 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3134 proc external_diff_get_one_file {diffid filename diffdir} {
3135 global nullid nullid2 nullfile
3138 if {$diffid == $nullid} {
3139 set difffile [file join [file dirname $gitdir] $filename]
3140 if {[file exists $difffile]} {
3145 if {$diffid == $nullid2} {
3146 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3147 return [save_file_from_commit :$filename $difffile index]
3149 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3150 return [save_file_from_commit $diffid:$filename $difffile \
3154 proc external_diff {} {
3155 global gitktmpdir nullid nullid2
3156 global flist_menu_file
3159 global gitdir extdifftool
3161 if {[llength $diffids] == 1} {
3162 # no reference commit given
3163 set diffidto [lindex $diffids 0]
3164 if {$diffidto eq $nullid} {
3165 # diffing working copy with index
3166 set diffidfrom $nullid2
3167 } elseif {$diffidto eq $nullid2} {
3168 # diffing index with HEAD
3169 set diffidfrom "HEAD"
3171 # use first parent commit
3172 global parentlist selectedline
3173 set diffidfrom [lindex $parentlist $selectedline 0]
3176 set diffidfrom [lindex $diffids 0]
3177 set diffidto [lindex $diffids 1]
3180 # make sure that several diffs wont collide
3181 if {![info exists gitktmpdir]} {
3182 set gitktmpdir [file join [file dirname $gitdir] \
3183 [format ".gitk-tmp.%s" [pid]]]
3184 if {[catch {file mkdir $gitktmpdir} err]} {
3185 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3192 set diffdir [file join $gitktmpdir $diffnum]
3193 if {[catch {file mkdir $diffdir} err]} {
3194 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3198 # gather files to diff
3199 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3200 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3202 if {$difffromfile ne {} && $difftofile ne {}} {
3203 set cmd [concat | [shellsplit $extdifftool] \
3204 [list $difffromfile $difftofile]]
3205 if {[catch {set fl [open $cmd r]} err]} {
3206 file delete -force $diffdir
3207 error_popup "$extdifftool: [mc "command failed:"] $err"
3209 fconfigure $fl -blocking 0
3210 filerun $fl [list delete_at_eof $fl $diffdir]
3215 proc find_hunk_blamespec {base line} {
3218 # Find and parse the hunk header
3219 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3220 if {$s_lix eq {}} return
3222 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3223 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3224 s_line old_specs osz osz1 new_line nsz]} {
3228 # base lines for the parents
3229 set base_lines [list $new_line]
3230 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3231 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3232 old_spec old_line osz]} {
3235 lappend base_lines $old_line
3238 # Now scan the lines to determine offset within the hunk
3239 set max_parent [expr {[llength $base_lines]-2}]
3241 set s_lno [lindex [split $s_lix "."] 0]
3243 # Determine if the line is removed
3244 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3245 if {[string match {[-+ ]*} $chunk]} {
3246 set removed_idx [string first "-" $chunk]
3247 # Choose a parent index
3248 if {$removed_idx >= 0} {
3249 set parent $removed_idx
3251 set unchanged_idx [string first " " $chunk]
3252 if {$unchanged_idx >= 0} {
3253 set parent $unchanged_idx
3255 # blame the current commit
3259 # then count other lines that belong to it
3260 for {set i $line} {[incr i -1] > $s_lno} {} {
3261 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3262 # Determine if the line is removed
3263 set removed_idx [string first "-" $chunk]
3265 set code [string index $chunk $parent]
3266 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3270 if {$removed_idx < 0} {
3280 incr dline [lindex $base_lines $parent]
3281 return [list $parent $dline]
3284 proc external_blame_diff {} {
3285 global currentid cmitmode
3286 global diff_menu_txtpos diff_menu_line
3287 global diff_menu_filebase flist_menu_file
3289 if {$cmitmode eq "tree"} {
3291 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3293 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3295 set parent_idx [lindex $hinfo 0]
3296 set line [lindex $hinfo 1]
3303 external_blame $parent_idx $line
3306 # Find the SHA1 ID of the blob for file $fname in the index
3308 proc index_sha1 {fname} {
3309 set f [open [list | git ls-files -s $fname] r]
3310 while {[gets $f line] >= 0} {
3311 set info [lindex [split $line "\t"] 0]
3312 set stage [lindex $info 2]
3313 if {$stage eq "0" || $stage eq "2"} {
3315 return [lindex $info 1]
3322 proc external_blame {parent_idx {line {}}} {
3323 global flist_menu_file
3324 global nullid nullid2
3325 global parentlist selectedline currentid
3327 if {$parent_idx > 0} {
3328 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3330 set base_commit $currentid
3333 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3334 error_popup [mc "No such commit"]
3338 set cmdline [list git gui blame]
3339 if {$line ne {} && $line > 1} {
3340 lappend cmdline "--line=$line"
3342 lappend cmdline $base_commit $flist_menu_file
3343 if {[catch {eval exec $cmdline &} err]} {
3344 error_popup "[mc "git gui blame: command failed:"] $err"
3348 proc show_line_source {} {
3349 global cmitmode currentid parents curview blamestuff blameinst
3350 global diff_menu_line diff_menu_filebase flist_menu_file
3351 global nullid nullid2 gitdir
3354 if {$cmitmode eq "tree"} {
3356 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3358 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3359 if {$h eq {}} return
3360 set pi [lindex $h 0]
3362 mark_ctext_line $diff_menu_line
3366 if {$currentid eq $nullid} {
3368 # must be a merge in progress...
3370 # get the last line from .git/MERGE_HEAD
3371 set f [open [file join $gitdir MERGE_HEAD] r]
3372 set id [lindex [split [read $f] "\n"] end-1]
3375 error_popup [mc "Couldn't read merge head: %s" $err]
3378 } elseif {$parents($curview,$currentid) eq $nullid2} {
3379 # need to do the blame from the index
3381 set from_index [index_sha1 $flist_menu_file]
3383 error_popup [mc "Error reading index: %s" $err]
3388 set id [lindex $parents($curview,$currentid) $pi]
3390 set line [lindex $h 1]
3393 if {$from_index ne {}} {
3394 lappend blameargs | git cat-file blob $from_index
3396 lappend blameargs | git blame -p -L$line,+1
3397 if {$from_index ne {}} {
3398 lappend blameargs --contents -
3400 lappend blameargs $id
3402 lappend blameargs -- $flist_menu_file
3404 set f [open $blameargs r]
3406 error_popup [mc "Couldn't start git blame: %s" $err]
3409 fconfigure $f -blocking 0
3410 set i [reg_instance $f]
3411 set blamestuff($i) {}
3413 filerun $f [list read_line_source $f $i]
3416 proc stopblaming {} {
3419 if {[info exists blameinst]} {
3420 stop_instance $blameinst
3425 proc read_line_source {fd inst} {
3426 global blamestuff curview commfd blameinst nullid nullid2
3428 while {[gets $fd line] >= 0} {
3429 lappend blamestuff($inst) $line
3436 fconfigure $fd -blocking 1
3437 if {[catch {close $fd} err]} {
3438 error_popup [mc "Error running git blame: %s" $err]
3443 set line [split [lindex $blamestuff($inst) 0] " "]
3444 set id [lindex $line 0]
3445 set lnum [lindex $line 1]
3446 if {[string length $id] == 40 && [string is xdigit $id] &&
3447 [string is digit -strict $lnum]} {
3448 # look for "filename" line
3449 foreach l $blamestuff($inst) {
3450 if {[string match "filename *" $l]} {
3451 set fname [string range $l 9 end]
3457 # all looks good, select it
3458 if {$id eq $nullid} {
3459 # blame uses all-zeroes to mean not committed,
3460 # which would mean a change in the index
3463 if {[commitinview $id $curview]} {
3464 selectline [rowofcommit $id] 1 [list $fname $lnum]
3466 error_popup [mc "That line comes from commit %s, \
3467 which is not in this view" [shortids $id]]
3470 puts "oops couldn't parse git blame output"
3475 # delete $dir when we see eof on $f (presumably because the child has exited)
3476 proc delete_at_eof {f dir} {
3477 while {[gets $f line] >= 0} {}
3479 if {[catch {close $f} err]} {
3480 error_popup "[mc "External diff viewer failed:"] $err"
3482 file delete -force $dir
3488 # Functions for adding and removing shell-type quoting
3490 proc shellquote {str} {
3491 if {![string match "*\['\"\\ \t]*" $str]} {
3494 if {![string match "*\['\"\\]*" $str]} {
3497 if {![string match "*'*" $str]} {
3500 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3503 proc shellarglist {l} {
3509 append str [shellquote $a]
3514 proc shelldequote {str} {
3519 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3520 append ret [string range $str $used end]
3521 set used [string length $str]
3524 set first [lindex $first 0]
3525 set ch [string index $str $first]
3526 if {$first > $used} {
3527 append ret [string range $str $used [expr {$first - 1}]]
3530 if {$ch eq " " || $ch eq "\t"} break
3533 set first [string first "'" $str $used]
3535 error "unmatched single-quote"
3537 append ret [string range $str $used [expr {$first - 1}]]
3542 if {$used >= [string length $str]} {
3543 error "trailing backslash"
3545 append ret [string index $str $used]
3550 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3551 error "unmatched double-quote"
3553 set first [lindex $first 0]
3554 set ch [string index $str $first]
3555 if {$first > $used} {
3556 append ret [string range $str $used [expr {$first - 1}]]
3559 if {$ch eq "\""} break
3561 append ret [string index $str $used]
3565 return [list $used $ret]
3568 proc shellsplit {str} {
3571 set str [string trimleft $str]
3572 if {$str eq {}} break
3573 set dq [shelldequote $str]
3574 set n [lindex $dq 0]
3575 set word [lindex $dq 1]
3576 set str [string range $str $n end]
3582 # Code to implement multiple views
3584 proc newview {ishighlight} {
3585 global nextviewnum newviewname newishighlight
3586 global revtreeargs viewargscmd newviewopts curview
3588 set newishighlight $ishighlight
3590 if {[winfo exists $top]} {
3594 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3595 set newviewopts($nextviewnum,perm) 0
3596 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3597 decode_view_opts $nextviewnum $revtreeargs
3598 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3601 set known_view_options {
3602 {perm b . {} {mc "Remember this view"}}
3603 {args t50= + {} {mc "Commits to include (arguments to git log):"}}
3604 {all b * "--all" {mc "Use all refs"}}
3605 {dorder b . {"--date-order" "-d"} {mc "Strictly sort by date"}}
3606 {lright b . "--left-right" {mc "Mark branch sides"}}
3607 {since t15 + {"--since=*" "--after=*"} {mc "Since date:"}}
3608 {until t15 . {"--until=*" "--before=*"} {mc "Until date:"}}
3609 {limit t10 + "--max-count=*" {mc "Max count:"}}
3610 {skip t10 . "--skip=*" {mc "Skip:"}}
3611 {first b . "--first-parent" {mc "Limit to first parent"}}
3612 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3615 proc encode_view_opts {n} {
3616 global known_view_options newviewopts
3619 foreach opt $known_view_options {
3620 set patterns [lindex $opt 3]
3621 if {$patterns eq {}} continue
3622 set pattern [lindex $patterns 0]
3624 set val $newviewopts($n,[lindex $opt 0])
3626 if {[lindex $opt 1] eq "b"} {
3628 lappend rargs $pattern
3631 set val [string trim $val]
3633 set pfix [string range $pattern 0 end-1]
3634 lappend rargs $pfix$val
3638 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3641 proc decode_view_opts {n view_args} {
3642 global known_view_options newviewopts
3644 foreach opt $known_view_options {
3645 if {[lindex $opt 1] eq "b"} {
3650 set newviewopts($n,[lindex $opt 0]) $val
3653 foreach arg $view_args {
3654 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3655 && ![info exists found(limit)]} {
3656 set newviewopts($n,limit) $cnt
3661 foreach opt $known_view_options {
3662 set id [lindex $opt 0]
3663 if {[info exists found($id)]} continue
3664 foreach pattern [lindex $opt 3] {
3665 if {![string match $pattern $arg]} continue
3666 if {[lindex $opt 1] ne "b"} {
3667 set size [string length $pattern]
3668 set val [string range $arg [expr {$size-1}] end]
3672 set newviewopts($n,$id) $val
3676 if {[info exists val]} break
3678 if {[info exists val]} continue
3681 set newviewopts($n,args) [shellarglist $oargs]
3684 proc edit_or_newview {} {
3696 global viewname viewperm newviewname newviewopts
3697 global viewargs viewargscmd
3699 set top .gitkvedit-$curview
3700 if {[winfo exists $top]} {
3704 set newviewname($curview) $viewname($curview)
3705 set newviewopts($curview,perm) $viewperm($curview)
3706 set newviewopts($curview,cmd) $viewargscmd($curview)
3707 decode_view_opts $curview $viewargs($curview)
3708 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3711 proc vieweditor {top n title} {
3712 global newviewname newviewopts viewfiles bgcolor
3713 global known_view_options
3716 wm title $top $title
3717 make_transient $top .
3721 label $top.nl -text [mc "Name"]
3722 entry $top.name -width 20 -textvariable newviewname($n)
3723 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3724 pack $top.nl -in $top.nfr -side left -padx {0 30}
3725 pack $top.name -in $top.nfr -side left
3731 foreach opt $known_view_options {
3732 set id [lindex $opt 0]
3733 set type [lindex $opt 1]
3734 set flags [lindex $opt 2]
3735 set title [eval [lindex $opt 4]]
3738 if {$flags eq "+" || $flags eq "*"} {
3739 set cframe $top.fr$cnt
3742 pack $cframe -in $top -fill x -pady 3 -padx 3
3743 set cexpand [expr {$flags eq "*"}]
3749 checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3750 pack $cframe.c_$id -in $cframe -side left \
3751 -padx [list $lxpad 0] -expand $cexpand -anchor w
3752 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3753 message $cframe.l_$id -aspect 1500 -text $title
3754 entry $cframe.e_$id -width $sz -background $bgcolor \
3755 -textvariable newviewopts($n,$id)
3756 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3757 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3758 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3759 message $cframe.l_$id -aspect 1500 -text $title
3760 entry $cframe.e_$id -width $sz -background $bgcolor \
3761 -textvariable newviewopts($n,$id)
3762 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3763 pack $cframe.e_$id -in $cframe -side top -fill x
3768 message $top.l -aspect 1500 \
3769 -text [mc "Enter files and directories to include, one per line:"]
3770 pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3771 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3772 if {[info exists viewfiles($n)]} {
3773 foreach f $viewfiles($n) {
3774 $top.t insert end $f
3775 $top.t insert end "\n"
3777 $top.t delete {end - 1c} end
3778 $top.t mark set insert 0.0
3780 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3782 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3783 button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3784 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3785 bind $top <Control-Return> [list newviewok $top $n]
3786 bind $top <F5> [list newviewok $top $n 1]
3787 bind $top <Escape> [list destroy $top]
3788 grid $top.buts.ok $top.buts.apply $top.buts.can
3789 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3790 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3791 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3792 pack $top.buts -in $top -side top -fill x
3796 proc doviewmenu {m first cmd op argv} {
3797 set nmenu [$m index end]
3798 for {set i $first} {$i <= $nmenu} {incr i} {
3799 if {[$m entrycget $i -command] eq $cmd} {
3800 eval $m $op $i $argv
3806 proc allviewmenus {n op args} {
3809 doviewmenu .bar.view 5 [list showview $n] $op $args
3810 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3813 proc newviewok {top n {apply 0}} {
3814 global nextviewnum newviewperm newviewname newishighlight
3815 global viewname viewfiles viewperm selectedview curview
3816 global viewargs viewargscmd newviewopts viewhlmenu
3819 set newargs [encode_view_opts $n]
3821 error_popup "[mc "Error in commit selection arguments:"] $err" $top
3825 foreach f [split [$top.t get 0.0 end] "\n"] {
3826 set ft [string trim $f]
3831 if {![info exists viewfiles($n)]} {
3832 # creating a new view
3834 set viewname($n) $newviewname($n)
3835 set viewperm($n) $newviewopts($n,perm)
3836 set viewfiles($n) $files
3837 set viewargs($n) $newargs
3838 set viewargscmd($n) $newviewopts($n,cmd)
3840 if {!$newishighlight} {
3843 run addvhighlight $n
3846 # editing an existing view
3847 set viewperm($n) $newviewopts($n,perm)
3848 if {$newviewname($n) ne $viewname($n)} {
3849 set viewname($n) $newviewname($n)
3850 doviewmenu .bar.view 5 [list showview $n] \
3851 entryconf [list -label $viewname($n)]
3852 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3853 # entryconf [list -label $viewname($n) -value $viewname($n)]
3855 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3856 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3857 set viewfiles($n) $files
3858 set viewargs($n) $newargs
3859 set viewargscmd($n) $newviewopts($n,cmd)
3860 if {$curview == $n} {
3866 catch {destroy $top}
3870 global curview viewperm hlview selectedhlview
3872 if {$curview == 0} return
3873 if {[info exists hlview] && $hlview == $curview} {
3874 set selectedhlview [mc "None"]
3877 allviewmenus $curview delete
3878 set viewperm($curview) 0
3882 proc addviewmenu {n} {
3883 global viewname viewhlmenu
3885 .bar.view add radiobutton -label $viewname($n) \
3886 -command [list showview $n] -variable selectedview -value $n
3887 #$viewhlmenu add radiobutton -label $viewname($n) \
3888 # -command [list addvhighlight $n] -variable selectedhlview
3892 global curview cached_commitrow ordertok
3893 global displayorder parentlist rowidlist rowisopt rowfinal
3894 global colormap rowtextx nextcolor canvxmax
3895 global numcommits viewcomplete
3896 global selectedline currentid canv canvy0
3898 global pending_select mainheadid
3901 global hlview selectedhlview commitinterest
3903 if {$n == $curview} return
3905 set ymax [lindex [$canv cget -scrollregion] 3]
3906 set span [$canv yview]
3907 set ytop [expr {[lindex $span 0] * $ymax}]
3908 set ybot [expr {[lindex $span 1] * $ymax}]
3909 set yscreen [expr {($ybot - $ytop) / 2}]
3910 if {$selectedline ne {}} {
3911 set selid $currentid
3912 set y [yc $selectedline]
3913 if {$ytop < $y && $y < $ybot} {
3914 set yscreen [expr {$y - $ytop}]
3916 } elseif {[info exists pending_select]} {
3917 set selid $pending_select
3918 unset pending_select
3922 catch {unset treediffs}
3924 if {[info exists hlview] && $hlview == $n} {
3926 set selectedhlview [mc "None"]
3928 catch {unset commitinterest}
3929 catch {unset cached_commitrow}
3930 catch {unset ordertok}
3934 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3935 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3938 if {![info exists viewcomplete($n)]} {
3948 set numcommits $commitidx($n)
3950 catch {unset colormap}
3951 catch {unset rowtextx}
3953 set canvxmax [$canv cget -width]
3959 if {$selid ne {} && [commitinview $selid $n]} {
3960 set row [rowofcommit $selid]
3961 # try to get the selected row in the same position on the screen
3962 set ymax [lindex [$canv cget -scrollregion] 3]
3963 set ytop [expr {[yc $row] - $yscreen}]
3967 set yf [expr {$ytop * 1.0 / $ymax}]
3969 allcanvs yview moveto $yf
3973 } elseif {!$viewcomplete($n)} {
3974 reset_pending_select $selid
3976 reset_pending_select {}
3978 if {[commitinview $pending_select $curview]} {
3979 selectline [rowofcommit $pending_select] 1
3981 set row [first_real_row]
3982 if {$row < $numcommits} {
3987 if {!$viewcomplete($n)} {
3988 if {$numcommits == 0} {
3989 show_status [mc "Reading commits..."]
3991 } elseif {$numcommits == 0} {
3992 show_status [mc "No commits selected"]
3996 # Stuff relating to the highlighting facility
3998 proc ishighlighted {id} {
3999 global vhighlights fhighlights nhighlights rhighlights
4001 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4002 return $nhighlights($id)
4004 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4005 return $vhighlights($id)
4007 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4008 return $fhighlights($id)
4010 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4011 return $rhighlights($id)
4016 proc bolden {id font} {
4017 global canv linehtag currentid boldids need_redisplay
4019 # need_redisplay = 1 means the display is stale and about to be redrawn
4020 if {$need_redisplay} return
4022 $canv itemconf $linehtag($id) -font $font
4023 if {[info exists currentid] && $id eq $currentid} {
4025 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4026 -outline {{}} -tags secsel \
4027 -fill [$canv cget -selectbackground]]
4032 proc bolden_name {id font} {
4033 global canv2 linentag currentid boldnameids need_redisplay
4035 if {$need_redisplay} return
4036 lappend boldnameids $id
4037 $canv2 itemconf $linentag($id) -font $font
4038 if {[info exists currentid] && $id eq $currentid} {
4039 $canv2 delete secsel
4040 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4041 -outline {{}} -tags secsel \
4042 -fill [$canv2 cget -selectbackground]]
4051 foreach id $boldids {
4052 if {![ishighlighted $id]} {
4055 lappend stillbold $id
4058 set boldids $stillbold
4061 proc addvhighlight {n} {
4062 global hlview viewcomplete curview vhl_done commitidx
4064 if {[info exists hlview]} {
4068 if {$n != $curview && ![info exists viewcomplete($n)]} {
4071 set vhl_done $commitidx($hlview)
4072 if {$vhl_done > 0} {
4077 proc delvhighlight {} {
4078 global hlview vhighlights
4080 if {![info exists hlview]} return
4082 catch {unset vhighlights}
4086 proc vhighlightmore {} {
4087 global hlview vhl_done commitidx vhighlights curview
4089 set max $commitidx($hlview)
4090 set vr [visiblerows]
4091 set r0 [lindex $vr 0]
4092 set r1 [lindex $vr 1]
4093 for {set i $vhl_done} {$i < $max} {incr i} {
4094 set id [commitonrow $i $hlview]
4095 if {[commitinview $id $curview]} {
4096 set row [rowofcommit $id]
4097 if {$r0 <= $row && $row <= $r1} {
4098 if {![highlighted $row]} {
4099 bolden $id mainfontbold
4101 set vhighlights($id) 1
4109 proc askvhighlight {row id} {
4110 global hlview vhighlights iddrawn
4112 if {[commitinview $id $hlview]} {
4113 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4114 bolden $id mainfontbold
4116 set vhighlights($id) 1
4118 set vhighlights($id) 0
4122 proc hfiles_change {} {
4123 global highlight_files filehighlight fhighlights fh_serial
4124 global highlight_paths
4126 if {[info exists filehighlight]} {
4127 # delete previous highlights
4128 catch {close $filehighlight}
4130 catch {unset fhighlights}
4132 unhighlight_filelist
4134 set highlight_paths {}
4135 after cancel do_file_hl $fh_serial
4137 if {$highlight_files ne {}} {
4138 after 300 do_file_hl $fh_serial
4142 proc gdttype_change {name ix op} {
4143 global gdttype highlight_files findstring findpattern
4146 if {$findstring ne {}} {
4147 if {$gdttype eq [mc "containing:"]} {
4148 if {$highlight_files ne {}} {
4149 set highlight_files {}
4154 if {$findpattern ne {}} {
4158 set highlight_files $findstring
4163 # enable/disable findtype/findloc menus too
4166 proc find_change {name ix op} {
4167 global gdttype findstring highlight_files
4170 if {$gdttype eq [mc "containing:"]} {
4173 if {$highlight_files ne $findstring} {
4174 set highlight_files $findstring
4181 proc findcom_change args {
4182 global nhighlights boldnameids
4183 global findpattern findtype findstring gdttype
4186 # delete previous highlights, if any
4187 foreach id $boldnameids {
4188 bolden_name $id mainfont
4191 catch {unset nhighlights}
4194 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4196 } elseif {$findtype eq [mc "Regexp"]} {
4197 set findpattern $findstring
4199 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4201 set findpattern "*$e*"
4205 proc makepatterns {l} {
4208 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4209 if {[string index $ee end] eq "/"} {
4219 proc do_file_hl {serial} {
4220 global highlight_files filehighlight highlight_paths gdttype fhl_list
4222 if {$gdttype eq [mc "touching paths:"]} {
4223 if {[catch {set paths [shellsplit $highlight_files]}]} return
4224 set highlight_paths [makepatterns $paths]
4226 set gdtargs [concat -- $paths]
4227 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4228 set gdtargs [list "-S$highlight_files"]
4230 # must be "containing:", i.e. we're searching commit info
4233 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4234 set filehighlight [open $cmd r+]
4235 fconfigure $filehighlight -blocking 0
4236 filerun $filehighlight readfhighlight
4242 proc flushhighlights {} {
4243 global filehighlight fhl_list
4245 if {[info exists filehighlight]} {
4247 puts $filehighlight ""
4248 flush $filehighlight
4252 proc askfilehighlight {row id} {
4253 global filehighlight fhighlights fhl_list
4255 lappend fhl_list $id
4256 set fhighlights($id) -1
4257 puts $filehighlight $id
4260 proc readfhighlight {} {
4261 global filehighlight fhighlights curview iddrawn
4262 global fhl_list find_dirn
4264 if {![info exists filehighlight]} {
4268 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4269 set line [string trim $line]
4270 set i [lsearch -exact $fhl_list $line]
4271 if {$i < 0} continue
4272 for {set j 0} {$j < $i} {incr j} {
4273 set id [lindex $fhl_list $j]
4274 set fhighlights($id) 0
4276 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4277 if {$line eq {}} continue
4278 if {![commitinview $line $curview]} continue
4279 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4280 bolden $line mainfontbold
4282 set fhighlights($line) 1
4284 if {[eof $filehighlight]} {
4286 puts "oops, git diff-tree died"
4287 catch {close $filehighlight}
4291 if {[info exists find_dirn]} {
4297 proc doesmatch {f} {
4298 global findtype findpattern
4300 if {$findtype eq [mc "Regexp"]} {
4301 return [regexp $findpattern $f]
4302 } elseif {$findtype eq [mc "IgnCase"]} {
4303 return [string match -nocase $findpattern $f]
4305 return [string match $findpattern $f]
4309 proc askfindhighlight {row id} {
4310 global nhighlights commitinfo iddrawn
4312 global markingmatches
4314 if {![info exists commitinfo($id)]} {
4317 set info $commitinfo($id)
4319 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4320 foreach f $info ty $fldtypes {
4321 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4323 if {$ty eq [mc "Author"]} {
4330 if {$isbold && [info exists iddrawn($id)]} {
4331 if {![ishighlighted $id]} {
4332 bolden $id mainfontbold
4334 bolden_name $id mainfontbold
4337 if {$markingmatches} {
4338 markrowmatches $row $id
4341 set nhighlights($id) $isbold
4344 proc markrowmatches {row id} {
4345 global canv canv2 linehtag linentag commitinfo findloc
4347 set headline [lindex $commitinfo($id) 0]
4348 set author [lindex $commitinfo($id) 1]
4349 $canv delete match$row
4350 $canv2 delete match$row
4351 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4352 set m [findmatches $headline]
4354 markmatches $canv $row $headline $linehtag($id) $m \
4355 [$canv itemcget $linehtag($id) -font] $row
4358 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4359 set m [findmatches $author]
4361 markmatches $canv2 $row $author $linentag($id) $m \
4362 [$canv2 itemcget $linentag($id) -font] $row
4367 proc vrel_change {name ix op} {
4368 global highlight_related
4371 if {$highlight_related ne [mc "None"]} {
4376 # prepare for testing whether commits are descendents or ancestors of a
4377 proc rhighlight_sel {a} {
4378 global descendent desc_todo ancestor anc_todo
4379 global highlight_related
4381 catch {unset descendent}
4382 set desc_todo [list $a]
4383 catch {unset ancestor}
4384 set anc_todo [list $a]
4385 if {$highlight_related ne [mc "None"]} {
4391 proc rhighlight_none {} {
4394 catch {unset rhighlights}
4398 proc is_descendent {a} {
4399 global curview children descendent desc_todo
4402 set la [rowofcommit $a]
4406 for {set i 0} {$i < [llength $todo]} {incr i} {
4407 set do [lindex $todo $i]
4408 if {[rowofcommit $do] < $la} {
4409 lappend leftover $do
4412 foreach nk $children($v,$do) {
4413 if {![info exists descendent($nk)]} {
4414 set descendent($nk) 1
4422 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4426 set descendent($a) 0
4427 set desc_todo $leftover
4430 proc is_ancestor {a} {
4431 global curview parents ancestor anc_todo
4434 set la [rowofcommit $a]
4438 for {set i 0} {$i < [llength $todo]} {incr i} {
4439 set do [lindex $todo $i]
4440 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4441 lappend leftover $do
4444 foreach np $parents($v,$do) {
4445 if {![info exists ancestor($np)]} {
4454 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4459 set anc_todo $leftover
4462 proc askrelhighlight {row id} {
4463 global descendent highlight_related iddrawn rhighlights
4464 global selectedline ancestor
4466 if {$selectedline eq {}} return
4468 if {$highlight_related eq [mc "Descendant"] ||
4469 $highlight_related eq [mc "Not descendant"]} {
4470 if {![info exists descendent($id)]} {
4473 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4476 } elseif {$highlight_related eq [mc "Ancestor"] ||
4477 $highlight_related eq [mc "Not ancestor"]} {
4478 if {![info exists ancestor($id)]} {
4481 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4485 if {[info exists iddrawn($id)]} {
4486 if {$isbold && ![ishighlighted $id]} {
4487 bolden $id mainfontbold
4490 set rhighlights($id) $isbold
4493 # Graph layout functions
4495 proc shortids {ids} {
4498 if {[llength $id] > 1} {
4499 lappend res [shortids $id]
4500 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4501 lappend res [string range $id 0 7]
4512 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4513 if {($n & $mask) != 0} {
4514 set ret [concat $ret $o]
4516 set o [concat $o $o]
4521 proc ordertoken {id} {
4522 global ordertok curview varcid varcstart varctok curview parents children
4523 global nullid nullid2
4525 if {[info exists ordertok($id)]} {
4526 return $ordertok($id)
4531 if {[info exists varcid($curview,$id)]} {
4532 set a $varcid($curview,$id)
4533 set p [lindex $varcstart($curview) $a]
4535 set p [lindex $children($curview,$id) 0]
4537 if {[info exists ordertok($p)]} {
4538 set tok $ordertok($p)
4541 set id [first_real_child $curview,$p]
4544 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4547 if {[llength $parents($curview,$id)] == 1} {
4548 lappend todo [list $p {}]
4550 set j [lsearch -exact $parents($curview,$id) $p]
4552 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4554 lappend todo [list $p [strrep $j]]
4557 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4558 set p [lindex $todo $i 0]
4559 append tok [lindex $todo $i 1]
4560 set ordertok($p) $tok
4562 set ordertok($origid) $tok
4566 # Work out where id should go in idlist so that order-token
4567 # values increase from left to right
4568 proc idcol {idlist id {i 0}} {
4569 set t [ordertoken $id]
4573 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4574 if {$i > [llength $idlist]} {
4575 set i [llength $idlist]
4577 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4580 if {$t > [ordertoken [lindex $idlist $i]]} {
4581 while {[incr i] < [llength $idlist] &&
4582 $t >= [ordertoken [lindex $idlist $i]]} {}
4588 proc initlayout {} {
4589 global rowidlist rowisopt rowfinal displayorder parentlist
4590 global numcommits canvxmax canv
4592 global colormap rowtextx
4601 set canvxmax [$canv cget -width]
4602 catch {unset colormap}
4603 catch {unset rowtextx}
4607 proc setcanvscroll {} {
4608 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4609 global lastscrollset lastscrollrows
4611 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4612 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4613 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4614 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4615 set lastscrollset [clock clicks -milliseconds]
4616 set lastscrollrows $numcommits
4619 proc visiblerows {} {
4620 global canv numcommits linespc
4622 set ymax [lindex [$canv cget -scrollregion] 3]
4623 if {$ymax eq {} || $ymax == 0} return
4625 set y0 [expr {int([lindex $f 0] * $ymax)}]
4626 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4630 set y1 [expr {int([lindex $f 1] * $ymax)}]
4631 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4632 if {$r1 >= $numcommits} {
4633 set r1 [expr {$numcommits - 1}]
4635 return [list $r0 $r1]
4638 proc layoutmore {} {
4639 global commitidx viewcomplete curview
4640 global numcommits pending_select curview
4641 global lastscrollset lastscrollrows
4643 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4644 [clock clicks -milliseconds] - $lastscrollset > 500} {
4647 if {[info exists pending_select] &&
4648 [commitinview $pending_select $curview]} {
4650 selectline [rowofcommit $pending_select] 1
4655 # With path limiting, we mightn't get the actual HEAD commit,
4656 # so ask git rev-list what is the first ancestor of HEAD that
4657 # touches a file in the path limit.
4658 proc get_viewmainhead {view} {
4659 global viewmainheadid vfilelimit viewinstances mainheadid
4662 set rfd [open [concat | git rev-list -1 $mainheadid \
4663 -- $vfilelimit($view)] r]
4664 set j [reg_instance $rfd]
4665 lappend viewinstances($view) $j
4666 fconfigure $rfd -blocking 0
4667 filerun $rfd [list getviewhead $rfd $j $view]
4668 set viewmainheadid($curview) {}
4672 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4673 proc getviewhead {fd inst view} {
4674 global viewmainheadid commfd curview viewinstances showlocalchanges
4677 if {[gets $fd line] < 0} {
4681 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4684 set viewmainheadid($view) $id
4687 set i [lsearch -exact $viewinstances($view) $inst]
4689 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4691 if {$showlocalchanges && $id ne {} && $view == $curview} {
4697 proc doshowlocalchanges {} {
4698 global curview viewmainheadid
4700 if {$viewmainheadid($curview) eq {}} return
4701 if {[commitinview $viewmainheadid($curview) $curview]} {
4704 interestedin $viewmainheadid($curview) dodiffindex
4708 proc dohidelocalchanges {} {
4709 global nullid nullid2 lserial curview
4711 if {[commitinview $nullid $curview]} {
4712 removefakerow $nullid
4714 if {[commitinview $nullid2 $curview]} {
4715 removefakerow $nullid2
4720 # spawn off a process to do git diff-index --cached HEAD
4721 proc dodiffindex {} {
4722 global lserial showlocalchanges vfilelimit curview
4725 if {!$showlocalchanges || !$isworktree} return
4727 set cmd "|git diff-index --cached HEAD"
4728 if {$vfilelimit($curview) ne {}} {
4729 set cmd [concat $cmd -- $vfilelimit($curview)]
4731 set fd [open $cmd r]
4732 fconfigure $fd -blocking 0
4733 set i [reg_instance $fd]
4734 filerun $fd [list readdiffindex $fd $lserial $i]
4737 proc readdiffindex {fd serial inst} {
4738 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4742 if {[gets $fd line] < 0} {
4748 # we only need to see one line and we don't really care what it says...
4751 if {$serial != $lserial} {
4755 # now see if there are any local changes not checked in to the index
4756 set cmd "|git diff-files"
4757 if {$vfilelimit($curview) ne {}} {
4758 set cmd [concat $cmd -- $vfilelimit($curview)]
4760 set fd [open $cmd r]
4761 fconfigure $fd -blocking 0
4762 set i [reg_instance $fd]
4763 filerun $fd [list readdifffiles $fd $serial $i]
4765 if {$isdiff && ![commitinview $nullid2 $curview]} {
4766 # add the line for the changes in the index to the graph
4767 set hl [mc "Local changes checked in to index but not committed"]
4768 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4769 set commitdata($nullid2) "\n $hl\n"
4770 if {[commitinview $nullid $curview]} {
4771 removefakerow $nullid
4773 insertfakerow $nullid2 $viewmainheadid($curview)
4774 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4775 if {[commitinview $nullid $curview]} {
4776 removefakerow $nullid
4778 removefakerow $nullid2
4783 proc readdifffiles {fd serial inst} {
4784 global viewmainheadid nullid nullid2 curview
4785 global commitinfo commitdata lserial
4788 if {[gets $fd line] < 0} {
4794 # we only need to see one line and we don't really care what it says...
4797 if {$serial != $lserial} {
4801 if {$isdiff && ![commitinview $nullid $curview]} {
4802 # add the line for the local diff to the graph
4803 set hl [mc "Local uncommitted changes, not checked in to index"]
4804 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4805 set commitdata($nullid) "\n $hl\n"
4806 if {[commitinview $nullid2 $curview]} {
4809 set p $viewmainheadid($curview)
4811 insertfakerow $nullid $p
4812 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4813 removefakerow $nullid
4818 proc nextuse {id row} {
4819 global curview children
4821 if {[info exists children($curview,$id)]} {
4822 foreach kid $children($curview,$id) {
4823 if {![commitinview $kid $curview]} {
4826 if {[rowofcommit $kid] > $row} {
4827 return [rowofcommit $kid]
4831 if {[commitinview $id $curview]} {
4832 return [rowofcommit $id]
4837 proc prevuse {id row} {
4838 global curview children
4841 if {[info exists children($curview,$id)]} {
4842 foreach kid $children($curview,$id) {
4843 if {![commitinview $kid $curview]} break
4844 if {[rowofcommit $kid] < $row} {
4845 set ret [rowofcommit $kid]
4852 proc make_idlist {row} {
4853 global displayorder parentlist uparrowlen downarrowlen mingaplen
4854 global commitidx curview children
4856 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4860 set ra [expr {$row - $downarrowlen}]
4864 set rb [expr {$row + $uparrowlen}]
4865 if {$rb > $commitidx($curview)} {
4866 set rb $commitidx($curview)
4868 make_disporder $r [expr {$rb + 1}]
4870 for {} {$r < $ra} {incr r} {
4871 set nextid [lindex $displayorder [expr {$r + 1}]]
4872 foreach p [lindex $parentlist $r] {
4873 if {$p eq $nextid} continue
4874 set rn [nextuse $p $r]
4876 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4877 lappend ids [list [ordertoken $p] $p]
4881 for {} {$r < $row} {incr r} {
4882 set nextid [lindex $displayorder [expr {$r + 1}]]
4883 foreach p [lindex $parentlist $r] {
4884 if {$p eq $nextid} continue
4885 set rn [nextuse $p $r]
4886 if {$rn < 0 || $rn >= $row} {
4887 lappend ids [list [ordertoken $p] $p]
4891 set id [lindex $displayorder $row]
4892 lappend ids [list [ordertoken $id] $id]
4894 foreach p [lindex $parentlist $r] {
4895 set firstkid [lindex $children($curview,$p) 0]
4896 if {[rowofcommit $firstkid] < $row} {
4897 lappend ids [list [ordertoken $p] $p]
4901 set id [lindex $displayorder $r]
4903 set firstkid [lindex $children($curview,$id) 0]
4904 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4905 lappend ids [list [ordertoken $id] $id]
4910 foreach idx [lsort -unique $ids] {
4911 lappend idlist [lindex $idx 1]
4916 proc rowsequal {a b} {
4917 while {[set i [lsearch -exact $a {}]] >= 0} {
4918 set a [lreplace $a $i $i]
4920 while {[set i [lsearch -exact $b {}]] >= 0} {
4921 set b [lreplace $b $i $i]
4923 return [expr {$a eq $b}]
4926 proc makeupline {id row rend col} {
4927 global rowidlist uparrowlen downarrowlen mingaplen
4929 for {set r $rend} {1} {set r $rstart} {
4930 set rstart [prevuse $id $r]
4931 if {$rstart < 0} return
4932 if {$rstart < $row} break
4934 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4935 set rstart [expr {$rend - $uparrowlen - 1}]
4937 for {set r $rstart} {[incr r] <= $row} {} {
4938 set idlist [lindex $rowidlist $r]
4939 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4940 set col [idcol $idlist $id $col]
4941 lset rowidlist $r [linsert $idlist $col $id]
4947 proc layoutrows {row endrow} {
4948 global rowidlist rowisopt rowfinal displayorder
4949 global uparrowlen downarrowlen maxwidth mingaplen
4950 global children parentlist
4951 global commitidx viewcomplete curview
4953 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4956 set rm1 [expr {$row - 1}]
4957 foreach id [lindex $rowidlist $rm1] {
4962 set final [lindex $rowfinal $rm1]
4964 for {} {$row < $endrow} {incr row} {
4965 set rm1 [expr {$row - 1}]
4966 if {$rm1 < 0 || $idlist eq {}} {
4967 set idlist [make_idlist $row]
4970 set id [lindex $displayorder $rm1]
4971 set col [lsearch -exact $idlist $id]
4972 set idlist [lreplace $idlist $col $col]
4973 foreach p [lindex $parentlist $rm1] {
4974 if {[lsearch -exact $idlist $p] < 0} {
4975 set col [idcol $idlist $p $col]
4976 set idlist [linsert $idlist $col $p]
4977 # if not the first child, we have to insert a line going up
4978 if {$id ne [lindex $children($curview,$p) 0]} {
4979 makeupline $p $rm1 $row $col
4983 set id [lindex $displayorder $row]
4984 if {$row > $downarrowlen} {
4985 set termrow [expr {$row - $downarrowlen - 1}]
4986 foreach p [lindex $parentlist $termrow] {
4987 set i [lsearch -exact $idlist $p]
4988 if {$i < 0} continue
4989 set nr [nextuse $p $termrow]
4990 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4991 set idlist [lreplace $idlist $i $i]
4995 set col [lsearch -exact $idlist $id]
4997 set col [idcol $idlist $id]
4998 set idlist [linsert $idlist $col $id]
4999 if {$children($curview,$id) ne {}} {
5000 makeupline $id $rm1 $row $col
5003 set r [expr {$row + $uparrowlen - 1}]
5004 if {$r < $commitidx($curview)} {
5006 foreach p [lindex $parentlist $r] {
5007 if {[lsearch -exact $idlist $p] >= 0} continue
5008 set fk [lindex $children($curview,$p) 0]
5009 if {[rowofcommit $fk] < $row} {
5010 set x [idcol $idlist $p $x]
5011 set idlist [linsert $idlist $x $p]
5014 if {[incr r] < $commitidx($curview)} {
5015 set p [lindex $displayorder $r]
5016 if {[lsearch -exact $idlist $p] < 0} {
5017 set fk [lindex $children($curview,$p) 0]
5018 if {$fk ne {} && [rowofcommit $fk] < $row} {
5019 set x [idcol $idlist $p $x]
5020 set idlist [linsert $idlist $x $p]
5026 if {$final && !$viewcomplete($curview) &&
5027 $row + $uparrowlen + $mingaplen + $downarrowlen
5028 >= $commitidx($curview)} {
5031 set l [llength $rowidlist]
5033 lappend rowidlist $idlist
5035 lappend rowfinal $final
5036 } elseif {$row < $l} {
5037 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5038 lset rowidlist $row $idlist
5041 lset rowfinal $row $final
5043 set pad [ntimes [expr {$row - $l}] {}]
5044 set rowidlist [concat $rowidlist $pad]
5045 lappend rowidlist $idlist
5046 set rowfinal [concat $rowfinal $pad]
5047 lappend rowfinal $final
5048 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5054 proc changedrow {row} {
5055 global displayorder iddrawn rowisopt need_redisplay
5057 set l [llength $rowisopt]
5059 lset rowisopt $row 0
5060 if {$row + 1 < $l} {
5061 lset rowisopt [expr {$row + 1}] 0
5062 if {$row + 2 < $l} {
5063 lset rowisopt [expr {$row + 2}] 0
5067 set id [lindex $displayorder $row]
5068 if {[info exists iddrawn($id)]} {
5069 set need_redisplay 1
5073 proc insert_pad {row col npad} {
5076 set pad [ntimes $npad {}]
5077 set idlist [lindex $rowidlist $row]
5078 set bef [lrange $idlist 0 [expr {$col - 1}]]
5079 set aft [lrange $idlist $col end]
5080 set i [lsearch -exact $aft {}]
5082 set aft [lreplace $aft $i $i]
5084 lset rowidlist $row [concat $bef $pad $aft]
5088 proc optimize_rows {row col endrow} {
5089 global rowidlist rowisopt displayorder curview children
5094 for {} {$row < $endrow} {incr row; set col 0} {
5095 if {[lindex $rowisopt $row]} continue
5097 set y0 [expr {$row - 1}]
5098 set ym [expr {$row - 2}]
5099 set idlist [lindex $rowidlist $row]
5100 set previdlist [lindex $rowidlist $y0]
5101 if {$idlist eq {} || $previdlist eq {}} continue
5103 set pprevidlist [lindex $rowidlist $ym]
5104 if {$pprevidlist eq {}} continue
5110 for {} {$col < [llength $idlist]} {incr col} {
5111 set id [lindex $idlist $col]
5112 if {[lindex $previdlist $col] eq $id} continue
5117 set x0 [lsearch -exact $previdlist $id]
5118 if {$x0 < 0} continue
5119 set z [expr {$x0 - $col}]
5123 set xm [lsearch -exact $pprevidlist $id]
5125 set z0 [expr {$xm - $x0}]
5129 # if row y0 is the first child of $id then it's not an arrow
5130 if {[lindex $children($curview,$id) 0] ne
5131 [lindex $displayorder $y0]} {
5135 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5136 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5139 # Looking at lines from this row to the previous row,
5140 # make them go straight up if they end in an arrow on
5141 # the previous row; otherwise make them go straight up
5143 if {$z < -1 || ($z < 0 && $isarrow)} {
5144 # Line currently goes left too much;
5145 # insert pads in the previous row, then optimize it
5146 set npad [expr {-1 - $z + $isarrow}]
5147 insert_pad $y0 $x0 $npad
5149 optimize_rows $y0 $x0 $row
5151 set previdlist [lindex $rowidlist $y0]
5152 set x0 [lsearch -exact $previdlist $id]
5153 set z [expr {$x0 - $col}]
5155 set pprevidlist [lindex $rowidlist $ym]
5156 set xm [lsearch -exact $pprevidlist $id]
5157 set z0 [expr {$xm - $x0}]
5159 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5160 # Line currently goes right too much;
5161 # insert pads in this line
5162 set npad [expr {$z - 1 + $isarrow}]
5163 insert_pad $row $col $npad
5164 set idlist [lindex $rowidlist $row]
5166 set z [expr {$x0 - $col}]
5169 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5170 # this line links to its first child on row $row-2
5171 set id [lindex $displayorder $ym]
5172 set xc [lsearch -exact $pprevidlist $id]
5174 set z0 [expr {$xc - $x0}]
5177 # avoid lines jigging left then immediately right
5178 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5179 insert_pad $y0 $x0 1
5181 optimize_rows $y0 $x0 $row
5182 set previdlist [lindex $rowidlist $y0]
5186 # Find the first column that doesn't have a line going right
5187 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5188 set id [lindex $idlist $col]
5189 if {$id eq {}} break
5190 set x0 [lsearch -exact $previdlist $id]
5192 # check if this is the link to the first child
5193 set kid [lindex $displayorder $y0]
5194 if {[lindex $children($curview,$id) 0] eq $kid} {
5195 # it is, work out offset to child
5196 set x0 [lsearch -exact $previdlist $kid]
5199 if {$x0 <= $col} break
5201 # Insert a pad at that column as long as it has a line and
5202 # isn't the last column
5203 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5204 set idlist [linsert $idlist $col {}]
5205 lset rowidlist $row $idlist
5213 global canvx0 linespc
5214 return [expr {$canvx0 + $col * $linespc}]
5218 global canvy0 linespc
5219 return [expr {$canvy0 + $row * $linespc}]
5222 proc linewidth {id} {
5223 global thickerline lthickness
5226 if {[info exists thickerline] && $id eq $thickerline} {
5227 set wid [expr {2 * $lthickness}]
5232 proc rowranges {id} {
5233 global curview children uparrowlen downarrowlen
5236 set kids $children($curview,$id)
5242 foreach child $kids {
5243 if {![commitinview $child $curview]} break
5244 set row [rowofcommit $child]
5245 if {![info exists prev]} {
5246 lappend ret [expr {$row + 1}]
5248 if {$row <= $prevrow} {
5249 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5251 # see if the line extends the whole way from prevrow to row
5252 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5253 [lsearch -exact [lindex $rowidlist \
5254 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5255 # it doesn't, see where it ends
5256 set r [expr {$prevrow + $downarrowlen}]
5257 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5258 while {[incr r -1] > $prevrow &&
5259 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5261 while {[incr r] <= $row &&
5262 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5266 # see where it starts up again
5267 set r [expr {$row - $uparrowlen}]
5268 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5269 while {[incr r] < $row &&
5270 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5272 while {[incr r -1] >= $prevrow &&
5273 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5279 if {$child eq $id} {
5288 proc drawlineseg {id row endrow arrowlow} {
5289 global rowidlist displayorder iddrawn linesegs
5290 global canv colormap linespc curview maxlinelen parentlist
5292 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5293 set le [expr {$row + 1}]
5296 set c [lsearch -exact [lindex $rowidlist $le] $id]
5302 set x [lindex $displayorder $le]
5307 if {[info exists iddrawn($x)] || $le == $endrow} {
5308 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5324 if {[info exists linesegs($id)]} {
5325 set lines $linesegs($id)
5327 set r0 [lindex $li 0]
5329 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5339 set li [lindex $lines [expr {$i-1}]]
5340 set r1 [lindex $li 1]
5341 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5346 set x [lindex $cols [expr {$le - $row}]]
5347 set xp [lindex $cols [expr {$le - 1 - $row}]]
5348 set dir [expr {$xp - $x}]
5350 set ith [lindex $lines $i 2]
5351 set coords [$canv coords $ith]
5352 set ah [$canv itemcget $ith -arrow]
5353 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5354 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5355 if {$x2 ne {} && $x - $x2 == $dir} {
5356 set coords [lrange $coords 0 end-2]
5359 set coords [list [xc $le $x] [yc $le]]
5362 set itl [lindex $lines [expr {$i-1}] 2]
5363 set al [$canv itemcget $itl -arrow]
5364 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5365 } elseif {$arrowlow} {
5366 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5367 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5371 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5372 for {set y $le} {[incr y -1] > $row} {} {
5374 set xp [lindex $cols [expr {$y - 1 - $row}]]
5375 set ndir [expr {$xp - $x}]
5376 if {$dir != $ndir || $xp < 0} {
5377 lappend coords [xc $y $x] [yc $y]
5383 # join parent line to first child
5384 set ch [lindex $displayorder $row]
5385 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5387 puts "oops: drawlineseg: child $ch not on row $row"
5388 } elseif {$xc != $x} {
5389 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5390 set d [expr {int(0.5 * $linespc)}]
5393 set x2 [expr {$x1 - $d}]
5395 set x2 [expr {$x1 + $d}]
5398 set y1 [expr {$y2 + $d}]
5399 lappend coords $x1 $y1 $x2 $y2
5400 } elseif {$xc < $x - 1} {
5401 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5402 } elseif {$xc > $x + 1} {
5403 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5407 lappend coords [xc $row $x] [yc $row]
5409 set xn [xc $row $xp]
5411 lappend coords $xn $yn
5415 set t [$canv create line $coords -width [linewidth $id] \
5416 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5419 set lines [linsert $lines $i [list $row $le $t]]
5421 $canv coords $ith $coords
5422 if {$arrow ne $ah} {
5423 $canv itemconf $ith -arrow $arrow
5425 lset lines $i 0 $row
5428 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5429 set ndir [expr {$xo - $xp}]
5430 set clow [$canv coords $itl]
5431 if {$dir == $ndir} {
5432 set clow [lrange $clow 2 end]
5434 set coords [concat $coords $clow]
5436 lset lines [expr {$i-1}] 1 $le
5438 # coalesce two pieces
5440 set b [lindex $lines [expr {$i-1}] 0]
5441 set e [lindex $lines $i 1]
5442 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5444 $canv coords $itl $coords
5445 if {$arrow ne $al} {
5446 $canv itemconf $itl -arrow $arrow
5450 set linesegs($id) $lines
5454 proc drawparentlinks {id row} {
5455 global rowidlist canv colormap curview parentlist
5456 global idpos linespc
5458 set rowids [lindex $rowidlist $row]
5459 set col [lsearch -exact $rowids $id]
5460 if {$col < 0} return
5461 set olds [lindex $parentlist $row]
5462 set row2 [expr {$row + 1}]
5463 set x [xc $row $col]
5466 set d [expr {int(0.5 * $linespc)}]
5467 set ymid [expr {$y + $d}]
5468 set ids [lindex $rowidlist $row2]
5469 # rmx = right-most X coord used
5472 set i [lsearch -exact $ids $p]
5474 puts "oops, parent $p of $id not in list"
5477 set x2 [xc $row2 $i]
5481 set j [lsearch -exact $rowids $p]
5483 # drawlineseg will do this one for us
5487 # should handle duplicated parents here...
5488 set coords [list $x $y]
5490 # if attaching to a vertical segment, draw a smaller
5491 # slant for visual distinctness
5494 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5496 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5498 } elseif {$i < $col && $i < $j} {
5499 # segment slants towards us already
5500 lappend coords [xc $row $j] $y
5502 if {$i < $col - 1} {
5503 lappend coords [expr {$x2 + $linespc}] $y
5504 } elseif {$i > $col + 1} {
5505 lappend coords [expr {$x2 - $linespc}] $y
5507 lappend coords $x2 $y2
5510 lappend coords $x2 $y2
5512 set t [$canv create line $coords -width [linewidth $p] \
5513 -fill $colormap($p) -tags lines.$p]
5517 if {$rmx > [lindex $idpos($id) 1]} {
5518 lset idpos($id) 1 $rmx
5523 proc drawlines {id} {
5526 $canv itemconf lines.$id -width [linewidth $id]
5529 proc drawcmittext {id row col} {
5530 global linespc canv canv2 canv3 fgcolor curview
5531 global cmitlisted commitinfo rowidlist parentlist
5532 global rowtextx idpos idtags idheads idotherrefs
5533 global linehtag linentag linedtag selectedline
5534 global canvxmax boldids boldnameids fgcolor
5535 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5537 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5538 set listed $cmitlisted($curview,$id)
5539 if {$id eq $nullid} {
5541 } elseif {$id eq $nullid2} {
5543 } elseif {$id eq $mainheadid} {
5546 set ofill [lindex $circlecolors $listed]
5548 set x [xc $row $col]
5550 set orad [expr {$linespc / 3}]
5552 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5553 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5554 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5555 } elseif {$listed == 3} {
5556 # triangle pointing left for left-side commits
5557 set t [$canv create polygon \
5558 [expr {$x - $orad}] $y \
5559 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5560 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5561 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5563 # triangle pointing right for right-side commits
5564 set t [$canv create polygon \
5565 [expr {$x + $orad - 1}] $y \
5566 [expr {$x - $orad}] [expr {$y - $orad}] \
5567 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5568 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5570 set circleitem($row) $t
5572 $canv bind $t <1> {selcanvline {} %x %y}
5573 set rmx [llength [lindex $rowidlist $row]]
5574 set olds [lindex $parentlist $row]
5576 set nextids [lindex $rowidlist [expr {$row + 1}]]
5578 set i [lsearch -exact $nextids $p]
5584 set xt [xc $row $rmx]
5585 set rowtextx($row) $xt
5586 set idpos($id) [list $x $xt $y]
5587 if {[info exists idtags($id)] || [info exists idheads($id)]
5588 || [info exists idotherrefs($id)]} {
5589 set xt [drawtags $id $x $xt $y]
5591 set headline [lindex $commitinfo($id) 0]
5592 set name [lindex $commitinfo($id) 1]
5593 set date [lindex $commitinfo($id) 2]
5594 set date [formatdate $date]
5597 set isbold [ishighlighted $id]
5600 set font mainfontbold
5602 lappend boldnameids $id
5603 set nfont mainfontbold
5606 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5607 -text $headline -font $font -tags text]
5608 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5609 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5610 -text $name -font $nfont -tags text]
5611 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5612 -text $date -font mainfont -tags text]
5613 if {$selectedline == $row} {
5616 set xr [expr {$xt + [font measure $font $headline]}]
5617 if {$xr > $canvxmax} {
5623 proc drawcmitrow {row} {
5624 global displayorder rowidlist nrows_drawn
5625 global iddrawn markingmatches
5626 global commitinfo numcommits
5627 global filehighlight fhighlights findpattern nhighlights
5628 global hlview vhighlights
5629 global highlight_related rhighlights
5631 if {$row >= $numcommits} return
5633 set id [lindex $displayorder $row]
5634 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5635 askvhighlight $row $id
5637 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5638 askfilehighlight $row $id
5640 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5641 askfindhighlight $row $id
5643 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5644 askrelhighlight $row $id
5646 if {![info exists iddrawn($id)]} {
5647 set col [lsearch -exact [lindex $rowidlist $row] $id]
5649 puts "oops, row $row id $id not in list"
5652 if {![info exists commitinfo($id)]} {
5656 drawcmittext $id $row $col
5660 if {$markingmatches} {
5661 markrowmatches $row $id
5665 proc drawcommits {row {endrow {}}} {
5666 global numcommits iddrawn displayorder curview need_redisplay
5667 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5672 if {$endrow eq {}} {
5675 if {$endrow >= $numcommits} {
5676 set endrow [expr {$numcommits - 1}]
5679 set rl1 [expr {$row - $downarrowlen - 3}]
5683 set ro1 [expr {$row - 3}]
5687 set r2 [expr {$endrow + $uparrowlen + 3}]
5688 if {$r2 > $numcommits} {
5691 for {set r $rl1} {$r < $r2} {incr r} {
5692 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5696 set rl1 [expr {$r + 1}]
5702 optimize_rows $ro1 0 $r2
5703 if {$need_redisplay || $nrows_drawn > 2000} {
5708 # make the lines join to already-drawn rows either side
5709 set r [expr {$row - 1}]
5710 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5713 set er [expr {$endrow + 1}]
5714 if {$er >= $numcommits ||
5715 ![info exists iddrawn([lindex $displayorder $er])]} {
5718 for {} {$r <= $er} {incr r} {
5719 set id [lindex $displayorder $r]
5720 set wasdrawn [info exists iddrawn($id)]
5722 if {$r == $er} break
5723 set nextid [lindex $displayorder [expr {$r + 1}]]
5724 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5725 drawparentlinks $id $r
5727 set rowids [lindex $rowidlist $r]
5728 foreach lid $rowids {
5729 if {$lid eq {}} continue
5730 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5732 # see if this is the first child of any of its parents
5733 foreach p [lindex $parentlist $r] {
5734 if {[lsearch -exact $rowids $p] < 0} {
5735 # make this line extend up to the child
5736 set lineend($p) [drawlineseg $p $r $er 0]
5740 set lineend($lid) [drawlineseg $lid $r $er 1]
5746 proc undolayout {row} {
5747 global uparrowlen mingaplen downarrowlen
5748 global rowidlist rowisopt rowfinal need_redisplay
5750 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5754 if {[llength $rowidlist] > $r} {
5756 set rowidlist [lrange $rowidlist 0 $r]
5757 set rowfinal [lrange $rowfinal 0 $r]
5758 set rowisopt [lrange $rowisopt 0 $r]
5759 set need_redisplay 1
5764 proc drawvisible {} {
5765 global canv linespc curview vrowmod selectedline targetrow targetid
5766 global need_redisplay cscroll numcommits
5768 set fs [$canv yview]
5769 set ymax [lindex [$canv cget -scrollregion] 3]
5770 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5771 set f0 [lindex $fs 0]
5772 set f1 [lindex $fs 1]
5773 set y0 [expr {int($f0 * $ymax)}]
5774 set y1 [expr {int($f1 * $ymax)}]
5776 if {[info exists targetid]} {
5777 if {[commitinview $targetid $curview]} {
5778 set r [rowofcommit $targetid]
5779 if {$r != $targetrow} {
5780 # Fix up the scrollregion and change the scrolling position
5781 # now that our target row has moved.
5782 set diff [expr {($r - $targetrow) * $linespc}]
5785 set ymax [lindex [$canv cget -scrollregion] 3]
5788 set f0 [expr {$y0 / $ymax}]
5789 set f1 [expr {$y1 / $ymax}]
5790 allcanvs yview moveto $f0
5791 $cscroll set $f0 $f1
5792 set need_redisplay 1
5799 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5800 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5801 if {$endrow >= $vrowmod($curview)} {
5802 update_arcrows $curview
5804 if {$selectedline ne {} &&
5805 $row <= $selectedline && $selectedline <= $endrow} {
5806 set targetrow $selectedline
5807 } elseif {[info exists targetid]} {
5808 set targetrow [expr {int(($row + $endrow) / 2)}]
5810 if {[info exists targetrow]} {
5811 if {$targetrow >= $numcommits} {
5812 set targetrow [expr {$numcommits - 1}]
5814 set targetid [commitonrow $targetrow]
5816 drawcommits $row $endrow
5819 proc clear_display {} {
5820 global iddrawn linesegs need_redisplay nrows_drawn
5821 global vhighlights fhighlights nhighlights rhighlights
5822 global linehtag linentag linedtag boldids boldnameids
5825 catch {unset iddrawn}
5826 catch {unset linesegs}
5827 catch {unset linehtag}
5828 catch {unset linentag}
5829 catch {unset linedtag}
5832 catch {unset vhighlights}
5833 catch {unset fhighlights}
5834 catch {unset nhighlights}
5835 catch {unset rhighlights}
5836 set need_redisplay 0
5840 proc findcrossings {id} {
5841 global rowidlist parentlist numcommits displayorder
5845 foreach {s e} [rowranges $id] {
5846 if {$e >= $numcommits} {
5847 set e [expr {$numcommits - 1}]
5849 if {$e <= $s} continue
5850 for {set row $e} {[incr row -1] >= $s} {} {
5851 set x [lsearch -exact [lindex $rowidlist $row] $id]
5853 set olds [lindex $parentlist $row]
5854 set kid [lindex $displayorder $row]
5855 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5856 if {$kidx < 0} continue
5857 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5859 set px [lsearch -exact $nextrow $p]
5860 if {$px < 0} continue
5861 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5862 if {[lsearch -exact $ccross $p] >= 0} continue
5863 if {$x == $px + ($kidx < $px? -1: 1)} {
5865 } elseif {[lsearch -exact $cross $p] < 0} {
5872 return [concat $ccross {{}} $cross]
5875 proc assigncolor {id} {
5876 global colormap colors nextcolor
5877 global parents children children curview
5879 if {[info exists colormap($id)]} return
5880 set ncolors [llength $colors]
5881 if {[info exists children($curview,$id)]} {
5882 set kids $children($curview,$id)
5886 if {[llength $kids] == 1} {
5887 set child [lindex $kids 0]
5888 if {[info exists colormap($child)]
5889 && [llength $parents($curview,$child)] == 1} {
5890 set colormap($id) $colormap($child)
5896 foreach x [findcrossings $id] {
5898 # delimiter between corner crossings and other crossings
5899 if {[llength $badcolors] >= $ncolors - 1} break
5900 set origbad $badcolors
5902 if {[info exists colormap($x)]
5903 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5904 lappend badcolors $colormap($x)
5907 if {[llength $badcolors] >= $ncolors} {
5908 set badcolors $origbad
5910 set origbad $badcolors
5911 if {[llength $badcolors] < $ncolors - 1} {
5912 foreach child $kids {
5913 if {[info exists colormap($child)]
5914 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5915 lappend badcolors $colormap($child)
5917 foreach p $parents($curview,$child) {
5918 if {[info exists colormap($p)]
5919 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5920 lappend badcolors $colormap($p)
5924 if {[llength $badcolors] >= $ncolors} {
5925 set badcolors $origbad
5928 for {set i 0} {$i <= $ncolors} {incr i} {
5929 set c [lindex $colors $nextcolor]
5930 if {[incr nextcolor] >= $ncolors} {
5933 if {[lsearch -exact $badcolors $c]} break
5935 set colormap($id) $c
5938 proc bindline {t id} {
5941 $canv bind $t <Enter> "lineenter %x %y $id"
5942 $canv bind $t <Motion> "linemotion %x %y $id"
5943 $canv bind $t <Leave> "lineleave $id"
5944 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5947 proc drawtags {id x xt y1} {
5948 global idtags idheads idotherrefs mainhead
5949 global linespc lthickness
5950 global canv rowtextx curview fgcolor bgcolor ctxbut
5955 if {[info exists idtags($id)]} {
5956 set marks $idtags($id)
5957 set ntags [llength $marks]
5959 if {[info exists idheads($id)]} {
5960 set marks [concat $marks $idheads($id)]
5961 set nheads [llength $idheads($id)]
5963 if {[info exists idotherrefs($id)]} {
5964 set marks [concat $marks $idotherrefs($id)]
5970 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5971 set yt [expr {$y1 - 0.5 * $linespc}]
5972 set yb [expr {$yt + $linespc - 1}]
5976 foreach tag $marks {
5978 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5979 set wid [font measure mainfontbold $tag]
5981 set wid [font measure mainfont $tag]
5985 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5987 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5988 -width $lthickness -fill black -tags tag.$id]
5990 foreach tag $marks x $xvals wid $wvals {
5991 set xl [expr {$x + $delta}]
5992 set xr [expr {$x + $delta + $wid + $lthickness}]
5994 if {[incr ntags -1] >= 0} {
5996 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5997 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5998 -width 1 -outline black -fill yellow -tags tag.$id]
5999 $canv bind $t <1> [list showtag $tag 1]
6000 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6002 # draw a head or other ref
6003 if {[incr nheads -1] >= 0} {
6005 if {$tag eq $mainhead} {
6006 set font mainfontbold
6011 set xl [expr {$xl - $delta/2}]
6012 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6013 -width 1 -outline black -fill $col -tags tag.$id
6014 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6015 set rwid [font measure mainfont $remoteprefix]
6016 set xi [expr {$x + 1}]
6017 set yti [expr {$yt + 1}]
6018 set xri [expr {$x + $rwid}]
6019 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6020 -width 0 -fill "#ffddaa" -tags tag.$id
6023 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6024 -font $font -tags [list tag.$id text]]
6026 $canv bind $t <1> [list showtag $tag 1]
6027 } elseif {$nheads >= 0} {
6028 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6034 proc xcoord {i level ln} {
6035 global canvx0 xspc1 xspc2
6037 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6038 if {$i > 0 && $i == $level} {
6039 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6040 } elseif {$i > $level} {
6041 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6046 proc show_status {msg} {
6050 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6051 -tags text -fill $fgcolor
6054 # Don't change the text pane cursor if it is currently the hand cursor,
6055 # showing that we are over a sha1 ID link.
6056 proc settextcursor {c} {
6057 global ctext curtextcursor
6059 if {[$ctext cget -cursor] == $curtextcursor} {
6060 $ctext config -cursor $c
6062 set curtextcursor $c
6065 proc nowbusy {what {name {}}} {
6066 global isbusy busyname statusw
6068 if {[array names isbusy] eq {}} {
6069 . config -cursor watch
6073 set busyname($what) $name
6075 $statusw conf -text $name
6079 proc notbusy {what} {
6080 global isbusy maincursor textcursor busyname statusw
6084 if {$busyname($what) ne {} &&
6085 [$statusw cget -text] eq $busyname($what)} {
6086 $statusw conf -text {}
6089 if {[array names isbusy] eq {}} {
6090 . config -cursor $maincursor
6091 settextcursor $textcursor
6095 proc findmatches {f} {
6096 global findtype findstring
6097 if {$findtype == [mc "Regexp"]} {
6098 set matches [regexp -indices -all -inline $findstring $f]
6101 if {$findtype == [mc "IgnCase"]} {
6102 set f [string tolower $f]
6103 set fs [string tolower $fs]
6107 set l [string length $fs]
6108 while {[set j [string first $fs $f $i]] >= 0} {
6109 lappend matches [list $j [expr {$j+$l-1}]]
6110 set i [expr {$j + $l}]
6116 proc dofind {{dirn 1} {wrap 1}} {
6117 global findstring findstartline findcurline selectedline numcommits
6118 global gdttype filehighlight fh_serial find_dirn findallowwrap
6120 if {[info exists find_dirn]} {
6121 if {$find_dirn == $dirn} return
6125 if {$findstring eq {} || $numcommits == 0} return
6126 if {$selectedline eq {}} {
6127 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6129 set findstartline $selectedline
6131 set findcurline $findstartline
6132 nowbusy finding [mc "Searching"]
6133 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6134 after cancel do_file_hl $fh_serial
6135 do_file_hl $fh_serial
6138 set findallowwrap $wrap
6142 proc stopfinding {} {
6143 global find_dirn findcurline fprogcoord
6145 if {[info exists find_dirn]} {
6156 global commitdata commitinfo numcommits findpattern findloc
6157 global findstartline findcurline findallowwrap
6158 global find_dirn gdttype fhighlights fprogcoord
6159 global curview varcorder vrownum varccommits vrowmod
6161 if {![info exists find_dirn]} {
6164 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6167 if {$find_dirn > 0} {
6169 if {$l >= $numcommits} {
6172 if {$l <= $findstartline} {
6173 set lim [expr {$findstartline + 1}]
6176 set moretodo $findallowwrap
6183 if {$l >= $findstartline} {
6184 set lim [expr {$findstartline - 1}]
6187 set moretodo $findallowwrap
6190 set n [expr {($lim - $l) * $find_dirn}]
6195 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6196 update_arcrows $curview
6200 set ai [bsearch $vrownum($curview) $l]
6201 set a [lindex $varcorder($curview) $ai]
6202 set arow [lindex $vrownum($curview) $ai]
6203 set ids [lindex $varccommits($curview,$a)]
6204 set arowend [expr {$arow + [llength $ids]}]
6205 if {$gdttype eq [mc "containing:"]} {
6206 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6207 if {$l < $arow || $l >= $arowend} {
6209 set a [lindex $varcorder($curview) $ai]
6210 set arow [lindex $vrownum($curview) $ai]
6211 set ids [lindex $varccommits($curview,$a)]
6212 set arowend [expr {$arow + [llength $ids]}]
6214 set id [lindex $ids [expr {$l - $arow}]]
6215 # shouldn't happen unless git log doesn't give all the commits...
6216 if {![info exists commitdata($id)] ||
6217 ![doesmatch $commitdata($id)]} {
6220 if {![info exists commitinfo($id)]} {
6223 set info $commitinfo($id)
6224 foreach f $info ty $fldtypes {
6225 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6234 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6235 if {$l < $arow || $l >= $arowend} {
6237 set a [lindex $varcorder($curview) $ai]
6238 set arow [lindex $vrownum($curview) $ai]
6239 set ids [lindex $varccommits($curview,$a)]
6240 set arowend [expr {$arow + [llength $ids]}]
6242 set id [lindex $ids [expr {$l - $arow}]]
6243 if {![info exists fhighlights($id)]} {
6244 # this sets fhighlights($id) to -1
6245 askfilehighlight $l $id
6247 if {$fhighlights($id) > 0} {
6251 if {$fhighlights($id) < 0} {
6254 set findcurline [expr {$l - $find_dirn}]
6259 if {$found || ($domore && !$moretodo)} {
6275 set findcurline [expr {$l - $find_dirn}]
6277 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6281 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6286 proc findselectline {l} {
6287 global findloc commentend ctext findcurline markingmatches gdttype
6289 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6292 if {$markingmatches &&
6293 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6294 # highlight the matches in the comments
6295 set f [$ctext get 1.0 $commentend]
6296 set matches [findmatches $f]
6297 foreach match $matches {
6298 set start [lindex $match 0]
6299 set end [expr {[lindex $match 1] + 1}]
6300 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6306 # mark the bits of a headline or author that match a find string
6307 proc markmatches {canv l str tag matches font row} {
6310 set bbox [$canv bbox $tag]
6311 set x0 [lindex $bbox 0]
6312 set y0 [lindex $bbox 1]
6313 set y1 [lindex $bbox 3]
6314 foreach match $matches {
6315 set start [lindex $match 0]
6316 set end [lindex $match 1]
6317 if {$start > $end} continue
6318 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6319 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6320 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6321 [expr {$x0+$xlen+2}] $y1 \
6322 -outline {} -tags [list match$l matches] -fill yellow]
6324 if {$row == $selectedline} {
6325 $canv raise $t secsel
6330 proc unmarkmatches {} {
6331 global markingmatches
6333 allcanvs delete matches
6334 set markingmatches 0
6338 proc selcanvline {w x y} {
6339 global canv canvy0 ctext linespc
6341 set ymax [lindex [$canv cget -scrollregion] 3]
6342 if {$ymax == {}} return
6343 set yfrac [lindex [$canv yview] 0]
6344 set y [expr {$y + $yfrac * $ymax}]
6345 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6350 set xmax [lindex [$canv cget -scrollregion] 2]
6351 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6352 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6358 proc commit_descriptor {p} {
6360 if {![info exists commitinfo($p)]} {
6364 if {[llength $commitinfo($p)] > 1} {
6365 set l [lindex $commitinfo($p) 0]
6370 # append some text to the ctext widget, and make any SHA1 ID
6371 # that we know about be a clickable link.
6372 proc appendwithlinks {text tags} {
6373 global ctext linknum curview
6375 set start [$ctext index "end - 1c"]
6376 $ctext insert end $text $tags
6377 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6381 set linkid [string range $text $s $e]
6383 $ctext tag delete link$linknum
6384 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6385 setlink $linkid link$linknum
6390 proc setlink {id lk} {
6391 global curview ctext pendinglinks
6394 if {[string length $id] < 40} {
6395 set matches [longid $id]
6396 if {[llength $matches] > 0} {
6397 if {[llength $matches] > 1} return
6399 set id [lindex $matches 0]
6402 set known [commitinview $id $curview]
6405 $ctext tag conf $lk -foreground blue -underline 1
6406 $ctext tag bind $lk <1> [list selbyid $id]
6407 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6408 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6410 lappend pendinglinks($id) $lk
6411 interestedin $id {makelink %P}
6415 proc makelink {id} {
6418 if {![info exists pendinglinks($id)]} return
6419 foreach lk $pendinglinks($id) {
6422 unset pendinglinks($id)
6425 proc linkcursor {w inc} {
6426 global linkentercount curtextcursor
6428 if {[incr linkentercount $inc] > 0} {
6429 $w configure -cursor hand2
6431 $w configure -cursor $curtextcursor
6432 if {$linkentercount < 0} {
6433 set linkentercount 0
6438 proc viewnextline {dir} {
6442 set ymax [lindex [$canv cget -scrollregion] 3]
6443 set wnow [$canv yview]
6444 set wtop [expr {[lindex $wnow 0] * $ymax}]
6445 set newtop [expr {$wtop + $dir * $linespc}]
6448 } elseif {$newtop > $ymax} {
6451 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6454 # add a list of tag or branch names at position pos
6455 # returns the number of names inserted
6456 proc appendrefs {pos ids var} {
6457 global ctext linknum curview $var maxrefs
6459 if {[catch {$ctext index $pos}]} {
6462 $ctext conf -state normal
6463 $ctext delete $pos "$pos lineend"
6466 foreach tag [set $var\($id\)] {
6467 lappend tags [list $tag $id]
6470 if {[llength $tags] > $maxrefs} {
6471 $ctext insert $pos "many ([llength $tags])"
6473 set tags [lsort -index 0 -decreasing $tags]
6476 set id [lindex $ti 1]
6479 $ctext tag delete $lk
6480 $ctext insert $pos $sep
6481 $ctext insert $pos [lindex $ti 0] $lk
6486 $ctext conf -state disabled
6487 return [llength $tags]
6490 # called when we have finished computing the nearby tags
6491 proc dispneartags {delay} {
6492 global selectedline currentid showneartags tagphase
6494 if {$selectedline eq {} || !$showneartags} return
6495 after cancel dispnexttag
6497 after 200 dispnexttag
6500 after idle dispnexttag
6505 proc dispnexttag {} {
6506 global selectedline currentid showneartags tagphase ctext
6508 if {$selectedline eq {} || !$showneartags} return
6509 switch -- $tagphase {
6511 set dtags [desctags $currentid]
6513 appendrefs precedes $dtags idtags
6517 set atags [anctags $currentid]
6519 appendrefs follows $atags idtags
6523 set dheads [descheads $currentid]
6524 if {$dheads ne {}} {
6525 if {[appendrefs branch $dheads idheads] > 1
6526 && [$ctext get "branch -3c"] eq "h"} {
6527 # turn "Branch" into "Branches"
6528 $ctext conf -state normal
6529 $ctext insert "branch -2c" "es"
6530 $ctext conf -state disabled
6535 if {[incr tagphase] <= 2} {
6536 after idle dispnexttag
6540 proc make_secsel {id} {
6541 global linehtag linentag linedtag canv canv2 canv3
6543 if {![info exists linehtag($id)]} return
6545 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6546 -tags secsel -fill [$canv cget -selectbackground]]
6548 $canv2 delete secsel
6549 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6550 -tags secsel -fill [$canv2 cget -selectbackground]]
6552 $canv3 delete secsel
6553 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6554 -tags secsel -fill [$canv3 cget -selectbackground]]
6558 proc selectline {l isnew {desired_loc {}}} {
6559 global canv ctext commitinfo selectedline
6560 global canvy0 linespc parents children curview
6561 global currentid sha1entry
6562 global commentend idtags linknum
6563 global mergemax numcommits pending_select
6564 global cmitmode showneartags allcommits
6565 global targetrow targetid lastscrollrows
6566 global autoselect jump_to_here
6568 catch {unset pending_select}
6573 if {$l < 0 || $l >= $numcommits} return
6574 set id [commitonrow $l]
6579 if {$lastscrollrows < $numcommits} {
6583 set y [expr {$canvy0 + $l * $linespc}]
6584 set ymax [lindex [$canv cget -scrollregion] 3]
6585 set ytop [expr {$y - $linespc - 1}]
6586 set ybot [expr {$y + $linespc + 1}]
6587 set wnow [$canv yview]
6588 set wtop [expr {[lindex $wnow 0] * $ymax}]
6589 set wbot [expr {[lindex $wnow 1] * $ymax}]
6590 set wh [expr {$wbot - $wtop}]
6592 if {$ytop < $wtop} {
6593 if {$ybot < $wtop} {
6594 set newtop [expr {$y - $wh / 2.0}]
6597 if {$newtop > $wtop - $linespc} {
6598 set newtop [expr {$wtop - $linespc}]
6601 } elseif {$ybot > $wbot} {
6602 if {$ytop > $wbot} {
6603 set newtop [expr {$y - $wh / 2.0}]
6605 set newtop [expr {$ybot - $wh}]
6606 if {$newtop < $wtop + $linespc} {
6607 set newtop [expr {$wtop + $linespc}]
6611 if {$newtop != $wtop} {
6615 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6622 addtohistory [list selbyid $id]
6625 $sha1entry delete 0 end
6626 $sha1entry insert 0 $id
6628 $sha1entry selection from 0
6629 $sha1entry selection to end
6633 $ctext conf -state normal
6636 if {![info exists commitinfo($id)]} {
6639 set info $commitinfo($id)
6640 set date [formatdate [lindex $info 2]]
6641 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6642 set date [formatdate [lindex $info 4]]
6643 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6644 if {[info exists idtags($id)]} {
6645 $ctext insert end [mc "Tags:"]
6646 foreach tag $idtags($id) {
6647 $ctext insert end " $tag"
6649 $ctext insert end "\n"
6653 set olds $parents($curview,$id)
6654 if {[llength $olds] > 1} {
6657 if {$np >= $mergemax} {
6662 $ctext insert end "[mc "Parent"]: " $tag
6663 appendwithlinks [commit_descriptor $p] {}
6668 append headers "[mc "Parent"]: [commit_descriptor $p]"
6672 foreach c $children($curview,$id) {
6673 append headers "[mc "Child"]: [commit_descriptor $c]"
6676 # make anything that looks like a SHA1 ID be a clickable link
6677 appendwithlinks $headers {}
6678 if {$showneartags} {
6679 if {![info exists allcommits]} {
6682 $ctext insert end "[mc "Branch"]: "
6683 $ctext mark set branch "end -1c"
6684 $ctext mark gravity branch left
6685 $ctext insert end "\n[mc "Follows"]: "
6686 $ctext mark set follows "end -1c"
6687 $ctext mark gravity follows left
6688 $ctext insert end "\n[mc "Precedes"]: "
6689 $ctext mark set precedes "end -1c"
6690 $ctext mark gravity precedes left
6691 $ctext insert end "\n"
6694 $ctext insert end "\n"
6695 set comment [lindex $info 5]
6696 if {[string first "\r" $comment] >= 0} {
6697 set comment [string map {"\r" "\n "} $comment]
6699 appendwithlinks $comment {comment}
6701 $ctext tag remove found 1.0 end
6702 $ctext conf -state disabled
6703 set commentend [$ctext index "end - 1c"]
6705 set jump_to_here $desired_loc
6706 init_flist [mc "Comments"]
6707 if {$cmitmode eq "tree"} {
6709 } elseif {[llength $olds] <= 1} {
6716 proc selfirstline {} {
6721 proc sellastline {} {
6724 set l [expr {$numcommits - 1}]
6728 proc selnextline {dir} {
6731 if {$selectedline eq {}} return
6732 set l [expr {$selectedline + $dir}]
6737 proc selnextpage {dir} {
6738 global canv linespc selectedline numcommits
6740 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6744 allcanvs yview scroll [expr {$dir * $lpp}] units
6746 if {$selectedline eq {}} return
6747 set l [expr {$selectedline + $dir * $lpp}]
6750 } elseif {$l >= $numcommits} {
6751 set l [expr $numcommits - 1]
6757 proc unselectline {} {
6758 global selectedline currentid
6761 catch {unset currentid}
6762 allcanvs delete secsel
6766 proc reselectline {} {
6769 if {$selectedline ne {}} {
6770 selectline $selectedline 0
6774 proc addtohistory {cmd} {
6775 global history historyindex curview
6777 set elt [list $curview $cmd]
6778 if {$historyindex > 0
6779 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6783 if {$historyindex < [llength $history]} {
6784 set history [lreplace $history $historyindex end $elt]
6786 lappend history $elt
6789 if {$historyindex > 1} {
6790 .tf.bar.leftbut conf -state normal
6792 .tf.bar.leftbut conf -state disabled
6794 .tf.bar.rightbut conf -state disabled
6800 set view [lindex $elt 0]
6801 set cmd [lindex $elt 1]
6802 if {$curview != $view} {
6809 global history historyindex
6812 if {$historyindex > 1} {
6813 incr historyindex -1
6814 godo [lindex $history [expr {$historyindex - 1}]]
6815 .tf.bar.rightbut conf -state normal
6817 if {$historyindex <= 1} {
6818 .tf.bar.leftbut conf -state disabled
6823 global history historyindex
6826 if {$historyindex < [llength $history]} {
6827 set cmd [lindex $history $historyindex]
6830 .tf.bar.leftbut conf -state normal
6832 if {$historyindex >= [llength $history]} {
6833 .tf.bar.rightbut conf -state disabled
6838 global treefilelist treeidlist diffids diffmergeid treepending
6839 global nullid nullid2
6842 catch {unset diffmergeid}
6843 if {![info exists treefilelist($id)]} {
6844 if {![info exists treepending]} {
6845 if {$id eq $nullid} {
6846 set cmd [list | git ls-files]
6847 } elseif {$id eq $nullid2} {
6848 set cmd [list | git ls-files --stage -t]
6850 set cmd [list | git ls-tree -r $id]
6852 if {[catch {set gtf [open $cmd r]}]} {
6856 set treefilelist($id) {}
6857 set treeidlist($id) {}
6858 fconfigure $gtf -blocking 0 -encoding binary
6859 filerun $gtf [list gettreeline $gtf $id]
6866 proc gettreeline {gtf id} {
6867 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6870 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6871 if {$diffids eq $nullid} {
6874 set i [string first "\t" $line]
6875 if {$i < 0} continue
6876 set fname [string range $line [expr {$i+1}] end]
6877 set line [string range $line 0 [expr {$i-1}]]
6878 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6879 set sha1 [lindex $line 2]
6880 lappend treeidlist($id) $sha1
6882 if {[string index $fname 0] eq "\""} {
6883 set fname [lindex $fname 0]
6885 set fname [encoding convertfrom $fname]
6886 lappend treefilelist($id) $fname
6889 return [expr {$nl >= 1000? 2: 1}]
6893 if {$cmitmode ne "tree"} {
6894 if {![info exists diffmergeid]} {
6895 gettreediffs $diffids
6897 } elseif {$id ne $diffids} {
6906 global treefilelist treeidlist diffids nullid nullid2
6907 global ctext_file_names ctext_file_lines
6908 global ctext commentend
6910 set i [lsearch -exact $treefilelist($diffids) $f]
6912 puts "oops, $f not in list for id $diffids"
6915 if {$diffids eq $nullid} {
6916 if {[catch {set bf [open $f r]} err]} {
6917 puts "oops, can't read $f: $err"
6921 set blob [lindex $treeidlist($diffids) $i]
6922 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6923 puts "oops, error reading blob $blob: $err"
6927 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6928 filerun $bf [list getblobline $bf $diffids]
6929 $ctext config -state normal
6930 clear_ctext $commentend
6931 lappend ctext_file_names $f
6932 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6933 $ctext insert end "\n"
6934 $ctext insert end "$f\n" filesep
6935 $ctext config -state disabled
6936 $ctext yview $commentend
6940 proc getblobline {bf id} {
6941 global diffids cmitmode ctext
6943 if {$id ne $diffids || $cmitmode ne "tree"} {
6947 $ctext config -state normal
6949 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6950 $ctext insert end "$line\n"
6953 global jump_to_here ctext_file_names commentend
6955 # delete last newline
6956 $ctext delete "end - 2c" "end - 1c"
6958 if {$jump_to_here ne {} &&
6959 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6960 set lnum [expr {[lindex $jump_to_here 1] +
6961 [lindex [split $commentend .] 0]}]
6962 mark_ctext_line $lnum
6966 $ctext config -state disabled
6967 return [expr {$nl >= 1000? 2: 1}]
6970 proc mark_ctext_line {lnum} {
6971 global ctext markbgcolor
6973 $ctext tag delete omark
6974 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
6975 $ctext tag conf omark -background $markbgcolor
6979 proc mergediff {id} {
6981 global diffids treediffs
6982 global parents curview
6986 set treediffs($id) {}
6987 set np [llength $parents($curview,$id)]
6992 proc startdiff {ids} {
6993 global treediffs diffids treepending diffmergeid nullid nullid2
6997 catch {unset diffmergeid}
6998 if {![info exists treediffs($ids)] ||
6999 [lsearch -exact $ids $nullid] >= 0 ||
7000 [lsearch -exact $ids $nullid2] >= 0} {
7001 if {![info exists treepending]} {
7009 proc path_filter {filter name} {
7011 set l [string length $p]
7012 if {[string index $p end] eq "/"} {
7013 if {[string compare -length $l $p $name] == 0} {
7017 if {[string compare -length $l $p $name] == 0 &&
7018 ([string length $name] == $l ||
7019 [string index $name $l] eq "/")} {
7027 proc addtocflist {ids} {
7030 add_flist $treediffs($ids)
7034 proc diffcmd {ids flags} {
7035 global nullid nullid2
7037 set i [lsearch -exact $ids $nullid]
7038 set j [lsearch -exact $ids $nullid2]
7040 if {[llength $ids] > 1 && $j < 0} {
7041 # comparing working directory with some specific revision
7042 set cmd [concat | git diff-index $flags]
7044 lappend cmd -R [lindex $ids 1]
7046 lappend cmd [lindex $ids 0]
7049 # comparing working directory with index
7050 set cmd [concat | git diff-files $flags]
7055 } elseif {$j >= 0} {
7056 set cmd [concat | git diff-index --cached $flags]
7057 if {[llength $ids] > 1} {
7058 # comparing index with specific revision
7060 lappend cmd -R [lindex $ids 1]
7062 lappend cmd [lindex $ids 0]
7065 # comparing index with HEAD
7069 set cmd [concat | git diff-tree -r $flags $ids]
7074 proc gettreediffs {ids} {
7075 global treediff treepending
7077 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7079 set treepending $ids
7081 fconfigure $gdtf -blocking 0 -encoding binary
7082 filerun $gdtf [list gettreediffline $gdtf $ids]
7085 proc gettreediffline {gdtf ids} {
7086 global treediff treediffs treepending diffids diffmergeid
7087 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7092 if {$perfile_attrs} {
7093 # cache_gitattr is slow, and even slower on win32 where we
7094 # have to invoke it for only about 30 paths at a time
7096 if {[tk windowingsystem] == "win32"} {
7100 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7101 set i [string first "\t" $line]
7103 set file [string range $line [expr {$i+1}] end]
7104 if {[string index $file 0] eq "\""} {
7105 set file [lindex $file 0]
7107 set file [encoding convertfrom $file]
7108 if {$file ne [lindex $treediff end]} {
7109 lappend treediff $file
7110 lappend sublist $file
7114 if {$perfile_attrs} {
7115 cache_gitattr encoding $sublist
7118 return [expr {$nr >= $max? 2: 1}]
7121 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7123 foreach f $treediff {
7124 if {[path_filter $vfilelimit($curview) $f]} {
7128 set treediffs($ids) $flist
7130 set treediffs($ids) $treediff
7133 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7135 } elseif {$ids != $diffids} {
7136 if {![info exists diffmergeid]} {
7137 gettreediffs $diffids
7145 # empty string or positive integer
7146 proc diffcontextvalidate {v} {
7147 return [regexp {^(|[1-9][0-9]*)$} $v]
7150 proc diffcontextchange {n1 n2 op} {
7151 global diffcontextstring diffcontext
7153 if {[string is integer -strict $diffcontextstring]} {
7154 if {$diffcontextstring > 0} {
7155 set diffcontext $diffcontextstring
7161 proc changeignorespace {} {
7165 proc getblobdiffs {ids} {
7166 global blobdifffd diffids env
7167 global diffinhdr treediffs
7170 global limitdiffs vfilelimit curview
7171 global diffencoding targetline diffnparents
7173 set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7177 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7178 set cmd [concat $cmd -- $vfilelimit($curview)]
7180 if {[catch {set bdf [open $cmd r]} err]} {
7181 error_popup [mc "Error getting diffs: %s" $err]
7187 set diffencoding [get_path_encoding {}]
7188 fconfigure $bdf -blocking 0 -encoding binary
7189 set blobdifffd($ids) $bdf
7190 filerun $bdf [list getblobdiffline $bdf $diffids]
7193 proc setinlist {var i val} {
7196 while {[llength [set $var]] < $i} {
7199 if {[llength [set $var]] == $i} {
7206 proc makediffhdr {fname ids} {
7207 global ctext curdiffstart treediffs diffencoding
7208 global ctext_file_names jump_to_here targetline diffline
7210 set fname [encoding convertfrom $fname]
7211 set diffencoding [get_path_encoding $fname]
7212 set i [lsearch -exact $treediffs($ids) $fname]
7214 setinlist difffilestart $i $curdiffstart
7216 lset ctext_file_names end $fname
7217 set l [expr {(78 - [string length $fname]) / 2}]
7218 set pad [string range "----------------------------------------" 1 $l]
7219 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7221 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7222 set targetline [lindex $jump_to_here 1]
7227 proc getblobdiffline {bdf ids} {
7228 global diffids blobdifffd ctext curdiffstart
7229 global diffnexthead diffnextnote difffilestart
7230 global ctext_file_names ctext_file_lines
7231 global diffinhdr treediffs mergemax diffnparents
7232 global diffencoding jump_to_here targetline diffline
7235 $ctext conf -state normal
7236 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7237 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7241 if {![string compare -length 5 "diff " $line]} {
7242 if {![regexp {^diff (--cc|--git) } $line m type]} {
7243 set line [encoding convertfrom $line]
7244 $ctext insert end "$line\n" hunksep
7247 # start of a new file
7249 $ctext insert end "\n"
7250 set curdiffstart [$ctext index "end - 1c"]
7251 lappend ctext_file_names ""
7252 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7253 $ctext insert end "\n" filesep
7255 if {$type eq "--cc"} {
7256 # start of a new file in a merge diff
7257 set fname [string range $line 10 end]
7258 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7259 lappend treediffs($ids) $fname
7260 add_flist [list $fname]
7264 set line [string range $line 11 end]
7265 # If the name hasn't changed the length will be odd,
7266 # the middle char will be a space, and the two bits either
7267 # side will be a/name and b/name, or "a/name" and "b/name".
7268 # If the name has changed we'll get "rename from" and
7269 # "rename to" or "copy from" and "copy to" lines following
7270 # this, and we'll use them to get the filenames.
7271 # This complexity is necessary because spaces in the
7272 # filename(s) don't get escaped.
7273 set l [string length $line]
7274 set i [expr {$l / 2}]
7275 if {!(($l & 1) && [string index $line $i] eq " " &&
7276 [string range $line 2 [expr {$i - 1}]] eq \
7277 [string range $line [expr {$i + 3}] end])} {
7280 # unescape if quoted and chop off the a/ from the front
7281 if {[string index $line 0] eq "\""} {
7282 set fname [string range [lindex $line 0] 2 end]
7284 set fname [string range $line 2 [expr {$i - 1}]]
7287 makediffhdr $fname $ids
7289 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7290 set fname [encoding convertfrom [string range $line 16 end]]
7291 $ctext insert end "\n"
7292 set curdiffstart [$ctext index "end - 1c"]
7293 lappend ctext_file_names $fname
7294 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7295 $ctext insert end "$line\n" filesep
7296 set i [lsearch -exact $treediffs($ids) $fname]
7298 setinlist difffilestart $i $curdiffstart
7301 } elseif {![string compare -length 2 "@@" $line]} {
7302 regexp {^@@+} $line ats
7303 set line [encoding convertfrom $diffencoding $line]
7304 $ctext insert end "$line\n" hunksep
7305 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7308 set diffnparents [expr {[string length $ats] - 1}]
7311 } elseif {$diffinhdr} {
7312 if {![string compare -length 12 "rename from " $line]} {
7313 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7314 if {[string index $fname 0] eq "\""} {
7315 set fname [lindex $fname 0]
7317 set fname [encoding convertfrom $fname]
7318 set i [lsearch -exact $treediffs($ids) $fname]
7320 setinlist difffilestart $i $curdiffstart
7322 } elseif {![string compare -length 10 $line "rename to "] ||
7323 ![string compare -length 8 $line "copy to "]} {
7324 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7325 if {[string index $fname 0] eq "\""} {
7326 set fname [lindex $fname 0]
7328 makediffhdr $fname $ids
7329 } elseif {[string compare -length 3 $line "---"] == 0} {
7332 } elseif {[string compare -length 3 $line "+++"] == 0} {
7336 $ctext insert end "$line\n" filesep
7339 set line [encoding convertfrom $diffencoding $line]
7340 # parse the prefix - one ' ', '-' or '+' for each parent
7341 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7342 set tag [expr {$diffnparents > 1? "m": "d"}]
7343 if {[string trim $prefix " -+"] eq {}} {
7344 # prefix only has " ", "-" and "+" in it: normal diff line
7345 set num [string first "-" $prefix]
7347 # removed line, first parent with line is $num
7348 if {$num >= $mergemax} {
7351 $ctext insert end "$line\n" $tag$num
7354 if {[string first "+" $prefix] >= 0} {
7356 lappend tags ${tag}result
7357 if {$diffnparents > 1} {
7358 set num [string first " " $prefix]
7360 if {$num >= $mergemax} {
7367 if {$targetline ne {}} {
7368 if {$diffline == $targetline} {
7369 set seehere [$ctext index "end - 1 chars"]
7375 $ctext insert end "$line\n" $tags
7378 # "\ No newline at end of file",
7379 # or something else we don't recognize
7380 $ctext insert end "$line\n" hunksep
7384 if {[info exists seehere]} {
7385 mark_ctext_line [lindex [split $seehere .] 0]
7387 $ctext conf -state disabled
7392 return [expr {$nr >= 1000? 2: 1}]
7395 proc changediffdisp {} {
7396 global ctext diffelide
7398 $ctext tag conf d0 -elide [lindex $diffelide 0]
7399 $ctext tag conf dresult -elide [lindex $diffelide 1]
7402 proc highlightfile {loc cline} {
7403 global ctext cflist cflist_top
7406 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7407 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7408 $cflist see $cline.0
7409 set cflist_top $cline
7413 global difffilestart ctext cmitmode
7415 if {$cmitmode eq "tree"} return
7418 set here [$ctext index @0,0]
7419 foreach loc $difffilestart {
7420 if {[$ctext compare $loc >= $here]} {
7421 highlightfile $prev $prevline
7427 highlightfile $prev $prevline
7431 global difffilestart ctext cmitmode
7433 if {$cmitmode eq "tree"} return
7434 set here [$ctext index @0,0]
7436 foreach loc $difffilestart {
7438 if {[$ctext compare $loc > $here]} {
7439 highlightfile $loc $line
7445 proc clear_ctext {{first 1.0}} {
7446 global ctext smarktop smarkbot
7447 global ctext_file_names ctext_file_lines
7450 set l [lindex [split $first .] 0]
7451 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7454 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7457 $ctext delete $first end
7458 if {$first eq "1.0"} {
7459 catch {unset pendinglinks}
7461 set ctext_file_names {}
7462 set ctext_file_lines {}
7465 proc settabs {{firstab {}}} {
7466 global firsttabstop tabstop ctext have_tk85
7468 if {$firstab ne {} && $have_tk85} {
7469 set firsttabstop $firstab
7471 set w [font measure textfont "0"]
7472 if {$firsttabstop != 0} {
7473 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7474 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7475 } elseif {$have_tk85 || $tabstop != 8} {
7476 $ctext conf -tabs [expr {$tabstop * $w}]
7478 $ctext conf -tabs {}
7482 proc incrsearch {name ix op} {
7483 global ctext searchstring searchdirn
7485 $ctext tag remove found 1.0 end
7486 if {[catch {$ctext index anchor}]} {
7487 # no anchor set, use start of selection, or of visible area
7488 set sel [$ctext tag ranges sel]
7490 $ctext mark set anchor [lindex $sel 0]
7491 } elseif {$searchdirn eq "-forwards"} {
7492 $ctext mark set anchor @0,0
7494 $ctext mark set anchor @0,[winfo height $ctext]
7497 if {$searchstring ne {}} {
7498 set here [$ctext search $searchdirn -- $searchstring anchor]
7507 global sstring ctext searchstring searchdirn
7510 $sstring icursor end
7511 set searchdirn -forwards
7512 if {$searchstring ne {}} {
7513 set sel [$ctext tag ranges sel]
7515 set start "[lindex $sel 0] + 1c"
7516 } elseif {[catch {set start [$ctext index anchor]}]} {
7519 set match [$ctext search -count mlen -- $searchstring $start]
7520 $ctext tag remove sel 1.0 end
7526 set mend "$match + $mlen c"
7527 $ctext tag add sel $match $mend
7528 $ctext mark unset anchor
7532 proc dosearchback {} {
7533 global sstring ctext searchstring searchdirn
7536 $sstring icursor end
7537 set searchdirn -backwards
7538 if {$searchstring ne {}} {
7539 set sel [$ctext tag ranges sel]
7541 set start [lindex $sel 0]
7542 } elseif {[catch {set start [$ctext index anchor]}]} {
7543 set start @0,[winfo height $ctext]
7545 set match [$ctext search -backwards -count ml -- $searchstring $start]
7546 $ctext tag remove sel 1.0 end
7552 set mend "$match + $ml c"
7553 $ctext tag add sel $match $mend
7554 $ctext mark unset anchor
7558 proc searchmark {first last} {
7559 global ctext searchstring
7563 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7564 if {$match eq {}} break
7565 set mend "$match + $mlen c"
7566 $ctext tag add found $match $mend
7570 proc searchmarkvisible {doall} {
7571 global ctext smarktop smarkbot
7573 set topline [lindex [split [$ctext index @0,0] .] 0]
7574 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7575 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7576 # no overlap with previous
7577 searchmark $topline $botline
7578 set smarktop $topline
7579 set smarkbot $botline
7581 if {$topline < $smarktop} {
7582 searchmark $topline [expr {$smarktop-1}]
7583 set smarktop $topline
7585 if {$botline > $smarkbot} {
7586 searchmark [expr {$smarkbot+1}] $botline
7587 set smarkbot $botline
7592 proc scrolltext {f0 f1} {
7595 .bleft.bottom.sb set $f0 $f1
7596 if {$searchstring ne {}} {
7602 global linespc charspc canvx0 canvy0
7603 global xspc1 xspc2 lthickness
7605 set linespc [font metrics mainfont -linespace]
7606 set charspc [font measure mainfont "m"]
7607 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7608 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7609 set lthickness [expr {int($linespc / 9) + 1}]
7610 set xspc1(0) $linespc
7618 set ymax [lindex [$canv cget -scrollregion] 3]
7619 if {$ymax eq {} || $ymax == 0} return
7620 set span [$canv yview]
7623 allcanvs yview moveto [lindex $span 0]
7625 if {$selectedline ne {}} {
7626 selectline $selectedline 0
7627 allcanvs yview moveto [lindex $span 0]
7631 proc parsefont {f n} {
7634 set fontattr($f,family) [lindex $n 0]
7636 if {$s eq {} || $s == 0} {
7639 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7641 set fontattr($f,size) $s
7642 set fontattr($f,weight) normal
7643 set fontattr($f,slant) roman
7644 foreach style [lrange $n 2 end] {
7647 "bold" {set fontattr($f,weight) $style}
7649 "italic" {set fontattr($f,slant) $style}
7654 proc fontflags {f {isbold 0}} {
7657 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7658 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7659 -slant $fontattr($f,slant)]
7665 set n [list $fontattr($f,family) $fontattr($f,size)]
7666 if {$fontattr($f,weight) eq "bold"} {
7669 if {$fontattr($f,slant) eq "italic"} {
7675 proc incrfont {inc} {
7676 global mainfont textfont ctext canv cflist showrefstop
7677 global stopped entries fontattr
7680 set s $fontattr(mainfont,size)
7685 set fontattr(mainfont,size) $s
7686 font config mainfont -size $s
7687 font config mainfontbold -size $s
7688 set mainfont [fontname mainfont]
7689 set s $fontattr(textfont,size)
7694 set fontattr(textfont,size) $s
7695 font config textfont -size $s
7696 font config textfontbold -size $s
7697 set textfont [fontname textfont]
7704 global sha1entry sha1string
7705 if {[string length $sha1string] == 40} {
7706 $sha1entry delete 0 end
7710 proc sha1change {n1 n2 op} {
7711 global sha1string currentid sha1but
7712 if {$sha1string == {}
7713 || ([info exists currentid] && $sha1string == $currentid)} {
7718 if {[$sha1but cget -state] == $state} return
7719 if {$state == "normal"} {
7720 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7722 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7726 proc gotocommit {} {
7727 global sha1string tagids headids curview varcid
7729 if {$sha1string == {}
7730 || ([info exists currentid] && $sha1string == $currentid)} return
7731 if {[info exists tagids($sha1string)]} {
7732 set id $tagids($sha1string)
7733 } elseif {[info exists headids($sha1string)]} {
7734 set id $headids($sha1string)
7736 set id [string tolower $sha1string]
7737 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7738 set matches [longid $id]
7739 if {$matches ne {}} {
7740 if {[llength $matches] > 1} {
7741 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7744 set id [lindex $matches 0]
7748 if {[commitinview $id $curview]} {
7749 selectline [rowofcommit $id] 1
7752 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7753 set msg [mc "SHA1 id %s is not known" $sha1string]
7755 set msg [mc "Tag/Head %s is not known" $sha1string]
7760 proc lineenter {x y id} {
7761 global hoverx hovery hoverid hovertimer
7762 global commitinfo canv
7764 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7768 if {[info exists hovertimer]} {
7769 after cancel $hovertimer
7771 set hovertimer [after 500 linehover]
7775 proc linemotion {x y id} {
7776 global hoverx hovery hoverid hovertimer
7778 if {[info exists hoverid] && $id == $hoverid} {
7781 if {[info exists hovertimer]} {
7782 after cancel $hovertimer
7784 set hovertimer [after 500 linehover]
7788 proc lineleave {id} {
7789 global hoverid hovertimer canv
7791 if {[info exists hoverid] && $id == $hoverid} {
7793 if {[info exists hovertimer]} {
7794 after cancel $hovertimer
7802 global hoverx hovery hoverid hovertimer
7803 global canv linespc lthickness
7806 set text [lindex $commitinfo($hoverid) 0]
7807 set ymax [lindex [$canv cget -scrollregion] 3]
7808 if {$ymax == {}} return
7809 set yfrac [lindex [$canv yview] 0]
7810 set x [expr {$hoverx + 2 * $linespc}]
7811 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7812 set x0 [expr {$x - 2 * $lthickness}]
7813 set y0 [expr {$y - 2 * $lthickness}]
7814 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7815 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7816 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7817 -fill \#ffff80 -outline black -width 1 -tags hover]
7819 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7824 proc clickisonarrow {id y} {
7827 set ranges [rowranges $id]
7828 set thresh [expr {2 * $lthickness + 6}]
7829 set n [expr {[llength $ranges] - 1}]
7830 for {set i 1} {$i < $n} {incr i} {
7831 set row [lindex $ranges $i]
7832 if {abs([yc $row] - $y) < $thresh} {
7839 proc arrowjump {id n y} {
7842 # 1 <-> 2, 3 <-> 4, etc...
7843 set n [expr {(($n - 1) ^ 1) + 1}]
7844 set row [lindex [rowranges $id] $n]
7846 set ymax [lindex [$canv cget -scrollregion] 3]
7847 if {$ymax eq {} || $ymax <= 0} return
7848 set view [$canv yview]
7849 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7850 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7854 allcanvs yview moveto $yfrac
7857 proc lineclick {x y id isnew} {
7858 global ctext commitinfo children canv thickerline curview
7860 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7865 # draw this line thicker than normal
7869 set ymax [lindex [$canv cget -scrollregion] 3]
7870 if {$ymax eq {}} return
7871 set yfrac [lindex [$canv yview] 0]
7872 set y [expr {$y + $yfrac * $ymax}]
7874 set dirn [clickisonarrow $id $y]
7876 arrowjump $id $dirn $y
7881 addtohistory [list lineclick $x $y $id 0]
7883 # fill the details pane with info about this line
7884 $ctext conf -state normal
7887 $ctext insert end "[mc "Parent"]:\t"
7888 $ctext insert end $id link0
7890 set info $commitinfo($id)
7891 $ctext insert end "\n\t[lindex $info 0]\n"
7892 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7893 set date [formatdate [lindex $info 2]]
7894 $ctext insert end "\t[mc "Date"]:\t$date\n"
7895 set kids $children($curview,$id)
7897 $ctext insert end "\n[mc "Children"]:"
7899 foreach child $kids {
7901 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7902 set info $commitinfo($child)
7903 $ctext insert end "\n\t"
7904 $ctext insert end $child link$i
7905 setlink $child link$i
7906 $ctext insert end "\n\t[lindex $info 0]"
7907 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7908 set date [formatdate [lindex $info 2]]
7909 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7912 $ctext conf -state disabled
7916 proc normalline {} {
7918 if {[info exists thickerline]} {
7927 if {[commitinview $id $curview]} {
7928 selectline [rowofcommit $id] 1
7934 if {![info exists startmstime]} {
7935 set startmstime [clock clicks -milliseconds]
7937 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7940 proc rowmenu {x y id} {
7941 global rowctxmenu selectedline rowmenuid curview
7942 global nullid nullid2 fakerowmenu mainhead
7946 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7951 if {$id ne $nullid && $id ne $nullid2} {
7952 set menu $rowctxmenu
7953 if {$mainhead ne {}} {
7954 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7956 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7959 set menu $fakerowmenu
7961 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7962 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7963 $menu entryconfigure [mca "Make patch"] -state $state
7964 tk_popup $menu $x $y
7967 proc diffvssel {dirn} {
7968 global rowmenuid selectedline
7970 if {$selectedline eq {}} return
7972 set oldid [commitonrow $selectedline]
7973 set newid $rowmenuid
7975 set oldid $rowmenuid
7976 set newid [commitonrow $selectedline]
7978 addtohistory [list doseldiff $oldid $newid]
7979 doseldiff $oldid $newid
7982 proc doseldiff {oldid newid} {
7986 $ctext conf -state normal
7988 init_flist [mc "Top"]
7989 $ctext insert end "[mc "From"] "
7990 $ctext insert end $oldid link0
7991 setlink $oldid link0
7992 $ctext insert end "\n "
7993 $ctext insert end [lindex $commitinfo($oldid) 0]
7994 $ctext insert end "\n\n[mc "To"] "
7995 $ctext insert end $newid link1
7996 setlink $newid link1
7997 $ctext insert end "\n "
7998 $ctext insert end [lindex $commitinfo($newid) 0]
7999 $ctext insert end "\n"
8000 $ctext conf -state disabled
8001 $ctext tag remove found 1.0 end
8002 startdiff [list $oldid $newid]
8006 global rowmenuid currentid commitinfo patchtop patchnum
8008 if {![info exists currentid]} return
8009 set oldid $currentid
8010 set oldhead [lindex $commitinfo($oldid) 0]
8011 set newid $rowmenuid
8012 set newhead [lindex $commitinfo($newid) 0]
8015 catch {destroy $top}
8017 make_transient $top .
8018 label $top.title -text [mc "Generate patch"]
8019 grid $top.title - -pady 10
8020 label $top.from -text [mc "From:"]
8021 entry $top.fromsha1 -width 40 -relief flat
8022 $top.fromsha1 insert 0 $oldid
8023 $top.fromsha1 conf -state readonly
8024 grid $top.from $top.fromsha1 -sticky w
8025 entry $top.fromhead -width 60 -relief flat
8026 $top.fromhead insert 0 $oldhead
8027 $top.fromhead conf -state readonly
8028 grid x $top.fromhead -sticky w
8029 label $top.to -text [mc "To:"]
8030 entry $top.tosha1 -width 40 -relief flat
8031 $top.tosha1 insert 0 $newid
8032 $top.tosha1 conf -state readonly
8033 grid $top.to $top.tosha1 -sticky w
8034 entry $top.tohead -width 60 -relief flat
8035 $top.tohead insert 0 $newhead
8036 $top.tohead conf -state readonly
8037 grid x $top.tohead -sticky w
8038 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8039 grid $top.rev x -pady 10
8040 label $top.flab -text [mc "Output file:"]
8041 entry $top.fname -width 60
8042 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8044 grid $top.flab $top.fname -sticky w
8046 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8047 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8048 bind $top <Key-Return> mkpatchgo
8049 bind $top <Key-Escape> mkpatchcan
8050 grid $top.buts.gen $top.buts.can
8051 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8052 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8053 grid $top.buts - -pady 10 -sticky ew
8057 proc mkpatchrev {} {
8060 set oldid [$patchtop.fromsha1 get]
8061 set oldhead [$patchtop.fromhead get]
8062 set newid [$patchtop.tosha1 get]
8063 set newhead [$patchtop.tohead get]
8064 foreach e [list fromsha1 fromhead tosha1 tohead] \
8065 v [list $newid $newhead $oldid $oldhead] {
8066 $patchtop.$e conf -state normal
8067 $patchtop.$e delete 0 end
8068 $patchtop.$e insert 0 $v
8069 $patchtop.$e conf -state readonly
8074 global patchtop nullid nullid2
8076 set oldid [$patchtop.fromsha1 get]
8077 set newid [$patchtop.tosha1 get]
8078 set fname [$patchtop.fname get]
8079 set cmd [diffcmd [list $oldid $newid] -p]
8080 # trim off the initial "|"
8081 set cmd [lrange $cmd 1 end]
8082 lappend cmd >$fname &
8083 if {[catch {eval exec $cmd} err]} {
8084 error_popup "[mc "Error creating patch:"] $err" $patchtop
8086 catch {destroy $patchtop}
8090 proc mkpatchcan {} {
8093 catch {destroy $patchtop}
8098 global rowmenuid mktagtop commitinfo
8102 catch {destroy $top}
8104 make_transient $top .
8105 label $top.title -text [mc "Create tag"]
8106 grid $top.title - -pady 10
8107 label $top.id -text [mc "ID:"]
8108 entry $top.sha1 -width 40 -relief flat
8109 $top.sha1 insert 0 $rowmenuid
8110 $top.sha1 conf -state readonly
8111 grid $top.id $top.sha1 -sticky w
8112 entry $top.head -width 60 -relief flat
8113 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8114 $top.head conf -state readonly
8115 grid x $top.head -sticky w
8116 label $top.tlab -text [mc "Tag name:"]
8117 entry $top.tag -width 60
8118 grid $top.tlab $top.tag -sticky w
8120 button $top.buts.gen -text [mc "Create"] -command mktaggo
8121 button $top.buts.can -text [mc "Cancel"] -command mktagcan
8122 bind $top <Key-Return> mktaggo
8123 bind $top <Key-Escape> mktagcan
8124 grid $top.buts.gen $top.buts.can
8125 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8126 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8127 grid $top.buts - -pady 10 -sticky ew
8132 global mktagtop env tagids idtags
8134 set id [$mktagtop.sha1 get]
8135 set tag [$mktagtop.tag get]
8137 error_popup [mc "No tag name specified"] $mktagtop
8140 if {[info exists tagids($tag)]} {
8141 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8145 exec git tag $tag $id
8147 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8151 set tagids($tag) $id
8152 lappend idtags($id) $tag
8160 proc redrawtags {id} {
8161 global canv linehtag idpos currentid curview cmitlisted
8162 global canvxmax iddrawn circleitem mainheadid circlecolors
8164 if {![commitinview $id $curview]} return
8165 if {![info exists iddrawn($id)]} return
8166 set row [rowofcommit $id]
8167 if {$id eq $mainheadid} {
8170 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8172 $canv itemconf $circleitem($row) -fill $ofill
8173 $canv delete tag.$id
8174 set xt [eval drawtags $id $idpos($id)]
8175 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8176 set text [$canv itemcget $linehtag($id) -text]
8177 set font [$canv itemcget $linehtag($id) -font]
8178 set xr [expr {$xt + [font measure $font $text]}]
8179 if {$xr > $canvxmax} {
8183 if {[info exists currentid] && $currentid == $id} {
8191 catch {destroy $mktagtop}
8196 if {![domktag]} return
8200 proc writecommit {} {
8201 global rowmenuid wrcomtop commitinfo wrcomcmd
8203 set top .writecommit
8205 catch {destroy $top}
8207 make_transient $top .
8208 label $top.title -text [mc "Write commit to file"]
8209 grid $top.title - -pady 10
8210 label $top.id -text [mc "ID:"]
8211 entry $top.sha1 -width 40 -relief flat
8212 $top.sha1 insert 0 $rowmenuid
8213 $top.sha1 conf -state readonly
8214 grid $top.id $top.sha1 -sticky w
8215 entry $top.head -width 60 -relief flat
8216 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8217 $top.head conf -state readonly
8218 grid x $top.head -sticky w
8219 label $top.clab -text [mc "Command:"]
8220 entry $top.cmd -width 60 -textvariable wrcomcmd
8221 grid $top.clab $top.cmd -sticky w -pady 10
8222 label $top.flab -text [mc "Output file:"]
8223 entry $top.fname -width 60
8224 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8225 grid $top.flab $top.fname -sticky w
8227 button $top.buts.gen -text [mc "Write"] -command wrcomgo
8228 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8229 bind $top <Key-Return> wrcomgo
8230 bind $top <Key-Escape> wrcomcan
8231 grid $top.buts.gen $top.buts.can
8232 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8233 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8234 grid $top.buts - -pady 10 -sticky ew
8241 set id [$wrcomtop.sha1 get]
8242 set cmd "echo $id | [$wrcomtop.cmd get]"
8243 set fname [$wrcomtop.fname get]
8244 if {[catch {exec sh -c $cmd >$fname &} err]} {
8245 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8247 catch {destroy $wrcomtop}
8254 catch {destroy $wrcomtop}
8259 global rowmenuid mkbrtop
8262 catch {destroy $top}
8264 make_transient $top .
8265 label $top.title -text [mc "Create new branch"]
8266 grid $top.title - -pady 10
8267 label $top.id -text [mc "ID:"]
8268 entry $top.sha1 -width 40 -relief flat
8269 $top.sha1 insert 0 $rowmenuid
8270 $top.sha1 conf -state readonly
8271 grid $top.id $top.sha1 -sticky w
8272 label $top.nlab -text [mc "Name:"]
8273 entry $top.name -width 40
8274 grid $top.nlab $top.name -sticky w
8276 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8277 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8278 bind $top <Key-Return> [list mkbrgo $top]
8279 bind $top <Key-Escape> "catch {destroy $top}"
8280 grid $top.buts.go $top.buts.can
8281 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8282 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8283 grid $top.buts - -pady 10 -sticky ew
8288 global headids idheads
8290 set name [$top.name get]
8291 set id [$top.sha1 get]
8295 error_popup [mc "Please specify a name for the new branch"] $top
8298 if {[info exists headids($name)]} {
8299 if {![confirm_popup [mc \
8300 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8303 set old_id $headids($name)
8306 catch {destroy $top}
8307 lappend cmdargs $name $id
8311 eval exec git branch $cmdargs
8317 if {$old_id ne {}} {
8323 set headids($name) $id
8324 lappend idheads($id) $name
8333 proc exec_citool {tool_args {baseid {}}} {
8334 global commitinfo env
8336 set save_env [array get env GIT_AUTHOR_*]
8338 if {$baseid ne {}} {
8339 if {![info exists commitinfo($baseid)]} {
8342 set author [lindex $commitinfo($baseid) 1]
8343 set date [lindex $commitinfo($baseid) 2]
8344 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8345 $author author name email]
8347 set env(GIT_AUTHOR_NAME) $name
8348 set env(GIT_AUTHOR_EMAIL) $email
8349 set env(GIT_AUTHOR_DATE) $date
8353 eval exec git citool $tool_args &
8355 array unset env GIT_AUTHOR_*
8356 array set env $save_env
8359 proc cherrypick {} {
8360 global rowmenuid curview
8361 global mainhead mainheadid
8363 set oldhead [exec git rev-parse HEAD]
8364 set dheads [descheads $rowmenuid]
8365 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8366 set ok [confirm_popup [mc "Commit %s is already\
8367 included in branch %s -- really re-apply it?" \
8368 [string range $rowmenuid 0 7] $mainhead]]
8371 nowbusy cherrypick [mc "Cherry-picking"]
8373 # Unfortunately git-cherry-pick writes stuff to stderr even when
8374 # no error occurs, and exec takes that as an indication of error...
8375 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8378 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8380 error_popup [mc "Cherry-pick failed because of local changes\
8381 to file '%s'.\nPlease commit, reset or stash\
8382 your changes and try again." $fname]
8383 } elseif {[regexp -line \
8384 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8386 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8387 conflict.\nDo you wish to run git citool to\
8389 # Force citool to read MERGE_MSG
8390 file delete [file join [gitdir] "GITGUI_MSG"]
8391 exec_citool {} $rowmenuid
8399 set newhead [exec git rev-parse HEAD]
8400 if {$newhead eq $oldhead} {
8402 error_popup [mc "No changes committed"]
8405 addnewchild $newhead $oldhead
8406 if {[commitinview $oldhead $curview]} {
8407 # XXX this isn't right if we have a path limit...
8408 insertrow $newhead $oldhead $curview
8409 if {$mainhead ne {}} {
8410 movehead $newhead $mainhead
8411 movedhead $newhead $mainhead
8413 set mainheadid $newhead
8422 global mainhead rowmenuid confirm_ok resettype
8425 set w ".confirmreset"
8428 wm title $w [mc "Confirm reset"]
8429 message $w.m -text \
8430 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8431 -justify center -aspect 1000
8432 pack $w.m -side top -fill x -padx 20 -pady 20
8433 frame $w.f -relief sunken -border 2
8434 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8435 grid $w.f.rt -sticky w
8437 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8438 -text [mc "Soft: Leave working tree and index untouched"]
8439 grid $w.f.soft -sticky w
8440 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8441 -text [mc "Mixed: Leave working tree untouched, reset index"]
8442 grid $w.f.mixed -sticky w
8443 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8444 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8445 grid $w.f.hard -sticky w
8446 pack $w.f -side top -fill x
8447 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8448 pack $w.ok -side left -fill x -padx 20 -pady 20
8449 button $w.cancel -text [mc Cancel] -command "destroy $w"
8450 bind $w <Key-Escape> [list destroy $w]
8451 pack $w.cancel -side right -fill x -padx 20 -pady 20
8452 bind $w <Visibility> "grab $w; focus $w"
8454 if {!$confirm_ok} return
8455 if {[catch {set fd [open \
8456 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8460 filerun $fd [list readresetstat $fd]
8461 nowbusy reset [mc "Resetting"]
8466 proc readresetstat {fd} {
8467 global mainhead mainheadid showlocalchanges rprogcoord
8469 if {[gets $fd line] >= 0} {
8470 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8471 set rprogcoord [expr {1.0 * $m / $n}]
8479 if {[catch {close $fd} err]} {
8482 set oldhead $mainheadid
8483 set newhead [exec git rev-parse HEAD]
8484 if {$newhead ne $oldhead} {
8485 movehead $newhead $mainhead
8486 movedhead $newhead $mainhead
8487 set mainheadid $newhead
8491 if {$showlocalchanges} {
8497 # context menu for a head
8498 proc headmenu {x y id head} {
8499 global headmenuid headmenuhead headctxmenu mainhead
8503 set headmenuhead $head
8505 if {$head eq $mainhead} {
8508 $headctxmenu entryconfigure 0 -state $state
8509 $headctxmenu entryconfigure 1 -state $state
8510 tk_popup $headctxmenu $x $y
8514 global headmenuid headmenuhead headids
8515 global showlocalchanges
8517 # check the tree is clean first??
8518 nowbusy checkout [mc "Checking out"]
8522 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8526 if {$showlocalchanges} {
8530 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8534 proc readcheckoutstat {fd newhead newheadid} {
8535 global mainhead mainheadid headids showlocalchanges progresscoords
8536 global viewmainheadid curview
8538 if {[gets $fd line] >= 0} {
8539 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8540 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8545 set progresscoords {0 0}
8548 if {[catch {close $fd} err]} {
8551 set oldmainid $mainheadid
8552 set mainhead $newhead
8553 set mainheadid $newheadid
8554 set viewmainheadid($curview) $newheadid
8555 redrawtags $oldmainid
8556 redrawtags $newheadid
8558 if {$showlocalchanges} {
8564 global headmenuid headmenuhead mainhead
8567 set head $headmenuhead
8569 # this check shouldn't be needed any more...
8570 if {$head eq $mainhead} {
8571 error_popup [mc "Cannot delete the currently checked-out branch"]
8574 set dheads [descheads $id]
8575 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8576 # the stuff on this branch isn't on any other branch
8577 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8578 branch.\nReally delete branch %s?" $head $head]]} return
8582 if {[catch {exec git branch -D $head} err]} {
8587 removehead $id $head
8588 removedhead $id $head
8595 # Display a list of tags and heads
8597 global showrefstop bgcolor fgcolor selectbgcolor
8598 global bglist fglist reflistfilter reflist maincursor
8601 set showrefstop $top
8602 if {[winfo exists $top]} {
8608 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8609 make_transient $top .
8610 text $top.list -background $bgcolor -foreground $fgcolor \
8611 -selectbackground $selectbgcolor -font mainfont \
8612 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8613 -width 30 -height 20 -cursor $maincursor \
8614 -spacing1 1 -spacing3 1 -state disabled
8615 $top.list tag configure highlight -background $selectbgcolor
8616 lappend bglist $top.list
8617 lappend fglist $top.list
8618 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8619 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8620 grid $top.list $top.ysb -sticky nsew
8621 grid $top.xsb x -sticky ew
8623 label $top.f.l -text "[mc "Filter"]: "
8624 entry $top.f.e -width 20 -textvariable reflistfilter
8625 set reflistfilter "*"
8626 trace add variable reflistfilter write reflistfilter_change
8627 pack $top.f.e -side right -fill x -expand 1
8628 pack $top.f.l -side left
8629 grid $top.f - -sticky ew -pady 2
8630 button $top.close -command [list destroy $top] -text [mc "Close"]
8631 bind $top <Key-Escape> [list destroy $top]
8633 grid columnconfigure $top 0 -weight 1
8634 grid rowconfigure $top 0 -weight 1
8635 bind $top.list <1> {break}
8636 bind $top.list <B1-Motion> {break}
8637 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8642 proc sel_reflist {w x y} {
8643 global showrefstop reflist headids tagids otherrefids
8645 if {![winfo exists $showrefstop]} return
8646 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8647 set ref [lindex $reflist [expr {$l-1}]]
8648 set n [lindex $ref 0]
8649 switch -- [lindex $ref 1] {
8650 "H" {selbyid $headids($n)}
8651 "T" {selbyid $tagids($n)}
8652 "o" {selbyid $otherrefids($n)}
8654 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8657 proc unsel_reflist {} {
8660 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8661 $showrefstop.list tag remove highlight 0.0 end
8664 proc reflistfilter_change {n1 n2 op} {
8665 global reflistfilter
8667 after cancel refill_reflist
8668 after 200 refill_reflist
8671 proc refill_reflist {} {
8672 global reflist reflistfilter showrefstop headids tagids otherrefids
8675 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8677 foreach n [array names headids] {
8678 if {[string match $reflistfilter $n]} {
8679 if {[commitinview $headids($n) $curview]} {
8680 lappend refs [list $n H]
8682 interestedin $headids($n) {run refill_reflist}
8686 foreach n [array names tagids] {
8687 if {[string match $reflistfilter $n]} {
8688 if {[commitinview $tagids($n) $curview]} {
8689 lappend refs [list $n T]
8691 interestedin $tagids($n) {run refill_reflist}
8695 foreach n [array names otherrefids] {
8696 if {[string match $reflistfilter $n]} {
8697 if {[commitinview $otherrefids($n) $curview]} {
8698 lappend refs [list $n o]
8700 interestedin $otherrefids($n) {run refill_reflist}
8704 set refs [lsort -index 0 $refs]
8705 if {$refs eq $reflist} return
8707 # Update the contents of $showrefstop.list according to the
8708 # differences between $reflist (old) and $refs (new)
8709 $showrefstop.list conf -state normal
8710 $showrefstop.list insert end "\n"
8713 while {$i < [llength $reflist] || $j < [llength $refs]} {
8714 if {$i < [llength $reflist]} {
8715 if {$j < [llength $refs]} {
8716 set cmp [string compare [lindex $reflist $i 0] \
8717 [lindex $refs $j 0]]
8719 set cmp [string compare [lindex $reflist $i 1] \
8720 [lindex $refs $j 1]]
8730 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8738 set l [expr {$j + 1}]
8739 $showrefstop.list image create $l.0 -align baseline \
8740 -image reficon-[lindex $refs $j 1] -padx 2
8741 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8747 # delete last newline
8748 $showrefstop.list delete end-2c end-1c
8749 $showrefstop.list conf -state disabled
8752 # Stuff for finding nearby tags
8753 proc getallcommits {} {
8754 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8755 global idheads idtags idotherrefs allparents tagobjid
8757 if {![info exists allcommits]} {
8763 set allccache [file join [gitdir] "gitk.cache"]
8765 set f [open $allccache r]
8774 set cmd [list | git rev-list --parents]
8775 set allcupdate [expr {$seeds ne {}}]
8779 set refs [concat [array names idheads] [array names idtags] \
8780 [array names idotherrefs]]
8783 foreach name [array names tagobjid] {
8784 lappend tagobjs $tagobjid($name)
8786 foreach id [lsort -unique $refs] {
8787 if {![info exists allparents($id)] &&
8788 [lsearch -exact $tagobjs $id] < 0} {
8799 set fd [open [concat $cmd $ids] r]
8800 fconfigure $fd -blocking 0
8803 filerun $fd [list getallclines $fd]
8809 # Since most commits have 1 parent and 1 child, we group strings of
8810 # such commits into "arcs" joining branch/merge points (BMPs), which
8811 # are commits that either don't have 1 parent or don't have 1 child.
8813 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8814 # arcout(id) - outgoing arcs for BMP
8815 # arcids(a) - list of IDs on arc including end but not start
8816 # arcstart(a) - BMP ID at start of arc
8817 # arcend(a) - BMP ID at end of arc
8818 # growing(a) - arc a is still growing
8819 # arctags(a) - IDs out of arcids (excluding end) that have tags
8820 # archeads(a) - IDs out of arcids (excluding end) that have heads
8821 # The start of an arc is at the descendent end, so "incoming" means
8822 # coming from descendents, and "outgoing" means going towards ancestors.
8824 proc getallclines {fd} {
8825 global allparents allchildren idtags idheads nextarc
8826 global arcnos arcids arctags arcout arcend arcstart archeads growing
8827 global seeds allcommits cachedarcs allcupdate
8830 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8831 set id [lindex $line 0]
8832 if {[info exists allparents($id)]} {
8837 set olds [lrange $line 1 end]
8838 set allparents($id) $olds
8839 if {![info exists allchildren($id)]} {
8840 set allchildren($id) {}
8845 if {[llength $olds] == 1 && [llength $a] == 1} {
8846 lappend arcids($a) $id
8847 if {[info exists idtags($id)]} {
8848 lappend arctags($a) $id
8850 if {[info exists idheads($id)]} {
8851 lappend archeads($a) $id
8853 if {[info exists allparents($olds)]} {
8854 # seen parent already
8855 if {![info exists arcout($olds)]} {
8858 lappend arcids($a) $olds
8859 set arcend($a) $olds
8862 lappend allchildren($olds) $id
8863 lappend arcnos($olds) $a
8867 foreach a $arcnos($id) {
8868 lappend arcids($a) $id
8875 lappend allchildren($p) $id
8876 set a [incr nextarc]
8877 set arcstart($a) $id
8884 if {[info exists allparents($p)]} {
8885 # seen it already, may need to make a new branch
8886 if {![info exists arcout($p)]} {
8889 lappend arcids($a) $p
8893 lappend arcnos($p) $a
8898 global cached_dheads cached_dtags cached_atags
8899 catch {unset cached_dheads}
8900 catch {unset cached_dtags}
8901 catch {unset cached_atags}
8904 return [expr {$nid >= 1000? 2: 1}]
8908 fconfigure $fd -blocking 1
8911 # got an error reading the list of commits
8912 # if we were updating, try rereading the whole thing again
8918 error_popup "[mc "Error reading commit topology information;\
8919 branch and preceding/following tag information\
8920 will be incomplete."]\n($err)"
8923 if {[incr allcommits -1] == 0} {
8933 proc recalcarc {a} {
8934 global arctags archeads arcids idtags idheads
8938 foreach id [lrange $arcids($a) 0 end-1] {
8939 if {[info exists idtags($id)]} {
8942 if {[info exists idheads($id)]} {
8947 set archeads($a) $ah
8951 global arcnos arcids nextarc arctags archeads idtags idheads
8952 global arcstart arcend arcout allparents growing
8955 if {[llength $a] != 1} {
8956 puts "oops splitarc called but [llength $a] arcs already"
8960 set i [lsearch -exact $arcids($a) $p]
8962 puts "oops splitarc $p not in arc $a"
8965 set na [incr nextarc]
8966 if {[info exists arcend($a)]} {
8967 set arcend($na) $arcend($a)
8969 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8970 set j [lsearch -exact $arcnos($l) $a]
8971 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8973 set tail [lrange $arcids($a) [expr {$i+1}] end]
8974 set arcids($a) [lrange $arcids($a) 0 $i]
8976 set arcstart($na) $p
8978 set arcids($na) $tail
8979 if {[info exists growing($a)]} {
8985 if {[llength $arcnos($id)] == 1} {
8988 set j [lsearch -exact $arcnos($id) $a]
8989 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8993 # reconstruct tags and heads lists
8994 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8999 set archeads($na) {}
9003 # Update things for a new commit added that is a child of one
9004 # existing commit. Used when cherry-picking.
9005 proc addnewchild {id p} {
9006 global allparents allchildren idtags nextarc
9007 global arcnos arcids arctags arcout arcend arcstart archeads growing
9008 global seeds allcommits
9010 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9011 set allparents($id) [list $p]
9012 set allchildren($id) {}
9015 lappend allchildren($p) $id
9016 set a [incr nextarc]
9017 set arcstart($a) $id
9020 set arcids($a) [list $p]
9022 if {![info exists arcout($p)]} {
9025 lappend arcnos($p) $a
9026 set arcout($id) [list $a]
9029 # This implements a cache for the topology information.
9030 # The cache saves, for each arc, the start and end of the arc,
9031 # the ids on the arc, and the outgoing arcs from the end.
9032 proc readcache {f} {
9033 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9034 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9039 if {$lim - $a > 500} {
9040 set lim [expr {$a + 500}]
9044 # finish reading the cache and setting up arctags, etc.
9046 if {$line ne "1"} {error "bad final version"}
9048 foreach id [array names idtags] {
9049 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9050 [llength $allparents($id)] == 1} {
9051 set a [lindex $arcnos($id) 0]
9052 if {$arctags($a) eq {}} {
9057 foreach id [array names idheads] {
9058 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9059 [llength $allparents($id)] == 1} {
9060 set a [lindex $arcnos($id) 0]
9061 if {$archeads($a) eq {}} {
9066 foreach id [lsort -unique $possible_seeds] {
9067 if {$arcnos($id) eq {}} {
9073 while {[incr a] <= $lim} {
9075 if {[llength $line] != 3} {error "bad line"}
9076 set s [lindex $line 0]
9078 lappend arcout($s) $a
9079 if {![info exists arcnos($s)]} {
9080 lappend possible_seeds $s
9083 set e [lindex $line 1]
9088 if {![info exists arcout($e)]} {
9092 set arcids($a) [lindex $line 2]
9093 foreach id $arcids($a) {
9094 lappend allparents($s) $id
9096 lappend arcnos($id) $a
9098 if {![info exists allparents($s)]} {
9099 set allparents($s) {}
9104 set nextarc [expr {$a - 1}]
9117 global nextarc cachedarcs possible_seeds
9121 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9122 # make sure it's an integer
9123 set cachedarcs [expr {int([lindex $line 1])}]
9124 if {$cachedarcs < 0} {error "bad number of arcs"}
9126 set possible_seeds {}
9134 proc dropcache {err} {
9135 global allcwait nextarc cachedarcs seeds
9137 #puts "dropping cache ($err)"
9138 foreach v {arcnos arcout arcids arcstart arcend growing \
9139 arctags archeads allparents allchildren} {
9150 proc writecache {f} {
9151 global cachearc cachedarcs allccache
9152 global arcstart arcend arcnos arcids arcout
9156 if {$lim - $a > 1000} {
9157 set lim [expr {$a + 1000}]
9160 while {[incr a] <= $lim} {
9161 if {[info exists arcend($a)]} {
9162 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9164 puts $f [list $arcstart($a) {} $arcids($a)]
9169 catch {file delete $allccache}
9170 #puts "writing cache failed ($err)"
9173 set cachearc [expr {$a - 1}]
9174 if {$a > $cachedarcs} {
9183 global nextarc cachedarcs cachearc allccache
9185 if {$nextarc == $cachedarcs} return
9187 set cachedarcs $nextarc
9189 set f [open $allccache w]
9190 puts $f [list 1 $cachedarcs]
9195 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9196 # or 0 if neither is true.
9197 proc anc_or_desc {a b} {
9198 global arcout arcstart arcend arcnos cached_isanc
9200 if {$arcnos($a) eq $arcnos($b)} {
9201 # Both are on the same arc(s); either both are the same BMP,
9202 # or if one is not a BMP, the other is also not a BMP or is
9203 # the BMP at end of the arc (and it only has 1 incoming arc).
9204 # Or both can be BMPs with no incoming arcs.
9205 if {$a eq $b || $arcnos($a) eq {}} {
9208 # assert {[llength $arcnos($a)] == 1}
9209 set arc [lindex $arcnos($a) 0]
9210 set i [lsearch -exact $arcids($arc) $a]
9211 set j [lsearch -exact $arcids($arc) $b]
9212 if {$i < 0 || $i > $j} {
9219 if {![info exists arcout($a)]} {
9220 set arc [lindex $arcnos($a) 0]
9221 if {[info exists arcend($arc)]} {
9222 set aend $arcend($arc)
9226 set a $arcstart($arc)
9230 if {![info exists arcout($b)]} {
9231 set arc [lindex $arcnos($b) 0]
9232 if {[info exists arcend($arc)]} {
9233 set bend $arcend($arc)
9237 set b $arcstart($arc)
9247 if {[info exists cached_isanc($a,$bend)]} {
9248 if {$cached_isanc($a,$bend)} {
9252 if {[info exists cached_isanc($b,$aend)]} {
9253 if {$cached_isanc($b,$aend)} {
9256 if {[info exists cached_isanc($a,$bend)]} {
9261 set todo [list $a $b]
9264 for {set i 0} {$i < [llength $todo]} {incr i} {
9265 set x [lindex $todo $i]
9266 if {$anc($x) eq {}} {
9269 foreach arc $arcnos($x) {
9270 set xd $arcstart($arc)
9272 set cached_isanc($a,$bend) 1
9273 set cached_isanc($b,$aend) 0
9275 } elseif {$xd eq $aend} {
9276 set cached_isanc($b,$aend) 1
9277 set cached_isanc($a,$bend) 0
9280 if {![info exists anc($xd)]} {
9281 set anc($xd) $anc($x)
9283 } elseif {$anc($xd) ne $anc($x)} {
9288 set cached_isanc($a,$bend) 0
9289 set cached_isanc($b,$aend) 0
9293 # This identifies whether $desc has an ancestor that is
9294 # a growing tip of the graph and which is not an ancestor of $anc
9295 # and returns 0 if so and 1 if not.
9296 # If we subsequently discover a tag on such a growing tip, and that
9297 # turns out to be a descendent of $anc (which it could, since we
9298 # don't necessarily see children before parents), then $desc
9299 # isn't a good choice to display as a descendent tag of
9300 # $anc (since it is the descendent of another tag which is
9301 # a descendent of $anc). Similarly, $anc isn't a good choice to
9302 # display as a ancestor tag of $desc.
9304 proc is_certain {desc anc} {
9305 global arcnos arcout arcstart arcend growing problems
9308 if {[llength $arcnos($anc)] == 1} {
9309 # tags on the same arc are certain
9310 if {$arcnos($desc) eq $arcnos($anc)} {
9313 if {![info exists arcout($anc)]} {
9314 # if $anc is partway along an arc, use the start of the arc instead
9315 set a [lindex $arcnos($anc) 0]
9316 set anc $arcstart($a)
9319 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9322 set a [lindex $arcnos($desc) 0]
9328 set anclist [list $x]
9332 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9333 set x [lindex $anclist $i]
9338 foreach a $arcout($x) {
9339 if {[info exists growing($a)]} {
9340 if {![info exists growanc($x)] && $dl($x)} {
9346 if {[info exists dl($y)]} {
9350 if {![info exists done($y)]} {
9353 if {[info exists growanc($x)]} {
9357 for {set k 0} {$k < [llength $xl]} {incr k} {
9358 set z [lindex $xl $k]
9359 foreach c $arcout($z) {
9360 if {[info exists arcend($c)]} {
9362 if {[info exists dl($v)] && $dl($v)} {
9364 if {![info exists done($v)]} {
9367 if {[info exists growanc($v)]} {
9377 } elseif {$y eq $anc || !$dl($x)} {
9388 foreach x [array names growanc] {
9397 proc validate_arctags {a} {
9398 global arctags idtags
9402 foreach id $arctags($a) {
9404 if {![info exists idtags($id)]} {
9405 set na [lreplace $na $i $i]
9412 proc validate_archeads {a} {
9413 global archeads idheads
9416 set na $archeads($a)
9417 foreach id $archeads($a) {
9419 if {![info exists idheads($id)]} {
9420 set na [lreplace $na $i $i]
9424 set archeads($a) $na
9427 # Return the list of IDs that have tags that are descendents of id,
9428 # ignoring IDs that are descendents of IDs already reported.
9429 proc desctags {id} {
9430 global arcnos arcstart arcids arctags idtags allparents
9431 global growing cached_dtags
9433 if {![info exists allparents($id)]} {
9436 set t1 [clock clicks -milliseconds]
9438 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9439 # part-way along an arc; check that arc first
9440 set a [lindex $arcnos($id) 0]
9441 if {$arctags($a) ne {}} {
9443 set i [lsearch -exact $arcids($a) $id]
9445 foreach t $arctags($a) {
9446 set j [lsearch -exact $arcids($a) $t]
9454 set id $arcstart($a)
9455 if {[info exists idtags($id)]} {
9459 if {[info exists cached_dtags($id)]} {
9460 return $cached_dtags($id)
9467 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9468 set id [lindex $todo $i]
9470 set ta [info exists hastaggedancestor($id)]
9474 # ignore tags on starting node
9475 if {!$ta && $i > 0} {
9476 if {[info exists idtags($id)]} {
9479 } elseif {[info exists cached_dtags($id)]} {
9480 set tagloc($id) $cached_dtags($id)
9484 foreach a $arcnos($id) {
9486 if {!$ta && $arctags($a) ne {}} {
9488 if {$arctags($a) ne {}} {
9489 lappend tagloc($id) [lindex $arctags($a) end]
9492 if {$ta || $arctags($a) ne {}} {
9493 set tomark [list $d]
9494 for {set j 0} {$j < [llength $tomark]} {incr j} {
9495 set dd [lindex $tomark $j]
9496 if {![info exists hastaggedancestor($dd)]} {
9497 if {[info exists done($dd)]} {
9498 foreach b $arcnos($dd) {
9499 lappend tomark $arcstart($b)
9501 if {[info exists tagloc($dd)]} {
9504 } elseif {[info exists queued($dd)]} {
9507 set hastaggedancestor($dd) 1
9511 if {![info exists queued($d)]} {
9514 if {![info exists hastaggedancestor($d)]} {
9521 foreach id [array names tagloc] {
9522 if {![info exists hastaggedancestor($id)]} {
9523 foreach t $tagloc($id) {
9524 if {[lsearch -exact $tags $t] < 0} {
9530 set t2 [clock clicks -milliseconds]
9533 # remove tags that are descendents of other tags
9534 for {set i 0} {$i < [llength $tags]} {incr i} {
9535 set a [lindex $tags $i]
9536 for {set j 0} {$j < $i} {incr j} {
9537 set b [lindex $tags $j]
9538 set r [anc_or_desc $a $b]
9540 set tags [lreplace $tags $j $j]
9543 } elseif {$r == -1} {
9544 set tags [lreplace $tags $i $i]
9551 if {[array names growing] ne {}} {
9552 # graph isn't finished, need to check if any tag could get
9553 # eclipsed by another tag coming later. Simply ignore any
9554 # tags that could later get eclipsed.
9557 if {[is_certain $t $origid]} {
9561 if {$tags eq $ctags} {
9562 set cached_dtags($origid) $tags
9567 set cached_dtags($origid) $tags
9569 set t3 [clock clicks -milliseconds]
9570 if {0 && $t3 - $t1 >= 100} {
9571 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9572 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9578 global arcnos arcids arcout arcend arctags idtags allparents
9579 global growing cached_atags
9581 if {![info exists allparents($id)]} {
9584 set t1 [clock clicks -milliseconds]
9586 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9587 # part-way along an arc; check that arc first
9588 set a [lindex $arcnos($id) 0]
9589 if {$arctags($a) ne {}} {
9591 set i [lsearch -exact $arcids($a) $id]
9592 foreach t $arctags($a) {
9593 set j [lsearch -exact $arcids($a) $t]
9599 if {![info exists arcend($a)]} {
9603 if {[info exists idtags($id)]} {
9607 if {[info exists cached_atags($id)]} {
9608 return $cached_atags($id)
9616 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9617 set id [lindex $todo $i]
9619 set td [info exists hastaggeddescendent($id)]
9623 # ignore tags on starting node
9624 if {!$td && $i > 0} {
9625 if {[info exists idtags($id)]} {
9628 } elseif {[info exists cached_atags($id)]} {
9629 set tagloc($id) $cached_atags($id)
9633 foreach a $arcout($id) {
9634 if {!$td && $arctags($a) ne {}} {
9636 if {$arctags($a) ne {}} {
9637 lappend tagloc($id) [lindex $arctags($a) 0]
9640 if {![info exists arcend($a)]} continue
9642 if {$td || $arctags($a) ne {}} {
9643 set tomark [list $d]
9644 for {set j 0} {$j < [llength $tomark]} {incr j} {
9645 set dd [lindex $tomark $j]
9646 if {![info exists hastaggeddescendent($dd)]} {
9647 if {[info exists done($dd)]} {
9648 foreach b $arcout($dd) {
9649 if {[info exists arcend($b)]} {
9650 lappend tomark $arcend($b)
9653 if {[info exists tagloc($dd)]} {
9656 } elseif {[info exists queued($dd)]} {
9659 set hastaggeddescendent($dd) 1
9663 if {![info exists queued($d)]} {
9666 if {![info exists hastaggeddescendent($d)]} {
9672 set t2 [clock clicks -milliseconds]
9675 foreach id [array names tagloc] {
9676 if {![info exists hastaggeddescendent($id)]} {
9677 foreach t $tagloc($id) {
9678 if {[lsearch -exact $tags $t] < 0} {
9685 # remove tags that are ancestors of other tags
9686 for {set i 0} {$i < [llength $tags]} {incr i} {
9687 set a [lindex $tags $i]
9688 for {set j 0} {$j < $i} {incr j} {
9689 set b [lindex $tags $j]
9690 set r [anc_or_desc $a $b]
9692 set tags [lreplace $tags $j $j]
9695 } elseif {$r == 1} {
9696 set tags [lreplace $tags $i $i]
9703 if {[array names growing] ne {}} {
9704 # graph isn't finished, need to check if any tag could get
9705 # eclipsed by another tag coming later. Simply ignore any
9706 # tags that could later get eclipsed.
9709 if {[is_certain $origid $t]} {
9713 if {$tags eq $ctags} {
9714 set cached_atags($origid) $tags
9719 set cached_atags($origid) $tags
9721 set t3 [clock clicks -milliseconds]
9722 if {0 && $t3 - $t1 >= 100} {
9723 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9724 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9729 # Return the list of IDs that have heads that are descendents of id,
9730 # including id itself if it has a head.
9731 proc descheads {id} {
9732 global arcnos arcstart arcids archeads idheads cached_dheads
9735 if {![info exists allparents($id)]} {
9739 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9740 # part-way along an arc; check it first
9741 set a [lindex $arcnos($id) 0]
9742 if {$archeads($a) ne {}} {
9743 validate_archeads $a
9744 set i [lsearch -exact $arcids($a) $id]
9745 foreach t $archeads($a) {
9746 set j [lsearch -exact $arcids($a) $t]
9751 set id $arcstart($a)
9757 for {set i 0} {$i < [llength $todo]} {incr i} {
9758 set id [lindex $todo $i]
9759 if {[info exists cached_dheads($id)]} {
9760 set ret [concat $ret $cached_dheads($id)]
9762 if {[info exists idheads($id)]} {
9765 foreach a $arcnos($id) {
9766 if {$archeads($a) ne {}} {
9767 validate_archeads $a
9768 if {$archeads($a) ne {}} {
9769 set ret [concat $ret $archeads($a)]
9773 if {![info exists seen($d)]} {
9780 set ret [lsort -unique $ret]
9781 set cached_dheads($origid) $ret
9782 return [concat $ret $aret]
9785 proc addedtag {id} {
9786 global arcnos arcout cached_dtags cached_atags
9788 if {![info exists arcnos($id)]} return
9789 if {![info exists arcout($id)]} {
9790 recalcarc [lindex $arcnos($id) 0]
9792 catch {unset cached_dtags}
9793 catch {unset cached_atags}
9796 proc addedhead {hid head} {
9797 global arcnos arcout cached_dheads
9799 if {![info exists arcnos($hid)]} return
9800 if {![info exists arcout($hid)]} {
9801 recalcarc [lindex $arcnos($hid) 0]
9803 catch {unset cached_dheads}
9806 proc removedhead {hid head} {
9807 global cached_dheads
9809 catch {unset cached_dheads}
9812 proc movedhead {hid head} {
9813 global arcnos arcout cached_dheads
9815 if {![info exists arcnos($hid)]} return
9816 if {![info exists arcout($hid)]} {
9817 recalcarc [lindex $arcnos($hid) 0]
9819 catch {unset cached_dheads}
9822 proc changedrefs {} {
9823 global cached_dheads cached_dtags cached_atags
9824 global arctags archeads arcnos arcout idheads idtags
9826 foreach id [concat [array names idheads] [array names idtags]] {
9827 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9828 set a [lindex $arcnos($id) 0]
9829 if {![info exists donearc($a)]} {
9835 catch {unset cached_dtags}
9836 catch {unset cached_atags}
9837 catch {unset cached_dheads}
9840 proc rereadrefs {} {
9841 global idtags idheads idotherrefs mainheadid
9843 set refids [concat [array names idtags] \
9844 [array names idheads] [array names idotherrefs]]
9845 foreach id $refids {
9846 if {![info exists ref($id)]} {
9847 set ref($id) [listrefs $id]
9850 set oldmainhead $mainheadid
9853 set refids [lsort -unique [concat $refids [array names idtags] \
9854 [array names idheads] [array names idotherrefs]]]
9855 foreach id $refids {
9856 set v [listrefs $id]
9857 if {![info exists ref($id)] || $ref($id) != $v} {
9861 if {$oldmainhead ne $mainheadid} {
9862 redrawtags $oldmainhead
9863 redrawtags $mainheadid
9868 proc listrefs {id} {
9869 global idtags idheads idotherrefs
9872 if {[info exists idtags($id)]} {
9876 if {[info exists idheads($id)]} {
9880 if {[info exists idotherrefs($id)]} {
9881 set z $idotherrefs($id)
9883 return [list $x $y $z]
9886 proc showtag {tag isnew} {
9887 global ctext tagcontents tagids linknum tagobjid
9890 addtohistory [list showtag $tag 0]
9892 $ctext conf -state normal
9896 if {![info exists tagcontents($tag)]} {
9898 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9901 if {[info exists tagcontents($tag)]} {
9902 set text $tagcontents($tag)
9904 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9906 appendwithlinks $text {}
9907 $ctext conf -state disabled
9919 if {[info exists gitktmpdir]} {
9920 catch {file delete -force $gitktmpdir}
9924 proc mkfontdisp {font top which} {
9925 global fontattr fontpref $font
9927 set fontpref($font) [set $font]
9928 button $top.${font}but -text $which -font optionfont \
9929 -command [list choosefont $font $which]
9930 label $top.$font -relief flat -font $font \
9931 -text $fontattr($font,family) -justify left
9932 grid x $top.${font}but $top.$font -sticky w
9935 proc choosefont {font which} {
9936 global fontparam fontlist fonttop fontattr
9939 set fontparam(which) $which
9940 set fontparam(font) $font
9941 set fontparam(family) [font actual $font -family]
9942 set fontparam(size) $fontattr($font,size)
9943 set fontparam(weight) $fontattr($font,weight)
9944 set fontparam(slant) $fontattr($font,slant)
9947 if {![winfo exists $top]} {
9949 eval font config sample [font actual $font]
9951 make_transient $top $prefstop
9952 wm title $top [mc "Gitk font chooser"]
9953 label $top.l -textvariable fontparam(which)
9954 pack $top.l -side top
9955 set fontlist [lsort [font families]]
9957 listbox $top.f.fam -listvariable fontlist \
9958 -yscrollcommand [list $top.f.sb set]
9959 bind $top.f.fam <<ListboxSelect>> selfontfam
9960 scrollbar $top.f.sb -command [list $top.f.fam yview]
9961 pack $top.f.sb -side right -fill y
9962 pack $top.f.fam -side left -fill both -expand 1
9963 pack $top.f -side top -fill both -expand 1
9965 spinbox $top.g.size -from 4 -to 40 -width 4 \
9966 -textvariable fontparam(size) \
9967 -validatecommand {string is integer -strict %s}
9968 checkbutton $top.g.bold -padx 5 \
9969 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9970 -variable fontparam(weight) -onvalue bold -offvalue normal
9971 checkbutton $top.g.ital -padx 5 \
9972 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9973 -variable fontparam(slant) -onvalue italic -offvalue roman
9974 pack $top.g.size $top.g.bold $top.g.ital -side left
9975 pack $top.g -side top
9976 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9978 $top.c create text 100 25 -anchor center -text $which -font sample \
9979 -fill black -tags text
9980 bind $top.c <Configure> [list centertext $top.c]
9981 pack $top.c -side top -fill x
9983 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9984 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9985 bind $top <Key-Return> fontok
9986 bind $top <Key-Escape> fontcan
9987 grid $top.buts.ok $top.buts.can
9988 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9989 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9990 pack $top.buts -side bottom -fill x
9991 trace add variable fontparam write chg_fontparam
9994 $top.c itemconf text -text $which
9996 set i [lsearch -exact $fontlist $fontparam(family)]
9998 $top.f.fam selection set $i
10003 proc centertext {w} {
10004 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10008 global fontparam fontpref prefstop
10010 set f $fontparam(font)
10011 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10012 if {$fontparam(weight) eq "bold"} {
10013 lappend fontpref($f) "bold"
10015 if {$fontparam(slant) eq "italic"} {
10016 lappend fontpref($f) "italic"
10019 $w conf -text $fontparam(family) -font $fontpref($f)
10025 global fonttop fontparam
10027 if {[info exists fonttop]} {
10028 catch {destroy $fonttop}
10029 catch {font delete sample}
10035 proc selfontfam {} {
10036 global fonttop fontparam
10038 set i [$fonttop.f.fam curselection]
10040 set fontparam(family) [$fonttop.f.fam get $i]
10044 proc chg_fontparam {v sub op} {
10047 font config sample -$sub $fontparam($sub)
10051 global maxwidth maxgraphpct
10052 global oldprefs prefstop showneartags showlocalchanges
10053 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10054 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10058 if {[winfo exists $top]} {
10062 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10063 limitdiffs tabstop perfile_attrs} {
10064 set oldprefs($v) [set $v]
10067 wm title $top [mc "Gitk preferences"]
10068 make_transient $top .
10069 label $top.ldisp -text [mc "Commit list display options"]
10070 grid $top.ldisp - -sticky w -pady 10
10071 label $top.spacer -text " "
10072 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10074 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10075 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10076 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10078 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10079 grid x $top.maxpctl $top.maxpct -sticky w
10080 frame $top.showlocal
10081 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
10082 checkbutton $top.showlocal.b -variable showlocalchanges
10083 pack $top.showlocal.b $top.showlocal.l -side left
10084 grid x $top.showlocal -sticky w
10085 frame $top.autoselect
10086 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
10087 checkbutton $top.autoselect.b -variable autoselect
10088 pack $top.autoselect.b $top.autoselect.l -side left
10089 grid x $top.autoselect -sticky w
10091 label $top.ddisp -text [mc "Diff display options"]
10092 grid $top.ddisp - -sticky w -pady 10
10093 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10094 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10095 grid x $top.tabstopl $top.tabstop -sticky w
10097 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
10098 checkbutton $top.ntag.b -variable showneartags
10099 pack $top.ntag.b $top.ntag.l -side left
10100 grid x $top.ntag -sticky w
10102 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
10103 checkbutton $top.ldiff.b -variable limitdiffs
10104 pack $top.ldiff.b $top.ldiff.l -side left
10105 grid x $top.ldiff -sticky w
10107 label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
10108 checkbutton $top.lattr.b -variable perfile_attrs
10109 pack $top.lattr.b $top.lattr.l -side left
10110 grid x $top.lattr -sticky w
10112 entry $top.extdifft -textvariable extdifftool
10113 frame $top.extdifff
10114 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10116 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10117 -command choose_extdiff
10118 pack $top.extdifff.l $top.extdifff.b -side left
10119 grid x $top.extdifff $top.extdifft -sticky w
10121 label $top.cdisp -text [mc "Colors: press to choose"]
10122 grid $top.cdisp - -sticky w -pady 10
10123 label $top.bg -padx 40 -relief sunk -background $bgcolor
10124 button $top.bgbut -text [mc "Background"] -font optionfont \
10125 -command [list choosecolor bgcolor {} $top.bg background setbg]
10126 grid x $top.bgbut $top.bg -sticky w
10127 label $top.fg -padx 40 -relief sunk -background $fgcolor
10128 button $top.fgbut -text [mc "Foreground"] -font optionfont \
10129 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
10130 grid x $top.fgbut $top.fg -sticky w
10131 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10132 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10133 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
10134 [list $ctext tag conf d0 -foreground]]
10135 grid x $top.diffoldbut $top.diffold -sticky w
10136 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10137 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10138 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
10139 [list $ctext tag conf dresult -foreground]]
10140 grid x $top.diffnewbut $top.diffnew -sticky w
10141 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10142 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10143 -command [list choosecolor diffcolors 2 $top.hunksep \
10144 "diff hunk header" \
10145 [list $ctext tag conf hunksep -foreground]]
10146 grid x $top.hunksepbut $top.hunksep -sticky w
10147 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10148 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10149 -command [list choosecolor markbgcolor {} $top.markbgsep \
10150 [mc "marked line background"] \
10151 [list $ctext tag conf omark -background]]
10152 grid x $top.markbgbut $top.markbgsep -sticky w
10153 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10154 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10155 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
10156 grid x $top.selbgbut $top.selbgsep -sticky w
10158 label $top.cfont -text [mc "Fonts: press to choose"]
10159 grid $top.cfont - -sticky w -pady 10
10160 mkfontdisp mainfont $top [mc "Main font"]
10161 mkfontdisp textfont $top [mc "Diff display font"]
10162 mkfontdisp uifont $top [mc "User interface font"]
10165 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10166 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10167 bind $top <Key-Return> prefsok
10168 bind $top <Key-Escape> prefscan
10169 grid $top.buts.ok $top.buts.can
10170 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10171 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10172 grid $top.buts - - -pady 10 -sticky ew
10173 bind $top <Visibility> "focus $top.buts.ok"
10176 proc choose_extdiff {} {
10179 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10181 set extdifftool $prog
10185 proc choosecolor {v vi w x cmd} {
10188 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10189 -title [mc "Gitk: choose color for %s" $x]]
10190 if {$c eq {}} return
10191 $w conf -background $c
10196 proc setselbg {c} {
10197 global bglist cflist
10198 foreach w $bglist {
10199 $w configure -selectbackground $c
10201 $cflist tag configure highlight \
10202 -background [$cflist cget -selectbackground]
10203 allcanvs itemconf secsel -fill $c
10209 foreach w $bglist {
10210 $w conf -background $c
10217 foreach w $fglist {
10218 $w conf -foreground $c
10220 allcanvs itemconf text -fill $c
10221 $canv itemconf circle -outline $c
10225 global oldprefs prefstop
10227 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10228 limitdiffs tabstop perfile_attrs} {
10230 set $v $oldprefs($v)
10232 catch {destroy $prefstop}
10238 global maxwidth maxgraphpct
10239 global oldprefs prefstop showneartags showlocalchanges
10240 global fontpref mainfont textfont uifont
10241 global limitdiffs treediffs perfile_attrs
10243 catch {destroy $prefstop}
10247 if {$mainfont ne $fontpref(mainfont)} {
10248 set mainfont $fontpref(mainfont)
10249 parsefont mainfont $mainfont
10250 eval font configure mainfont [fontflags mainfont]
10251 eval font configure mainfontbold [fontflags mainfont 1]
10255 if {$textfont ne $fontpref(textfont)} {
10256 set textfont $fontpref(textfont)
10257 parsefont textfont $textfont
10258 eval font configure textfont [fontflags textfont]
10259 eval font configure textfontbold [fontflags textfont 1]
10261 if {$uifont ne $fontpref(uifont)} {
10262 set uifont $fontpref(uifont)
10263 parsefont uifont $uifont
10264 eval font configure uifont [fontflags uifont]
10267 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10268 if {$showlocalchanges} {
10274 if {$limitdiffs != $oldprefs(limitdiffs) ||
10275 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10276 # treediffs elements are limited by path;
10277 # won't have encodings cached if perfile_attrs was just turned on
10278 catch {unset treediffs}
10280 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10281 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10283 } elseif {$showneartags != $oldprefs(showneartags) ||
10284 $limitdiffs != $oldprefs(limitdiffs)} {
10289 proc formatdate {d} {
10290 global datetimeformat
10292 set d [clock format $d -format $datetimeformat]
10297 # This list of encoding names and aliases is distilled from
10298 # http://www.iana.org/assignments/character-sets.
10299 # Not all of them are supported by Tcl.
10300 set encoding_aliases {
10301 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10302 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10303 { ISO-10646-UTF-1 csISO10646UTF1 }
10304 { ISO_646.basic:1983 ref csISO646basic1983 }
10305 { INVARIANT csINVARIANT }
10306 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10307 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10308 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10309 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10310 { NATS-DANO iso-ir-9-1 csNATSDANO }
10311 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10312 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10313 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10314 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10315 { ISO-2022-KR csISO2022KR }
10317 { ISO-2022-JP csISO2022JP }
10318 { ISO-2022-JP-2 csISO2022JP2 }
10319 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10320 csISO13JISC6220jp }
10321 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10322 { IT iso-ir-15 ISO646-IT csISO15Italian }
10323 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10324 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10325 { greek7-old iso-ir-18 csISO18Greek7Old }
10326 { latin-greek iso-ir-19 csISO19LatinGreek }
10327 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10328 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10329 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10330 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10331 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10332 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10333 { INIS iso-ir-49 csISO49INIS }
10334 { INIS-8 iso-ir-50 csISO50INIS8 }
10335 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10336 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10337 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10338 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10339 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10340 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10341 csISO60Norwegian1 }
10342 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10343 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10344 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10345 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10346 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10347 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10348 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10349 { greek7 iso-ir-88 csISO88Greek7 }
10350 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10351 { iso-ir-90 csISO90 }
10352 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10353 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10354 csISO92JISC62991984b }
10355 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10356 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10357 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10358 csISO95JIS62291984handadd }
10359 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10360 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10361 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10362 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10363 CP819 csISOLatin1 }
10364 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10365 { T.61-7bit iso-ir-102 csISO102T617bit }
10366 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10367 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10368 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10369 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10370 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10371 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10372 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10373 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10374 arabic csISOLatinArabic }
10375 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10376 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10377 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10378 greek greek8 csISOLatinGreek }
10379 { T.101-G2 iso-ir-128 csISO128T101G2 }
10380 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10382 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10383 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10384 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10385 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10386 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10387 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10388 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10389 csISOLatinCyrillic }
10390 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10391 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10392 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10393 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10394 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10395 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10396 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10397 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10398 { ISO_10367-box iso-ir-155 csISO10367Box }
10399 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10400 { latin-lap lap iso-ir-158 csISO158Lap }
10401 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10402 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10405 { JIS_X0201 X0201 csHalfWidthKatakana }
10406 { KSC5636 ISO646-KR csKSC5636 }
10407 { ISO-10646-UCS-2 csUnicode }
10408 { ISO-10646-UCS-4 csUCS4 }
10409 { DEC-MCS dec csDECMCS }
10410 { hp-roman8 roman8 r8 csHPRoman8 }
10411 { macintosh mac csMacintosh }
10412 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10414 { IBM038 EBCDIC-INT cp038 csIBM038 }
10415 { IBM273 CP273 csIBM273 }
10416 { IBM274 EBCDIC-BE CP274 csIBM274 }
10417 { IBM275 EBCDIC-BR cp275 csIBM275 }
10418 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10419 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10420 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10421 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10422 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10423 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10424 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10425 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10426 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10427 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10428 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10429 { IBM437 cp437 437 csPC8CodePage437 }
10430 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10431 { IBM775 cp775 csPC775Baltic }
10432 { IBM850 cp850 850 csPC850Multilingual }
10433 { IBM851 cp851 851 csIBM851 }
10434 { IBM852 cp852 852 csPCp852 }
10435 { IBM855 cp855 855 csIBM855 }
10436 { IBM857 cp857 857 csIBM857 }
10437 { IBM860 cp860 860 csIBM860 }
10438 { IBM861 cp861 861 cp-is csIBM861 }
10439 { IBM862 cp862 862 csPC862LatinHebrew }
10440 { IBM863 cp863 863 csIBM863 }
10441 { IBM864 cp864 csIBM864 }
10442 { IBM865 cp865 865 csIBM865 }
10443 { IBM866 cp866 866 csIBM866 }
10444 { IBM868 CP868 cp-ar csIBM868 }
10445 { IBM869 cp869 869 cp-gr csIBM869 }
10446 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10447 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10448 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10449 { IBM891 cp891 csIBM891 }
10450 { IBM903 cp903 csIBM903 }
10451 { IBM904 cp904 904 csIBBM904 }
10452 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10453 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10454 { IBM1026 CP1026 csIBM1026 }
10455 { EBCDIC-AT-DE csIBMEBCDICATDE }
10456 { EBCDIC-AT-DE-A csEBCDICATDEA }
10457 { EBCDIC-CA-FR csEBCDICCAFR }
10458 { EBCDIC-DK-NO csEBCDICDKNO }
10459 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10460 { EBCDIC-FI-SE csEBCDICFISE }
10461 { EBCDIC-FI-SE-A csEBCDICFISEA }
10462 { EBCDIC-FR csEBCDICFR }
10463 { EBCDIC-IT csEBCDICIT }
10464 { EBCDIC-PT csEBCDICPT }
10465 { EBCDIC-ES csEBCDICES }
10466 { EBCDIC-ES-A csEBCDICESA }
10467 { EBCDIC-ES-S csEBCDICESS }
10468 { EBCDIC-UK csEBCDICUK }
10469 { EBCDIC-US csEBCDICUS }
10470 { UNKNOWN-8BIT csUnknown8BiT }
10471 { MNEMONIC csMnemonic }
10473 { VISCII csVISCII }
10476 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10477 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10478 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10479 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10480 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10481 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10482 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10483 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10484 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10485 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10486 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10487 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10488 { IBM1047 IBM-1047 }
10489 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10490 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10491 { UNICODE-1-1 csUnicode11 }
10492 { CESU-8 csCESU-8 }
10493 { BOCU-1 csBOCU-1 }
10494 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10495 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10497 { ISO-8859-15 ISO_8859-15 Latin-9 }
10498 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10499 { GBK CP936 MS936 windows-936 }
10500 { JIS_Encoding csJISEncoding }
10501 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10502 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10504 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10505 { ISO-10646-UCS-Basic csUnicodeASCII }
10506 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10507 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10508 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10509 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10510 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10511 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10512 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10513 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10514 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10515 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10516 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10517 { Ventura-US csVenturaUS }
10518 { Ventura-International csVenturaInternational }
10519 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10520 { PC8-Turkish csPC8Turkish }
10521 { IBM-Symbols csIBMSymbols }
10522 { IBM-Thai csIBMThai }
10523 { HP-Legal csHPLegal }
10524 { HP-Pi-font csHPPiFont }
10525 { HP-Math8 csHPMath8 }
10526 { Adobe-Symbol-Encoding csHPPSMath }
10527 { HP-DeskTop csHPDesktop }
10528 { Ventura-Math csVenturaMath }
10529 { Microsoft-Publishing csMicrosoftPublishing }
10530 { Windows-31J csWindows31J }
10531 { GB2312 csGB2312 }
10535 proc tcl_encoding {enc} {
10536 global encoding_aliases tcl_encoding_cache
10537 if {[info exists tcl_encoding_cache($enc)]} {
10538 return $tcl_encoding_cache($enc)
10540 set names [encoding names]
10541 set lcnames [string tolower $names]
10542 set enc [string tolower $enc]
10543 set i [lsearch -exact $lcnames $enc]
10545 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10546 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10547 set i [lsearch -exact $lcnames $encx]
10551 foreach l $encoding_aliases {
10552 set ll [string tolower $l]
10553 if {[lsearch -exact $ll $enc] < 0} continue
10554 # look through the aliases for one that tcl knows about
10556 set i [lsearch -exact $lcnames $e]
10558 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10559 set i [lsearch -exact $lcnames $ex]
10569 set tclenc [lindex $names $i]
10571 set tcl_encoding_cache($enc) $tclenc
10575 proc gitattr {path attr default} {
10576 global path_attr_cache
10577 if {[info exists path_attr_cache($attr,$path)]} {
10578 set r $path_attr_cache($attr,$path)
10580 set r "unspecified"
10581 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10582 regexp "(.*): encoding: (.*)" $line m f r
10584 set path_attr_cache($attr,$path) $r
10586 if {$r eq "unspecified"} {
10592 proc cache_gitattr {attr pathlist} {
10593 global path_attr_cache
10595 foreach path $pathlist {
10596 if {![info exists path_attr_cache($attr,$path)]} {
10597 lappend newlist $path
10601 if {[tk windowingsystem] == "win32"} {
10602 # windows has a 32k limit on the arguments to a command...
10605 while {$newlist ne {}} {
10606 set head [lrange $newlist 0 [expr {$lim - 1}]]
10607 set newlist [lrange $newlist $lim end]
10608 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10609 foreach row [split $rlist "\n"] {
10610 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10611 if {[string index $path 0] eq "\""} {
10612 set path [encoding convertfrom [lindex $path 0]]
10614 set path_attr_cache($attr,$path) $value
10621 proc get_path_encoding {path} {
10622 global gui_encoding perfile_attrs
10623 set tcl_enc $gui_encoding
10624 if {$path ne {} && $perfile_attrs} {
10625 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10633 # First check that Tcl/Tk is recent enough
10634 if {[catch {package require Tk 8.4} err]} {
10635 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10636 Gitk requires at least Tcl/Tk 8.4."]
10641 set wrcomcmd "git diff-tree --stdin -p --pretty"
10645 set gitencoding [exec git config --get i18n.commitencoding]
10648 set gitencoding [exec git config --get i18n.logoutputencoding]
10650 if {$gitencoding == ""} {
10651 set gitencoding "utf-8"
10653 set tclencoding [tcl_encoding $gitencoding]
10654 if {$tclencoding == {}} {
10655 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10658 set gui_encoding [encoding system]
10660 set enc [exec git config --get gui.encoding]
10662 set tclenc [tcl_encoding $enc]
10663 if {$tclenc ne {}} {
10664 set gui_encoding $tclenc
10666 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10671 set mainfont {Helvetica 9}
10672 set textfont {Courier 9}
10673 set uifont {Helvetica 9 bold}
10675 set findmergefiles 0
10683 set cmitmode "patch"
10684 set wrapcomment "none"
10688 set showlocalchanges 1
10690 set datetimeformat "%Y-%m-%d %H:%M:%S"
10692 set perfile_attrs 0
10694 set extdifftool "meld"
10696 set colors {green red blue magenta darkgrey brown orange}
10699 set diffcolors {red "#00a000" blue}
10702 set selectbgcolor gray85
10703 set markbgcolor "#e0e0ff"
10705 set circlecolors {white blue gray blue blue}
10707 # button for popping up context menus
10708 if {[tk windowingsystem] eq "aqua"} {
10709 set ctxbut <Button-2>
10711 set ctxbut <Button-3>
10714 ## For msgcat loading, first locate the installation location.
10715 if { [info exists ::env(GITK_MSGSDIR)] } {
10716 ## Msgsdir was manually set in the environment.
10717 set gitk_msgsdir $::env(GITK_MSGSDIR)
10719 ## Let's guess the prefix from argv0.
10720 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10721 set gitk_libdir [file join $gitk_prefix share gitk lib]
10722 set gitk_msgsdir [file join $gitk_libdir msgs]
10726 ## Internationalization (i18n) through msgcat and gettext. See
10727 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10728 package require msgcat
10729 namespace import ::msgcat::mc
10730 ## And eventually load the actual message catalog
10731 ::msgcat::mcload $gitk_msgsdir
10733 catch {source ~/.gitk}
10735 font create optionfont -family sans-serif -size -12
10737 parsefont mainfont $mainfont
10738 eval font create mainfont [fontflags mainfont]
10739 eval font create mainfontbold [fontflags mainfont 1]
10741 parsefont textfont $textfont
10742 eval font create textfont [fontflags textfont]
10743 eval font create textfontbold [fontflags textfont 1]
10745 parsefont uifont $uifont
10746 eval font create uifont [fontflags uifont]
10750 # check that we can find a .git directory somewhere...
10751 if {[catch {set gitdir [gitdir]}]} {
10752 show_error {} . [mc "Cannot find a git repository here."]
10755 if {![file isdirectory $gitdir]} {
10756 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10761 set selectheadid {}
10764 set cmdline_files {}
10766 set revtreeargscmd {}
10767 foreach arg $argv {
10768 switch -glob -- $arg {
10771 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10774 "--select-commit=*" {
10775 set selecthead [string range $arg 16 end]
10778 set revtreeargscmd [string range $arg 10 end]
10781 lappend revtreeargs $arg
10787 if {$selecthead eq "HEAD"} {
10791 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10792 # no -- on command line, but some arguments (other than --argscmd)
10794 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10795 set cmdline_files [split $f "\n"]
10796 set n [llength $cmdline_files]
10797 set revtreeargs [lrange $revtreeargs 0 end-$n]
10798 # Unfortunately git rev-parse doesn't produce an error when
10799 # something is both a revision and a filename. To be consistent
10800 # with git log and git rev-list, check revtreeargs for filenames.
10801 foreach arg $revtreeargs {
10802 if {[file exists $arg]} {
10803 show_error {} . [mc "Ambiguous argument '%s': both revision\
10804 and filename" $arg]
10809 # unfortunately we get both stdout and stderr in $err,
10810 # so look for "fatal:".
10811 set i [string first "fatal:" $err]
10813 set err [string range $err [expr {$i + 6}] end]
10815 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10820 set nullid "0000000000000000000000000000000000000000"
10821 set nullid2 "0000000000000000000000000000000000000001"
10822 set nullfile "/dev/null"
10824 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10831 set highlight_paths {}
10833 set searchdirn -forwards
10836 set diffelide {0 0}
10837 set markingmatches 0
10838 set linkentercount 0
10839 set need_redisplay 0
10846 set selectedhlview [mc "None"]
10847 set highlight_related [mc "None"]
10848 set highlight_files {}
10849 set viewfiles(0) {}
10852 set viewargscmd(0) {}
10854 set selectedline {}
10862 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10865 # wait for the window to become visible
10866 tkwait visibility .
10867 wm title . "[file tail $argv0]: [file tail [pwd]]"
10870 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10871 # create a view for the files/dirs specified on the command line
10875 set viewname(1) [mc "Command line"]
10876 set viewfiles(1) $cmdline_files
10877 set viewargs(1) $revtreeargs
10878 set viewargscmd(1) $revtreeargscmd
10882 .bar.view entryconf [mca "Edit view..."] -state normal
10883 .bar.view entryconf [mca "Delete view"] -state normal
10886 if {[info exists permviews]} {
10887 foreach v $permviews {
10890 set viewname($n) [lindex $v 0]
10891 set viewfiles($n) [lindex $v 1]
10892 set viewargs($n) [lindex $v 2]
10893 set viewargscmd($n) [lindex $v 3]