2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
12 if {[info exists env
(GIT_DIR
)]} {
15 return [exec git rev-parse
--git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
25 global isonrunq runq currunq
28 if {[info exists isonrunq
($script)]} return
29 if {$runq eq
{} && ![info exists currunq
]} {
32 lappend runq
[list
{} $script]
33 set isonrunq
($script) 1
36 proc filerun
{fd
script} {
37 fileevent
$fd readable
[list filereadable
$fd $script]
40 proc filereadable
{fd
script} {
43 fileevent
$fd readable
{}
44 if {$runq eq
{} && ![info exists currunq
]} {
47 lappend runq
[list
$fd $script]
53 for {set i
0} {$i < [llength
$runq]} {} {
54 if {[lindex
$runq $i 0] eq
$fd} {
55 set runq
[lreplace
$runq $i $i]
63 global isonrunq runq currunq
65 set tstart
[clock clicks
-milliseconds]
67 while {[llength
$runq] > 0} {
68 set fd
[lindex
$runq 0 0]
69 set script [lindex
$runq 0 1]
70 set currunq
[lindex
$runq 0]
71 set runq
[lrange
$runq 1 end
]
72 set repeat
[eval $script]
74 set t1
[clock clicks
-milliseconds]
75 set t
[expr {$t1 - $t0}]
76 if {$repeat ne
{} && $repeat} {
77 if {$fd eq
{} ||
$repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq
[list
$fd $script]
82 fileevent
$fd readable
[list filereadable
$fd $script]
84 } elseif
{$fd eq
{}} {
85 unset isonrunq
($script)
88 if {$t1 - $tstart >= 80} break
95 proc reg_instance
{fd
} {
96 global commfd leftover loginstance
98 set i
[incr loginstance
]
104 proc unmerged_files
{files
} {
107 # find the list of unmerged files
111 set fd
[open
"| git ls-files -u" r
]
113 show_error
{} .
"[mc "Couldn
't get list of unmerged files:"] $err"
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
122 if {$files eq {} || [path_filter $files $fname]} {
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
139 set origargs $arglist
143 foreach arg $arglist {
150 switch -glob -- $arg {
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
158 # These request or affect diff output, which we don't want.
159 # Some could be used to set our defaults for diff display.
161 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165 "--ignore-space-change" - "-U*" - "--unified=*" {
166 lappend diffargs
$arg
168 # These cause our parsing of git log's output to fail, or else
169 # they're options we want to set ourselves, so ignore them.
170 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171 "--name-only" - "--name-status" - "--color" - "--color-words" -
172 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176 "--objects" - "--objects-edge" - "--reverse" {
178 # These are harmless, and some are even useful
179 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
180 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
181 "--full-history" - "--dense" - "--sparse" -
182 "--follow" - "--left-right" - "--encoding=*" {
185 # These mean that we get a subset of the commits
186 "--diff-filter=*" - "--no-merges" - "--unpacked" -
187 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
188 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
189 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
190 "--remove-empty" - "--first-parent" - "--cherry-pick" -
191 "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
195 # This appears to be the only one that has a value as a
196 # separate word following it
203 set notflag
[expr {!$notflag}]
211 # git rev-parse doesn't understand --merge
212 lappend revargs
--gitk-symmetric-diff-marker MERGE_HEAD...HEAD
214 # Other flag arguments including -<n>
216 if {[string is digit
-strict [string range
$arg 1 end
]]} {
219 # a flag argument that we don't recognize;
220 # that means we can't optimize
225 # Non-flag arguments specify commits or ranges of commits
227 if {[string match
"*...*" $arg]} {
228 lappend revargs
--gitk-symmetric-diff-marker
234 set vdflags
($n) $diffargs
235 set vflags
($n) $glflags
236 set vrevs
($n) $revargs
237 set vfiltered
($n) $filtered
238 set vorigargs
($n) $origargs
242 proc parseviewrevs
{view revs
} {
243 global vposids vnegids
248 if {[catch
{set ids
[eval exec git rev-parse
$revs]} err
]} {
249 # we get stdout followed by stderr in $err
250 # for an unknown rev, git rev-parse echoes it and then errors out
251 set errlines
[split $err "\n"]
253 for {set l
0} {$l < [llength
$errlines]} {incr l
} {
254 set line
[lindex
$errlines $l]
255 if {!([string length
$line] == 40 && [string is xdigit
$line])} {
256 if {[string match
"fatal:*" $line]} {
257 if {[string match
"fatal: ambiguous argument*" $line]
259 if {[llength
$badrev] == 1} {
260 set err
"unknown revision $badrev"
262 set err
"unknown revisions: [join $badrev ", "]"
265 set err
[join [lrange
$errlines $l end
] "\n"]
272 error_popup
"[mc "Error parsing revisions
:"] $err"
279 foreach id
[split $ids "\n"] {
280 if {$id eq
"--gitk-symmetric-diff-marker"} {
282 } elseif
{[string match
"^*" $id]} {
289 lappend neg
[string range
$id 1 end
]
294 lset ret end
[lindex
$ret end
]...
$id
300 set vposids
($view) $pos
301 set vnegids
($view) $neg
305 # Start off a git log process and arrange to read its output
306 proc start_rev_list
{view
} {
307 global startmsecs commitidx viewcomplete curview
309 global viewargs viewargscmd viewfiles vfilelimit
310 global showlocalchanges
311 global viewactive viewinstances vmergeonly
313 global vcanopt vflags vrevs vorigargs
315 set startmsecs
[clock clicks
-milliseconds]
316 set commitidx
($view) 0
317 # these are set this way for the error exits
318 set viewcomplete
($view) 1
319 set viewactive
($view) 0
322 set args
$viewargs($view)
323 if {$viewargscmd($view) ne
{}} {
325 set str
[exec sh
-c $viewargscmd($view)]
327 error_popup
"[mc "Error executing
--argscmd command:"] $err"
330 set args
[concat
$args [split $str "\n"]]
332 set vcanopt
($view) [parseviewargs
$view $args]
334 set files
$viewfiles($view)
335 if {$vmergeonly($view)} {
336 set files
[unmerged_files
$files]
339 if {$nr_unmerged == 0} {
340 error_popup
[mc
"No files selected: --merge specified but\
341 no files are unmerged."]
343 error_popup
[mc
"No files selected: --merge specified but\
344 no unmerged files are within file limit."]
349 set vfilelimit
($view) $files
351 if {$vcanopt($view)} {
352 set revs
[parseviewrevs
$view $vrevs($view)]
356 set args
[concat
$vflags($view) $revs]
358 set args
$vorigargs($view)
362 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
363 --boundary $args "--" $files] r
]
365 error_popup
"[mc "Error executing git log
:"] $err"
368 set i
[reg_instance
$fd]
369 set viewinstances
($view) [list
$i]
370 if {$showlocalchanges && $mainheadid ne
{}} {
371 interestedin
$mainheadid dodiffindex
373 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
374 if {$tclencoding != {}} {
375 fconfigure
$fd -encoding $tclencoding
377 filerun
$fd [list getcommitlines
$fd $i $view 0]
378 nowbusy
$view [mc
"Reading"]
379 set viewcomplete
($view) 0
380 set viewactive
($view) 1
384 proc stop_instance
{inst
} {
385 global commfd leftover
387 set fd
$commfd($inst)
391 if {$
::tcl_platform
(platform
) eq
{windows
}} {
400 unset leftover
($inst)
403 proc stop_backends
{} {
406 foreach inst
[array names commfd
] {
411 proc stop_rev_list
{view
} {
414 foreach inst
$viewinstances($view) {
417 set viewinstances
($view) {}
420 proc reset_pending_select
{selid
} {
421 global pending_select mainheadid selectheadid
424 set pending_select
$selid
425 } elseif
{$selectheadid ne
{}} {
426 set pending_select
$selectheadid
428 set pending_select
$mainheadid
432 proc getcommits
{selid
} {
433 global canv curview need_redisplay viewactive
436 if {[start_rev_list
$curview]} {
437 reset_pending_select
$selid
438 show_status
[mc
"Reading commits..."]
441 show_status
[mc
"No commits selected"]
445 proc updatecommits
{} {
446 global curview vcanopt vorigargs vfilelimit viewinstances
447 global viewactive viewcomplete tclencoding
448 global startmsecs showneartags showlocalchanges
449 global mainheadid pending_select
451 global varcid vposids vnegids vflags vrevs
453 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
454 set oldmainid
$mainheadid
456 if {$showlocalchanges} {
457 if {$mainheadid ne
$oldmainid} {
460 if {[commitinview
$mainheadid $curview]} {
465 if {$vcanopt($view)} {
466 set oldpos
$vposids($view)
467 set oldneg
$vnegids($view)
468 set revs
[parseviewrevs
$view $vrevs($view)]
472 # note: getting the delta when negative refs change is hard,
473 # and could require multiple git log invocations, so in that
474 # case we ask git log for all the commits (not just the delta)
475 if {$oldneg eq
$vnegids($view)} {
478 # take out positive refs that we asked for before or
479 # that we have already seen
481 if {[string length
$rev] == 40} {
482 if {[lsearch
-exact $oldpos $rev] < 0
483 && ![info exists varcid
($view,$rev)]} {
488 lappend
$newrevs $rev
491 if {$npos == 0} return
493 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
495 set args
[concat
$vflags($view) $revs --not $oldpos]
497 set args
$vorigargs($view)
500 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
501 --boundary $args "--" $vfilelimit($view)] r
]
503 error_popup
"[mc "Error executing git log
:"] $err"
506 if {$viewactive($view) == 0} {
507 set startmsecs
[clock clicks
-milliseconds]
509 set i
[reg_instance
$fd]
510 lappend viewinstances
($view) $i
511 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
512 if {$tclencoding != {}} {
513 fconfigure
$fd -encoding $tclencoding
515 filerun
$fd [list getcommitlines
$fd $i $view 1]
516 incr viewactive
($view)
517 set viewcomplete
($view) 0
518 reset_pending_select
{}
519 nowbusy
$view "Reading"
525 proc reloadcommits
{} {
526 global curview viewcomplete selectedline currentid thickerline
527 global showneartags treediffs commitinterest cached_commitrow
531 if {$selectedline ne
{}} {
535 if {!$viewcomplete($curview)} {
536 stop_rev_list
$curview
540 catch
{unset currentid
}
541 catch
{unset thickerline
}
542 catch
{unset treediffs
}
549 catch
{unset commitinterest
}
550 catch
{unset cached_commitrow
}
551 catch
{unset targetid
}
557 # This makes a string representation of a positive integer which
558 # sorts as a string in numerical order
561 return [format
"%x" $n]
562 } elseif
{$n < 256} {
563 return [format
"x%.2x" $n]
564 } elseif
{$n < 65536} {
565 return [format
"y%.4x" $n]
567 return [format
"z%.8x" $n]
570 # Procedures used in reordering commits from git log (without
571 # --topo-order) into the order for display.
573 proc varcinit
{view
} {
574 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
575 global vtokmod varcmod vrowmod varcix vlastins
577 set varcstart
($view) {{}}
578 set vupptr
($view) {0}
579 set vdownptr
($view) {0}
580 set vleftptr
($view) {0}
581 set vbackptr
($view) {0}
582 set varctok
($view) {{}}
583 set varcrow
($view) {{}}
584 set vtokmod
($view) {}
587 set varcix
($view) {{}}
588 set vlastins
($view) {0}
591 proc resetvarcs
{view
} {
592 global varcid varccommits parents children vseedcount ordertok
594 foreach vid
[array names varcid
$view,*] {
599 # some commits might have children but haven't been seen yet
600 foreach vid
[array names children
$view,*] {
603 foreach va
[array names varccommits
$view,*] {
604 unset varccommits
($va)
606 foreach vd
[array names vseedcount
$view,*] {
607 unset vseedcount
($vd)
609 catch
{unset ordertok
}
612 # returns a list of the commits with no children
614 global vdownptr vleftptr varcstart
617 set a
[lindex
$vdownptr($v) 0]
619 lappend ret
[lindex
$varcstart($v) $a]
620 set a
[lindex
$vleftptr($v) $a]
625 proc newvarc
{view id
} {
626 global varcid varctok parents children vdatemode
627 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
628 global commitdata commitinfo vseedcount varccommits vlastins
630 set a
[llength
$varctok($view)]
632 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
633 if {![info exists commitinfo
($id)]} {
634 parsecommit
$id $commitdata($id) 1
636 set cdate
[lindex
$commitinfo($id) 4]
637 if {![string is integer
-strict $cdate]} {
640 if {![info exists vseedcount
($view,$cdate)]} {
641 set vseedcount
($view,$cdate) -1
643 set c
[incr vseedcount
($view,$cdate)]
644 set cdate
[expr {$cdate ^
0xffffffff}]
645 set tok
"s[strrep $cdate][strrep $c]"
650 if {[llength
$children($vid)] > 0} {
651 set kid
[lindex
$children($vid) end
]
652 set k
$varcid($view,$kid)
653 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
656 set tok
[lindex
$varctok($view) $k]
660 set i
[lsearch
-exact $parents($view,$ki) $id]
661 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
662 append tok
[strrep
$j]
664 set c
[lindex
$vlastins($view) $ka]
665 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
667 set b
[lindex
$vdownptr($view) $ka]
669 set b
[lindex
$vleftptr($view) $c]
671 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
673 set b
[lindex
$vleftptr($view) $c]
676 lset vdownptr
($view) $ka $a
677 lappend vbackptr
($view) 0
679 lset vleftptr
($view) $c $a
680 lappend vbackptr
($view) $c
682 lset vlastins
($view) $ka $a
683 lappend vupptr
($view) $ka
684 lappend vleftptr
($view) $b
686 lset vbackptr
($view) $b $a
688 lappend varctok
($view) $tok
689 lappend varcstart
($view) $id
690 lappend vdownptr
($view) 0
691 lappend varcrow
($view) {}
692 lappend varcix
($view) {}
693 set varccommits
($view,$a) {}
694 lappend vlastins
($view) 0
698 proc splitvarc
{p v
} {
699 global varcid varcstart varccommits varctok
700 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
702 set oa
$varcid($v,$p)
703 set ac
$varccommits($v,$oa)
704 set i
[lsearch
-exact $varccommits($v,$oa) $p]
706 set na
[llength
$varctok($v)]
707 # "%" sorts before "0"...
708 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
709 lappend varctok
($v) $tok
710 lappend varcrow
($v) {}
711 lappend varcix
($v) {}
712 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
713 set varccommits
($v,$na) [lrange
$ac $i end
]
714 lappend varcstart
($v) $p
715 foreach id
$varccommits($v,$na) {
716 set varcid
($v,$id) $na
718 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
719 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
720 lset vdownptr
($v) $oa $na
721 lset vlastins
($v) $oa 0
722 lappend vupptr
($v) $oa
723 lappend vleftptr
($v) 0
724 lappend vbackptr
($v) 0
725 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
726 lset vupptr
($v) $b $na
730 proc renumbervarc
{a v
} {
731 global parents children varctok varcstart varccommits
732 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
734 set t1
[clock clicks
-milliseconds]
740 if {[info exists isrelated
($a)]} {
742 set id
[lindex
$varccommits($v,$a) end
]
743 foreach p
$parents($v,$id) {
744 if {[info exists varcid
($v,$p)]} {
745 set isrelated
($varcid($v,$p)) 1
750 set b
[lindex
$vdownptr($v) $a]
753 set b
[lindex
$vleftptr($v) $a]
755 set a
[lindex
$vupptr($v) $a]
761 if {![info exists kidchanged
($a)]} continue
762 set id
[lindex
$varcstart($v) $a]
763 if {[llength
$children($v,$id)] > 1} {
764 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
767 set oldtok
[lindex
$varctok($v) $a]
768 if {!$vdatemode($v)} {
774 set kid
[last_real_child
$v,$id]
776 set k
$varcid($v,$kid)
777 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
780 set tok
[lindex
$varctok($v) $k]
784 set i
[lsearch
-exact $parents($v,$ki) $id]
785 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
786 append tok
[strrep
$j]
788 if {$tok eq
$oldtok} {
791 set id
[lindex
$varccommits($v,$a) end
]
792 foreach p
$parents($v,$id) {
793 if {[info exists varcid
($v,$p)]} {
794 set kidchanged
($varcid($v,$p)) 1
799 lset varctok
($v) $a $tok
800 set b
[lindex
$vupptr($v) $a]
802 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
805 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
808 set c
[lindex
$vbackptr($v) $a]
809 set d
[lindex
$vleftptr($v) $a]
811 lset vdownptr
($v) $b $d
813 lset vleftptr
($v) $c $d
816 lset vbackptr
($v) $d $c
818 if {[lindex
$vlastins($v) $b] == $a} {
819 lset vlastins
($v) $b $c
821 lset vupptr
($v) $a $ka
822 set c
[lindex
$vlastins($v) $ka]
824 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
826 set b
[lindex
$vdownptr($v) $ka]
828 set b
[lindex
$vleftptr($v) $c]
831 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
833 set b
[lindex
$vleftptr($v) $c]
836 lset vdownptr
($v) $ka $a
837 lset vbackptr
($v) $a 0
839 lset vleftptr
($v) $c $a
840 lset vbackptr
($v) $a $c
842 lset vleftptr
($v) $a $b
844 lset vbackptr
($v) $b $a
846 lset vlastins
($v) $ka $a
849 foreach id
[array names sortkids
] {
850 if {[llength
$children($v,$id)] > 1} {
851 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
855 set t2
[clock clicks
-milliseconds]
856 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
859 # Fix up the graph after we have found out that in view $v,
860 # $p (a commit that we have already seen) is actually the parent
861 # of the last commit in arc $a.
862 proc fix_reversal
{p a v
} {
863 global varcid varcstart varctok vupptr
865 set pa
$varcid($v,$p)
866 if {$p ne
[lindex
$varcstart($v) $pa]} {
868 set pa
$varcid($v,$p)
870 # seeds always need to be renumbered
871 if {[lindex
$vupptr($v) $pa] == 0 ||
872 [string compare
[lindex
$varctok($v) $a] \
873 [lindex
$varctok($v) $pa]] > 0} {
878 proc insertrow
{id p v
} {
879 global cmitlisted children parents varcid varctok vtokmod
880 global varccommits ordertok commitidx numcommits curview
881 global targetid targetrow
885 set cmitlisted
($vid) 1
886 set children
($vid) {}
887 set parents
($vid) [list
$p]
888 set a
[newvarc
$v $id]
890 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
893 lappend varccommits
($v,$a) $id
895 if {[llength
[lappend children
($vp) $id]] > 1} {
896 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
897 catch
{unset ordertok
}
899 fix_reversal
$p $a $v
901 if {$v == $curview} {
902 set numcommits
$commitidx($v)
904 if {[info exists targetid
]} {
905 if {![comes_before
$targetid $p]} {
912 proc insertfakerow
{id p
} {
913 global varcid varccommits parents children cmitlisted
914 global commitidx varctok vtokmod targetid targetrow curview numcommits
918 set i
[lsearch
-exact $varccommits($v,$a) $p]
920 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
923 set children
($v,$id) {}
924 set parents
($v,$id) [list
$p]
925 set varcid
($v,$id) $a
926 lappend children
($v,$p) $id
927 set cmitlisted
($v,$id) 1
928 set numcommits
[incr commitidx
($v)]
929 # note we deliberately don't update varcstart($v) even if $i == 0
930 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
932 if {[info exists targetid
]} {
933 if {![comes_before
$targetid $p]} {
941 proc removefakerow
{id
} {
942 global varcid varccommits parents children commitidx
943 global varctok vtokmod cmitlisted currentid selectedline
944 global targetid curview numcommits
947 if {[llength
$parents($v,$id)] != 1} {
948 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
951 set p
[lindex
$parents($v,$id) 0]
952 set a
$varcid($v,$id)
953 set i
[lsearch
-exact $varccommits($v,$a) $id]
955 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
959 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
960 unset parents
($v,$id)
961 unset children
($v,$id)
962 unset cmitlisted
($v,$id)
963 set numcommits
[incr commitidx
($v) -1]
964 set j
[lsearch
-exact $children($v,$p) $id]
966 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
969 if {[info exist currentid
] && $id eq
$currentid} {
973 if {[info exists targetid
] && $targetid eq
$id} {
980 proc first_real_child
{vp
} {
981 global children nullid nullid2
983 foreach id
$children($vp) {
984 if {$id ne
$nullid && $id ne
$nullid2} {
991 proc last_real_child
{vp
} {
992 global children nullid nullid2
994 set kids
$children($vp)
995 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
996 set id
[lindex
$kids $i]
997 if {$id ne
$nullid && $id ne
$nullid2} {
1004 proc vtokcmp
{v a b
} {
1005 global varctok varcid
1007 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1008 [lindex
$varctok($v) $varcid($v,$b)]]
1011 # This assumes that if lim is not given, the caller has checked that
1012 # arc a's token is less than $vtokmod($v)
1013 proc modify_arc
{v a
{lim
{}}} {
1014 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1017 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
1020 set r
[lindex
$varcrow($v) $a]
1021 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
1024 set vtokmod
($v) [lindex
$varctok($v) $a]
1026 if {$v == $curview} {
1027 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
1028 set a
[lindex
$vupptr($v) $a]
1034 set lim
[llength
$varccommits($v,$a)]
1036 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1043 proc update_arcrows
{v
} {
1044 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1045 global varcid vrownum varcorder varcix varccommits
1046 global vupptr vdownptr vleftptr varctok
1047 global displayorder parentlist curview cached_commitrow
1049 if {$vrowmod($v) == $commitidx($v)} return
1050 if {$v == $curview} {
1051 if {[llength
$displayorder] > $vrowmod($v)} {
1052 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1053 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1055 catch
{unset cached_commitrow
}
1057 set narctot
[expr {[llength
$varctok($v)] - 1}]
1059 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1060 # go up the tree until we find something that has a row number,
1061 # or we get to a seed
1062 set a
[lindex
$vupptr($v) $a]
1065 set a
[lindex
$vdownptr($v) 0]
1068 set varcorder
($v) [list
$a]
1069 lset varcix
($v) $a 0
1070 lset varcrow
($v) $a 0
1074 set arcn
[lindex
$varcix($v) $a]
1075 if {[llength
$vrownum($v)] > $arcn + 1} {
1076 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1077 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1079 set row
[lindex
$varcrow($v) $a]
1083 incr row
[llength
$varccommits($v,$a)]
1084 # go down if possible
1085 set b
[lindex
$vdownptr($v) $a]
1087 # if not, go left, or go up until we can go left
1089 set b
[lindex
$vleftptr($v) $a]
1091 set a
[lindex
$vupptr($v) $a]
1097 lappend vrownum
($v) $row
1098 lappend varcorder
($v) $a
1099 lset varcix
($v) $a $arcn
1100 lset varcrow
($v) $a $row
1102 set vtokmod
($v) [lindex
$varctok($v) $p]
1104 set vrowmod
($v) $row
1105 if {[info exists currentid
]} {
1106 set selectedline
[rowofcommit
$currentid]
1110 # Test whether view $v contains commit $id
1111 proc commitinview
{id v
} {
1114 return [info exists varcid
($v,$id)]
1117 # Return the row number for commit $id in the current view
1118 proc rowofcommit
{id
} {
1119 global varcid varccommits varcrow curview cached_commitrow
1120 global varctok vtokmod
1123 if {![info exists varcid
($v,$id)]} {
1124 puts
"oops rowofcommit no arc for [shortids $id]"
1127 set a
$varcid($v,$id)
1128 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1131 if {[info exists cached_commitrow
($id)]} {
1132 return $cached_commitrow($id)
1134 set i
[lsearch
-exact $varccommits($v,$a) $id]
1136 puts
"oops didn't find commit [shortids $id] in arc $a"
1139 incr i
[lindex
$varcrow($v) $a]
1140 set cached_commitrow
($id) $i
1144 # Returns 1 if a is on an earlier row than b, otherwise 0
1145 proc comes_before
{a b
} {
1146 global varcid varctok curview
1149 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1150 ![info exists varcid
($v,$b)]} {
1153 if {$varcid($v,$a) != $varcid($v,$b)} {
1154 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1155 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1157 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1160 proc bsearch
{l elt
} {
1161 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1166 while {$hi - $lo > 1} {
1167 set mid
[expr {int
(($lo + $hi) / 2)}]
1168 set t
[lindex
$l $mid]
1171 } elseif
{$elt > $t} {
1180 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1181 proc make_disporder
{start end
} {
1182 global vrownum curview commitidx displayorder parentlist
1183 global varccommits varcorder parents vrowmod varcrow
1184 global d_valid_start d_valid_end
1186 if {$end > $vrowmod($curview)} {
1187 update_arcrows
$curview
1189 set ai
[bsearch
$vrownum($curview) $start]
1190 set start
[lindex
$vrownum($curview) $ai]
1191 set narc
[llength
$vrownum($curview)]
1192 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1193 set a
[lindex
$varcorder($curview) $ai]
1194 set l
[llength
$displayorder]
1195 set al
[llength
$varccommits($curview,$a)]
1196 if {$l < $r + $al} {
1198 set pad
[ntimes
[expr {$r - $l}] {}]
1199 set displayorder
[concat
$displayorder $pad]
1200 set parentlist
[concat
$parentlist $pad]
1201 } elseif
{$l > $r} {
1202 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1203 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1205 foreach id
$varccommits($curview,$a) {
1206 lappend displayorder
$id
1207 lappend parentlist
$parents($curview,$id)
1209 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1211 foreach id
$varccommits($curview,$a) {
1212 lset displayorder
$i $id
1213 lset parentlist
$i $parents($curview,$id)
1221 proc commitonrow
{row
} {
1224 set id
[lindex
$displayorder $row]
1226 make_disporder
$row [expr {$row + 1}]
1227 set id
[lindex
$displayorder $row]
1232 proc closevarcs
{v
} {
1233 global varctok varccommits varcid parents children
1234 global cmitlisted commitidx vtokmod
1236 set missing_parents
0
1238 set narcs
[llength
$varctok($v)]
1239 for {set a
1} {$a < $narcs} {incr a
} {
1240 set id
[lindex
$varccommits($v,$a) end
]
1241 foreach p
$parents($v,$id) {
1242 if {[info exists varcid
($v,$p)]} continue
1243 # add p as a new commit
1244 incr missing_parents
1245 set cmitlisted
($v,$p) 0
1246 set parents
($v,$p) {}
1247 if {[llength
$children($v,$p)] == 1 &&
1248 [llength
$parents($v,$id)] == 1} {
1251 set b
[newvarc
$v $p]
1253 set varcid
($v,$p) $b
1254 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1257 lappend varccommits
($v,$b) $p
1259 set scripts
[check_interest
$p $scripts]
1262 if {$missing_parents > 0} {
1263 foreach s
$scripts {
1269 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1270 # Assumes we already have an arc for $rwid.
1271 proc rewrite_commit
{v id rwid
} {
1272 global children parents varcid varctok vtokmod varccommits
1274 foreach ch
$children($v,$id) {
1275 # make $rwid be $ch's parent in place of $id
1276 set i
[lsearch
-exact $parents($v,$ch) $id]
1278 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1280 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1281 # add $ch to $rwid's children and sort the list if necessary
1282 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1283 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1284 $children($v,$rwid)]
1286 # fix the graph after joining $id to $rwid
1287 set a
$varcid($v,$ch)
1288 fix_reversal
$rwid $a $v
1289 # parentlist is wrong for the last element of arc $a
1290 # even if displayorder is right, hence the 3rd arg here
1291 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1295 # Mechanism for registering a command to be executed when we come
1296 # across a particular commit. To handle the case when only the
1297 # prefix of the commit is known, the commitinterest array is now
1298 # indexed by the first 4 characters of the ID. Each element is a
1299 # list of id, cmd pairs.
1300 proc interestedin
{id cmd
} {
1301 global commitinterest
1303 lappend commitinterest
([string range
$id 0 3]) $id $cmd
1306 proc check_interest
{id scripts
} {
1307 global commitinterest
1309 set prefix
[string range
$id 0 3]
1310 if {[info exists commitinterest
($prefix)]} {
1312 foreach
{i
script} $commitinterest($prefix) {
1313 if {[string match
"$i*" $id]} {
1314 lappend scripts
[string map
[list
"%I" $id "%P" $i] $script]
1316 lappend newlist
$i $script
1319 if {$newlist ne
{}} {
1320 set commitinterest
($prefix) $newlist
1322 unset commitinterest
($prefix)
1328 proc getcommitlines
{fd inst view updating
} {
1329 global cmitlisted leftover
1330 global commitidx commitdata vdatemode
1331 global parents children curview hlview
1332 global idpending ordertok
1333 global varccommits varcid varctok vtokmod vfilelimit
1335 set stuff
[read $fd 500000]
1336 # git log doesn't terminate the last commit with a null...
1337 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1344 global commfd viewcomplete viewactive viewname
1345 global viewinstances
1347 set i
[lsearch
-exact $viewinstances($view) $inst]
1349 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1351 # set it blocking so we wait for the process to terminate
1352 fconfigure
$fd -blocking 1
1353 if {[catch
{close
$fd} err
]} {
1355 if {$view != $curview} {
1356 set fv
" for the \"$viewname($view)\" view"
1358 if {[string range
$err 0 4] == "usage"} {
1359 set err
"Gitk: error reading commits$fv:\
1360 bad arguments to git log."
1361 if {$viewname($view) eq
"Command line"} {
1363 " (Note: arguments to gitk are passed to git log\
1364 to allow selection of commits to be displayed.)"
1367 set err
"Error reading commits$fv: $err"
1371 if {[incr viewactive
($view) -1] <= 0} {
1372 set viewcomplete
($view) 1
1373 # Check if we have seen any ids listed as parents that haven't
1374 # appeared in the list
1378 if {$view == $curview} {
1387 set i
[string first
"\0" $stuff $start]
1389 append leftover
($inst) [string range
$stuff $start end
]
1393 set cmit
$leftover($inst)
1394 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1395 set leftover
($inst) {}
1397 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1399 set start
[expr {$i + 1}]
1400 set j
[string first
"\n" $cmit]
1403 if {$j >= 0 && [string match
"commit *" $cmit]} {
1404 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1405 if {[string match
{[-^
<>]*} $ids]} {
1406 switch
-- [string index
$ids 0] {
1412 set ids
[string range
$ids 1 end
]
1416 if {[string length
$id] != 40} {
1424 if {[string length
$shortcmit] > 80} {
1425 set shortcmit
"[string range $shortcmit 0 80]..."
1427 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1430 set id [lindex $ids 0]
1433 if {!$listed && $updating && ![info exists varcid($vid)] &&
1434 $vfilelimit($view) ne {}} {
1435 # git log doesn't rewrite parents
for unlisted commits
1436 # when doing path limiting, so work around that here
1437 # by working out the rewritten parent with git rev-list
1438 # and if we already know about it, using the rewritten
1439 # parent as a substitute parent for $id's children.
1441 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1442 $id -- $vfilelimit($view)]
1444 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1445 # use $rwid in place of $id
1446 rewrite_commit
$view $id $rwid
1453 if {[info exists varcid
($vid)]} {
1454 if {$cmitlisted($vid) ||
!$listed} continue
1458 set olds
[lrange
$ids 1 end
]
1462 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1463 set cmitlisted
($vid) $listed
1464 set parents
($vid) $olds
1465 if {![info exists children
($vid)]} {
1466 set children
($vid) {}
1467 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1468 set k
[lindex
$children($vid) 0]
1469 if {[llength
$parents($view,$k)] == 1 &&
1470 (!$vdatemode($view) ||
1471 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1472 set a
$varcid($view,$k)
1477 set a
[newvarc
$view $id]
1479 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1482 if {![info exists varcid
($vid)]} {
1484 lappend varccommits
($view,$a) $id
1485 incr commitidx
($view)
1490 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1492 if {[llength
[lappend children
($vp) $id]] > 1 &&
1493 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1494 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1496 catch
{unset ordertok
}
1498 if {[info exists varcid
($view,$p)]} {
1499 fix_reversal
$p $a $view
1505 set scripts
[check_interest
$id $scripts]
1509 global numcommits hlview
1511 if {$view == $curview} {
1512 set numcommits
$commitidx($view)
1515 if {[info exists hlview
] && $view == $hlview} {
1516 # we never actually get here...
1519 foreach s
$scripts {
1526 proc chewcommits
{} {
1527 global curview hlview viewcomplete
1528 global pending_select
1531 if {$viewcomplete($curview)} {
1532 global commitidx varctok
1533 global numcommits startmsecs
1535 if {[info exists pending_select
]} {
1537 reset_pending_select
{}
1539 if {[commitinview
$pending_select $curview]} {
1540 selectline
[rowofcommit
$pending_select] 1
1542 set row
[first_real_row
]
1546 if {$commitidx($curview) > 0} {
1547 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1548 #puts "overall $ms ms for $numcommits commits"
1549 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1551 show_status
[mc
"No commits selected"]
1558 proc readcommit
{id
} {
1559 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1560 parsecommit
$id $contents 0
1563 proc parsecommit
{id contents listed
} {
1564 global commitinfo cdate
1573 set hdrend
[string first
"\n\n" $contents]
1575 # should never happen...
1576 set hdrend
[string length
$contents]
1578 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1579 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1580 foreach line
[split $header "\n"] {
1581 set tag
[lindex
$line 0]
1582 if {$tag == "author"} {
1583 set audate
[lindex
$line end-1
]
1584 set auname
[lrange
$line 1 end-2
]
1585 } elseif
{$tag == "committer"} {
1586 set comdate
[lindex
$line end-1
]
1587 set comname
[lrange
$line 1 end-2
]
1591 # take the first non-blank line of the comment as the headline
1592 set headline
[string trimleft
$comment]
1593 set i
[string first
"\n" $headline]
1595 set headline
[string range
$headline 0 $i]
1597 set headline
[string trimright
$headline]
1598 set i
[string first
"\r" $headline]
1600 set headline
[string trimright
[string range
$headline 0 $i]]
1603 # git log indents the comment by 4 spaces;
1604 # if we got this via git cat-file, add the indentation
1606 foreach line
[split $comment "\n"] {
1607 append newcomment
" "
1608 append newcomment
$line
1609 append newcomment
"\n"
1611 set comment
$newcomment
1613 if {$comdate != {}} {
1614 set cdate
($id) $comdate
1616 set commitinfo
($id) [list
$headline $auname $audate \
1617 $comname $comdate $comment]
1620 proc getcommit
{id
} {
1621 global commitdata commitinfo
1623 if {[info exists commitdata
($id)]} {
1624 parsecommit
$id $commitdata($id) 1
1627 if {![info exists commitinfo
($id)]} {
1628 set commitinfo
($id) [list
[mc
"No commit information available"]]
1634 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1635 # and are present in the current view.
1636 # This is fairly slow...
1637 proc longid
{prefix
} {
1638 global varcid curview
1641 foreach match
[array names varcid
"$curview,$prefix*"] {
1642 lappend ids
[lindex
[split $match ","] 1]
1648 global tagids idtags headids idheads tagobjid
1649 global otherrefids idotherrefs mainhead mainheadid
1650 global selecthead selectheadid
1652 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1655 set refd
[open
[list | git show-ref
-d] r
]
1656 while {[gets
$refd line
] >= 0} {
1657 if {[string index
$line 40] ne
" "} continue
1658 set id
[string range
$line 0 39]
1659 set ref
[string range
$line 41 end
]
1660 if {![string match
"refs/*" $ref]} continue
1661 set name
[string range
$ref 5 end
]
1662 if {[string match
"remotes/*" $name]} {
1663 if {![string match
"*/HEAD" $name]} {
1664 set headids
($name) $id
1665 lappend idheads
($id) $name
1667 } elseif
{[string match
"heads/*" $name]} {
1668 set name
[string range
$name 6 end
]
1669 set headids
($name) $id
1670 lappend idheads
($id) $name
1671 } elseif
{[string match
"tags/*" $name]} {
1672 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1673 # which is what we want since the former is the commit ID
1674 set name
[string range
$name 5 end
]
1675 if {[string match
"*^{}" $name]} {
1676 set name
[string range
$name 0 end-3
]
1678 set tagobjid
($name) $id
1680 set tagids
($name) $id
1681 lappend idtags
($id) $name
1683 set otherrefids
($name) $id
1684 lappend idotherrefs
($id) $name
1691 set mainheadid
[exec git rev-parse HEAD
]
1692 set thehead
[exec git symbolic-ref HEAD
]
1693 if {[string match
"refs/heads/*" $thehead]} {
1694 set mainhead
[string range
$thehead 11 end
]
1698 if {$selecthead ne
{}} {
1700 set selectheadid
[exec git rev-parse
--verify $selecthead]
1705 # skip over fake commits
1706 proc first_real_row
{} {
1707 global nullid nullid2 numcommits
1709 for {set row
0} {$row < $numcommits} {incr row
} {
1710 set id
[commitonrow
$row]
1711 if {$id ne
$nullid && $id ne
$nullid2} {
1718 # update things for a head moved to a child of its previous location
1719 proc movehead
{id name
} {
1720 global headids idheads
1722 removehead
$headids($name) $name
1723 set headids
($name) $id
1724 lappend idheads
($id) $name
1727 # update things when a head has been removed
1728 proc removehead
{id name
} {
1729 global headids idheads
1731 if {$idheads($id) eq
$name} {
1734 set i
[lsearch
-exact $idheads($id) $name]
1736 set idheads
($id) [lreplace
$idheads($id) $i $i]
1739 unset headids
($name)
1742 proc show_error
{w top msg
} {
1743 message
$w.m
-text $msg -justify center
-aspect 400
1744 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1745 button
$w.ok
-text [mc OK
] -command "destroy $top"
1746 pack
$w.ok
-side bottom
-fill x
1747 bind $top <Visibility
> "grab $top; focus $top"
1748 bind $top <Key-Return
> "destroy $top"
1749 bind $top <Key-space
> "destroy $top"
1750 bind $top <Key-Escape
> "destroy $top"
1754 proc error_popup msg
{
1758 show_error
$w $w $msg
1761 proc confirm_popup msg
{
1767 message
$w.m
-text $msg -justify center
-aspect 400
1768 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1769 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1770 pack
$w.ok
-side left
-fill x
1771 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1772 pack
$w.cancel
-side right
-fill x
1773 bind $w <Visibility
> "grab $w; focus $w"
1774 bind $w <Key-Return
> "set confirm_ok 1; destroy $w"
1775 bind $w <Key-space
> "set confirm_ok 1; destroy $w"
1776 bind $w <Key-Escape
> "destroy $w"
1781 proc setoptions
{} {
1782 option add
*Panedwindow.showHandle
1 startupFile
1783 option add
*Panedwindow.sashRelief raised startupFile
1784 option add
*Button.font uifont startupFile
1785 option add
*Checkbutton.font uifont startupFile
1786 option add
*Radiobutton.font uifont startupFile
1787 option add
*Menu.font uifont startupFile
1788 option add
*Menubutton.font uifont startupFile
1789 option add
*Label.font uifont startupFile
1790 option add
*Message.font uifont startupFile
1791 option add
*Entry.font uifont startupFile
1794 # Make a menu and submenus.
1795 # m is the window name for the menu, items is the list of menu items to add.
1796 # Each item is a list {mc label type description options...}
1797 # mc is ignored; it's so we can put mc there to alert xgettext
1798 # label is the string that appears in the menu
1799 # type is cascade, command or radiobutton (should add checkbutton)
1800 # description depends on type; it's the sublist for cascade, the
1801 # command to invoke for command, or {variable value} for radiobutton
1802 proc makemenu
{m items
} {
1805 set name
[mc
[lindex
$i 1]]
1806 set type [lindex
$i 2]
1807 set thing
[lindex
$i 3]
1808 set params
[list
$type]
1810 set u
[string first
"&" [string map
{&& x
} $name]]
1811 lappend params
-label [string map
{&& & & {}} $name]
1813 lappend params
-underline $u
1818 set submenu
[string tolower
[string map
{& ""} [lindex
$i 1]]]
1819 lappend params
-menu $m.
$submenu
1822 lappend params
-command $thing
1825 lappend params
-variable [lindex
$thing 0] \
1826 -value [lindex
$thing 1]
1829 eval $m add
$params [lrange
$i 4 end
]
1830 if {$type eq
"cascade"} {
1831 makemenu
$m.
$submenu $thing
1836 # translate string and remove ampersands
1838 return [string map
{&& & & {}} [mc
$str]]
1841 proc makewindow
{} {
1842 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1844 global findtype findtypemenu findloc findstring fstring geometry
1845 global entries sha1entry sha1string sha1but
1846 global diffcontextstring diffcontext
1848 global maincursor textcursor curtextcursor
1849 global rowctxmenu fakerowmenu mergemax wrapcomment
1850 global highlight_files gdttype
1851 global searchstring sstring
1852 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1853 global headctxmenu progresscanv progressitem progresscoords statusw
1854 global fprogitem fprogcoord lastprogupdate progupdatepending
1855 global rprogitem rprogcoord rownumsel numcommits
1858 # The "mc" arguments here are purely so that xgettext
1859 # sees the following string as needing to be translated
1861 {mc
"File" cascade
{
1862 {mc
"Update" command updatecommits
-accelerator F5
}
1863 {mc
"Reload" command reloadcommits
}
1864 {mc
"Reread references" command rereadrefs
}
1865 {mc
"List references" command showrefs
}
1866 {mc
"Quit" command doquit
}
1868 {mc
"Edit" cascade
{
1869 {mc
"Preferences" command doprefs
}
1871 {mc
"View" cascade
{
1872 {mc
"New view..." command {newview
0}}
1873 {mc
"Edit view..." command editview
-state disabled
}
1874 {mc
"Delete view" command delview
-state disabled
}
1876 {mc
"All files" radiobutton
{selectedview
0} -command {showview
0}}
1878 {mc
"Help" cascade
{
1879 {mc
"About gitk" command about
}
1880 {mc
"Key bindings" command keys
}
1883 . configure
-menu .bar
1885 # the gui has upper and lower half, parts of a paned window.
1886 panedwindow .ctop
-orient vertical
1888 # possibly use assumed geometry
1889 if {![info exists geometry
(pwsash0
)]} {
1890 set geometry
(topheight
) [expr {15 * $linespc}]
1891 set geometry
(topwidth
) [expr {80 * $charspc}]
1892 set geometry
(botheight
) [expr {15 * $linespc}]
1893 set geometry
(botwidth
) [expr {50 * $charspc}]
1894 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1895 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1898 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1899 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1901 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1903 # create three canvases
1904 set cscroll .tf.histframe.csb
1905 set canv .tf.histframe.pwclist.canv
1907 -selectbackground $selectbgcolor \
1908 -background $bgcolor -bd 0 \
1909 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1910 .tf.histframe.pwclist add
$canv
1911 set canv2 .tf.histframe.pwclist.canv2
1913 -selectbackground $selectbgcolor \
1914 -background $bgcolor -bd 0 -yscrollincr $linespc
1915 .tf.histframe.pwclist add
$canv2
1916 set canv3 .tf.histframe.pwclist.canv3
1918 -selectbackground $selectbgcolor \
1919 -background $bgcolor -bd 0 -yscrollincr $linespc
1920 .tf.histframe.pwclist add
$canv3
1921 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1922 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1924 # a scroll bar to rule them
1925 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1926 pack
$cscroll -side right
-fill y
1927 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1928 lappend bglist
$canv $canv2 $canv3
1929 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1931 # we have two button bars at bottom of top frame. Bar 1
1933 frame .tf.lbar
-height 15
1935 set sha1entry .tf.bar.sha1
1936 set entries
$sha1entry
1937 set sha1but .tf.bar.sha1label
1938 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
1939 -command gotocommit
-width 8
1940 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1941 pack .tf.bar.sha1label
-side left
1942 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1943 trace add variable sha1string
write sha1change
1944 pack
$sha1entry -side left
-pady 2
1946 image create bitmap bm-left
-data {
1947 #define left_width 16
1948 #define left_height 16
1949 static unsigned char left_bits
[] = {
1950 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1951 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1952 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1954 image create bitmap bm-right
-data {
1955 #define right_width 16
1956 #define right_height 16
1957 static unsigned char right_bits
[] = {
1958 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1959 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1960 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1962 button .tf.bar.leftbut
-image bm-left
-command goback \
1963 -state disabled
-width 26
1964 pack .tf.bar.leftbut
-side left
-fill y
1965 button .tf.bar.rightbut
-image bm-right
-command goforw \
1966 -state disabled
-width 26
1967 pack .tf.bar.rightbut
-side left
-fill y
1969 label .tf.bar.rowlabel
-text [mc
"Row"]
1971 label .tf.bar.rownum
-width 7 -font textfont
-textvariable rownumsel \
1972 -relief sunken
-anchor e
1973 label .tf.bar.rowlabel2
-text "/"
1974 label .tf.bar.numcommits
-width 7 -font textfont
-textvariable numcommits \
1975 -relief sunken
-anchor e
1976 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1979 trace add variable selectedline
write selectedline_change
1981 # Status label and progress bar
1982 set statusw .tf.bar.status
1983 label
$statusw -width 15 -relief sunken
1984 pack
$statusw -side left
-padx 5
1985 set h
[expr {[font metrics uifont
-linespace] + 2}]
1986 set progresscanv .tf.bar.progress
1987 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1988 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1989 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1990 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1991 pack
$progresscanv -side right
-expand 1 -fill x
1992 set progresscoords
{0 0}
1995 bind $progresscanv <Configure
> adjustprogress
1996 set lastprogupdate
[clock clicks
-milliseconds]
1997 set progupdatepending
0
1999 # build up the bottom bar of upper window
2000 label .tf.lbar.flabel
-text "[mc "Find
"] "
2001 button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
2002 button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
2003 label .tf.lbar.flab2
-text " [mc "commit
"] "
2004 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2006 set gdttype
[mc
"containing:"]
2007 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
2008 [mc
"containing:"] \
2009 [mc
"touching paths:"] \
2010 [mc
"adding/removing string:"]]
2011 trace add variable gdttype
write gdttype_change
2012 pack .tf.lbar.gdttype
-side left
-fill y
2015 set fstring .tf.lbar.findstring
2016 lappend entries
$fstring
2017 entry
$fstring -width 30 -font textfont
-textvariable findstring
2018 trace add variable findstring
write find_change
2019 set findtype
[mc
"Exact"]
2020 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
2021 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
2022 trace add variable findtype
write findcom_change
2023 set findloc
[mc
"All fields"]
2024 tk_optionMenu .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
2025 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
2026 trace add variable findloc
write find_change
2027 pack .tf.lbar.findloc
-side right
2028 pack .tf.lbar.findtype
-side right
2029 pack
$fstring -side left
-expand 1 -fill x
2031 # Finish putting the upper half of the viewer together
2032 pack .tf.lbar
-in .tf
-side bottom
-fill x
2033 pack .tf.bar
-in .tf
-side bottom
-fill x
2034 pack .tf.histframe
-fill both
-side top
-expand 1
2036 .ctop paneconfigure .tf
-height $geometry(topheight
)
2037 .ctop paneconfigure .tf
-width $geometry(topwidth
)
2039 # now build up the bottom
2040 panedwindow .pwbottom
-orient horizontal
2042 # lower left, a text box over search bar, scroll bar to the right
2043 # if we know window height, then that will set the lower text height, otherwise
2044 # we set lower text height which will drive window height
2045 if {[info exists geometry
(main
)]} {
2046 frame .bleft
-width $geometry(botwidth
)
2048 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
2054 button .bleft.top.search
-text [mc
"Search"] -command dosearch
2055 pack .bleft.top.search
-side left
-padx 5
2056 set sstring .bleft.top.sstring
2057 entry
$sstring -width 20 -font textfont
-textvariable searchstring
2058 lappend entries
$sstring
2059 trace add variable searchstring
write incrsearch
2060 pack
$sstring -side left
-expand 1 -fill x
2061 radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
2062 -command changediffdisp
-variable diffelide
-value {0 0}
2063 radiobutton .bleft.mid.old
-text [mc
"Old version"] \
2064 -command changediffdisp
-variable diffelide
-value {0 1}
2065 radiobutton .bleft.mid.new
-text [mc
"New version"] \
2066 -command changediffdisp
-variable diffelide
-value {1 0}
2067 label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
2068 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
2069 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
2070 -from 1 -increment 1 -to 10000000 \
2071 -validate all
-validatecommand "diffcontextvalidate %P" \
2072 -textvariable diffcontextstring
2073 .bleft.mid.diffcontext
set $diffcontext
2074 trace add variable diffcontextstring
write diffcontextchange
2075 lappend entries .bleft.mid.diffcontext
2076 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
2077 checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
2078 -command changeignorespace
-variable ignorespace
2079 pack .bleft.mid.ignspace
-side left
-padx 5
2080 set ctext .bleft.bottom.ctext
2081 text
$ctext -background $bgcolor -foreground $fgcolor \
2082 -state disabled
-font textfont \
2083 -yscrollcommand scrolltext
-wrap none \
2084 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2086 $ctext conf
-tabstyle wordprocessor
2088 scrollbar .bleft.bottom.sb
-command "$ctext yview"
2089 scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h \
2091 pack .bleft.top
-side top
-fill x
2092 pack .bleft.mid
-side top
-fill x
2093 grid
$ctext .bleft.bottom.sb
-sticky nsew
2094 grid .bleft.bottom.sbhorizontal
-sticky ew
2095 grid columnconfigure .bleft.bottom
0 -weight 1
2096 grid rowconfigure .bleft.bottom
0 -weight 1
2097 grid rowconfigure .bleft.bottom
1 -weight 0
2098 pack .bleft.bottom
-side top
-fill both
-expand 1
2099 lappend bglist
$ctext
2100 lappend fglist
$ctext
2102 $ctext tag conf comment
-wrap $wrapcomment
2103 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
2104 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
2105 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
2106 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
2107 $ctext tag conf m0
-fore red
2108 $ctext tag conf m1
-fore blue
2109 $ctext tag conf m2
-fore green
2110 $ctext tag conf m3
-fore purple
2111 $ctext tag conf
m4 -fore brown
2112 $ctext tag conf m5
-fore "#009090"
2113 $ctext tag conf m6
-fore magenta
2114 $ctext tag conf m7
-fore "#808000"
2115 $ctext tag conf m8
-fore "#009000"
2116 $ctext tag conf m9
-fore "#ff0080"
2117 $ctext tag conf m10
-fore cyan
2118 $ctext tag conf m11
-fore "#b07070"
2119 $ctext tag conf m12
-fore "#70b0f0"
2120 $ctext tag conf m13
-fore "#70f0b0"
2121 $ctext tag conf m14
-fore "#f0b070"
2122 $ctext tag conf m15
-fore "#ff70b0"
2123 $ctext tag conf mmax
-fore darkgrey
2125 $ctext tag conf mresult
-font textfontbold
2126 $ctext tag conf msep
-font textfontbold
2127 $ctext tag conf found
-back yellow
2129 .pwbottom add .bleft
2130 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2135 radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2136 -command reselectline
-variable cmitmode
-value "patch"
2137 radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2138 -command reselectline
-variable cmitmode
-value "tree"
2139 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2140 pack .bright.mode
-side top
-fill x
2141 set cflist .bright.cfiles
2142 set indent
[font measure mainfont
"nn"]
2144 -selectbackground $selectbgcolor \
2145 -background $bgcolor -foreground $fgcolor \
2147 -tabs [list
$indent [expr {2 * $indent}]] \
2148 -yscrollcommand ".bright.sb set" \
2149 -cursor [. cget
-cursor] \
2150 -spacing1 1 -spacing3 1
2151 lappend bglist
$cflist
2152 lappend fglist
$cflist
2153 scrollbar .bright.sb
-command "$cflist yview"
2154 pack .bright.sb
-side right
-fill y
2155 pack
$cflist -side left
-fill both
-expand 1
2156 $cflist tag configure highlight \
2157 -background [$cflist cget
-selectbackground]
2158 $cflist tag configure bold
-font mainfontbold
2160 .pwbottom add .bright
2163 # restore window width & height if known
2164 if {[info exists geometry
(main
)]} {
2165 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2166 if {$w > [winfo screenwidth .
]} {
2167 set w
[winfo screenwidth .
]
2169 if {$h > [winfo screenheight .
]} {
2170 set h
[winfo screenheight .
]
2172 wm geometry .
"${w}x$h"
2176 if {[tk windowingsystem
] eq
{aqua
}} {
2182 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2183 pack .ctop
-fill both
-expand 1
2184 bindall
<1> {selcanvline
%W
%x
%y
}
2185 #bindall <B1-Motion> {selcanvline %W %x %y}
2186 if {[tk windowingsystem
] == "win32"} {
2187 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2188 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2190 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2191 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2192 if {[tk windowingsystem
] eq
"aqua"} {
2193 bindall
<MouseWheel
> {
2194 set delta
[expr {- (%D
)}]
2195 allcanvs yview scroll
$delta units
2199 bindall
<2> "canvscan mark %W %x %y"
2200 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
2201 bindkey
<Home
> selfirstline
2202 bindkey
<End
> sellastline
2203 bind .
<Key-Up
> "selnextline -1"
2204 bind .
<Key-Down
> "selnextline 1"
2205 bind .
<Shift-Key-Up
> "dofind -1 0"
2206 bind .
<Shift-Key-Down
> "dofind 1 0"
2207 bindkey
<Key-Right
> "goforw"
2208 bindkey
<Key-Left
> "goback"
2209 bind .
<Key-Prior
> "selnextpage -1"
2210 bind .
<Key-Next
> "selnextpage 1"
2211 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2212 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2213 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2214 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2215 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2216 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2217 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2218 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2219 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2220 bindkey p
"selnextline -1"
2221 bindkey n
"selnextline 1"
2224 bindkey i
"selnextline -1"
2225 bindkey k
"selnextline 1"
2229 bindkey d
"$ctext yview scroll 18 units"
2230 bindkey u
"$ctext yview scroll -18 units"
2231 bindkey
/ {dofind
1 1}
2232 bindkey
<Key-Return
> {dofind
1 1}
2233 bindkey ?
{dofind
-1 1}
2235 bindkey
<F5
> updatecommits
2236 bind .
<$M1B-q> doquit
2237 bind .
<$M1B-f> {dofind
1 1}
2238 bind .
<$M1B-g> {dofind
1 0}
2239 bind .
<$M1B-r> dosearchback
2240 bind .
<$M1B-s> dosearch
2241 bind .
<$M1B-equal> {incrfont
1}
2242 bind .
<$M1B-plus> {incrfont
1}
2243 bind .
<$M1B-KP_Add> {incrfont
1}
2244 bind .
<$M1B-minus> {incrfont
-1}
2245 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2246 wm protocol . WM_DELETE_WINDOW doquit
2247 bind .
<Destroy
> {stop_backends
}
2248 bind .
<Button-1
> "click %W"
2249 bind $fstring <Key-Return
> {dofind
1 1}
2250 bind $sha1entry <Key-Return
> {gotocommit
; break}
2251 bind $sha1entry <<PasteSelection>> clearsha1
2252 bind $cflist <1> {sel_flist %W %x %y; break}
2253 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2254 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2256 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2257 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2259 set maincursor [. cget -cursor]
2260 set textcursor [$ctext cget -cursor]
2261 set curtextcursor $textcursor
2263 set rowctxmenu .rowctxmenu
2264 makemenu $rowctxmenu {
2265 {mc "Diff this -> selected" command {diffvssel 0}}
2266 {mc "Diff selected -> this" command {diffvssel 1}}
2267 {mc "Make patch" command mkpatch}
2268 {mc "Create tag" command mktag}
2269 {mc "Write commit to file" command writecommit}
2270 {mc "Create new branch" command mkbranch}
2271 {mc "Cherry-pick this commit" command cherrypick}
2272 {mc "Reset HEAD branch to here" command resethead}
2274 $rowctxmenu configure -tearoff 0
2276 set fakerowmenu .fakerowmenu
2277 makemenu $fakerowmenu {
2278 {mc "Diff this -> selected" command {diffvssel 0}}
2279 {mc "Diff selected -> this" command {diffvssel 1}}
2280 {mc "Make patch" command mkpatch}
2282 $fakerowmenu configure -tearoff 0
2284 set headctxmenu .headctxmenu
2285 makemenu $headctxmenu {
2286 {mc "Check out this branch" command cobranch}
2287 {mc "Remove this branch" command rmbranch}
2289 $headctxmenu configure -tearoff 0
2292 set flist_menu .flistctxmenu
2293 makemenu $flist_menu {
2294 {mc "Highlight this too" command {flist_hl 0}}
2295 {mc "Highlight this only" command {flist_hl 1}}
2296 {mc "External diff" command {external_diff}}
2297 {mc "Blame parent commit" command {external_blame 1}}
2299 $flist_menu configure -tearoff 0
2302 set diff_menu .diffctxmenu
2303 makemenu $diff_menu {
2304 {mc "Show origin of this line" command show_line_source}
2305 {mc "Run git gui blame on this line" command {external_blame_diff}}
2307 $diff_menu configure -tearoff 0
2310 # Windows sends all mouse wheel events to the current focused window, not
2311 # the one where the mouse hovers, so bind those events here and redirect
2312 # to the correct window
2313 proc windows_mousewheel_redirector {W X Y D} {
2314 global canv canv2 canv3
2315 set w [winfo containing -displayof $W $X $Y]
2317 set u [expr {$D < 0 ? 5 : -5}]
2318 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2319 allcanvs yview scroll $u units
2322 $w yview scroll $u units
2328 # Update row number label when selectedline changes
2329 proc selectedline_change {n1 n2 op} {
2330 global selectedline rownumsel
2332 if {$selectedline eq {}} {
2335 set rownumsel [expr {$selectedline + 1}]
2339 # mouse-2 makes all windows scan vertically, but only the one
2340 # the cursor is in scans horizontally
2341 proc canvscan {op w x y} {
2342 global canv canv2 canv3
2343 foreach c [list $canv $canv2 $canv3] {
2352 proc scrollcanv {cscroll f0 f1} {
2353 $cscroll set $f0 $f1
2358 # when we make a key binding for the toplevel, make sure
2359 # it doesn't get triggered when that key is pressed in the
2360 # find string entry widget.
2361 proc bindkey {ev script} {
2364 set escript [bind Entry $ev]
2365 if {$escript == {}} {
2366 set escript [bind Entry <Key>]
2368 foreach e $entries {
2369 bind $e $ev "$escript; break"
2373 # set the focus back to the toplevel for any click outside
2376 global ctext entries
2377 foreach e [concat $entries $ctext] {
2378 if {$w == $e} return
2383 # Adjust the progress bar for a change in requested extent or canvas size
2384 proc adjustprogress {} {
2385 global progresscanv progressitem progresscoords
2386 global fprogitem fprogcoord lastprogupdate progupdatepending
2387 global rprogitem rprogcoord
2389 set w [expr {[winfo width $progresscanv] - 4}]
2390 set x0 [expr {$w * [lindex $progresscoords 0]}]
2391 set x1 [expr {$w * [lindex $progresscoords 1]}]
2392 set h [winfo height $progresscanv]
2393 $progresscanv coords $progressitem $x0 0 $x1 $h
2394 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2395 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2396 set now [clock clicks -milliseconds]
2397 if {$now >= $lastprogupdate + 100} {
2398 set progupdatepending 0
2400 } elseif {!$progupdatepending} {
2401 set progupdatepending 1
2402 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2406 proc doprogupdate {} {
2407 global lastprogupdate progupdatepending
2409 if {$progupdatepending} {
2410 set progupdatepending 0
2411 set lastprogupdate [clock clicks -milliseconds]
2416 proc savestuff {w} {
2417 global canv canv2 canv3 mainfont textfont uifont tabstop
2418 global stuffsaved findmergefiles maxgraphpct
2419 global maxwidth showneartags showlocalchanges
2420 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2421 global cmitmode wrapcomment datetimeformat limitdiffs
2422 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2423 global autoselect extdifftool perfile_attrs markbgcolor
2425 if {$stuffsaved} return
2426 if {![winfo viewable .]} return
2428 set f [open "~/.gitk-new" w]
2429 puts $f [list set mainfont $mainfont]
2430 puts $f [list set textfont $textfont]
2431 puts $f [list set uifont $uifont]
2432 puts $f [list set tabstop $tabstop]
2433 puts $f [list set findmergefiles $findmergefiles]
2434 puts $f [list set maxgraphpct $maxgraphpct]
2435 puts $f [list set maxwidth $maxwidth]
2436 puts $f [list set cmitmode $cmitmode]
2437 puts $f [list set wrapcomment $wrapcomment]
2438 puts $f [list set autoselect $autoselect]
2439 puts $f [list set showneartags $showneartags]
2440 puts $f [list set showlocalchanges $showlocalchanges]
2441 puts $f [list set datetimeformat $datetimeformat]
2442 puts $f [list set limitdiffs $limitdiffs]
2443 puts $f [list set bgcolor $bgcolor]
2444 puts $f [list set fgcolor $fgcolor]
2445 puts $f [list set colors $colors]
2446 puts $f [list set diffcolors $diffcolors]
2447 puts $f [list set markbgcolor $markbgcolor]
2448 puts $f [list set diffcontext $diffcontext]
2449 puts $f [list set selectbgcolor $selectbgcolor]
2450 puts $f [list set extdifftool $extdifftool]
2451 puts $f [list set perfile_attrs $perfile_attrs]
2453 puts $f "set geometry(main) [wm geometry .]"
2454 puts $f "set geometry(topwidth) [winfo width .tf]"
2455 puts $f "set geometry(topheight) [winfo height .tf]"
2456 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2457 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2458 puts $f "set geometry(botwidth) [winfo width .bleft]"
2459 puts $f "set geometry(botheight) [winfo height .bleft]"
2461 puts -nonewline $f "set permviews {"
2462 for {set v 0} {$v < $nextviewnum} {incr v} {
2463 if {$viewperm($v)} {
2464 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2469 file rename -force "~/.gitk-new" "~/.gitk"
2474 proc resizeclistpanes {win w} {
2476 if {[info exists oldwidth($win)]} {
2477 set s0 [$win sash coord 0]
2478 set s1 [$win sash coord 1]
2480 set sash0 [expr {int($w/2 - 2)}]
2481 set sash1 [expr {int($w*5/6 - 2)}]
2483 set factor [expr {1.0 * $w / $oldwidth($win)}]
2484 set sash0 [expr {int($factor * [lindex $s0 0])}]
2485 set sash1 [expr {int($factor * [lindex $s1 0])}]
2489 if {$sash1 < $sash0 + 20} {
2490 set sash1 [expr {$sash0 + 20}]
2492 if {$sash1 > $w - 10} {
2493 set sash1 [expr {$w - 10}]
2494 if {$sash0 > $sash1 - 20} {
2495 set sash0 [expr {$sash1 - 20}]
2499 $win sash place 0 $sash0 [lindex $s0 1]
2500 $win sash place 1 $sash1 [lindex $s1 1]
2502 set oldwidth($win) $w
2505 proc resizecdetpanes {win w} {
2507 if {[info exists oldwidth($win)]} {
2508 set s0 [$win sash coord 0]
2510 set sash0 [expr {int($w*3/4 - 2)}]
2512 set factor [expr {1.0 * $w / $oldwidth($win)}]
2513 set sash0 [expr {int($factor * [lindex $s0 0])}]
2517 if {$sash0 > $w - 15} {
2518 set sash0 [expr {$w - 15}]
2521 $win sash place 0 $sash0 [lindex $s0 1]
2523 set oldwidth($win) $w
2526 proc allcanvs args {
2527 global canv canv2 canv3
2533 proc bindall {event action} {
2534 global canv canv2 canv3
2535 bind $canv $event $action
2536 bind $canv2 $event $action
2537 bind $canv3 $event $action
2543 if {[winfo exists $w]} {
2548 wm title $w [mc "About gitk"]
2549 message $w.m -text [mc "
2550 Gitk - a commit viewer for git
2552 Copyright © 2005-2008 Paul Mackerras
2554 Use and redistribute under the terms of the GNU General Public License"] \
2555 -justify center -aspect 400 -border 2 -bg white -relief groove
2556 pack $w.m -side top -fill x -padx 2 -pady 2
2557 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2558 pack $w.ok -side bottom
2559 bind $w <Visibility> "focus $w.ok"
2560 bind $w <Key-Escape> "destroy $w"
2561 bind $w <Key-Return> "destroy $w"
2566 if {[winfo exists $w]} {
2570 if {[tk windowingsystem] eq {aqua}} {
2576 wm title $w [mc "Gitk key bindings"]
2577 message $w.m -text "
2578 [mc "Gitk key bindings:"]
2580 [mc "<%s-Q> Quit" $M1T]
2581 [mc "<Home> Move to first commit"]
2582 [mc "<End> Move to last commit"]
2583 [mc "<Up>, p, i Move up one commit"]
2584 [mc "<Down>, n, k Move down one commit"]
2585 [mc "<Left>, z, j Go back in history list"]
2586 [mc "<Right>, x, l Go forward in history list"]
2587 [mc "<PageUp> Move up one page in commit list"]
2588 [mc "<PageDown> Move down one page in commit list"]
2589 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2590 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2591 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2592 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2593 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2594 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2595 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2596 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2597 [mc "<Delete>, b Scroll diff view up one page"]
2598 [mc "<Backspace> Scroll diff view up one page"]
2599 [mc "<Space> Scroll diff view down one page"]
2600 [mc "u Scroll diff view up 18 lines"]
2601 [mc "d Scroll diff view down 18 lines"]
2602 [mc "<%s-F> Find" $M1T]
2603 [mc "<%s-G> Move to next find hit" $M1T]
2604 [mc "<Return> Move to next find hit"]
2605 [mc "/ Move to next find hit, or redo find"]
2606 [mc "? Move to previous find hit"]
2607 [mc "f Scroll diff view to next file"]
2608 [mc "<%s-S> Search for next hit in diff view" $M1T]
2609 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2610 [mc "<%s-KP+> Increase font size" $M1T]
2611 [mc "<%s-plus> Increase font size" $M1T]
2612 [mc "<%s-KP-> Decrease font size" $M1T]
2613 [mc "<%s-minus> Decrease font size" $M1T]
2616 -justify left -bg white -border 2 -relief groove
2617 pack $w.m -side top -fill both -padx 2 -pady 2
2618 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2619 bind $w <Key-Escape> [list destroy $w]
2620 pack $w.ok -side bottom
2621 bind $w <Visibility> "focus $w.ok"
2622 bind $w <Key-Escape> "destroy $w"
2623 bind $w <Key-Return> "destroy $w"
2626 # Procedures for manipulating the file list window at the
2627 # bottom right of the overall window.
2629 proc treeview {w l openlevs} {
2630 global treecontents treediropen treeheight treeparent treeindex
2640 set treecontents() {}
2641 $w conf -state normal
2643 while {[string range $f 0 $prefixend] ne $prefix} {
2644 if {$lev <= $openlevs} {
2645 $w mark set e:$treeindex($prefix) "end -1c"
2646 $w mark gravity e:$treeindex($prefix) left
2648 set treeheight($prefix) $ht
2649 incr ht [lindex $htstack end]
2650 set htstack [lreplace $htstack end end]
2651 set prefixend [lindex $prefendstack end]
2652 set prefendstack [lreplace $prefendstack end end]
2653 set prefix [string range $prefix 0 $prefixend]
2656 set tail [string range $f [expr {$prefixend+1}] end]
2657 while {[set slash [string first "/" $tail]] >= 0} {
2660 lappend prefendstack $prefixend
2661 incr prefixend [expr {$slash + 1}]
2662 set d [string range $tail 0 $slash]
2663 lappend treecontents($prefix) $d
2664 set oldprefix $prefix
2666 set treecontents($prefix) {}
2667 set treeindex($prefix) [incr ix]
2668 set treeparent($prefix) $oldprefix
2669 set tail [string range $tail [expr {$slash+1}] end]
2670 if {$lev <= $openlevs} {
2672 set treediropen($prefix) [expr {$lev < $openlevs}]
2673 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2674 $w mark set d:$ix "end -1c"
2675 $w mark gravity d:$ix left
2677 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2679 $w image create end -align center -image $bm -padx 1 \
2681 $w insert end $d [highlight_tag $prefix]
2682 $w mark set s:$ix "end -1c"
2683 $w mark gravity s:$ix left
2688 if {$lev <= $openlevs} {
2691 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2693 $w insert end $tail [highlight_tag $f]
2695 lappend treecontents($prefix) $tail
2698 while {$htstack ne {}} {
2699 set treeheight($prefix) $ht
2700 incr ht [lindex $htstack end]
2701 set htstack [lreplace $htstack end end]
2702 set prefixend [lindex $prefendstack end]
2703 set prefendstack [lreplace $prefendstack end end]
2704 set prefix [string range $prefix 0 $prefixend]
2706 $w conf -state disabled
2709 proc linetoelt {l} {
2710 global treeheight treecontents
2715 foreach e $treecontents($prefix) {
2720 if {[string index $e end] eq "/"} {
2721 set n $treeheight($prefix$e)
2733 proc highlight_tree {y prefix} {
2734 global treeheight treecontents cflist
2736 foreach e $treecontents($prefix) {
2738 if {[highlight_tag $path] ne {}} {
2739 $cflist tag add bold $y.0 "$y.0 lineend"
2742 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2743 set y [highlight_tree $y $path]
2749 proc treeclosedir {w dir} {
2750 global treediropen treeheight treeparent treeindex
2752 set ix $treeindex($dir)
2753 $w conf -state normal
2754 $w delete s:$ix e:$ix
2755 set treediropen($dir) 0
2756 $w image configure a:$ix -image tri-rt
2757 $w conf -state disabled
2758 set n [expr {1 - $treeheight($dir)}]
2759 while {$dir ne {}} {
2760 incr treeheight($dir) $n
2761 set dir $treeparent($dir)
2765 proc treeopendir {w dir} {
2766 global treediropen treeheight treeparent treecontents treeindex
2768 set ix $treeindex($dir)
2769 $w conf -state normal
2770 $w image configure a:$ix -image tri-dn
2771 $w mark set e:$ix s:$ix
2772 $w mark gravity e:$ix right
2775 set n [llength $treecontents($dir)]
2776 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2779 incr treeheight($x) $n
2781 foreach e $treecontents($dir) {
2783 if {[string index $e end] eq "/"} {
2784 set iy $treeindex($de)
2785 $w mark set d:$iy e:$ix
2786 $w mark gravity d:$iy left
2787 $w insert e:$ix $str
2788 set treediropen($de) 0
2789 $w image create e:$ix -align center -image tri-rt -padx 1 \
2791 $w insert e:$ix $e [highlight_tag $de]
2792 $w mark set s:$iy e:$ix
2793 $w mark gravity s:$iy left
2794 set treeheight($de) 1
2796 $w insert e:$ix $str
2797 $w insert e:$ix $e [highlight_tag $de]
2800 $w mark gravity e:$ix right
2801 $w conf -state disabled
2802 set treediropen($dir) 1
2803 set top [lindex [split [$w index @0,0] .] 0]
2804 set ht [$w cget -height]
2805 set l [lindex [split [$w index s:$ix] .] 0]
2808 } elseif {$l + $n + 1 > $top + $ht} {
2809 set top [expr {$l + $n + 2 - $ht}]
2817 proc treeclick {w x y} {
2818 global treediropen cmitmode ctext cflist cflist_top
2820 if {$cmitmode ne "tree"} return
2821 if {![info exists cflist_top]} return
2822 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2823 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2824 $cflist tag add highlight $l.0 "$l.0 lineend"
2830 set e [linetoelt $l]
2831 if {[string index $e end] ne "/"} {
2833 } elseif {$treediropen($e)} {
2840 proc setfilelist {id} {
2841 global treefilelist cflist jump_to_here
2843 treeview $cflist $treefilelist($id) 0
2844 if {$jump_to_here ne {}} {
2845 set f [lindex $jump_to_here 0]
2846 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2852 image create bitmap tri-rt -background black -foreground blue -data {
2853 #define tri-rt_width 13
2854 #define tri-rt_height 13
2855 static unsigned char tri-rt_bits[] = {
2856 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2857 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2860 #define tri-rt-mask_width 13
2861 #define tri-rt-mask_height 13
2862 static unsigned char tri-rt-mask_bits[] = {
2863 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2864 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2867 image create bitmap tri-dn -background black -foreground blue -data {
2868 #define tri-dn_width 13
2869 #define tri-dn_height 13
2870 static unsigned char tri-dn_bits[] = {
2871 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2872 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2875 #define tri-dn-mask_width 13
2876 #define tri-dn-mask_height 13
2877 static unsigned char tri-dn-mask_bits[] = {
2878 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2879 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2883 image create bitmap reficon-T -background black -foreground yellow -data {
2884 #define tagicon_width 13
2885 #define tagicon_height 9
2886 static unsigned char tagicon_bits[] = {
2887 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2888 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2890 #define tagicon-mask_width 13
2891 #define tagicon-mask_height 9
2892 static unsigned char tagicon-mask_bits[] = {
2893 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2894 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2897 #define headicon_width 13
2898 #define headicon_height 9
2899 static unsigned char headicon_bits[] = {
2900 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2901 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2904 #define headicon-mask_width 13
2905 #define headicon-mask_height 9
2906 static unsigned char headicon-mask_bits[] = {
2907 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2908 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2910 image create bitmap reficon-H -background black -foreground green \
2911 -data $rectdata -maskdata $rectmask
2912 image create bitmap reficon-o -background black -foreground "#ddddff" \
2913 -data $rectdata -maskdata $rectmask
2915 proc init_flist {first} {
2916 global cflist cflist_top difffilestart
2918 $cflist conf -state normal
2919 $cflist delete 0.0 end
2921 $cflist insert end $first
2923 $cflist tag add highlight 1.0 "1.0 lineend"
2925 catch {unset cflist_top}
2927 $cflist conf -state disabled
2928 set difffilestart {}
2931 proc highlight_tag {f} {
2932 global highlight_paths
2934 foreach p $highlight_paths {
2935 if {[string match $p $f]} {
2942 proc highlight_filelist {} {
2943 global cmitmode cflist
2945 $cflist conf -state normal
2946 if {$cmitmode ne "tree"} {
2947 set end [lindex [split [$cflist index end] .] 0]
2948 for {set l 2} {$l < $end} {incr l} {
2949 set line [$cflist get $l.0 "$l.0 lineend"]
2950 if {[highlight_tag $line] ne {}} {
2951 $cflist tag add bold $l.0 "$l.0 lineend"
2957 $cflist conf -state disabled
2960 proc unhighlight_filelist {} {
2963 $cflist conf -state normal
2964 $cflist tag remove bold 1.0 end
2965 $cflist conf -state disabled
2968 proc add_flist {fl} {
2971 $cflist conf -state normal
2973 $cflist insert end "\n"
2974 $cflist insert end $f [highlight_tag $f]
2976 $cflist conf -state disabled
2979 proc sel_flist {w x y} {
2980 global ctext difffilestart cflist cflist_top cmitmode
2982 if {$cmitmode eq "tree"} return
2983 if {![info exists cflist_top]} return
2984 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2985 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2986 $cflist tag add highlight $l.0 "$l.0 lineend"
2991 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2995 proc pop_flist_menu {w X Y x y} {
2996 global ctext cflist cmitmode flist_menu flist_menu_file
2997 global treediffs diffids
3000 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3002 if {$cmitmode eq "tree"} {
3003 set e [linetoelt $l]
3004 if {[string index $e end] eq "/"} return
3006 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3008 set flist_menu_file $e
3009 set xdiffstate "normal"
3010 if {$cmitmode eq "tree"} {
3011 set xdiffstate "disabled"
3013 # Disable "External diff" item in tree mode
3014 $flist_menu entryconf 2 -state $xdiffstate
3015 tk_popup $flist_menu $X $Y
3018 proc find_ctext_fileinfo {line} {
3019 global ctext_file_names ctext_file_lines
3021 set ok [bsearch $ctext_file_lines $line]
3022 set tline [lindex $ctext_file_lines $ok]
3024 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3027 return [list [lindex $ctext_file_names $ok] $tline]
3031 proc pop_diff_menu {w X Y x y} {
3032 global ctext diff_menu flist_menu_file
3033 global diff_menu_txtpos diff_menu_line
3034 global diff_menu_filebase
3036 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3037 set diff_menu_line [lindex $diff_menu_txtpos 0]
3038 # don't pop up the menu on hunk-separator or file-separator lines
3039 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3043 set f [find_ctext_fileinfo $diff_menu_line]
3044 if {$f eq {}} return
3045 set flist_menu_file [lindex $f 0]
3046 set diff_menu_filebase [lindex $f 1]
3047 tk_popup $diff_menu $X $Y
3050 proc flist_hl {only} {
3051 global flist_menu_file findstring gdttype
3053 set x [shellquote $flist_menu_file]
3054 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3057 append findstring " " $x
3059 set gdttype [mc "touching paths:"]
3062 proc save_file_from_commit {filename output what} {
3065 if {[catch {exec git show $filename -- > $output} err]} {
3066 if {[string match "fatal: bad revision *" $err]} {
3069 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3075 proc external_diff_get_one_file {diffid filename diffdir} {
3076 global nullid nullid2 nullfile
3079 if {$diffid == $nullid} {
3080 set difffile [file join [file dirname $gitdir] $filename]
3081 if {[file exists $difffile]} {
3086 if {$diffid == $nullid2} {
3087 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3088 return [save_file_from_commit :$filename $difffile index]
3090 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3091 return [save_file_from_commit $diffid:$filename $difffile \
3095 proc external_diff {} {
3096 global gitktmpdir nullid nullid2
3097 global flist_menu_file
3100 global gitdir extdifftool
3102 if {[llength $diffids] == 1} {
3103 # no reference commit given
3104 set diffidto [lindex $diffids 0]
3105 if {$diffidto eq $nullid} {
3106 # diffing working copy with index
3107 set diffidfrom $nullid2
3108 } elseif {$diffidto eq $nullid2} {
3109 # diffing index with HEAD
3110 set diffidfrom "HEAD"
3112 # use first parent commit
3113 global parentlist selectedline
3114 set diffidfrom [lindex $parentlist $selectedline 0]
3117 set diffidfrom [lindex $diffids 0]
3118 set diffidto [lindex $diffids 1]
3121 # make sure that several diffs wont collide
3122 if {![info exists gitktmpdir]} {
3123 set gitktmpdir [file join [file dirname $gitdir] \
3124 [format ".gitk-tmp.%s" [pid]]]
3125 if {[catch {file mkdir $gitktmpdir} err]} {
3126 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3133 set diffdir [file join $gitktmpdir $diffnum]
3134 if {[catch {file mkdir $diffdir} err]} {
3135 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3139 # gather files to diff
3140 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3141 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3143 if {$difffromfile ne {} && $difftofile ne {}} {
3144 set cmd [concat | [shellsplit $extdifftool] \
3145 [list $difffromfile $difftofile]]
3146 if {[catch {set fl [open $cmd r]} err]} {
3147 file delete -force $diffdir
3148 error_popup "$extdifftool: [mc "command failed:"] $err"
3150 fconfigure $fl -blocking 0
3151 filerun $fl [list delete_at_eof $fl $diffdir]
3156 proc find_hunk_blamespec {base line} {
3159 # Find and parse the hunk header
3160 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3161 if {$s_lix eq {}} return
3163 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3164 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3165 s_line old_specs osz osz1 new_line nsz]} {
3169 # base lines for the parents
3170 set base_lines [list $new_line]
3171 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3172 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3173 old_spec old_line osz]} {
3176 lappend base_lines $old_line
3179 # Now scan the lines to determine offset within the hunk
3180 set max_parent [expr {[llength $base_lines]-2}]
3182 set s_lno [lindex [split $s_lix "."] 0]
3184 # Determine if the line is removed
3185 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3186 if {[string match {[-+ ]*} $chunk]} {
3187 set removed_idx [string first "-" $chunk]
3188 # Choose a parent index
3189 if {$removed_idx >= 0} {
3190 set parent $removed_idx
3192 set unchanged_idx [string first " " $chunk]
3193 if {$unchanged_idx >= 0} {
3194 set parent $unchanged_idx
3196 # blame the current commit
3200 # then count other lines that belong to it
3201 for {set i $line} {[incr i -1] > $s_lno} {} {
3202 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3203 # Determine if the line is removed
3204 set removed_idx [string first "-" $chunk]
3206 set code [string index $chunk $parent]
3207 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3211 if {$removed_idx < 0} {
3221 incr dline [lindex $base_lines $parent]
3222 return [list $parent $dline]
3225 proc external_blame_diff {} {
3226 global currentid diffmergeid cmitmode
3227 global diff_menu_txtpos diff_menu_line
3228 global diff_menu_filebase flist_menu_file
3230 if {$cmitmode eq "tree"} {
3232 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3234 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3236 set parent_idx [lindex $hinfo 0]
3237 set line [lindex $hinfo 1]
3244 external_blame $parent_idx $line
3247 proc external_blame {parent_idx {line {}}} {
3248 global flist_menu_file
3249 global nullid nullid2
3250 global parentlist selectedline currentid
3252 if {$parent_idx > 0} {
3253 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3255 set base_commit $currentid
3258 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3259 error_popup [mc "No such commit"]
3263 set cmdline [list git gui blame]
3264 if {$line ne {} && $line > 1} {
3265 lappend cmdline "--line=$line"
3267 lappend cmdline $base_commit $flist_menu_file
3268 if {[catch {eval exec $cmdline &} err]} {
3269 error_popup "[mc "git gui blame: command failed:"] $err"
3273 proc show_line_source {} {
3274 global cmitmode currentid parents curview blamestuff blameinst
3275 global diff_menu_line diff_menu_filebase flist_menu_file
3277 if {$cmitmode eq "tree"} {
3279 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3281 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3282 if {$h eq {}} return
3283 set pi [lindex $h 0]
3285 mark_ctext_line $diff_menu_line
3288 set id [lindex $parents($curview,$currentid) [expr {$pi - 1}]]
3289 set line [lindex $h 1]
3292 set f [open [list | git blame -p -L$line,+1 $id -- $flist_menu_file] r]
3294 error_popup [mc "Couldn't start git blame: %s" $err]
3297 fconfigure $f -blocking 0
3298 set i [reg_instance $f]
3299 set blamestuff($i) {}
3301 filerun $f [list read_line_source $f $i]
3304 proc stopblaming {} {
3307 if {[info exists blameinst]} {
3308 stop_instance $blameinst
3313 proc read_line_source {fd inst} {
3314 global blamestuff curview commfd blameinst
3316 while {[gets $fd line] >= 0} {
3317 lappend blamestuff($inst) $line
3324 fconfigure $fd -blocking 1
3325 if {[catch {close $fd} err]} {
3326 error_popup [mc "Error running git blame: %s" $err]
3331 set line [split [lindex $blamestuff($inst) 0] " "]
3332 set id [lindex $line 0]
3333 set lnum [lindex $line 1]
3334 if {[string length $id] == 40 && [string is xdigit $id] &&
3335 [string is digit -strict $lnum]} {
3336 # look for "filename" line
3337 foreach l $blamestuff($inst) {
3338 if {[string match "filename *" $l]} {
3339 set fname [string range $l 9 end]
3345 # all looks good, select it
3346 if {[commitinview $id $curview]} {
3347 selectline [rowofcommit $id] 1 [list $fname $lnum]
3349 error_popup [mc "That line comes from commit %s, \
3350 which is not in this view" [shortids $id]]
3353 puts "oops couldn't parse git blame output"
3358 # delete $dir when we see eof on $f (presumably because the child has exited)
3359 proc delete_at_eof {f dir} {
3360 while {[gets $f line] >= 0} {}
3362 if {[catch {close $f} err]} {
3363 error_popup "[mc "External diff viewer failed:"] $err"
3365 file delete -force $dir
3371 # Functions for adding and removing shell-type quoting
3373 proc shellquote {str} {
3374 if {![string match "*\['\"\\ \t]*" $str]} {
3377 if {![string match "*\['\"\\]*" $str]} {
3380 if {![string match "*'*" $str]} {
3383 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3386 proc shellarglist {l} {
3392 append str [shellquote $a]
3397 proc shelldequote {str} {
3402 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3403 append ret [string range $str $used end]
3404 set used [string length $str]
3407 set first [lindex $first 0]
3408 set ch [string index $str $first]
3409 if {$first > $used} {
3410 append ret [string range $str $used [expr {$first - 1}]]
3413 if {$ch eq " " || $ch eq "\t"} break
3416 set first [string first "'" $str $used]
3418 error "unmatched single-quote"
3420 append ret [string range $str $used [expr {$first - 1}]]
3425 if {$used >= [string length $str]} {
3426 error "trailing backslash"
3428 append ret [string index $str $used]
3433 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3434 error "unmatched double-quote"
3436 set first [lindex $first 0]
3437 set ch [string index $str $first]
3438 if {$first > $used} {
3439 append ret [string range $str $used [expr {$first - 1}]]
3442 if {$ch eq "\""} break
3444 append ret [string index $str $used]
3448 return [list $used $ret]
3451 proc shellsplit {str} {
3454 set str [string trimleft $str]
3455 if {$str eq {}} break
3456 set dq [shelldequote $str]
3457 set n [lindex $dq 0]
3458 set word [lindex $dq 1]
3459 set str [string range $str $n end]
3465 # Code to implement multiple views
3467 proc newview {ishighlight} {
3468 global nextviewnum newviewname newviewperm newishighlight
3469 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3471 set newishighlight $ishighlight
3473 if {[winfo exists $top]} {
3477 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3478 set newviewperm($nextviewnum) 0
3479 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3480 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3481 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3486 global viewname viewperm newviewname newviewperm
3487 global viewargs newviewargs viewargscmd newviewargscmd
3489 set top .gitkvedit-$curview
3490 if {[winfo exists $top]} {
3494 set newviewname($curview) $viewname($curview)
3495 set newviewperm($curview) $viewperm($curview)
3496 set newviewargs($curview) [shellarglist $viewargs($curview)]
3497 set newviewargscmd($curview) $viewargscmd($curview)
3498 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3501 proc vieweditor {top n title} {
3502 global newviewname newviewperm viewfiles bgcolor
3505 wm title $top $title
3506 label $top.nl -text [mc "Name"]
3507 entry $top.name -width 20 -textvariable newviewname($n)
3508 grid $top.nl $top.name -sticky w -pady 5
3509 checkbutton $top.perm -text [mc "Remember this view"] \
3510 -variable newviewperm($n)
3511 grid $top.perm - -pady 5 -sticky w
3512 message $top.al -aspect 1000 \
3513 -text [mc "Commits to include (arguments to git log):"]
3514 grid $top.al - -sticky w -pady 5
3515 entry $top.args -width 50 -textvariable newviewargs($n) \
3516 -background $bgcolor
3517 grid $top.args - -sticky ew -padx 5
3519 message $top.ac -aspect 1000 \
3520 -text [mc "Command to generate more commits to include:"]
3521 grid $top.ac - -sticky w -pady 5
3522 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3524 grid $top.argscmd - -sticky ew -padx 5
3526 message $top.l -aspect 1000 \
3527 -text [mc "Enter files and directories to include, one per line:"]
3528 grid $top.l - -sticky w
3529 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3530 if {[info exists viewfiles($n)]} {
3531 foreach f $viewfiles($n) {
3532 $top.t insert end $f
3533 $top.t insert end "\n"
3535 $top.t delete {end - 1c} end
3536 $top.t mark set insert 0.0
3538 grid $top.t - -sticky ew -padx 5
3540 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3541 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3542 bind $top <Escape> [list destroy $top]
3543 grid $top.buts.ok $top.buts.can
3544 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3545 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3546 grid $top.buts - -pady 10 -sticky ew
3550 proc doviewmenu {m first cmd op argv} {
3551 set nmenu [$m index end]
3552 for {set i $first} {$i <= $nmenu} {incr i} {
3553 if {[$m entrycget $i -command] eq $cmd} {
3554 eval $m $op $i $argv
3560 proc allviewmenus {n op args} {
3563 doviewmenu .bar.view 5 [list showview $n] $op $args
3564 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3567 proc newviewok {top n} {
3568 global nextviewnum newviewperm newviewname newishighlight
3569 global viewname viewfiles viewperm selectedview curview
3570 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3573 set newargs [shellsplit $newviewargs($n)]
3575 error_popup "[mc "Error in commit selection arguments:"] $err"
3581 foreach f [split [$top.t get 0.0 end] "\n"] {
3582 set ft [string trim $f]
3587 if {![info exists viewfiles($n)]} {
3588 # creating a new view
3590 set viewname($n) $newviewname($n)
3591 set viewperm($n) $newviewperm($n)
3592 set viewfiles($n) $files
3593 set viewargs($n) $newargs
3594 set viewargscmd($n) $newviewargscmd($n)
3596 if {!$newishighlight} {
3599 run addvhighlight $n
3602 # editing an existing view
3603 set viewperm($n) $newviewperm($n)
3604 if {$newviewname($n) ne $viewname($n)} {
3605 set viewname($n) $newviewname($n)
3606 doviewmenu .bar.view 5 [list showview $n] \
3607 entryconf [list -label $viewname($n)]
3608 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3609 # entryconf [list -label $viewname($n) -value $viewname($n)]
3611 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3612 $newviewargscmd($n) ne $viewargscmd($n)} {
3613 set viewfiles($n) $files
3614 set viewargs($n) $newargs
3615 set viewargscmd($n) $newviewargscmd($n)
3616 if {$curview == $n} {
3621 catch {destroy $top}
3625 global curview viewperm hlview selectedhlview
3627 if {$curview == 0} return
3628 if {[info exists hlview] && $hlview == $curview} {
3629 set selectedhlview [mc "None"]
3632 allviewmenus $curview delete
3633 set viewperm($curview) 0
3637 proc addviewmenu {n} {
3638 global viewname viewhlmenu
3640 .bar.view add radiobutton -label $viewname($n) \
3641 -command [list showview $n] -variable selectedview -value $n
3642 #$viewhlmenu add radiobutton -label $viewname($n) \
3643 # -command [list addvhighlight $n] -variable selectedhlview
3647 global curview cached_commitrow ordertok
3648 global displayorder parentlist rowidlist rowisopt rowfinal
3649 global colormap rowtextx nextcolor canvxmax
3650 global numcommits viewcomplete
3651 global selectedline currentid canv canvy0
3653 global pending_select mainheadid
3656 global hlview selectedhlview commitinterest
3658 if {$n == $curview} return
3660 set ymax [lindex [$canv cget -scrollregion] 3]
3661 set span [$canv yview]
3662 set ytop [expr {[lindex $span 0] * $ymax}]
3663 set ybot [expr {[lindex $span 1] * $ymax}]
3664 set yscreen [expr {($ybot - $ytop) / 2}]
3665 if {$selectedline ne {}} {
3666 set selid $currentid
3667 set y [yc $selectedline]
3668 if {$ytop < $y && $y < $ybot} {
3669 set yscreen [expr {$y - $ytop}]
3671 } elseif {[info exists pending_select]} {
3672 set selid $pending_select
3673 unset pending_select
3677 catch {unset treediffs}
3679 if {[info exists hlview] && $hlview == $n} {
3681 set selectedhlview [mc "None"]
3683 catch {unset commitinterest}
3684 catch {unset cached_commitrow}
3685 catch {unset ordertok}
3689 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3690 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3693 if {![info exists viewcomplete($n)]} {
3703 set numcommits $commitidx($n)
3705 catch {unset colormap}
3706 catch {unset rowtextx}
3708 set canvxmax [$canv cget -width]
3714 if {$selid ne {} && [commitinview $selid $n]} {
3715 set row [rowofcommit $selid]
3716 # try to get the selected row in the same position on the screen
3717 set ymax [lindex [$canv cget -scrollregion] 3]
3718 set ytop [expr {[yc $row] - $yscreen}]
3722 set yf [expr {$ytop * 1.0 / $ymax}]
3724 allcanvs yview moveto $yf
3728 } elseif {!$viewcomplete($n)} {
3729 reset_pending_select $selid
3731 reset_pending_select {}
3733 if {[commitinview $pending_select $curview]} {
3734 selectline [rowofcommit $pending_select] 1
3736 set row [first_real_row]
3737 if {$row < $numcommits} {
3742 if {!$viewcomplete($n)} {
3743 if {$numcommits == 0} {
3744 show_status [mc "Reading commits..."]
3746 } elseif {$numcommits == 0} {
3747 show_status [mc "No commits selected"]
3751 # Stuff relating to the highlighting facility
3753 proc ishighlighted {id} {
3754 global vhighlights fhighlights nhighlights rhighlights
3756 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3757 return $nhighlights($id)
3759 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3760 return $vhighlights($id)
3762 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3763 return $fhighlights($id)
3765 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3766 return $rhighlights($id)
3771 proc bolden {row font} {
3772 global canv linehtag selectedline boldrows
3774 lappend boldrows $row
3775 $canv itemconf $linehtag($row) -font $font
3776 if {$row == $selectedline} {
3778 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3779 -outline {{}} -tags secsel \
3780 -fill [$canv cget -selectbackground]]
3785 proc bolden_name {row font} {
3786 global canv2 linentag selectedline boldnamerows
3788 lappend boldnamerows $row
3789 $canv2 itemconf $linentag($row) -font $font
3790 if {$row == $selectedline} {
3791 $canv2 delete secsel
3792 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3793 -outline {{}} -tags secsel \
3794 -fill [$canv2 cget -selectbackground]]
3803 foreach row $boldrows {
3804 if {![ishighlighted [commitonrow $row]]} {
3805 bolden $row mainfont
3807 lappend stillbold $row
3810 set boldrows $stillbold
3813 proc addvhighlight {n} {
3814 global hlview viewcomplete curview vhl_done commitidx
3816 if {[info exists hlview]} {
3820 if {$n != $curview && ![info exists viewcomplete($n)]} {
3823 set vhl_done $commitidx($hlview)
3824 if {$vhl_done > 0} {
3829 proc delvhighlight {} {
3830 global hlview vhighlights
3832 if {![info exists hlview]} return
3834 catch {unset vhighlights}
3838 proc vhighlightmore {} {
3839 global hlview vhl_done commitidx vhighlights curview
3841 set max $commitidx($hlview)
3842 set vr [visiblerows]
3843 set r0 [lindex $vr 0]
3844 set r1 [lindex $vr 1]
3845 for {set i $vhl_done} {$i < $max} {incr i} {
3846 set id [commitonrow $i $hlview]
3847 if {[commitinview $id $curview]} {
3848 set row [rowofcommit $id]
3849 if {$r0 <= $row && $row <= $r1} {
3850 if {![highlighted $row]} {
3851 bolden $row mainfontbold
3853 set vhighlights($id) 1
3861 proc askvhighlight {row id} {
3862 global hlview vhighlights iddrawn
3864 if {[commitinview $id $hlview]} {
3865 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3866 bolden $row mainfontbold
3868 set vhighlights($id) 1
3870 set vhighlights($id) 0
3874 proc hfiles_change {} {
3875 global highlight_files filehighlight fhighlights fh_serial
3876 global highlight_paths gdttype
3878 if {[info exists filehighlight]} {
3879 # delete previous highlights
3880 catch {close $filehighlight}
3882 catch {unset fhighlights}
3884 unhighlight_filelist
3886 set highlight_paths {}
3887 after cancel do_file_hl $fh_serial
3889 if {$highlight_files ne {}} {
3890 after 300 do_file_hl $fh_serial
3894 proc gdttype_change {name ix op} {
3895 global gdttype highlight_files findstring findpattern
3898 if {$findstring ne {}} {
3899 if {$gdttype eq [mc "containing:"]} {
3900 if {$highlight_files ne {}} {
3901 set highlight_files {}
3906 if {$findpattern ne {}} {
3910 set highlight_files $findstring
3915 # enable/disable findtype/findloc menus too
3918 proc find_change {name ix op} {
3919 global gdttype findstring highlight_files
3922 if {$gdttype eq [mc "containing:"]} {
3925 if {$highlight_files ne $findstring} {
3926 set highlight_files $findstring
3933 proc findcom_change args {
3934 global nhighlights boldnamerows
3935 global findpattern findtype findstring gdttype
3938 # delete previous highlights, if any
3939 foreach row $boldnamerows {
3940 bolden_name $row mainfont
3943 catch {unset nhighlights}
3946 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3948 } elseif {$findtype eq [mc "Regexp"]} {
3949 set findpattern $findstring
3951 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3953 set findpattern "*$e*"
3957 proc makepatterns {l} {
3960 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3961 if {[string index $ee end] eq "/"} {
3971 proc do_file_hl {serial} {
3972 global highlight_files filehighlight highlight_paths gdttype fhl_list
3974 if {$gdttype eq [mc "touching paths:"]} {
3975 if {[catch {set paths [shellsplit $highlight_files]}]} return
3976 set highlight_paths [makepatterns $paths]
3978 set gdtargs [concat -- $paths]
3979 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3980 set gdtargs [list "-S$highlight_files"]
3982 # must be "containing:", i.e. we're searching commit info
3985 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3986 set filehighlight [open $cmd r+]
3987 fconfigure $filehighlight -blocking 0
3988 filerun $filehighlight readfhighlight
3994 proc flushhighlights {} {
3995 global filehighlight fhl_list
3997 if {[info exists filehighlight]} {
3999 puts $filehighlight ""
4000 flush $filehighlight
4004 proc askfilehighlight {row id} {
4005 global filehighlight fhighlights fhl_list
4007 lappend fhl_list $id
4008 set fhighlights($id) -1
4009 puts $filehighlight $id
4012 proc readfhighlight {} {
4013 global filehighlight fhighlights curview iddrawn
4014 global fhl_list find_dirn
4016 if {![info exists filehighlight]} {
4020 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4021 set line [string trim $line]
4022 set i [lsearch -exact $fhl_list $line]
4023 if {$i < 0} continue
4024 for {set j 0} {$j < $i} {incr j} {
4025 set id [lindex $fhl_list $j]
4026 set fhighlights($id) 0
4028 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4029 if {$line eq {}} continue
4030 if {![commitinview $line $curview]} continue
4031 set row [rowofcommit $line]
4032 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4033 bolden $row mainfontbold
4035 set fhighlights($line) 1
4037 if {[eof $filehighlight]} {
4039 puts "oops, git diff-tree died"
4040 catch {close $filehighlight}
4044 if {[info exists find_dirn]} {
4050 proc doesmatch {f} {
4051 global findtype findpattern
4053 if {$findtype eq [mc "Regexp"]} {
4054 return [regexp $findpattern $f]
4055 } elseif {$findtype eq [mc "IgnCase"]} {
4056 return [string match -nocase $findpattern $f]
4058 return [string match $findpattern $f]
4062 proc askfindhighlight {row id} {
4063 global nhighlights commitinfo iddrawn
4065 global markingmatches
4067 if {![info exists commitinfo($id)]} {
4070 set info $commitinfo($id)
4072 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4073 foreach f $info ty $fldtypes {
4074 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4076 if {$ty eq [mc "Author"]} {
4083 if {$isbold && [info exists iddrawn($id)]} {
4084 if {![ishighlighted $id]} {
4085 bolden $row mainfontbold
4087 bolden_name $row mainfontbold
4090 if {$markingmatches} {
4091 markrowmatches $row $id
4094 set nhighlights($id) $isbold
4097 proc markrowmatches {row id} {
4098 global canv canv2 linehtag linentag commitinfo findloc
4100 set headline [lindex $commitinfo($id) 0]
4101 set author [lindex $commitinfo($id) 1]
4102 $canv delete match$row
4103 $canv2 delete match$row
4104 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4105 set m [findmatches $headline]
4107 markmatches $canv $row $headline $linehtag($row) $m \
4108 [$canv itemcget $linehtag($row) -font] $row
4111 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4112 set m [findmatches $author]
4114 markmatches $canv2 $row $author $linentag($row) $m \
4115 [$canv2 itemcget $linentag($row) -font] $row
4120 proc vrel_change {name ix op} {
4121 global highlight_related
4124 if {$highlight_related ne [mc "None"]} {
4129 # prepare for testing whether commits are descendents or ancestors of a
4130 proc rhighlight_sel {a} {
4131 global descendent desc_todo ancestor anc_todo
4132 global highlight_related
4134 catch {unset descendent}
4135 set desc_todo [list $a]
4136 catch {unset ancestor}
4137 set anc_todo [list $a]
4138 if {$highlight_related ne [mc "None"]} {
4144 proc rhighlight_none {} {
4147 catch {unset rhighlights}
4151 proc is_descendent {a} {
4152 global curview children descendent desc_todo
4155 set la [rowofcommit $a]
4159 for {set i 0} {$i < [llength $todo]} {incr i} {
4160 set do [lindex $todo $i]
4161 if {[rowofcommit $do] < $la} {
4162 lappend leftover $do
4165 foreach nk $children($v,$do) {
4166 if {![info exists descendent($nk)]} {
4167 set descendent($nk) 1
4175 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4179 set descendent($a) 0
4180 set desc_todo $leftover
4183 proc is_ancestor {a} {
4184 global curview parents ancestor anc_todo
4187 set la [rowofcommit $a]
4191 for {set i 0} {$i < [llength $todo]} {incr i} {
4192 set do [lindex $todo $i]
4193 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4194 lappend leftover $do
4197 foreach np $parents($v,$do) {
4198 if {![info exists ancestor($np)]} {
4207 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4212 set anc_todo $leftover
4215 proc askrelhighlight {row id} {
4216 global descendent highlight_related iddrawn rhighlights
4217 global selectedline ancestor
4219 if {$selectedline eq {}} return
4221 if {$highlight_related eq [mc "Descendant"] ||
4222 $highlight_related eq [mc "Not descendant"]} {
4223 if {![info exists descendent($id)]} {
4226 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4229 } elseif {$highlight_related eq [mc "Ancestor"] ||
4230 $highlight_related eq [mc "Not ancestor"]} {
4231 if {![info exists ancestor($id)]} {
4234 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4238 if {[info exists iddrawn($id)]} {
4239 if {$isbold && ![ishighlighted $id]} {
4240 bolden $row mainfontbold
4243 set rhighlights($id) $isbold
4246 # Graph layout functions
4248 proc shortids {ids} {
4251 if {[llength $id] > 1} {
4252 lappend res [shortids $id]
4253 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4254 lappend res [string range $id 0 7]
4265 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4266 if {($n & $mask) != 0} {
4267 set ret [concat $ret $o]
4269 set o [concat $o $o]
4274 proc ordertoken {id} {
4275 global ordertok curview varcid varcstart varctok curview parents children
4276 global nullid nullid2
4278 if {[info exists ordertok($id)]} {
4279 return $ordertok($id)
4284 if {[info exists varcid($curview,$id)]} {
4285 set a $varcid($curview,$id)
4286 set p [lindex $varcstart($curview) $a]
4288 set p [lindex $children($curview,$id) 0]
4290 if {[info exists ordertok($p)]} {
4291 set tok $ordertok($p)
4294 set id [first_real_child $curview,$p]
4297 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4300 if {[llength $parents($curview,$id)] == 1} {
4301 lappend todo [list $p {}]
4303 set j [lsearch -exact $parents($curview,$id) $p]
4305 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4307 lappend todo [list $p [strrep $j]]
4310 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4311 set p [lindex $todo $i 0]
4312 append tok [lindex $todo $i 1]
4313 set ordertok($p) $tok
4315 set ordertok($origid) $tok
4319 # Work out where id should go in idlist so that order-token
4320 # values increase from left to right
4321 proc idcol {idlist id {i 0}} {
4322 set t [ordertoken $id]
4326 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4327 if {$i > [llength $idlist]} {
4328 set i [llength $idlist]
4330 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4333 if {$t > [ordertoken [lindex $idlist $i]]} {
4334 while {[incr i] < [llength $idlist] &&
4335 $t >= [ordertoken [lindex $idlist $i]]} {}
4341 proc initlayout {} {
4342 global rowidlist rowisopt rowfinal displayorder parentlist
4343 global numcommits canvxmax canv
4345 global colormap rowtextx
4354 set canvxmax [$canv cget -width]
4355 catch {unset colormap}
4356 catch {unset rowtextx}
4360 proc setcanvscroll {} {
4361 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4362 global lastscrollset lastscrollrows
4364 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4365 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4366 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4367 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4368 set lastscrollset [clock clicks -milliseconds]
4369 set lastscrollrows $numcommits
4372 proc visiblerows {} {
4373 global canv numcommits linespc
4375 set ymax [lindex [$canv cget -scrollregion] 3]
4376 if {$ymax eq {} || $ymax == 0} return
4378 set y0 [expr {int([lindex $f 0] * $ymax)}]
4379 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4383 set y1 [expr {int([lindex $f 1] * $ymax)}]
4384 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4385 if {$r1 >= $numcommits} {
4386 set r1 [expr {$numcommits - 1}]
4388 return [list $r0 $r1]
4391 proc layoutmore {} {
4392 global commitidx viewcomplete curview
4393 global numcommits pending_select curview
4394 global lastscrollset lastscrollrows
4396 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4397 [clock clicks -milliseconds] - $lastscrollset > 500} {
4400 if {[info exists pending_select] &&
4401 [commitinview $pending_select $curview]} {
4403 selectline [rowofcommit $pending_select] 1
4408 proc doshowlocalchanges {} {
4409 global curview mainheadid
4411 if {$mainheadid eq {}} return
4412 if {[commitinview $mainheadid $curview]} {
4415 interestedin $mainheadid dodiffindex
4419 proc dohidelocalchanges {} {
4420 global nullid nullid2 lserial curview
4422 if {[commitinview $nullid $curview]} {
4423 removefakerow $nullid
4425 if {[commitinview $nullid2 $curview]} {
4426 removefakerow $nullid2
4431 # spawn off a process to do git diff-index --cached HEAD
4432 proc dodiffindex {} {
4433 global lserial showlocalchanges
4436 if {!$showlocalchanges || !$isworktree} return
4438 set fd [open "|git diff-index --cached HEAD" r]
4439 fconfigure $fd -blocking 0
4440 set i [reg_instance $fd]
4441 filerun $fd [list readdiffindex $fd $lserial $i]
4444 proc readdiffindex {fd serial inst} {
4445 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4448 if {[gets $fd line] < 0} {
4454 # we only need to see one line and we don't really care what it says...
4457 if {$serial != $lserial} {
4461 # now see if there are any local changes not checked in to the index
4462 set fd [open "|git diff-files" r]
4463 fconfigure $fd -blocking 0
4464 set i [reg_instance $fd]
4465 filerun $fd [list readdifffiles $fd $serial $i]
4467 if {$isdiff && ![commitinview $nullid2 $curview]} {
4468 # add the line for the changes in the index to the graph
4469 set hl [mc "Local changes checked in to index but not committed"]
4470 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4471 set commitdata($nullid2) "\n $hl\n"
4472 if {[commitinview $nullid $curview]} {
4473 removefakerow $nullid
4475 insertfakerow $nullid2 $mainheadid
4476 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4477 removefakerow $nullid2
4482 proc readdifffiles {fd serial inst} {
4483 global mainheadid nullid nullid2 curview
4484 global commitinfo commitdata lserial
4487 if {[gets $fd line] < 0} {
4493 # we only need to see one line and we don't really care what it says...
4496 if {$serial != $lserial} {
4500 if {$isdiff && ![commitinview $nullid $curview]} {
4501 # add the line for the local diff to the graph
4502 set hl [mc "Local uncommitted changes, not checked in to index"]
4503 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4504 set commitdata($nullid) "\n $hl\n"
4505 if {[commitinview $nullid2 $curview]} {
4510 insertfakerow $nullid $p
4511 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4512 removefakerow $nullid
4517 proc nextuse {id row} {
4518 global curview children
4520 if {[info exists children($curview,$id)]} {
4521 foreach kid $children($curview,$id) {
4522 if {![commitinview $kid $curview]} {
4525 if {[rowofcommit $kid] > $row} {
4526 return [rowofcommit $kid]
4530 if {[commitinview $id $curview]} {
4531 return [rowofcommit $id]
4536 proc prevuse {id row} {
4537 global curview children
4540 if {[info exists children($curview,$id)]} {
4541 foreach kid $children($curview,$id) {
4542 if {![commitinview $kid $curview]} break
4543 if {[rowofcommit $kid] < $row} {
4544 set ret [rowofcommit $kid]
4551 proc make_idlist {row} {
4552 global displayorder parentlist uparrowlen downarrowlen mingaplen
4553 global commitidx curview children
4555 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4559 set ra [expr {$row - $downarrowlen}]
4563 set rb [expr {$row + $uparrowlen}]
4564 if {$rb > $commitidx($curview)} {
4565 set rb $commitidx($curview)
4567 make_disporder $r [expr {$rb + 1}]
4569 for {} {$r < $ra} {incr r} {
4570 set nextid [lindex $displayorder [expr {$r + 1}]]
4571 foreach p [lindex $parentlist $r] {
4572 if {$p eq $nextid} continue
4573 set rn [nextuse $p $r]
4575 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4576 lappend ids [list [ordertoken $p] $p]
4580 for {} {$r < $row} {incr r} {
4581 set nextid [lindex $displayorder [expr {$r + 1}]]
4582 foreach p [lindex $parentlist $r] {
4583 if {$p eq $nextid} continue
4584 set rn [nextuse $p $r]
4585 if {$rn < 0 || $rn >= $row} {
4586 lappend ids [list [ordertoken $p] $p]
4590 set id [lindex $displayorder $row]
4591 lappend ids [list [ordertoken $id] $id]
4593 foreach p [lindex $parentlist $r] {
4594 set firstkid [lindex $children($curview,$p) 0]
4595 if {[rowofcommit $firstkid] < $row} {
4596 lappend ids [list [ordertoken $p] $p]
4600 set id [lindex $displayorder $r]
4602 set firstkid [lindex $children($curview,$id) 0]
4603 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4604 lappend ids [list [ordertoken $id] $id]
4609 foreach idx [lsort -unique $ids] {
4610 lappend idlist [lindex $idx 1]
4615 proc rowsequal {a b} {
4616 while {[set i [lsearch -exact $a {}]] >= 0} {
4617 set a [lreplace $a $i $i]
4619 while {[set i [lsearch -exact $b {}]] >= 0} {
4620 set b [lreplace $b $i $i]
4622 return [expr {$a eq $b}]
4625 proc makeupline {id row rend col} {
4626 global rowidlist uparrowlen downarrowlen mingaplen
4628 for {set r $rend} {1} {set r $rstart} {
4629 set rstart [prevuse $id $r]
4630 if {$rstart < 0} return
4631 if {$rstart < $row} break
4633 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4634 set rstart [expr {$rend - $uparrowlen - 1}]
4636 for {set r $rstart} {[incr r] <= $row} {} {
4637 set idlist [lindex $rowidlist $r]
4638 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4639 set col [idcol $idlist $id $col]
4640 lset rowidlist $r [linsert $idlist $col $id]
4646 proc layoutrows {row endrow} {
4647 global rowidlist rowisopt rowfinal displayorder
4648 global uparrowlen downarrowlen maxwidth mingaplen
4649 global children parentlist
4650 global commitidx viewcomplete curview
4652 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4655 set rm1 [expr {$row - 1}]
4656 foreach id [lindex $rowidlist $rm1] {
4661 set final [lindex $rowfinal $rm1]
4663 for {} {$row < $endrow} {incr row} {
4664 set rm1 [expr {$row - 1}]
4665 if {$rm1 < 0 || $idlist eq {}} {
4666 set idlist [make_idlist $row]
4669 set id [lindex $displayorder $rm1]
4670 set col [lsearch -exact $idlist $id]
4671 set idlist [lreplace $idlist $col $col]
4672 foreach p [lindex $parentlist $rm1] {
4673 if {[lsearch -exact $idlist $p] < 0} {
4674 set col [idcol $idlist $p $col]
4675 set idlist [linsert $idlist $col $p]
4676 # if not the first child, we have to insert a line going up
4677 if {$id ne [lindex $children($curview,$p) 0]} {
4678 makeupline $p $rm1 $row $col
4682 set id [lindex $displayorder $row]
4683 if {$row > $downarrowlen} {
4684 set termrow [expr {$row - $downarrowlen - 1}]
4685 foreach p [lindex $parentlist $termrow] {
4686 set i [lsearch -exact $idlist $p]
4687 if {$i < 0} continue
4688 set nr [nextuse $p $termrow]
4689 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4690 set idlist [lreplace $idlist $i $i]
4694 set col [lsearch -exact $idlist $id]
4696 set col [idcol $idlist $id]
4697 set idlist [linsert $idlist $col $id]
4698 if {$children($curview,$id) ne {}} {
4699 makeupline $id $rm1 $row $col
4702 set r [expr {$row + $uparrowlen - 1}]
4703 if {$r < $commitidx($curview)} {
4705 foreach p [lindex $parentlist $r] {
4706 if {[lsearch -exact $idlist $p] >= 0} continue
4707 set fk [lindex $children($curview,$p) 0]
4708 if {[rowofcommit $fk] < $row} {
4709 set x [idcol $idlist $p $x]
4710 set idlist [linsert $idlist $x $p]
4713 if {[incr r] < $commitidx($curview)} {
4714 set p [lindex $displayorder $r]
4715 if {[lsearch -exact $idlist $p] < 0} {
4716 set fk [lindex $children($curview,$p) 0]
4717 if {$fk ne {} && [rowofcommit $fk] < $row} {
4718 set x [idcol $idlist $p $x]
4719 set idlist [linsert $idlist $x $p]
4725 if {$final && !$viewcomplete($curview) &&
4726 $row + $uparrowlen + $mingaplen + $downarrowlen
4727 >= $commitidx($curview)} {
4730 set l [llength $rowidlist]
4732 lappend rowidlist $idlist
4734 lappend rowfinal $final
4735 } elseif {$row < $l} {
4736 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4737 lset rowidlist $row $idlist
4740 lset rowfinal $row $final
4742 set pad [ntimes [expr {$row - $l}] {}]
4743 set rowidlist [concat $rowidlist $pad]
4744 lappend rowidlist $idlist
4745 set rowfinal [concat $rowfinal $pad]
4746 lappend rowfinal $final
4747 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4753 proc changedrow {row} {
4754 global displayorder iddrawn rowisopt need_redisplay
4756 set l [llength $rowisopt]
4758 lset rowisopt $row 0
4759 if {$row + 1 < $l} {
4760 lset rowisopt [expr {$row + 1}] 0
4761 if {$row + 2 < $l} {
4762 lset rowisopt [expr {$row + 2}] 0
4766 set id [lindex $displayorder $row]
4767 if {[info exists iddrawn($id)]} {
4768 set need_redisplay 1
4772 proc insert_pad {row col npad} {
4775 set pad [ntimes $npad {}]
4776 set idlist [lindex $rowidlist $row]
4777 set bef [lrange $idlist 0 [expr {$col - 1}]]
4778 set aft [lrange $idlist $col end]
4779 set i [lsearch -exact $aft {}]
4781 set aft [lreplace $aft $i $i]
4783 lset rowidlist $row [concat $bef $pad $aft]
4787 proc optimize_rows {row col endrow} {
4788 global rowidlist rowisopt displayorder curview children
4793 for {} {$row < $endrow} {incr row; set col 0} {
4794 if {[lindex $rowisopt $row]} continue
4796 set y0 [expr {$row - 1}]
4797 set ym [expr {$row - 2}]
4798 set idlist [lindex $rowidlist $row]
4799 set previdlist [lindex $rowidlist $y0]
4800 if {$idlist eq {} || $previdlist eq {}} continue
4802 set pprevidlist [lindex $rowidlist $ym]
4803 if {$pprevidlist eq {}} continue
4809 for {} {$col < [llength $idlist]} {incr col} {
4810 set id [lindex $idlist $col]
4811 if {[lindex $previdlist $col] eq $id} continue
4816 set x0 [lsearch -exact $previdlist $id]
4817 if {$x0 < 0} continue
4818 set z [expr {$x0 - $col}]
4822 set xm [lsearch -exact $pprevidlist $id]
4824 set z0 [expr {$xm - $x0}]
4828 # if row y0 is the first child of $id then it's not an arrow
4829 if {[lindex $children($curview,$id) 0] ne
4830 [lindex $displayorder $y0]} {
4834 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4835 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4838 # Looking at lines from this row to the previous row,
4839 # make them go straight up if they end in an arrow on
4840 # the previous row; otherwise make them go straight up
4842 if {$z < -1 || ($z < 0 && $isarrow)} {
4843 # Line currently goes left too much;
4844 # insert pads in the previous row, then optimize it
4845 set npad [expr {-1 - $z + $isarrow}]
4846 insert_pad $y0 $x0 $npad
4848 optimize_rows $y0 $x0 $row
4850 set previdlist [lindex $rowidlist $y0]
4851 set x0 [lsearch -exact $previdlist $id]
4852 set z [expr {$x0 - $col}]
4854 set pprevidlist [lindex $rowidlist $ym]
4855 set xm [lsearch -exact $pprevidlist $id]
4856 set z0 [expr {$xm - $x0}]
4858 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4859 # Line currently goes right too much;
4860 # insert pads in this line
4861 set npad [expr {$z - 1 + $isarrow}]
4862 insert_pad $row $col $npad
4863 set idlist [lindex $rowidlist $row]
4865 set z [expr {$x0 - $col}]
4868 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4869 # this line links to its first child on row $row-2
4870 set id [lindex $displayorder $ym]
4871 set xc [lsearch -exact $pprevidlist $id]
4873 set z0 [expr {$xc - $x0}]
4876 # avoid lines jigging left then immediately right
4877 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4878 insert_pad $y0 $x0 1
4880 optimize_rows $y0 $x0 $row
4881 set previdlist [lindex $rowidlist $y0]
4885 # Find the first column that doesn't have a line going right
4886 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4887 set id [lindex $idlist $col]
4888 if {$id eq {}} break
4889 set x0 [lsearch -exact $previdlist $id]
4891 # check if this is the link to the first child
4892 set kid [lindex $displayorder $y0]
4893 if {[lindex $children($curview,$id) 0] eq $kid} {
4894 # it is, work out offset to child
4895 set x0 [lsearch -exact $previdlist $kid]
4898 if {$x0 <= $col} break
4900 # Insert a pad at that column as long as it has a line and
4901 # isn't the last column
4902 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4903 set idlist [linsert $idlist $col {}]
4904 lset rowidlist $row $idlist
4912 global canvx0 linespc
4913 return [expr {$canvx0 + $col * $linespc}]
4917 global canvy0 linespc
4918 return [expr {$canvy0 + $row * $linespc}]
4921 proc linewidth {id} {
4922 global thickerline lthickness
4925 if {[info exists thickerline] && $id eq $thickerline} {
4926 set wid [expr {2 * $lthickness}]
4931 proc rowranges {id} {
4932 global curview children uparrowlen downarrowlen
4935 set kids $children($curview,$id)
4941 foreach child $kids {
4942 if {![commitinview $child $curview]} break
4943 set row [rowofcommit $child]
4944 if {![info exists prev]} {
4945 lappend ret [expr {$row + 1}]
4947 if {$row <= $prevrow} {
4948 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4950 # see if the line extends the whole way from prevrow to row
4951 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4952 [lsearch -exact [lindex $rowidlist \
4953 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4954 # it doesn't, see where it ends
4955 set r [expr {$prevrow + $downarrowlen}]
4956 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4957 while {[incr r -1] > $prevrow &&
4958 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4960 while {[incr r] <= $row &&
4961 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4965 # see where it starts up again
4966 set r [expr {$row - $uparrowlen}]
4967 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4968 while {[incr r] < $row &&
4969 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4971 while {[incr r -1] >= $prevrow &&
4972 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4978 if {$child eq $id} {
4987 proc drawlineseg {id row endrow arrowlow} {
4988 global rowidlist displayorder iddrawn linesegs
4989 global canv colormap linespc curview maxlinelen parentlist
4991 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4992 set le [expr {$row + 1}]
4995 set c [lsearch -exact [lindex $rowidlist $le] $id]
5001 set x [lindex $displayorder $le]
5006 if {[info exists iddrawn($x)] || $le == $endrow} {
5007 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5023 if {[info exists linesegs($id)]} {
5024 set lines $linesegs($id)
5026 set r0 [lindex $li 0]
5028 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5038 set li [lindex $lines [expr {$i-1}]]
5039 set r1 [lindex $li 1]
5040 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5045 set x [lindex $cols [expr {$le - $row}]]
5046 set xp [lindex $cols [expr {$le - 1 - $row}]]
5047 set dir [expr {$xp - $x}]
5049 set ith [lindex $lines $i 2]
5050 set coords [$canv coords $ith]
5051 set ah [$canv itemcget $ith -arrow]
5052 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5053 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5054 if {$x2 ne {} && $x - $x2 == $dir} {
5055 set coords [lrange $coords 0 end-2]
5058 set coords [list [xc $le $x] [yc $le]]
5061 set itl [lindex $lines [expr {$i-1}] 2]
5062 set al [$canv itemcget $itl -arrow]
5063 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5064 } elseif {$arrowlow} {
5065 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5066 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5070 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5071 for {set y $le} {[incr y -1] > $row} {} {
5073 set xp [lindex $cols [expr {$y - 1 - $row}]]
5074 set ndir [expr {$xp - $x}]
5075 if {$dir != $ndir || $xp < 0} {
5076 lappend coords [xc $y $x] [yc $y]
5082 # join parent line to first child
5083 set ch [lindex $displayorder $row]
5084 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5086 puts "oops: drawlineseg: child $ch not on row $row"
5087 } elseif {$xc != $x} {
5088 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5089 set d [expr {int(0.5 * $linespc)}]
5092 set x2 [expr {$x1 - $d}]
5094 set x2 [expr {$x1 + $d}]
5097 set y1 [expr {$y2 + $d}]
5098 lappend coords $x1 $y1 $x2 $y2
5099 } elseif {$xc < $x - 1} {
5100 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5101 } elseif {$xc > $x + 1} {
5102 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5106 lappend coords [xc $row $x] [yc $row]
5108 set xn [xc $row $xp]
5110 lappend coords $xn $yn
5114 set t [$canv create line $coords -width [linewidth $id] \
5115 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5118 set lines [linsert $lines $i [list $row $le $t]]
5120 $canv coords $ith $coords
5121 if {$arrow ne $ah} {
5122 $canv itemconf $ith -arrow $arrow
5124 lset lines $i 0 $row
5127 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5128 set ndir [expr {$xo - $xp}]
5129 set clow [$canv coords $itl]
5130 if {$dir == $ndir} {
5131 set clow [lrange $clow 2 end]
5133 set coords [concat $coords $clow]
5135 lset lines [expr {$i-1}] 1 $le
5137 # coalesce two pieces
5139 set b [lindex $lines [expr {$i-1}] 0]
5140 set e [lindex $lines $i 1]
5141 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5143 $canv coords $itl $coords
5144 if {$arrow ne $al} {
5145 $canv itemconf $itl -arrow $arrow
5149 set linesegs($id) $lines
5153 proc drawparentlinks {id row} {
5154 global rowidlist canv colormap curview parentlist
5155 global idpos linespc
5157 set rowids [lindex $rowidlist $row]
5158 set col [lsearch -exact $rowids $id]
5159 if {$col < 0} return
5160 set olds [lindex $parentlist $row]
5161 set row2 [expr {$row + 1}]
5162 set x [xc $row $col]
5165 set d [expr {int(0.5 * $linespc)}]
5166 set ymid [expr {$y + $d}]
5167 set ids [lindex $rowidlist $row2]
5168 # rmx = right-most X coord used
5171 set i [lsearch -exact $ids $p]
5173 puts "oops, parent $p of $id not in list"
5176 set x2 [xc $row2 $i]
5180 set j [lsearch -exact $rowids $p]
5182 # drawlineseg will do this one for us
5186 # should handle duplicated parents here...
5187 set coords [list $x $y]
5189 # if attaching to a vertical segment, draw a smaller
5190 # slant for visual distinctness
5193 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5195 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5197 } elseif {$i < $col && $i < $j} {
5198 # segment slants towards us already
5199 lappend coords [xc $row $j] $y
5201 if {$i < $col - 1} {
5202 lappend coords [expr {$x2 + $linespc}] $y
5203 } elseif {$i > $col + 1} {
5204 lappend coords [expr {$x2 - $linespc}] $y
5206 lappend coords $x2 $y2
5209 lappend coords $x2 $y2
5211 set t [$canv create line $coords -width [linewidth $p] \
5212 -fill $colormap($p) -tags lines.$p]
5216 if {$rmx > [lindex $idpos($id) 1]} {
5217 lset idpos($id) 1 $rmx
5222 proc drawlines {id} {
5225 $canv itemconf lines.$id -width [linewidth $id]
5228 proc drawcmittext {id row col} {
5229 global linespc canv canv2 canv3 fgcolor curview
5230 global cmitlisted commitinfo rowidlist parentlist
5231 global rowtextx idpos idtags idheads idotherrefs
5232 global linehtag linentag linedtag selectedline
5233 global canvxmax boldrows boldnamerows fgcolor
5234 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5236 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5237 set listed $cmitlisted($curview,$id)
5238 if {$id eq $nullid} {
5240 } elseif {$id eq $nullid2} {
5242 } elseif {$id eq $mainheadid} {
5245 set ofill [lindex $circlecolors $listed]
5247 set x [xc $row $col]
5249 set orad [expr {$linespc / 3}]
5251 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5252 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5253 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5254 } elseif {$listed == 3} {
5255 # triangle pointing left for left-side commits
5256 set t [$canv create polygon \
5257 [expr {$x - $orad}] $y \
5258 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5259 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5260 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5262 # triangle pointing right for right-side commits
5263 set t [$canv create polygon \
5264 [expr {$x + $orad - 1}] $y \
5265 [expr {$x - $orad}] [expr {$y - $orad}] \
5266 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5267 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5269 set circleitem($row) $t
5271 $canv bind $t <1> {selcanvline {} %x %y}
5272 set rmx [llength [lindex $rowidlist $row]]
5273 set olds [lindex $parentlist $row]
5275 set nextids [lindex $rowidlist [expr {$row + 1}]]
5277 set i [lsearch -exact $nextids $p]
5283 set xt [xc $row $rmx]
5284 set rowtextx($row) $xt
5285 set idpos($id) [list $x $xt $y]
5286 if {[info exists idtags($id)] || [info exists idheads($id)]
5287 || [info exists idotherrefs($id)]} {
5288 set xt [drawtags $id $x $xt $y]
5290 set headline [lindex $commitinfo($id) 0]
5291 set name [lindex $commitinfo($id) 1]
5292 set date [lindex $commitinfo($id) 2]
5293 set date [formatdate $date]
5296 set isbold [ishighlighted $id]
5298 lappend boldrows $row
5299 set font mainfontbold
5301 lappend boldnamerows $row
5302 set nfont mainfontbold
5305 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
5306 -text $headline -font $font -tags text]
5307 $canv bind $linehtag($row) $ctxbut "rowmenu %X %Y $id"
5308 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5309 -text $name -font $nfont -tags text]
5310 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5311 -text $date -font mainfont -tags text]
5312 if {$selectedline == $row} {
5315 set xr [expr {$xt + [font measure $font $headline]}]
5316 if {$xr > $canvxmax} {
5322 proc drawcmitrow {row} {
5323 global displayorder rowidlist nrows_drawn
5324 global iddrawn markingmatches
5325 global commitinfo numcommits
5326 global filehighlight fhighlights findpattern nhighlights
5327 global hlview vhighlights
5328 global highlight_related rhighlights
5330 if {$row >= $numcommits} return
5332 set id [lindex $displayorder $row]
5333 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5334 askvhighlight $row $id
5336 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5337 askfilehighlight $row $id
5339 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5340 askfindhighlight $row $id
5342 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5343 askrelhighlight $row $id
5345 if {![info exists iddrawn($id)]} {
5346 set col [lsearch -exact [lindex $rowidlist $row] $id]
5348 puts "oops, row $row id $id not in list"
5351 if {![info exists commitinfo($id)]} {
5355 drawcmittext $id $row $col
5359 if {$markingmatches} {
5360 markrowmatches $row $id
5364 proc drawcommits {row {endrow {}}} {
5365 global numcommits iddrawn displayorder curview need_redisplay
5366 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5371 if {$endrow eq {}} {
5374 if {$endrow >= $numcommits} {
5375 set endrow [expr {$numcommits - 1}]
5378 set rl1 [expr {$row - $downarrowlen - 3}]
5382 set ro1 [expr {$row - 3}]
5386 set r2 [expr {$endrow + $uparrowlen + 3}]
5387 if {$r2 > $numcommits} {
5390 for {set r $rl1} {$r < $r2} {incr r} {
5391 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5395 set rl1 [expr {$r + 1}]
5401 optimize_rows $ro1 0 $r2
5402 if {$need_redisplay || $nrows_drawn > 2000} {
5407 # make the lines join to already-drawn rows either side
5408 set r [expr {$row - 1}]
5409 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5412 set er [expr {$endrow + 1}]
5413 if {$er >= $numcommits ||
5414 ![info exists iddrawn([lindex $displayorder $er])]} {
5417 for {} {$r <= $er} {incr r} {
5418 set id [lindex $displayorder $r]
5419 set wasdrawn [info exists iddrawn($id)]
5421 if {$r == $er} break
5422 set nextid [lindex $displayorder [expr {$r + 1}]]
5423 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5424 drawparentlinks $id $r
5426 set rowids [lindex $rowidlist $r]
5427 foreach lid $rowids {
5428 if {$lid eq {}} continue
5429 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5431 # see if this is the first child of any of its parents
5432 foreach p [lindex $parentlist $r] {
5433 if {[lsearch -exact $rowids $p] < 0} {
5434 # make this line extend up to the child
5435 set lineend($p) [drawlineseg $p $r $er 0]
5439 set lineend($lid) [drawlineseg $lid $r $er 1]
5445 proc undolayout {row} {
5446 global uparrowlen mingaplen downarrowlen
5447 global rowidlist rowisopt rowfinal need_redisplay
5449 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5453 if {[llength $rowidlist] > $r} {
5455 set rowidlist [lrange $rowidlist 0 $r]
5456 set rowfinal [lrange $rowfinal 0 $r]
5457 set rowisopt [lrange $rowisopt 0 $r]
5458 set need_redisplay 1
5463 proc drawvisible {} {
5464 global canv linespc curview vrowmod selectedline targetrow targetid
5465 global need_redisplay cscroll numcommits
5467 set fs [$canv yview]
5468 set ymax [lindex [$canv cget -scrollregion] 3]
5469 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5470 set f0 [lindex $fs 0]
5471 set f1 [lindex $fs 1]
5472 set y0 [expr {int($f0 * $ymax)}]
5473 set y1 [expr {int($f1 * $ymax)}]
5475 if {[info exists targetid]} {
5476 if {[commitinview $targetid $curview]} {
5477 set r [rowofcommit $targetid]
5478 if {$r != $targetrow} {
5479 # Fix up the scrollregion and change the scrolling position
5480 # now that our target row has moved.
5481 set diff [expr {($r - $targetrow) * $linespc}]
5484 set ymax [lindex [$canv cget -scrollregion] 3]
5487 set f0 [expr {$y0 / $ymax}]
5488 set f1 [expr {$y1 / $ymax}]
5489 allcanvs yview moveto $f0
5490 $cscroll set $f0 $f1
5491 set need_redisplay 1
5498 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5499 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5500 if {$endrow >= $vrowmod($curview)} {
5501 update_arcrows $curview
5503 if {$selectedline ne {} &&
5504 $row <= $selectedline && $selectedline <= $endrow} {
5505 set targetrow $selectedline
5506 } elseif {[info exists targetid]} {
5507 set targetrow [expr {int(($row + $endrow) / 2)}]
5509 if {[info exists targetrow]} {
5510 if {$targetrow >= $numcommits} {
5511 set targetrow [expr {$numcommits - 1}]
5513 set targetid [commitonrow $targetrow]
5515 drawcommits $row $endrow
5518 proc clear_display {} {
5519 global iddrawn linesegs need_redisplay nrows_drawn
5520 global vhighlights fhighlights nhighlights rhighlights
5521 global linehtag linentag linedtag boldrows boldnamerows
5524 catch {unset iddrawn}
5525 catch {unset linesegs}
5526 catch {unset linehtag}
5527 catch {unset linentag}
5528 catch {unset linedtag}
5531 catch {unset vhighlights}
5532 catch {unset fhighlights}
5533 catch {unset nhighlights}
5534 catch {unset rhighlights}
5535 set need_redisplay 0
5539 proc findcrossings {id} {
5540 global rowidlist parentlist numcommits displayorder
5544 foreach {s e} [rowranges $id] {
5545 if {$e >= $numcommits} {
5546 set e [expr {$numcommits - 1}]
5548 if {$e <= $s} continue
5549 for {set row $e} {[incr row -1] >= $s} {} {
5550 set x [lsearch -exact [lindex $rowidlist $row] $id]
5552 set olds [lindex $parentlist $row]
5553 set kid [lindex $displayorder $row]
5554 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5555 if {$kidx < 0} continue
5556 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5558 set px [lsearch -exact $nextrow $p]
5559 if {$px < 0} continue
5560 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5561 if {[lsearch -exact $ccross $p] >= 0} continue
5562 if {$x == $px + ($kidx < $px? -1: 1)} {
5564 } elseif {[lsearch -exact $cross $p] < 0} {
5571 return [concat $ccross {{}} $cross]
5574 proc assigncolor {id} {
5575 global colormap colors nextcolor
5576 global parents children children curview
5578 if {[info exists colormap($id)]} return
5579 set ncolors [llength $colors]
5580 if {[info exists children($curview,$id)]} {
5581 set kids $children($curview,$id)
5585 if {[llength $kids] == 1} {
5586 set child [lindex $kids 0]
5587 if {[info exists colormap($child)]
5588 && [llength $parents($curview,$child)] == 1} {
5589 set colormap($id) $colormap($child)
5595 foreach x [findcrossings $id] {
5597 # delimiter between corner crossings and other crossings
5598 if {[llength $badcolors] >= $ncolors - 1} break
5599 set origbad $badcolors
5601 if {[info exists colormap($x)]
5602 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5603 lappend badcolors $colormap($x)
5606 if {[llength $badcolors] >= $ncolors} {
5607 set badcolors $origbad
5609 set origbad $badcolors
5610 if {[llength $badcolors] < $ncolors - 1} {
5611 foreach child $kids {
5612 if {[info exists colormap($child)]
5613 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5614 lappend badcolors $colormap($child)
5616 foreach p $parents($curview,$child) {
5617 if {[info exists colormap($p)]
5618 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5619 lappend badcolors $colormap($p)
5623 if {[llength $badcolors] >= $ncolors} {
5624 set badcolors $origbad
5627 for {set i 0} {$i <= $ncolors} {incr i} {
5628 set c [lindex $colors $nextcolor]
5629 if {[incr nextcolor] >= $ncolors} {
5632 if {[lsearch -exact $badcolors $c]} break
5634 set colormap($id) $c
5637 proc bindline {t id} {
5640 $canv bind $t <Enter> "lineenter %x %y $id"
5641 $canv bind $t <Motion> "linemotion %x %y $id"
5642 $canv bind $t <Leave> "lineleave $id"
5643 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5646 proc drawtags {id x xt y1} {
5647 global idtags idheads idotherrefs mainhead
5648 global linespc lthickness
5649 global canv rowtextx curview fgcolor bgcolor ctxbut
5654 if {[info exists idtags($id)]} {
5655 set marks $idtags($id)
5656 set ntags [llength $marks]
5658 if {[info exists idheads($id)]} {
5659 set marks [concat $marks $idheads($id)]
5660 set nheads [llength $idheads($id)]
5662 if {[info exists idotherrefs($id)]} {
5663 set marks [concat $marks $idotherrefs($id)]
5669 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5670 set yt [expr {$y1 - 0.5 * $linespc}]
5671 set yb [expr {$yt + $linespc - 1}]
5675 foreach tag $marks {
5677 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5678 set wid [font measure mainfontbold $tag]
5680 set wid [font measure mainfont $tag]
5684 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5686 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5687 -width $lthickness -fill black -tags tag.$id]
5689 foreach tag $marks x $xvals wid $wvals {
5690 set xl [expr {$x + $delta}]
5691 set xr [expr {$x + $delta + $wid + $lthickness}]
5693 if {[incr ntags -1] >= 0} {
5695 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5696 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5697 -width 1 -outline black -fill yellow -tags tag.$id]
5698 $canv bind $t <1> [list showtag $tag 1]
5699 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5701 # draw a head or other ref
5702 if {[incr nheads -1] >= 0} {
5704 if {$tag eq $mainhead} {
5705 set font mainfontbold
5710 set xl [expr {$xl - $delta/2}]
5711 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5712 -width 1 -outline black -fill $col -tags tag.$id
5713 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5714 set rwid [font measure mainfont $remoteprefix]
5715 set xi [expr {$x + 1}]
5716 set yti [expr {$yt + 1}]
5717 set xri [expr {$x + $rwid}]
5718 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5719 -width 0 -fill "#ffddaa" -tags tag.$id
5722 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5723 -font $font -tags [list tag.$id text]]
5725 $canv bind $t <1> [list showtag $tag 1]
5726 } elseif {$nheads >= 0} {
5727 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
5733 proc xcoord {i level ln} {
5734 global canvx0 xspc1 xspc2
5736 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5737 if {$i > 0 && $i == $level} {
5738 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5739 } elseif {$i > $level} {
5740 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5745 proc show_status {msg} {
5749 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5750 -tags text -fill $fgcolor
5753 # Don't change the text pane cursor if it is currently the hand cursor,
5754 # showing that we are over a sha1 ID link.
5755 proc settextcursor {c} {
5756 global ctext curtextcursor
5758 if {[$ctext cget -cursor] == $curtextcursor} {
5759 $ctext config -cursor $c
5761 set curtextcursor $c
5764 proc nowbusy {what {name {}}} {
5765 global isbusy busyname statusw
5767 if {[array names isbusy] eq {}} {
5768 . config -cursor watch
5772 set busyname($what) $name
5774 $statusw conf -text $name
5778 proc notbusy {what} {
5779 global isbusy maincursor textcursor busyname statusw
5783 if {$busyname($what) ne {} &&
5784 [$statusw cget -text] eq $busyname($what)} {
5785 $statusw conf -text {}
5788 if {[array names isbusy] eq {}} {
5789 . config -cursor $maincursor
5790 settextcursor $textcursor
5794 proc findmatches {f} {
5795 global findtype findstring
5796 if {$findtype == [mc "Regexp"]} {
5797 set matches [regexp -indices -all -inline $findstring $f]
5800 if {$findtype == [mc "IgnCase"]} {
5801 set f [string tolower $f]
5802 set fs [string tolower $fs]
5806 set l [string length $fs]
5807 while {[set j [string first $fs $f $i]] >= 0} {
5808 lappend matches [list $j [expr {$j+$l-1}]]
5809 set i [expr {$j + $l}]
5815 proc dofind {{dirn 1} {wrap 1}} {
5816 global findstring findstartline findcurline selectedline numcommits
5817 global gdttype filehighlight fh_serial find_dirn findallowwrap
5819 if {[info exists find_dirn]} {
5820 if {$find_dirn == $dirn} return
5824 if {$findstring eq {} || $numcommits == 0} return
5825 if {$selectedline eq {}} {
5826 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5828 set findstartline $selectedline
5830 set findcurline $findstartline
5831 nowbusy finding [mc "Searching"]
5832 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5833 after cancel do_file_hl $fh_serial
5834 do_file_hl $fh_serial
5837 set findallowwrap $wrap
5841 proc stopfinding {} {
5842 global find_dirn findcurline fprogcoord
5844 if {[info exists find_dirn]} {
5855 global commitdata commitinfo numcommits findpattern findloc
5856 global findstartline findcurline findallowwrap
5857 global find_dirn gdttype fhighlights fprogcoord
5858 global curview varcorder vrownum varccommits vrowmod
5860 if {![info exists find_dirn]} {
5863 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5866 if {$find_dirn > 0} {
5868 if {$l >= $numcommits} {
5871 if {$l <= $findstartline} {
5872 set lim [expr {$findstartline + 1}]
5875 set moretodo $findallowwrap
5882 if {$l >= $findstartline} {
5883 set lim [expr {$findstartline - 1}]
5886 set moretodo $findallowwrap
5889 set n [expr {($lim - $l) * $find_dirn}]
5894 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5895 update_arcrows $curview
5899 set ai [bsearch $vrownum($curview) $l]
5900 set a [lindex $varcorder($curview) $ai]
5901 set arow [lindex $vrownum($curview) $ai]
5902 set ids [lindex $varccommits($curview,$a)]
5903 set arowend [expr {$arow + [llength $ids]}]
5904 if {$gdttype eq [mc "containing:"]} {
5905 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5906 if {$l < $arow || $l >= $arowend} {
5908 set a [lindex $varcorder($curview) $ai]
5909 set arow [lindex $vrownum($curview) $ai]
5910 set ids [lindex $varccommits($curview,$a)]
5911 set arowend [expr {$arow + [llength $ids]}]
5913 set id [lindex $ids [expr {$l - $arow}]]
5914 # shouldn't happen unless git log doesn't give all the commits...
5915 if {![info exists commitdata($id)] ||
5916 ![doesmatch $commitdata($id)]} {
5919 if {![info exists commitinfo($id)]} {
5922 set info $commitinfo($id)
5923 foreach f $info ty $fldtypes {
5924 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5933 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5934 if {$l < $arow || $l >= $arowend} {
5936 set a [lindex $varcorder($curview) $ai]
5937 set arow [lindex $vrownum($curview) $ai]
5938 set ids [lindex $varccommits($curview,$a)]
5939 set arowend [expr {$arow + [llength $ids]}]
5941 set id [lindex $ids [expr {$l - $arow}]]
5942 if {![info exists fhighlights($id)]} {
5943 # this sets fhighlights($id) to -1
5944 askfilehighlight $l $id
5946 if {$fhighlights($id) > 0} {
5950 if {$fhighlights($id) < 0} {
5953 set findcurline [expr {$l - $find_dirn}]
5958 if {$found || ($domore && !$moretodo)} {
5974 set findcurline [expr {$l - $find_dirn}]
5976 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5980 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5985 proc findselectline {l} {
5986 global findloc commentend ctext findcurline markingmatches gdttype
5988 set markingmatches 1
5991 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5992 # highlight the matches in the comments
5993 set f [$ctext get 1.0 $commentend]
5994 set matches [findmatches $f]
5995 foreach match $matches {
5996 set start [lindex $match 0]
5997 set end [expr {[lindex $match 1] + 1}]
5998 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6004 # mark the bits of a headline or author that match a find string
6005 proc markmatches {canv l str tag matches font row} {
6008 set bbox [$canv bbox $tag]
6009 set x0 [lindex $bbox 0]
6010 set y0 [lindex $bbox 1]
6011 set y1 [lindex $bbox 3]
6012 foreach match $matches {
6013 set start [lindex $match 0]
6014 set end [lindex $match 1]
6015 if {$start > $end} continue
6016 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6017 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6018 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6019 [expr {$x0+$xlen+2}] $y1 \
6020 -outline {} -tags [list match$l matches] -fill yellow]
6022 if {$row == $selectedline} {
6023 $canv raise $t secsel
6028 proc unmarkmatches {} {
6029 global markingmatches
6031 allcanvs delete matches
6032 set markingmatches 0
6036 proc selcanvline {w x y} {
6037 global canv canvy0 ctext linespc
6039 set ymax [lindex [$canv cget -scrollregion] 3]
6040 if {$ymax == {}} return
6041 set yfrac [lindex [$canv yview] 0]
6042 set y [expr {$y + $yfrac * $ymax}]
6043 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6048 set xmax [lindex [$canv cget -scrollregion] 2]
6049 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6050 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6056 proc commit_descriptor {p} {
6058 if {![info exists commitinfo($p)]} {
6062 if {[llength $commitinfo($p)] > 1} {
6063 set l [lindex $commitinfo($p) 0]
6068 # append some text to the ctext widget, and make any SHA1 ID
6069 # that we know about be a clickable link.
6070 proc appendwithlinks {text tags} {
6071 global ctext linknum curview
6073 set start [$ctext index "end - 1c"]
6074 $ctext insert end $text $tags
6075 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6079 set linkid [string range $text $s $e]
6081 $ctext tag delete link$linknum
6082 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6083 setlink $linkid link$linknum
6088 proc setlink {id lk} {
6089 global curview ctext pendinglinks
6092 if {[string length $id] < 40} {
6093 set matches [longid $id]
6094 if {[llength $matches] > 0} {
6095 if {[llength $matches] > 1} return
6097 set id [lindex $matches 0]
6100 set known [commitinview $id $curview]
6103 $ctext tag conf $lk -foreground blue -underline 1
6104 $ctext tag bind $lk <1> [list selbyid $id]
6105 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6106 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6108 lappend pendinglinks($id) $lk
6109 interestedin $id {makelink %P}
6113 proc makelink {id} {
6116 if {![info exists pendinglinks($id)]} return
6117 foreach lk $pendinglinks($id) {
6120 unset pendinglinks($id)
6123 proc linkcursor {w inc} {
6124 global linkentercount curtextcursor
6126 if {[incr linkentercount $inc] > 0} {
6127 $w configure -cursor hand2
6129 $w configure -cursor $curtextcursor
6130 if {$linkentercount < 0} {
6131 set linkentercount 0
6136 proc viewnextline {dir} {
6140 set ymax [lindex [$canv cget -scrollregion] 3]
6141 set wnow [$canv yview]
6142 set wtop [expr {[lindex $wnow 0] * $ymax}]
6143 set newtop [expr {$wtop + $dir * $linespc}]
6146 } elseif {$newtop > $ymax} {
6149 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6152 # add a list of tag or branch names at position pos
6153 # returns the number of names inserted
6154 proc appendrefs {pos ids var} {
6155 global ctext linknum curview $var maxrefs
6157 if {[catch {$ctext index $pos}]} {
6160 $ctext conf -state normal
6161 $ctext delete $pos "$pos lineend"
6164 foreach tag [set $var\($id\)] {
6165 lappend tags [list $tag $id]
6168 if {[llength $tags] > $maxrefs} {
6169 $ctext insert $pos "many ([llength $tags])"
6171 set tags [lsort -index 0 -decreasing $tags]
6174 set id [lindex $ti 1]
6177 $ctext tag delete $lk
6178 $ctext insert $pos $sep
6179 $ctext insert $pos [lindex $ti 0] $lk
6184 $ctext conf -state disabled
6185 return [llength $tags]
6188 # called when we have finished computing the nearby tags
6189 proc dispneartags {delay} {
6190 global selectedline currentid showneartags tagphase
6192 if {$selectedline eq {} || !$showneartags} return
6193 after cancel dispnexttag
6195 after 200 dispnexttag
6198 after idle dispnexttag
6203 proc dispnexttag {} {
6204 global selectedline currentid showneartags tagphase ctext
6206 if {$selectedline eq {} || !$showneartags} return
6207 switch -- $tagphase {
6209 set dtags [desctags $currentid]
6211 appendrefs precedes $dtags idtags
6215 set atags [anctags $currentid]
6217 appendrefs follows $atags idtags
6221 set dheads [descheads $currentid]
6222 if {$dheads ne {}} {
6223 if {[appendrefs branch $dheads idheads] > 1
6224 && [$ctext get "branch -3c"] eq "h"} {
6225 # turn "Branch" into "Branches"
6226 $ctext conf -state normal
6227 $ctext insert "branch -2c" "es"
6228 $ctext conf -state disabled
6233 if {[incr tagphase] <= 2} {
6234 after idle dispnexttag
6238 proc make_secsel {l} {
6239 global linehtag linentag linedtag canv canv2 canv3
6241 if {![info exists linehtag($l)]} return
6243 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
6244 -tags secsel -fill [$canv cget -selectbackground]]
6246 $canv2 delete secsel
6247 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
6248 -tags secsel -fill [$canv2 cget -selectbackground]]
6250 $canv3 delete secsel
6251 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
6252 -tags secsel -fill [$canv3 cget -selectbackground]]
6256 proc selectline {l isnew {desired_loc {}}} {
6257 global canv ctext commitinfo selectedline
6258 global canvy0 linespc parents children curview
6259 global currentid sha1entry
6260 global commentend idtags linknum
6261 global mergemax numcommits pending_select
6262 global cmitmode showneartags allcommits
6263 global targetrow targetid lastscrollrows
6264 global autoselect jump_to_here
6266 catch {unset pending_select}
6271 if {$l < 0 || $l >= $numcommits} return
6272 set id [commitonrow $l]
6277 if {$lastscrollrows < $numcommits} {
6281 set y [expr {$canvy0 + $l * $linespc}]
6282 set ymax [lindex [$canv cget -scrollregion] 3]
6283 set ytop [expr {$y - $linespc - 1}]
6284 set ybot [expr {$y + $linespc + 1}]
6285 set wnow [$canv yview]
6286 set wtop [expr {[lindex $wnow 0] * $ymax}]
6287 set wbot [expr {[lindex $wnow 1] * $ymax}]
6288 set wh [expr {$wbot - $wtop}]
6290 if {$ytop < $wtop} {
6291 if {$ybot < $wtop} {
6292 set newtop [expr {$y - $wh / 2.0}]
6295 if {$newtop > $wtop - $linespc} {
6296 set newtop [expr {$wtop - $linespc}]
6299 } elseif {$ybot > $wbot} {
6300 if {$ytop > $wbot} {
6301 set newtop [expr {$y - $wh / 2.0}]
6303 set newtop [expr {$ybot - $wh}]
6304 if {$newtop < $wtop + $linespc} {
6305 set newtop [expr {$wtop + $linespc}]
6309 if {$newtop != $wtop} {
6313 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6320 addtohistory [list selbyid $id]
6323 $sha1entry delete 0 end
6324 $sha1entry insert 0 $id
6326 $sha1entry selection from 0
6327 $sha1entry selection to end
6331 $ctext conf -state normal
6334 if {![info exists commitinfo($id)]} {
6337 set info $commitinfo($id)
6338 set date [formatdate [lindex $info 2]]
6339 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6340 set date [formatdate [lindex $info 4]]
6341 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6342 if {[info exists idtags($id)]} {
6343 $ctext insert end [mc "Tags:"]
6344 foreach tag $idtags($id) {
6345 $ctext insert end " $tag"
6347 $ctext insert end "\n"
6351 set olds $parents($curview,$id)
6352 if {[llength $olds] > 1} {
6355 if {$np >= $mergemax} {
6360 $ctext insert end "[mc "Parent"]: " $tag
6361 appendwithlinks [commit_descriptor $p] {}
6366 append headers "[mc "Parent"]: [commit_descriptor $p]"
6370 foreach c $children($curview,$id) {
6371 append headers "[mc "Child"]: [commit_descriptor $c]"
6374 # make anything that looks like a SHA1 ID be a clickable link
6375 appendwithlinks $headers {}
6376 if {$showneartags} {
6377 if {![info exists allcommits]} {
6380 $ctext insert end "[mc "Branch"]: "
6381 $ctext mark set branch "end -1c"
6382 $ctext mark gravity branch left
6383 $ctext insert end "\n[mc "Follows"]: "
6384 $ctext mark set follows "end -1c"
6385 $ctext mark gravity follows left
6386 $ctext insert end "\n[mc "Precedes"]: "
6387 $ctext mark set precedes "end -1c"
6388 $ctext mark gravity precedes left
6389 $ctext insert end "\n"
6392 $ctext insert end "\n"
6393 set comment [lindex $info 5]
6394 if {[string first "\r" $comment] >= 0} {
6395 set comment [string map {"\r" "\n "} $comment]
6397 appendwithlinks $comment {comment}
6399 $ctext tag remove found 1.0 end
6400 $ctext conf -state disabled
6401 set commentend [$ctext index "end - 1c"]
6403 set jump_to_here $desired_loc
6404 init_flist [mc "Comments"]
6405 if {$cmitmode eq "tree"} {
6407 } elseif {[llength $olds] <= 1} {
6414 proc selfirstline {} {
6419 proc sellastline {} {
6422 set l [expr {$numcommits - 1}]
6426 proc selnextline {dir} {
6429 if {$selectedline eq {}} return
6430 set l [expr {$selectedline + $dir}]
6435 proc selnextpage {dir} {
6436 global canv linespc selectedline numcommits
6438 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6442 allcanvs yview scroll [expr {$dir * $lpp}] units
6444 if {$selectedline eq {}} return
6445 set l [expr {$selectedline + $dir * $lpp}]
6448 } elseif {$l >= $numcommits} {
6449 set l [expr $numcommits - 1]
6455 proc unselectline {} {
6456 global selectedline currentid
6459 catch {unset currentid}
6460 allcanvs delete secsel
6464 proc reselectline {} {
6467 if {$selectedline ne {}} {
6468 selectline $selectedline 0
6472 proc addtohistory {cmd} {
6473 global history historyindex curview
6475 set elt [list $curview $cmd]
6476 if {$historyindex > 0
6477 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6481 if {$historyindex < [llength $history]} {
6482 set history [lreplace $history $historyindex end $elt]
6484 lappend history $elt
6487 if {$historyindex > 1} {
6488 .tf.bar.leftbut conf -state normal
6490 .tf.bar.leftbut conf -state disabled
6492 .tf.bar.rightbut conf -state disabled
6498 set view [lindex $elt 0]
6499 set cmd [lindex $elt 1]
6500 if {$curview != $view} {
6507 global history historyindex
6510 if {$historyindex > 1} {
6511 incr historyindex -1
6512 godo [lindex $history [expr {$historyindex - 1}]]
6513 .tf.bar.rightbut conf -state normal
6515 if {$historyindex <= 1} {
6516 .tf.bar.leftbut conf -state disabled
6521 global history historyindex
6524 if {$historyindex < [llength $history]} {
6525 set cmd [lindex $history $historyindex]
6528 .tf.bar.leftbut conf -state normal
6530 if {$historyindex >= [llength $history]} {
6531 .tf.bar.rightbut conf -state disabled
6536 global treefilelist treeidlist diffids diffmergeid treepending
6537 global nullid nullid2
6540 catch {unset diffmergeid}
6541 if {![info exists treefilelist($id)]} {
6542 if {![info exists treepending]} {
6543 if {$id eq $nullid} {
6544 set cmd [list | git ls-files]
6545 } elseif {$id eq $nullid2} {
6546 set cmd [list | git ls-files --stage -t]
6548 set cmd [list | git ls-tree -r $id]
6550 if {[catch {set gtf [open $cmd r]}]} {
6554 set treefilelist($id) {}
6555 set treeidlist($id) {}
6556 fconfigure $gtf -blocking 0 -encoding binary
6557 filerun $gtf [list gettreeline $gtf $id]
6564 proc gettreeline {gtf id} {
6565 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6568 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6569 if {$diffids eq $nullid} {
6572 set i [string first "\t" $line]
6573 if {$i < 0} continue
6574 set fname [string range $line [expr {$i+1}] end]
6575 set line [string range $line 0 [expr {$i-1}]]
6576 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6577 set sha1 [lindex $line 2]
6578 lappend treeidlist($id) $sha1
6580 if {[string index $fname 0] eq "\""} {
6581 set fname [lindex $fname 0]
6583 set fname [encoding convertfrom $fname]
6584 lappend treefilelist($id) $fname
6587 return [expr {$nl >= 1000? 2: 1}]
6591 if {$cmitmode ne "tree"} {
6592 if {![info exists diffmergeid]} {
6593 gettreediffs $diffids
6595 } elseif {$id ne $diffids} {
6604 global treefilelist treeidlist diffids nullid nullid2
6605 global ctext_file_names ctext_file_lines
6606 global ctext commentend
6608 set i [lsearch -exact $treefilelist($diffids) $f]
6610 puts "oops, $f not in list for id $diffids"
6613 if {$diffids eq $nullid} {
6614 if {[catch {set bf [open $f r]} err]} {
6615 puts "oops, can't read $f: $err"
6619 set blob [lindex $treeidlist($diffids) $i]
6620 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6621 puts "oops, error reading blob $blob: $err"
6625 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6626 filerun $bf [list getblobline $bf $diffids]
6627 $ctext config -state normal
6628 clear_ctext $commentend
6629 lappend ctext_file_names $f
6630 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6631 $ctext insert end "\n"
6632 $ctext insert end "$f\n" filesep
6633 $ctext config -state disabled
6634 $ctext yview $commentend
6638 proc getblobline {bf id} {
6639 global diffids cmitmode ctext
6641 if {$id ne $diffids || $cmitmode ne "tree"} {
6645 $ctext config -state normal
6647 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6648 $ctext insert end "$line\n"
6651 global jump_to_here ctext_file_names commentend
6653 # delete last newline
6654 $ctext delete "end - 2c" "end - 1c"
6656 if {$jump_to_here ne {} &&
6657 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6658 set lnum [expr {[lindex $jump_to_here 1] +
6659 [lindex [split $commentend .] 0]}]
6660 mark_ctext_line $lnum
6664 $ctext config -state disabled
6665 return [expr {$nl >= 1000? 2: 1}]
6668 proc mark_ctext_line {lnum} {
6669 global ctext markbgcolor
6671 $ctext tag delete omark
6672 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
6673 $ctext tag conf omark -background $markbgcolor
6677 proc mergediff {id} {
6678 global diffmergeid mdifffd
6679 global diffids treediffs
6683 global limitdiffs vfilelimit curview
6688 set treediffs($id) {}
6690 # this doesn't seem to actually affect anything...
6691 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6692 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6693 set cmd [concat $cmd -- $vfilelimit($curview)]
6695 if {[catch {set mdf [open $cmd r]} err]} {
6696 error_popup "[mc "Error getting merge diffs:"] $err"
6699 fconfigure $mdf -blocking 0 -encoding binary
6700 set mdifffd($id) $mdf
6701 set np [llength $parents($curview,$id)]
6702 set diffencoding [get_path_encoding {}]
6704 filerun $mdf [list getmergediffline $mdf $id $np]
6707 proc getmergediffline {mdf id np} {
6708 global diffmergeid ctext cflist mergemax
6709 global difffilestart mdifffd treediffs
6710 global ctext_file_names ctext_file_lines
6711 global diffencoding jump_to_here targetline diffline
6713 $ctext conf -state normal
6715 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6716 if {![info exists diffmergeid] || $id != $diffmergeid
6717 || $mdf != $mdifffd($id)} {
6721 if {[regexp {^diff --cc (.*)} $line match fname]} {
6722 # start of a new file
6723 set fname [encoding convertfrom $fname]
6724 $ctext insert end "\n"
6725 set here [$ctext index "end - 1c"]
6726 lappend difffilestart $here
6727 lappend treediffs($id) $fname
6728 add_flist [list $fname]
6729 lappend ctext_file_names $fname
6730 lappend ctext_file_lines [lindex [split $here "."] 0]
6731 set diffencoding [get_path_encoding $fname]
6732 set l [expr {(78 - [string length $fname]) / 2}]
6733 set pad [string range "----------------------------------------" 1 $l]
6734 $ctext insert end "$pad $fname $pad\n" filesep
6736 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
6737 set targetline [lindex $jump_to_here 1]
6740 } elseif {[regexp {^@@} $line]} {
6741 set line [encoding convertfrom $diffencoding $line]
6742 $ctext insert end "$line\n" hunksep
6743 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
6746 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6749 set line [encoding convertfrom $diffencoding $line]
6750 # parse the prefix - one ' ', '-' or '+' for each parent
6755 for {set j 0} {$j < $np} {incr j} {
6756 set c [string range $line $j $j]
6759 } elseif {$c == "-"} {
6761 } elseif {$c == "+"} {
6770 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6771 # line doesn't appear in result, parents in $minuses have the line
6772 set num [lindex $minuses 0]
6773 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6774 # line appears in result, parents in $pluses don't have the line
6775 lappend tags mresult
6776 set num [lindex $spaces 0]
6779 if {$num >= $mergemax} {
6784 $ctext insert end "$line\n" $tags
6785 if {$targetline ne {} && $minuses eq {}} {
6786 if {$diffline == $targetline} {
6787 set here [$ctext index "end - 1 line"]
6788 mark_ctext_line [lindex [split $here .] 0]
6796 $ctext conf -state disabled
6801 return [expr {$nr >= 1000? 2: 1}]
6804 proc startdiff {ids} {
6805 global treediffs diffids treepending diffmergeid nullid nullid2
6809 catch {unset diffmergeid}
6810 if {![info exists treediffs($ids)] ||
6811 [lsearch -exact $ids $nullid] >= 0 ||
6812 [lsearch -exact $ids $nullid2] >= 0} {
6813 if {![info exists treepending]} {
6821 proc path_filter {filter name} {
6823 set l [string length $p]
6824 if {[string index $p end] eq "/"} {
6825 if {[string compare -length $l $p $name] == 0} {
6829 if {[string compare -length $l $p $name] == 0 &&
6830 ([string length $name] == $l ||
6831 [string index $name $l] eq "/")} {
6839 proc addtocflist {ids} {
6842 add_flist $treediffs($ids)
6846 proc diffcmd {ids flags} {
6847 global nullid nullid2
6849 set i [lsearch -exact $ids $nullid]
6850 set j [lsearch -exact $ids $nullid2]
6852 if {[llength $ids] > 1 && $j < 0} {
6853 # comparing working directory with some specific revision
6854 set cmd [concat | git diff-index $flags]
6856 lappend cmd -R [lindex $ids 1]
6858 lappend cmd [lindex $ids 0]
6861 # comparing working directory with index
6862 set cmd [concat | git diff-files $flags]
6867 } elseif {$j >= 0} {
6868 set cmd [concat | git diff-index --cached $flags]
6869 if {[llength $ids] > 1} {
6870 # comparing index with specific revision
6872 lappend cmd -R [lindex $ids 1]
6874 lappend cmd [lindex $ids 0]
6877 # comparing index with HEAD
6881 set cmd [concat | git diff-tree -r $flags $ids]
6886 proc gettreediffs {ids} {
6887 global treediff treepending
6889 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6891 set treepending $ids
6893 fconfigure $gdtf -blocking 0 -encoding binary
6894 filerun $gdtf [list gettreediffline $gdtf $ids]
6897 proc gettreediffline {gdtf ids} {
6898 global treediff treediffs treepending diffids diffmergeid
6899 global cmitmode vfilelimit curview limitdiffs perfile_attrs
6904 if {$perfile_attrs} {
6905 # cache_gitattr is slow, and even slower on win32 where we
6906 # have to invoke it for only about 30 paths at a time
6908 if {[tk windowingsystem] == "win32"} {
6912 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
6913 set i [string first "\t" $line]
6915 set file [string range $line [expr {$i+1}] end]
6916 if {[string index $file 0] eq "\""} {
6917 set file [lindex $file 0]
6919 set file [encoding convertfrom $file]
6920 lappend treediff $file
6921 lappend sublist $file
6924 if {$perfile_attrs} {
6925 cache_gitattr encoding $sublist
6928 return [expr {$nr >= $max? 2: 1}]
6931 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6933 foreach f $treediff {
6934 if {[path_filter $vfilelimit($curview) $f]} {
6938 set treediffs($ids) $flist
6940 set treediffs($ids) $treediff
6943 if {$cmitmode eq "tree"} {
6945 } elseif {$ids != $diffids} {
6946 if {![info exists diffmergeid]} {
6947 gettreediffs $diffids
6955 # empty string or positive integer
6956 proc diffcontextvalidate {v} {
6957 return [regexp {^(|[1-9][0-9]*)$} $v]
6960 proc diffcontextchange {n1 n2 op} {
6961 global diffcontextstring diffcontext
6963 if {[string is integer -strict $diffcontextstring]} {
6964 if {$diffcontextstring > 0} {
6965 set diffcontext $diffcontextstring
6971 proc changeignorespace {} {
6975 proc getblobdiffs {ids} {
6976 global blobdifffd diffids env
6977 global diffinhdr treediffs
6980 global limitdiffs vfilelimit curview
6981 global diffencoding targetline
6983 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6987 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6988 set cmd [concat $cmd -- $vfilelimit($curview)]
6990 if {[catch {set bdf [open $cmd r]} err]} {
6991 puts "error getting diffs: $err"
6996 set diffencoding [get_path_encoding {}]
6997 fconfigure $bdf -blocking 0 -encoding binary
6998 set blobdifffd($ids) $bdf
6999 filerun $bdf [list getblobdiffline $bdf $diffids]
7002 proc setinlist {var i val} {
7005 while {[llength [set $var]] < $i} {
7008 if {[llength [set $var]] == $i} {
7015 proc makediffhdr {fname ids} {
7016 global ctext curdiffstart treediffs
7017 global ctext_file_names jump_to_here targetline diffline
7019 set i [lsearch -exact $treediffs($ids) $fname]
7021 setinlist difffilestart $i $curdiffstart
7023 set ctext_file_names [lreplace $ctext_file_names end end $fname]
7024 set l [expr {(78 - [string length $fname]) / 2}]
7025 set pad [string range "----------------------------------------" 1 $l]
7026 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7028 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7029 set targetline [lindex $jump_to_here 1]
7034 proc getblobdiffline {bdf ids} {
7035 global diffids blobdifffd ctext curdiffstart
7036 global diffnexthead diffnextnote difffilestart
7037 global ctext_file_names ctext_file_lines
7038 global diffinhdr treediffs
7039 global diffencoding jump_to_here targetline diffline
7042 $ctext conf -state normal
7043 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7044 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7048 if {![string compare -length 11 "diff --git " $line]} {
7049 # trim off "diff --git "
7050 set line [string range $line 11 end]
7052 # start of a new file
7053 $ctext insert end "\n"
7054 set curdiffstart [$ctext index "end - 1c"]
7055 lappend ctext_file_names ""
7056 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7057 $ctext insert end "\n" filesep
7058 # If the name hasn't changed the length will be odd,
7059 # the middle char will be a space, and the two bits either
7060 # side will be a/name and b/name, or "a/name" and "b/name".
7061 # If the name has changed we'll get "rename from" and
7062 # "rename to" or "copy from" and "copy to" lines following this,
7063 # and we'll use them to get the filenames.
7064 # This complexity is necessary because spaces in the filename(s)
7065 # don't get escaped.
7066 set l [string length $line]
7067 set i [expr {$l / 2}]
7068 if {!(($l & 1) && [string index $line $i] eq " " &&
7069 [string range $line 2 [expr {$i - 1}]] eq \
7070 [string range $line [expr {$i + 3}] end])} {
7073 # unescape if quoted and chop off the a/ from the front
7074 if {[string index $line 0] eq "\""} {
7075 set fname [string range [lindex $line 0] 2 end]
7077 set fname [string range $line 2 [expr {$i - 1}]]
7079 set fname [encoding convertfrom $fname]
7080 set diffencoding [get_path_encoding $fname]
7081 makediffhdr $fname $ids
7083 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
7084 $line match f1l f1c f2l f2c rest]} {
7085 set line [encoding convertfrom $diffencoding $line]
7086 $ctext insert end "$line\n" hunksep
7090 } elseif {$diffinhdr} {
7091 if {![string compare -length 12 "rename from " $line]} {
7092 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7093 if {[string index $fname 0] eq "\""} {
7094 set fname [lindex $fname 0]
7096 set fname [encoding convertfrom $fname]
7097 set i [lsearch -exact $treediffs($ids) $fname]
7099 setinlist difffilestart $i $curdiffstart
7101 } elseif {![string compare -length 10 $line "rename to "] ||
7102 ![string compare -length 8 $line "copy to "]} {
7103 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7104 if {[string index $fname 0] eq "\""} {
7105 set fname [lindex $fname 0]
7107 set fname [encoding convertfrom $fname]
7108 set diffencoding [get_path_encoding $fname]
7109 makediffhdr $fname $ids
7110 } elseif {[string compare -length 3 $line "---"] == 0} {
7113 } elseif {[string compare -length 3 $line "+++"] == 0} {
7117 $ctext insert end "$line\n" filesep
7120 set line [encoding convertfrom $diffencoding $line]
7121 set x [string range $line 0 0]
7122 set here [$ctext index "end - 1 chars"]
7123 if {$x == "-" || $x == "+"} {
7124 set tag [expr {$x == "+"}]
7125 $ctext insert end "$line\n" d$tag
7126 } elseif {$x == " "} {
7127 $ctext insert end "$line\n"
7129 # "\ No newline at end of file",
7130 # or something else we don't recognize
7131 $ctext insert end "$line\n" hunksep
7133 if {$targetline ne {} && ($x eq " " || $x eq "+")} {
7134 if {$diffline == $targetline} {
7135 mark_ctext_line [lindex [split $here .] 0]
7143 $ctext conf -state disabled
7148 return [expr {$nr >= 1000? 2: 1}]
7151 proc changediffdisp {} {
7152 global ctext diffelide
7154 $ctext tag conf d0 -elide [lindex $diffelide 0]
7155 $ctext tag conf d1 -elide [lindex $diffelide 1]
7158 proc highlightfile {loc cline} {
7159 global ctext cflist cflist_top
7162 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7163 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7164 $cflist see $cline.0
7165 set cflist_top $cline
7169 global difffilestart ctext cmitmode
7171 if {$cmitmode eq "tree"} return
7174 set here [$ctext index @0,0]
7175 foreach loc $difffilestart {
7176 if {[$ctext compare $loc >= $here]} {
7177 highlightfile $prev $prevline
7183 highlightfile $prev $prevline
7187 global difffilestart ctext cmitmode
7189 if {$cmitmode eq "tree"} return
7190 set here [$ctext index @0,0]
7192 foreach loc $difffilestart {
7194 if {[$ctext compare $loc > $here]} {
7195 highlightfile $loc $line
7201 proc clear_ctext {{first 1.0}} {
7202 global ctext smarktop smarkbot
7203 global ctext_file_names ctext_file_lines
7206 set l [lindex [split $first .] 0]
7207 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7210 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7213 $ctext delete $first end
7214 if {$first eq "1.0"} {
7215 catch {unset pendinglinks}
7217 set ctext_file_names {}
7218 set ctext_file_lines {}
7221 proc settabs {{firstab {}}} {
7222 global firsttabstop tabstop ctext have_tk85
7224 if {$firstab ne {} && $have_tk85} {
7225 set firsttabstop $firstab
7227 set w [font measure textfont "0"]
7228 if {$firsttabstop != 0} {
7229 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7230 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7231 } elseif {$have_tk85 || $tabstop != 8} {
7232 $ctext conf -tabs [expr {$tabstop * $w}]
7234 $ctext conf -tabs {}
7238 proc incrsearch {name ix op} {
7239 global ctext searchstring searchdirn
7241 $ctext tag remove found 1.0 end
7242 if {[catch {$ctext index anchor}]} {
7243 # no anchor set, use start of selection, or of visible area
7244 set sel [$ctext tag ranges sel]
7246 $ctext mark set anchor [lindex $sel 0]
7247 } elseif {$searchdirn eq "-forwards"} {
7248 $ctext mark set anchor @0,0
7250 $ctext mark set anchor @0,[winfo height $ctext]
7253 if {$searchstring ne {}} {
7254 set here [$ctext search $searchdirn -- $searchstring anchor]
7263 global sstring ctext searchstring searchdirn
7266 $sstring icursor end
7267 set searchdirn -forwards
7268 if {$searchstring ne {}} {
7269 set sel [$ctext tag ranges sel]
7271 set start "[lindex $sel 0] + 1c"
7272 } elseif {[catch {set start [$ctext index anchor]}]} {
7275 set match [$ctext search -count mlen -- $searchstring $start]
7276 $ctext tag remove sel 1.0 end
7282 set mend "$match + $mlen c"
7283 $ctext tag add sel $match $mend
7284 $ctext mark unset anchor
7288 proc dosearchback {} {
7289 global sstring ctext searchstring searchdirn
7292 $sstring icursor end
7293 set searchdirn -backwards
7294 if {$searchstring ne {}} {
7295 set sel [$ctext tag ranges sel]
7297 set start [lindex $sel 0]
7298 } elseif {[catch {set start [$ctext index anchor]}]} {
7299 set start @0,[winfo height $ctext]
7301 set match [$ctext search -backwards -count ml -- $searchstring $start]
7302 $ctext tag remove sel 1.0 end
7308 set mend "$match + $ml c"
7309 $ctext tag add sel $match $mend
7310 $ctext mark unset anchor
7314 proc searchmark {first last} {
7315 global ctext searchstring
7319 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7320 if {$match eq {}} break
7321 set mend "$match + $mlen c"
7322 $ctext tag add found $match $mend
7326 proc searchmarkvisible {doall} {
7327 global ctext smarktop smarkbot
7329 set topline [lindex [split [$ctext index @0,0] .] 0]
7330 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7331 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7332 # no overlap with previous
7333 searchmark $topline $botline
7334 set smarktop $topline
7335 set smarkbot $botline
7337 if {$topline < $smarktop} {
7338 searchmark $topline [expr {$smarktop-1}]
7339 set smarktop $topline
7341 if {$botline > $smarkbot} {
7342 searchmark [expr {$smarkbot+1}] $botline
7343 set smarkbot $botline
7348 proc scrolltext {f0 f1} {
7351 .bleft.bottom.sb set $f0 $f1
7352 if {$searchstring ne {}} {
7358 global linespc charspc canvx0 canvy0
7359 global xspc1 xspc2 lthickness
7361 set linespc [font metrics mainfont -linespace]
7362 set charspc [font measure mainfont "m"]
7363 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7364 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7365 set lthickness [expr {int($linespc / 9) + 1}]
7366 set xspc1(0) $linespc
7374 set ymax [lindex [$canv cget -scrollregion] 3]
7375 if {$ymax eq {} || $ymax == 0} return
7376 set span [$canv yview]
7379 allcanvs yview moveto [lindex $span 0]
7381 if {$selectedline ne {}} {
7382 selectline $selectedline 0
7383 allcanvs yview moveto [lindex $span 0]
7387 proc parsefont {f n} {
7390 set fontattr($f,family) [lindex $n 0]
7392 if {$s eq {} || $s == 0} {
7395 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7397 set fontattr($f,size) $s
7398 set fontattr($f,weight) normal
7399 set fontattr($f,slant) roman
7400 foreach style [lrange $n 2 end] {
7403 "bold" {set fontattr($f,weight) $style}
7405 "italic" {set fontattr($f,slant) $style}
7410 proc fontflags {f {isbold 0}} {
7413 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7414 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7415 -slant $fontattr($f,slant)]
7421 set n [list $fontattr($f,family) $fontattr($f,size)]
7422 if {$fontattr($f,weight) eq "bold"} {
7425 if {$fontattr($f,slant) eq "italic"} {
7431 proc incrfont {inc} {
7432 global mainfont textfont ctext canv cflist showrefstop
7433 global stopped entries fontattr
7436 set s $fontattr(mainfont,size)
7441 set fontattr(mainfont,size) $s
7442 font config mainfont -size $s
7443 font config mainfontbold -size $s
7444 set mainfont [fontname mainfont]
7445 set s $fontattr(textfont,size)
7450 set fontattr(textfont,size) $s
7451 font config textfont -size $s
7452 font config textfontbold -size $s
7453 set textfont [fontname textfont]
7460 global sha1entry sha1string
7461 if {[string length $sha1string] == 40} {
7462 $sha1entry delete 0 end
7466 proc sha1change {n1 n2 op} {
7467 global sha1string currentid sha1but
7468 if {$sha1string == {}
7469 || ([info exists currentid] && $sha1string == $currentid)} {
7474 if {[$sha1but cget -state] == $state} return
7475 if {$state == "normal"} {
7476 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7478 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7482 proc gotocommit {} {
7483 global sha1string tagids headids curview varcid
7485 if {$sha1string == {}
7486 || ([info exists currentid] && $sha1string == $currentid)} return
7487 if {[info exists tagids($sha1string)]} {
7488 set id $tagids($sha1string)
7489 } elseif {[info exists headids($sha1string)]} {
7490 set id $headids($sha1string)
7492 set id [string tolower $sha1string]
7493 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7494 set matches [longid $id]
7495 if {$matches ne {}} {
7496 if {[llength $matches] > 1} {
7497 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7500 set id [lindex $matches 0]
7504 if {[commitinview $id $curview]} {
7505 selectline [rowofcommit $id] 1
7508 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7509 set msg [mc "SHA1 id %s is not known" $sha1string]
7511 set msg [mc "Tag/Head %s is not known" $sha1string]
7516 proc lineenter {x y id} {
7517 global hoverx hovery hoverid hovertimer
7518 global commitinfo canv
7520 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7524 if {[info exists hovertimer]} {
7525 after cancel $hovertimer
7527 set hovertimer [after 500 linehover]
7531 proc linemotion {x y id} {
7532 global hoverx hovery hoverid hovertimer
7534 if {[info exists hoverid] && $id == $hoverid} {
7537 if {[info exists hovertimer]} {
7538 after cancel $hovertimer
7540 set hovertimer [after 500 linehover]
7544 proc lineleave {id} {
7545 global hoverid hovertimer canv
7547 if {[info exists hoverid] && $id == $hoverid} {
7549 if {[info exists hovertimer]} {
7550 after cancel $hovertimer
7558 global hoverx hovery hoverid hovertimer
7559 global canv linespc lthickness
7562 set text [lindex $commitinfo($hoverid) 0]
7563 set ymax [lindex [$canv cget -scrollregion] 3]
7564 if {$ymax == {}} return
7565 set yfrac [lindex [$canv yview] 0]
7566 set x [expr {$hoverx + 2 * $linespc}]
7567 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7568 set x0 [expr {$x - 2 * $lthickness}]
7569 set y0 [expr {$y - 2 * $lthickness}]
7570 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7571 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7572 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7573 -fill \#ffff80 -outline black -width 1 -tags hover]
7575 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7580 proc clickisonarrow {id y} {
7583 set ranges [rowranges $id]
7584 set thresh [expr {2 * $lthickness + 6}]
7585 set n [expr {[llength $ranges] - 1}]
7586 for {set i 1} {$i < $n} {incr i} {
7587 set row [lindex $ranges $i]
7588 if {abs([yc $row] - $y) < $thresh} {
7595 proc arrowjump {id n y} {
7598 # 1 <-> 2, 3 <-> 4, etc...
7599 set n [expr {(($n - 1) ^ 1) + 1}]
7600 set row [lindex [rowranges $id] $n]
7602 set ymax [lindex [$canv cget -scrollregion] 3]
7603 if {$ymax eq {} || $ymax <= 0} return
7604 set view [$canv yview]
7605 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7606 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7610 allcanvs yview moveto $yfrac
7613 proc lineclick {x y id isnew} {
7614 global ctext commitinfo children canv thickerline curview
7616 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7621 # draw this line thicker than normal
7625 set ymax [lindex [$canv cget -scrollregion] 3]
7626 if {$ymax eq {}} return
7627 set yfrac [lindex [$canv yview] 0]
7628 set y [expr {$y + $yfrac * $ymax}]
7630 set dirn [clickisonarrow $id $y]
7632 arrowjump $id $dirn $y
7637 addtohistory [list lineclick $x $y $id 0]
7639 # fill the details pane with info about this line
7640 $ctext conf -state normal
7643 $ctext insert end "[mc "Parent"]:\t"
7644 $ctext insert end $id link0
7646 set info $commitinfo($id)
7647 $ctext insert end "\n\t[lindex $info 0]\n"
7648 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7649 set date [formatdate [lindex $info 2]]
7650 $ctext insert end "\t[mc "Date"]:\t$date\n"
7651 set kids $children($curview,$id)
7653 $ctext insert end "\n[mc "Children"]:"
7655 foreach child $kids {
7657 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7658 set info $commitinfo($child)
7659 $ctext insert end "\n\t"
7660 $ctext insert end $child link$i
7661 setlink $child link$i
7662 $ctext insert end "\n\t[lindex $info 0]"
7663 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7664 set date [formatdate [lindex $info 2]]
7665 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7668 $ctext conf -state disabled
7672 proc normalline {} {
7674 if {[info exists thickerline]} {
7683 if {[commitinview $id $curview]} {
7684 selectline [rowofcommit $id] 1
7690 if {![info exists startmstime]} {
7691 set startmstime [clock clicks -milliseconds]
7693 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7696 proc rowmenu {x y id} {
7697 global rowctxmenu selectedline rowmenuid curview
7698 global nullid nullid2 fakerowmenu mainhead
7702 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7707 if {$id ne $nullid && $id ne $nullid2} {
7708 set menu $rowctxmenu
7709 if {$mainhead ne {}} {
7710 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7712 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7715 set menu $fakerowmenu
7717 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7718 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7719 $menu entryconfigure [mca "Make patch"] -state $state
7720 tk_popup $menu $x $y
7723 proc diffvssel {dirn} {
7724 global rowmenuid selectedline
7726 if {$selectedline eq {}} return
7728 set oldid [commitonrow $selectedline]
7729 set newid $rowmenuid
7731 set oldid $rowmenuid
7732 set newid [commitonrow $selectedline]
7734 addtohistory [list doseldiff $oldid $newid]
7735 doseldiff $oldid $newid
7738 proc doseldiff {oldid newid} {
7742 $ctext conf -state normal
7744 init_flist [mc "Top"]
7745 $ctext insert end "[mc "From"] "
7746 $ctext insert end $oldid link0
7747 setlink $oldid link0
7748 $ctext insert end "\n "
7749 $ctext insert end [lindex $commitinfo($oldid) 0]
7750 $ctext insert end "\n\n[mc "To"] "
7751 $ctext insert end $newid link1
7752 setlink $newid link1
7753 $ctext insert end "\n "
7754 $ctext insert end [lindex $commitinfo($newid) 0]
7755 $ctext insert end "\n"
7756 $ctext conf -state disabled
7757 $ctext tag remove found 1.0 end
7758 startdiff [list $oldid $newid]
7762 global rowmenuid currentid commitinfo patchtop patchnum
7764 if {![info exists currentid]} return
7765 set oldid $currentid
7766 set oldhead [lindex $commitinfo($oldid) 0]
7767 set newid $rowmenuid
7768 set newhead [lindex $commitinfo($newid) 0]
7771 catch {destroy $top}
7773 label $top.title -text [mc "Generate patch"]
7774 grid $top.title - -pady 10
7775 label $top.from -text [mc "From:"]
7776 entry $top.fromsha1 -width 40 -relief flat
7777 $top.fromsha1 insert 0 $oldid
7778 $top.fromsha1 conf -state readonly
7779 grid $top.from $top.fromsha1 -sticky w
7780 entry $top.fromhead -width 60 -relief flat
7781 $top.fromhead insert 0 $oldhead
7782 $top.fromhead conf -state readonly
7783 grid x $top.fromhead -sticky w
7784 label $top.to -text [mc "To:"]
7785 entry $top.tosha1 -width 40 -relief flat
7786 $top.tosha1 insert 0 $newid
7787 $top.tosha1 conf -state readonly
7788 grid $top.to $top.tosha1 -sticky w
7789 entry $top.tohead -width 60 -relief flat
7790 $top.tohead insert 0 $newhead
7791 $top.tohead conf -state readonly
7792 grid x $top.tohead -sticky w
7793 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7794 grid $top.rev x -pady 10
7795 label $top.flab -text [mc "Output file:"]
7796 entry $top.fname -width 60
7797 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7799 grid $top.flab $top.fname -sticky w
7801 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7802 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7803 bind $top <Key-Return> mkpatchgo
7804 bind $top <Key-Escape> mkpatchcan
7805 grid $top.buts.gen $top.buts.can
7806 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7807 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7808 grid $top.buts - -pady 10 -sticky ew
7812 proc mkpatchrev {} {
7815 set oldid [$patchtop.fromsha1 get]
7816 set oldhead [$patchtop.fromhead get]
7817 set newid [$patchtop.tosha1 get]
7818 set newhead [$patchtop.tohead get]
7819 foreach e [list fromsha1 fromhead tosha1 tohead] \
7820 v [list $newid $newhead $oldid $oldhead] {
7821 $patchtop.$e conf -state normal
7822 $patchtop.$e delete 0 end
7823 $patchtop.$e insert 0 $v
7824 $patchtop.$e conf -state readonly
7829 global patchtop nullid nullid2
7831 set oldid [$patchtop.fromsha1 get]
7832 set newid [$patchtop.tosha1 get]
7833 set fname [$patchtop.fname get]
7834 set cmd [diffcmd [list $oldid $newid] -p]
7835 # trim off the initial "|"
7836 set cmd [lrange $cmd 1 end]
7837 lappend cmd >$fname &
7838 if {[catch {eval exec $cmd} err]} {
7839 error_popup "[mc "Error creating patch:"] $err"
7841 catch {destroy $patchtop}
7845 proc mkpatchcan {} {
7848 catch {destroy $patchtop}
7853 global rowmenuid mktagtop commitinfo
7857 catch {destroy $top}
7859 label $top.title -text [mc "Create tag"]
7860 grid $top.title - -pady 10
7861 label $top.id -text [mc "ID:"]
7862 entry $top.sha1 -width 40 -relief flat
7863 $top.sha1 insert 0 $rowmenuid
7864 $top.sha1 conf -state readonly
7865 grid $top.id $top.sha1 -sticky w
7866 entry $top.head -width 60 -relief flat
7867 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7868 $top.head conf -state readonly
7869 grid x $top.head -sticky w
7870 label $top.tlab -text [mc "Tag name:"]
7871 entry $top.tag -width 60
7872 grid $top.tlab $top.tag -sticky w
7874 button $top.buts.gen -text [mc "Create"] -command mktaggo
7875 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7876 bind $top <Key-Return> mktaggo
7877 bind $top <Key-Escape> mktagcan
7878 grid $top.buts.gen $top.buts.can
7879 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7880 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7881 grid $top.buts - -pady 10 -sticky ew
7886 global mktagtop env tagids idtags
7888 set id [$mktagtop.sha1 get]
7889 set tag [$mktagtop.tag get]
7891 error_popup [mc "No tag name specified"]
7894 if {[info exists tagids($tag)]} {
7895 error_popup [mc "Tag \"%s\" already exists" $tag]
7899 exec git tag $tag $id
7901 error_popup "[mc "Error creating tag:"] $err"
7905 set tagids($tag) $id
7906 lappend idtags($id) $tag
7913 proc redrawtags {id} {
7914 global canv linehtag idpos currentid curview cmitlisted
7915 global canvxmax iddrawn circleitem mainheadid circlecolors
7917 if {![commitinview $id $curview]} return
7918 if {![info exists iddrawn($id)]} return
7919 set row [rowofcommit $id]
7920 if {$id eq $mainheadid} {
7923 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7925 $canv itemconf $circleitem($row) -fill $ofill
7926 $canv delete tag.$id
7927 set xt [eval drawtags $id $idpos($id)]
7928 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7929 set text [$canv itemcget $linehtag($row) -text]
7930 set font [$canv itemcget $linehtag($row) -font]
7931 set xr [expr {$xt + [font measure $font $text]}]
7932 if {$xr > $canvxmax} {
7936 if {[info exists currentid] && $currentid == $id} {
7944 catch {destroy $mktagtop}
7953 proc writecommit {} {
7954 global rowmenuid wrcomtop commitinfo wrcomcmd
7956 set top .writecommit
7958 catch {destroy $top}
7960 label $top.title -text [mc "Write commit to file"]
7961 grid $top.title - -pady 10
7962 label $top.id -text [mc "ID:"]
7963 entry $top.sha1 -width 40 -relief flat
7964 $top.sha1 insert 0 $rowmenuid
7965 $top.sha1 conf -state readonly
7966 grid $top.id $top.sha1 -sticky w
7967 entry $top.head -width 60 -relief flat
7968 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7969 $top.head conf -state readonly
7970 grid x $top.head -sticky w
7971 label $top.clab -text [mc "Command:"]
7972 entry $top.cmd -width 60 -textvariable wrcomcmd
7973 grid $top.clab $top.cmd -sticky w -pady 10
7974 label $top.flab -text [mc "Output file:"]
7975 entry $top.fname -width 60
7976 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7977 grid $top.flab $top.fname -sticky w
7979 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7980 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7981 bind $top <Key-Return> wrcomgo
7982 bind $top <Key-Escape> wrcomcan
7983 grid $top.buts.gen $top.buts.can
7984 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7985 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7986 grid $top.buts - -pady 10 -sticky ew
7993 set id [$wrcomtop.sha1 get]
7994 set cmd "echo $id | [$wrcomtop.cmd get]"
7995 set fname [$wrcomtop.fname get]
7996 if {[catch {exec sh -c $cmd >$fname &} err]} {
7997 error_popup "[mc "Error writing commit:"] $err"
7999 catch {destroy $wrcomtop}
8006 catch {destroy $wrcomtop}
8011 global rowmenuid mkbrtop
8014 catch {destroy $top}
8016 label $top.title -text [mc "Create new branch"]
8017 grid $top.title - -pady 10
8018 label $top.id -text [mc "ID:"]
8019 entry $top.sha1 -width 40 -relief flat
8020 $top.sha1 insert 0 $rowmenuid
8021 $top.sha1 conf -state readonly
8022 grid $top.id $top.sha1 -sticky w
8023 label $top.nlab -text [mc "Name:"]
8024 entry $top.name -width 40
8025 bind $top.name <Key-Return> "[list mkbrgo $top]"
8026 grid $top.nlab $top.name -sticky w
8028 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8029 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8030 bind $top <Key-Return> [list mkbrgo $top]
8031 bind $top <Key-Escape> "catch {destroy $top}"
8032 grid $top.buts.go $top.buts.can
8033 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8034 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8035 grid $top.buts - -pady 10 -sticky ew
8040 global headids idheads
8042 set name [$top.name get]
8043 set id [$top.sha1 get]
8047 error_popup [mc "Please specify a name for the new branch"]
8050 if {[info exists headids($name)]} {
8051 if {![confirm_popup [mc \
8052 "Branch '%s' already exists. Overwrite?" $name]]} {
8055 set old_id $headids($name)
8058 catch {destroy $top}
8059 lappend cmdargs $name $id
8063 eval exec git branch $cmdargs
8069 if {$old_id ne {}} {
8075 set headids($name) $id
8076 lappend idheads($id) $name
8085 proc cherrypick {} {
8086 global rowmenuid curview
8087 global mainhead mainheadid
8089 set oldhead [exec git rev-parse HEAD]
8090 set dheads [descheads $rowmenuid]
8091 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8092 set ok [confirm_popup [mc "Commit %s is already\
8093 included in branch %s -- really re-apply it?" \
8094 [string range $rowmenuid 0 7] $mainhead]]
8097 nowbusy cherrypick [mc "Cherry-picking"]
8099 # Unfortunately git-cherry-pick writes stuff to stderr even when
8100 # no error occurs, and exec takes that as an indication of error...
8101 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8106 set newhead [exec git rev-parse HEAD]
8107 if {$newhead eq $oldhead} {
8109 error_popup [mc "No changes committed"]
8112 addnewchild $newhead $oldhead
8113 if {[commitinview $oldhead $curview]} {
8114 insertrow $newhead $oldhead $curview
8115 if {$mainhead ne {}} {
8116 movehead $newhead $mainhead
8117 movedhead $newhead $mainhead
8119 set mainheadid $newhead
8128 global mainhead rowmenuid confirm_ok resettype
8131 set w ".confirmreset"
8134 wm title $w [mc "Confirm reset"]
8135 message $w.m -text \
8136 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8137 -justify center -aspect 1000
8138 pack $w.m -side top -fill x -padx 20 -pady 20
8139 frame $w.f -relief sunken -border 2
8140 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8141 grid $w.f.rt -sticky w
8143 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8144 -text [mc "Soft: Leave working tree and index untouched"]
8145 grid $w.f.soft -sticky w
8146 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8147 -text [mc "Mixed: Leave working tree untouched, reset index"]
8148 grid $w.f.mixed -sticky w
8149 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8150 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8151 grid $w.f.hard -sticky w
8152 pack $w.f -side top -fill x
8153 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8154 pack $w.ok -side left -fill x -padx 20 -pady 20
8155 button $w.cancel -text [mc Cancel] -command "destroy $w"
8156 bind $w <Key-Escape> [list destroy $w]
8157 pack $w.cancel -side right -fill x -padx 20 -pady 20
8158 bind $w <Visibility> "grab $w; focus $w"
8160 if {!$confirm_ok} return
8161 if {[catch {set fd [open \
8162 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8166 filerun $fd [list readresetstat $fd]
8167 nowbusy reset [mc "Resetting"]
8172 proc readresetstat {fd} {
8173 global mainhead mainheadid showlocalchanges rprogcoord
8175 if {[gets $fd line] >= 0} {
8176 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8177 set rprogcoord [expr {1.0 * $m / $n}]
8185 if {[catch {close $fd} err]} {
8188 set oldhead $mainheadid
8189 set newhead [exec git rev-parse HEAD]
8190 if {$newhead ne $oldhead} {
8191 movehead $newhead $mainhead
8192 movedhead $newhead $mainhead
8193 set mainheadid $newhead
8197 if {$showlocalchanges} {
8203 # context menu for a head
8204 proc headmenu {x y id head} {
8205 global headmenuid headmenuhead headctxmenu mainhead
8209 set headmenuhead $head
8211 if {$head eq $mainhead} {
8214 $headctxmenu entryconfigure 0 -state $state
8215 $headctxmenu entryconfigure 1 -state $state
8216 tk_popup $headctxmenu $x $y
8220 global headmenuid headmenuhead headids
8221 global showlocalchanges mainheadid
8223 # check the tree is clean first??
8224 nowbusy checkout [mc "Checking out"]
8228 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8232 if {$showlocalchanges} {
8236 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8240 proc readcheckoutstat {fd newhead newheadid} {
8241 global mainhead mainheadid headids showlocalchanges progresscoords
8243 if {[gets $fd line] >= 0} {
8244 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8245 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8250 set progresscoords {0 0}
8253 if {[catch {close $fd} err]} {
8256 set oldmainid $mainheadid
8257 set mainhead $newhead
8258 set mainheadid $newheadid
8259 redrawtags $oldmainid
8260 redrawtags $newheadid
8262 if {$showlocalchanges} {
8268 global headmenuid headmenuhead mainhead
8271 set head $headmenuhead
8273 # this check shouldn't be needed any more...
8274 if {$head eq $mainhead} {
8275 error_popup [mc "Cannot delete the currently checked-out branch"]
8278 set dheads [descheads $id]
8279 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8280 # the stuff on this branch isn't on any other branch
8281 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8282 branch.\nReally delete branch %s?" $head $head]]} return
8286 if {[catch {exec git branch -D $head} err]} {
8291 removehead $id $head
8292 removedhead $id $head
8299 # Display a list of tags and heads
8301 global showrefstop bgcolor fgcolor selectbgcolor
8302 global bglist fglist reflistfilter reflist maincursor
8305 set showrefstop $top
8306 if {[winfo exists $top]} {
8312 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8313 text $top.list -background $bgcolor -foreground $fgcolor \
8314 -selectbackground $selectbgcolor -font mainfont \
8315 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8316 -width 30 -height 20 -cursor $maincursor \
8317 -spacing1 1 -spacing3 1 -state disabled
8318 $top.list tag configure highlight -background $selectbgcolor
8319 lappend bglist $top.list
8320 lappend fglist $top.list
8321 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8322 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8323 grid $top.list $top.ysb -sticky nsew
8324 grid $top.xsb x -sticky ew
8326 label $top.f.l -text "[mc "Filter"]: "
8327 entry $top.f.e -width 20 -textvariable reflistfilter
8328 set reflistfilter "*"
8329 trace add variable reflistfilter write reflistfilter_change
8330 pack $top.f.e -side right -fill x -expand 1
8331 pack $top.f.l -side left
8332 grid $top.f - -sticky ew -pady 2
8333 button $top.close -command [list destroy $top] -text [mc "Close"]
8334 bind $top <Key-Escape> [list destroy $top]
8336 grid columnconfigure $top 0 -weight 1
8337 grid rowconfigure $top 0 -weight 1
8338 bind $top.list <1> {break}
8339 bind $top.list <B1-Motion> {break}
8340 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8345 proc sel_reflist {w x y} {
8346 global showrefstop reflist headids tagids otherrefids
8348 if {![winfo exists $showrefstop]} return
8349 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8350 set ref [lindex $reflist [expr {$l-1}]]
8351 set n [lindex $ref 0]
8352 switch -- [lindex $ref 1] {
8353 "H" {selbyid $headids($n)}
8354 "T" {selbyid $tagids($n)}
8355 "o" {selbyid $otherrefids($n)}
8357 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8360 proc unsel_reflist {} {
8363 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8364 $showrefstop.list tag remove highlight 0.0 end
8367 proc reflistfilter_change {n1 n2 op} {
8368 global reflistfilter
8370 after cancel refill_reflist
8371 after 200 refill_reflist
8374 proc refill_reflist {} {
8375 global reflist reflistfilter showrefstop headids tagids otherrefids
8378 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8380 foreach n [array names headids] {
8381 if {[string match $reflistfilter $n]} {
8382 if {[commitinview $headids($n) $curview]} {
8383 lappend refs [list $n H]
8385 interestedin $headids($n) {run refill_reflist}
8389 foreach n [array names tagids] {
8390 if {[string match $reflistfilter $n]} {
8391 if {[commitinview $tagids($n) $curview]} {
8392 lappend refs [list $n T]
8394 interestedin $tagids($n) {run refill_reflist}
8398 foreach n [array names otherrefids] {
8399 if {[string match $reflistfilter $n]} {
8400 if {[commitinview $otherrefids($n) $curview]} {
8401 lappend refs [list $n o]
8403 interestedin $otherrefids($n) {run refill_reflist}
8407 set refs [lsort -index 0 $refs]
8408 if {$refs eq $reflist} return
8410 # Update the contents of $showrefstop.list according to the
8411 # differences between $reflist (old) and $refs (new)
8412 $showrefstop.list conf -state normal
8413 $showrefstop.list insert end "\n"
8416 while {$i < [llength $reflist] || $j < [llength $refs]} {
8417 if {$i < [llength $reflist]} {
8418 if {$j < [llength $refs]} {
8419 set cmp [string compare [lindex $reflist $i 0] \
8420 [lindex $refs $j 0]]
8422 set cmp [string compare [lindex $reflist $i 1] \
8423 [lindex $refs $j 1]]
8433 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8441 set l [expr {$j + 1}]
8442 $showrefstop.list image create $l.0 -align baseline \
8443 -image reficon-[lindex $refs $j 1] -padx 2
8444 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8450 # delete last newline
8451 $showrefstop.list delete end-2c end-1c
8452 $showrefstop.list conf -state disabled
8455 # Stuff for finding nearby tags
8456 proc getallcommits {} {
8457 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8458 global idheads idtags idotherrefs allparents tagobjid
8460 if {![info exists allcommits]} {
8466 set allccache [file join [gitdir] "gitk.cache"]
8468 set f [open $allccache r]
8477 set cmd [list | git rev-list --parents]
8478 set allcupdate [expr {$seeds ne {}}]
8482 set refs [concat [array names idheads] [array names idtags] \
8483 [array names idotherrefs]]
8486 foreach name [array names tagobjid] {
8487 lappend tagobjs $tagobjid($name)
8489 foreach id [lsort -unique $refs] {
8490 if {![info exists allparents($id)] &&
8491 [lsearch -exact $tagobjs $id] < 0} {
8502 set fd [open [concat $cmd $ids] r]
8503 fconfigure $fd -blocking 0
8506 filerun $fd [list getallclines $fd]
8512 # Since most commits have 1 parent and 1 child, we group strings of
8513 # such commits into "arcs" joining branch/merge points (BMPs), which
8514 # are commits that either don't have 1 parent or don't have 1 child.
8516 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8517 # arcout(id) - outgoing arcs for BMP
8518 # arcids(a) - list of IDs on arc including end but not start
8519 # arcstart(a) - BMP ID at start of arc
8520 # arcend(a) - BMP ID at end of arc
8521 # growing(a) - arc a is still growing
8522 # arctags(a) - IDs out of arcids (excluding end) that have tags
8523 # archeads(a) - IDs out of arcids (excluding end) that have heads
8524 # The start of an arc is at the descendent end, so "incoming" means
8525 # coming from descendents, and "outgoing" means going towards ancestors.
8527 proc getallclines {fd} {
8528 global allparents allchildren idtags idheads nextarc
8529 global arcnos arcids arctags arcout arcend arcstart archeads growing
8530 global seeds allcommits cachedarcs allcupdate
8533 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8534 set id [lindex $line 0]
8535 if {[info exists allparents($id)]} {
8540 set olds [lrange $line 1 end]
8541 set allparents($id) $olds
8542 if {![info exists allchildren($id)]} {
8543 set allchildren($id) {}
8548 if {[llength $olds] == 1 && [llength $a] == 1} {
8549 lappend arcids($a) $id
8550 if {[info exists idtags($id)]} {
8551 lappend arctags($a) $id
8553 if {[info exists idheads($id)]} {
8554 lappend archeads($a) $id
8556 if {[info exists allparents($olds)]} {
8557 # seen parent already
8558 if {![info exists arcout($olds)]} {
8561 lappend arcids($a) $olds
8562 set arcend($a) $olds
8565 lappend allchildren($olds) $id
8566 lappend arcnos($olds) $a
8570 foreach a $arcnos($id) {
8571 lappend arcids($a) $id
8578 lappend allchildren($p) $id
8579 set a [incr nextarc]
8580 set arcstart($a) $id
8587 if {[info exists allparents($p)]} {
8588 # seen it already, may need to make a new branch
8589 if {![info exists arcout($p)]} {
8592 lappend arcids($a) $p
8596 lappend arcnos($p) $a
8601 global cached_dheads cached_dtags cached_atags
8602 catch {unset cached_dheads}
8603 catch {unset cached_dtags}
8604 catch {unset cached_atags}
8607 return [expr {$nid >= 1000? 2: 1}]
8611 fconfigure $fd -blocking 1
8614 # got an error reading the list of commits
8615 # if we were updating, try rereading the whole thing again
8621 error_popup "[mc "Error reading commit topology information;\
8622 branch and preceding/following tag information\
8623 will be incomplete."]\n($err)"
8626 if {[incr allcommits -1] == 0} {
8636 proc recalcarc {a} {
8637 global arctags archeads arcids idtags idheads
8641 foreach id [lrange $arcids($a) 0 end-1] {
8642 if {[info exists idtags($id)]} {
8645 if {[info exists idheads($id)]} {
8650 set archeads($a) $ah
8654 global arcnos arcids nextarc arctags archeads idtags idheads
8655 global arcstart arcend arcout allparents growing
8658 if {[llength $a] != 1} {
8659 puts "oops splitarc called but [llength $a] arcs already"
8663 set i [lsearch -exact $arcids($a) $p]
8665 puts "oops splitarc $p not in arc $a"
8668 set na [incr nextarc]
8669 if {[info exists arcend($a)]} {
8670 set arcend($na) $arcend($a)
8672 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8673 set j [lsearch -exact $arcnos($l) $a]
8674 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8676 set tail [lrange $arcids($a) [expr {$i+1}] end]
8677 set arcids($a) [lrange $arcids($a) 0 $i]
8679 set arcstart($na) $p
8681 set arcids($na) $tail
8682 if {[info exists growing($a)]} {
8688 if {[llength $arcnos($id)] == 1} {
8691 set j [lsearch -exact $arcnos($id) $a]
8692 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8696 # reconstruct tags and heads lists
8697 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8702 set archeads($na) {}
8706 # Update things for a new commit added that is a child of one
8707 # existing commit. Used when cherry-picking.
8708 proc addnewchild {id p} {
8709 global allparents allchildren idtags nextarc
8710 global arcnos arcids arctags arcout arcend arcstart archeads growing
8711 global seeds allcommits
8713 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8714 set allparents($id) [list $p]
8715 set allchildren($id) {}
8718 lappend allchildren($p) $id
8719 set a [incr nextarc]
8720 set arcstart($a) $id
8723 set arcids($a) [list $p]
8725 if {![info exists arcout($p)]} {
8728 lappend arcnos($p) $a
8729 set arcout($id) [list $a]
8732 # This implements a cache for the topology information.
8733 # The cache saves, for each arc, the start and end of the arc,
8734 # the ids on the arc, and the outgoing arcs from the end.
8735 proc readcache {f} {
8736 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8737 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8742 if {$lim - $a > 500} {
8743 set lim [expr {$a + 500}]
8747 # finish reading the cache and setting up arctags, etc.
8749 if {$line ne "1"} {error "bad final version"}
8751 foreach id [array names idtags] {
8752 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8753 [llength $allparents($id)] == 1} {
8754 set a [lindex $arcnos($id) 0]
8755 if {$arctags($a) eq {}} {
8760 foreach id [array names idheads] {
8761 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8762 [llength $allparents($id)] == 1} {
8763 set a [lindex $arcnos($id) 0]
8764 if {$archeads($a) eq {}} {
8769 foreach id [lsort -unique $possible_seeds] {
8770 if {$arcnos($id) eq {}} {
8776 while {[incr a] <= $lim} {
8778 if {[llength $line] != 3} {error "bad line"}
8779 set s [lindex $line 0]
8781 lappend arcout($s) $a
8782 if {![info exists arcnos($s)]} {
8783 lappend possible_seeds $s
8786 set e [lindex $line 1]
8791 if {![info exists arcout($e)]} {
8795 set arcids($a) [lindex $line 2]
8796 foreach id $arcids($a) {
8797 lappend allparents($s) $id
8799 lappend arcnos($id) $a
8801 if {![info exists allparents($s)]} {
8802 set allparents($s) {}
8807 set nextarc [expr {$a - 1}]
8820 global nextarc cachedarcs possible_seeds
8824 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8825 # make sure it's an integer
8826 set cachedarcs [expr {int([lindex $line 1])}]
8827 if {$cachedarcs < 0} {error "bad number of arcs"}
8829 set possible_seeds {}
8837 proc dropcache {err} {
8838 global allcwait nextarc cachedarcs seeds
8840 #puts "dropping cache ($err)"
8841 foreach v {arcnos arcout arcids arcstart arcend growing \
8842 arctags archeads allparents allchildren} {
8853 proc writecache {f} {
8854 global cachearc cachedarcs allccache
8855 global arcstart arcend arcnos arcids arcout
8859 if {$lim - $a > 1000} {
8860 set lim [expr {$a + 1000}]
8863 while {[incr a] <= $lim} {
8864 if {[info exists arcend($a)]} {
8865 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8867 puts $f [list $arcstart($a) {} $arcids($a)]
8872 catch {file delete $allccache}
8873 #puts "writing cache failed ($err)"
8876 set cachearc [expr {$a - 1}]
8877 if {$a > $cachedarcs} {
8886 global nextarc cachedarcs cachearc allccache
8888 if {$nextarc == $cachedarcs} return
8890 set cachedarcs $nextarc
8892 set f [open $allccache w]
8893 puts $f [list 1 $cachedarcs]
8898 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8899 # or 0 if neither is true.
8900 proc anc_or_desc {a b} {
8901 global arcout arcstart arcend arcnos cached_isanc
8903 if {$arcnos($a) eq $arcnos($b)} {
8904 # Both are on the same arc(s); either both are the same BMP,
8905 # or if one is not a BMP, the other is also not a BMP or is
8906 # the BMP at end of the arc (and it only has 1 incoming arc).
8907 # Or both can be BMPs with no incoming arcs.
8908 if {$a eq $b || $arcnos($a) eq {}} {
8911 # assert {[llength $arcnos($a)] == 1}
8912 set arc [lindex $arcnos($a) 0]
8913 set i [lsearch -exact $arcids($arc) $a]
8914 set j [lsearch -exact $arcids($arc) $b]
8915 if {$i < 0 || $i > $j} {
8922 if {![info exists arcout($a)]} {
8923 set arc [lindex $arcnos($a) 0]
8924 if {[info exists arcend($arc)]} {
8925 set aend $arcend($arc)
8929 set a $arcstart($arc)
8933 if {![info exists arcout($b)]} {
8934 set arc [lindex $arcnos($b) 0]
8935 if {[info exists arcend($arc)]} {
8936 set bend $arcend($arc)
8940 set b $arcstart($arc)
8950 if {[info exists cached_isanc($a,$bend)]} {
8951 if {$cached_isanc($a,$bend)} {
8955 if {[info exists cached_isanc($b,$aend)]} {
8956 if {$cached_isanc($b,$aend)} {
8959 if {[info exists cached_isanc($a,$bend)]} {
8964 set todo [list $a $b]
8967 for {set i 0} {$i < [llength $todo]} {incr i} {
8968 set x [lindex $todo $i]
8969 if {$anc($x) eq {}} {
8972 foreach arc $arcnos($x) {
8973 set xd $arcstart($arc)
8975 set cached_isanc($a,$bend) 1
8976 set cached_isanc($b,$aend) 0
8978 } elseif {$xd eq $aend} {
8979 set cached_isanc($b,$aend) 1
8980 set cached_isanc($a,$bend) 0
8983 if {![info exists anc($xd)]} {
8984 set anc($xd) $anc($x)
8986 } elseif {$anc($xd) ne $anc($x)} {
8991 set cached_isanc($a,$bend) 0
8992 set cached_isanc($b,$aend) 0
8996 # This identifies whether $desc has an ancestor that is
8997 # a growing tip of the graph and which is not an ancestor of $anc
8998 # and returns 0 if so and 1 if not.
8999 # If we subsequently discover a tag on such a growing tip, and that
9000 # turns out to be a descendent of $anc (which it could, since we
9001 # don't necessarily see children before parents), then $desc
9002 # isn't a good choice to display as a descendent tag of
9003 # $anc (since it is the descendent of another tag which is
9004 # a descendent of $anc). Similarly, $anc isn't a good choice to
9005 # display as a ancestor tag of $desc.
9007 proc is_certain {desc anc} {
9008 global arcnos arcout arcstart arcend growing problems
9011 if {[llength $arcnos($anc)] == 1} {
9012 # tags on the same arc are certain
9013 if {$arcnos($desc) eq $arcnos($anc)} {
9016 if {![info exists arcout($anc)]} {
9017 # if $anc is partway along an arc, use the start of the arc instead
9018 set a [lindex $arcnos($anc) 0]
9019 set anc $arcstart($a)
9022 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9025 set a [lindex $arcnos($desc) 0]
9031 set anclist [list $x]
9035 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9036 set x [lindex $anclist $i]
9041 foreach a $arcout($x) {
9042 if {[info exists growing($a)]} {
9043 if {![info exists growanc($x)] && $dl($x)} {
9049 if {[info exists dl($y)]} {
9053 if {![info exists done($y)]} {
9056 if {[info exists growanc($x)]} {
9060 for {set k 0} {$k < [llength $xl]} {incr k} {
9061 set z [lindex $xl $k]
9062 foreach c $arcout($z) {
9063 if {[info exists arcend($c)]} {
9065 if {[info exists dl($v)] && $dl($v)} {
9067 if {![info exists done($v)]} {
9070 if {[info exists growanc($v)]} {
9080 } elseif {$y eq $anc || !$dl($x)} {
9091 foreach x [array names growanc] {
9100 proc validate_arctags {a} {
9101 global arctags idtags
9105 foreach id $arctags($a) {
9107 if {![info exists idtags($id)]} {
9108 set na [lreplace $na $i $i]
9115 proc validate_archeads {a} {
9116 global archeads idheads
9119 set na $archeads($a)
9120 foreach id $archeads($a) {
9122 if {![info exists idheads($id)]} {
9123 set na [lreplace $na $i $i]
9127 set archeads($a) $na
9130 # Return the list of IDs that have tags that are descendents of id,
9131 # ignoring IDs that are descendents of IDs already reported.
9132 proc desctags {id} {
9133 global arcnos arcstart arcids arctags idtags allparents
9134 global growing cached_dtags
9136 if {![info exists allparents($id)]} {
9139 set t1 [clock clicks -milliseconds]
9141 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9142 # part-way along an arc; check that arc first
9143 set a [lindex $arcnos($id) 0]
9144 if {$arctags($a) ne {}} {
9146 set i [lsearch -exact $arcids($a) $id]
9148 foreach t $arctags($a) {
9149 set j [lsearch -exact $arcids($a) $t]
9157 set id $arcstart($a)
9158 if {[info exists idtags($id)]} {
9162 if {[info exists cached_dtags($id)]} {
9163 return $cached_dtags($id)
9170 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9171 set id [lindex $todo $i]
9173 set ta [info exists hastaggedancestor($id)]
9177 # ignore tags on starting node
9178 if {!$ta && $i > 0} {
9179 if {[info exists idtags($id)]} {
9182 } elseif {[info exists cached_dtags($id)]} {
9183 set tagloc($id) $cached_dtags($id)
9187 foreach a $arcnos($id) {
9189 if {!$ta && $arctags($a) ne {}} {
9191 if {$arctags($a) ne {}} {
9192 lappend tagloc($id) [lindex $arctags($a) end]
9195 if {$ta || $arctags($a) ne {}} {
9196 set tomark [list $d]
9197 for {set j 0} {$j < [llength $tomark]} {incr j} {
9198 set dd [lindex $tomark $j]
9199 if {![info exists hastaggedancestor($dd)]} {
9200 if {[info exists done($dd)]} {
9201 foreach b $arcnos($dd) {
9202 lappend tomark $arcstart($b)
9204 if {[info exists tagloc($dd)]} {
9207 } elseif {[info exists queued($dd)]} {
9210 set hastaggedancestor($dd) 1
9214 if {![info exists queued($d)]} {
9217 if {![info exists hastaggedancestor($d)]} {
9224 foreach id [array names tagloc] {
9225 if {![info exists hastaggedancestor($id)]} {
9226 foreach t $tagloc($id) {
9227 if {[lsearch -exact $tags $t] < 0} {
9233 set t2 [clock clicks -milliseconds]
9236 # remove tags that are descendents of other tags
9237 for {set i 0} {$i < [llength $tags]} {incr i} {
9238 set a [lindex $tags $i]
9239 for {set j 0} {$j < $i} {incr j} {
9240 set b [lindex $tags $j]
9241 set r [anc_or_desc $a $b]
9243 set tags [lreplace $tags $j $j]
9246 } elseif {$r == -1} {
9247 set tags [lreplace $tags $i $i]
9254 if {[array names growing] ne {}} {
9255 # graph isn't finished, need to check if any tag could get
9256 # eclipsed by another tag coming later. Simply ignore any
9257 # tags that could later get eclipsed.
9260 if {[is_certain $t $origid]} {
9264 if {$tags eq $ctags} {
9265 set cached_dtags($origid) $tags
9270 set cached_dtags($origid) $tags
9272 set t3 [clock clicks -milliseconds]
9273 if {0 && $t3 - $t1 >= 100} {
9274 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9275 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9281 global arcnos arcids arcout arcend arctags idtags allparents
9282 global growing cached_atags
9284 if {![info exists allparents($id)]} {
9287 set t1 [clock clicks -milliseconds]
9289 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9290 # part-way along an arc; check that arc first
9291 set a [lindex $arcnos($id) 0]
9292 if {$arctags($a) ne {}} {
9294 set i [lsearch -exact $arcids($a) $id]
9295 foreach t $arctags($a) {
9296 set j [lsearch -exact $arcids($a) $t]
9302 if {![info exists arcend($a)]} {
9306 if {[info exists idtags($id)]} {
9310 if {[info exists cached_atags($id)]} {
9311 return $cached_atags($id)
9319 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9320 set id [lindex $todo $i]
9322 set td [info exists hastaggeddescendent($id)]
9326 # ignore tags on starting node
9327 if {!$td && $i > 0} {
9328 if {[info exists idtags($id)]} {
9331 } elseif {[info exists cached_atags($id)]} {
9332 set tagloc($id) $cached_atags($id)
9336 foreach a $arcout($id) {
9337 if {!$td && $arctags($a) ne {}} {
9339 if {$arctags($a) ne {}} {
9340 lappend tagloc($id) [lindex $arctags($a) 0]
9343 if {![info exists arcend($a)]} continue
9345 if {$td || $arctags($a) ne {}} {
9346 set tomark [list $d]
9347 for {set j 0} {$j < [llength $tomark]} {incr j} {
9348 set dd [lindex $tomark $j]
9349 if {![info exists hastaggeddescendent($dd)]} {
9350 if {[info exists done($dd)]} {
9351 foreach b $arcout($dd) {
9352 if {[info exists arcend($b)]} {
9353 lappend tomark $arcend($b)
9356 if {[info exists tagloc($dd)]} {
9359 } elseif {[info exists queued($dd)]} {
9362 set hastaggeddescendent($dd) 1
9366 if {![info exists queued($d)]} {
9369 if {![info exists hastaggeddescendent($d)]} {
9375 set t2 [clock clicks -milliseconds]
9378 foreach id [array names tagloc] {
9379 if {![info exists hastaggeddescendent($id)]} {
9380 foreach t $tagloc($id) {
9381 if {[lsearch -exact $tags $t] < 0} {
9388 # remove tags that are ancestors of other tags
9389 for {set i 0} {$i < [llength $tags]} {incr i} {
9390 set a [lindex $tags $i]
9391 for {set j 0} {$j < $i} {incr j} {
9392 set b [lindex $tags $j]
9393 set r [anc_or_desc $a $b]
9395 set tags [lreplace $tags $j $j]
9398 } elseif {$r == 1} {
9399 set tags [lreplace $tags $i $i]
9406 if {[array names growing] ne {}} {
9407 # graph isn't finished, need to check if any tag could get
9408 # eclipsed by another tag coming later. Simply ignore any
9409 # tags that could later get eclipsed.
9412 if {[is_certain $origid $t]} {
9416 if {$tags eq $ctags} {
9417 set cached_atags($origid) $tags
9422 set cached_atags($origid) $tags
9424 set t3 [clock clicks -milliseconds]
9425 if {0 && $t3 - $t1 >= 100} {
9426 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9427 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9432 # Return the list of IDs that have heads that are descendents of id,
9433 # including id itself if it has a head.
9434 proc descheads {id} {
9435 global arcnos arcstart arcids archeads idheads cached_dheads
9438 if {![info exists allparents($id)]} {
9442 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9443 # part-way along an arc; check it first
9444 set a [lindex $arcnos($id) 0]
9445 if {$archeads($a) ne {}} {
9446 validate_archeads $a
9447 set i [lsearch -exact $arcids($a) $id]
9448 foreach t $archeads($a) {
9449 set j [lsearch -exact $arcids($a) $t]
9454 set id $arcstart($a)
9460 for {set i 0} {$i < [llength $todo]} {incr i} {
9461 set id [lindex $todo $i]
9462 if {[info exists cached_dheads($id)]} {
9463 set ret [concat $ret $cached_dheads($id)]
9465 if {[info exists idheads($id)]} {
9468 foreach a $arcnos($id) {
9469 if {$archeads($a) ne {}} {
9470 validate_archeads $a
9471 if {$archeads($a) ne {}} {
9472 set ret [concat $ret $archeads($a)]
9476 if {![info exists seen($d)]} {
9483 set ret [lsort -unique $ret]
9484 set cached_dheads($origid) $ret
9485 return [concat $ret $aret]
9488 proc addedtag {id} {
9489 global arcnos arcout cached_dtags cached_atags
9491 if {![info exists arcnos($id)]} return
9492 if {![info exists arcout($id)]} {
9493 recalcarc [lindex $arcnos($id) 0]
9495 catch {unset cached_dtags}
9496 catch {unset cached_atags}
9499 proc addedhead {hid head} {
9500 global arcnos arcout cached_dheads
9502 if {![info exists arcnos($hid)]} return
9503 if {![info exists arcout($hid)]} {
9504 recalcarc [lindex $arcnos($hid) 0]
9506 catch {unset cached_dheads}
9509 proc removedhead {hid head} {
9510 global cached_dheads
9512 catch {unset cached_dheads}
9515 proc movedhead {hid head} {
9516 global arcnos arcout cached_dheads
9518 if {![info exists arcnos($hid)]} return
9519 if {![info exists arcout($hid)]} {
9520 recalcarc [lindex $arcnos($hid) 0]
9522 catch {unset cached_dheads}
9525 proc changedrefs {} {
9526 global cached_dheads cached_dtags cached_atags
9527 global arctags archeads arcnos arcout idheads idtags
9529 foreach id [concat [array names idheads] [array names idtags]] {
9530 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9531 set a [lindex $arcnos($id) 0]
9532 if {![info exists donearc($a)]} {
9538 catch {unset cached_dtags}
9539 catch {unset cached_atags}
9540 catch {unset cached_dheads}
9543 proc rereadrefs {} {
9544 global idtags idheads idotherrefs mainheadid
9546 set refids [concat [array names idtags] \
9547 [array names idheads] [array names idotherrefs]]
9548 foreach id $refids {
9549 if {![info exists ref($id)]} {
9550 set ref($id) [listrefs $id]
9553 set oldmainhead $mainheadid
9556 set refids [lsort -unique [concat $refids [array names idtags] \
9557 [array names idheads] [array names idotherrefs]]]
9558 foreach id $refids {
9559 set v [listrefs $id]
9560 if {![info exists ref($id)] || $ref($id) != $v} {
9564 if {$oldmainhead ne $mainheadid} {
9565 redrawtags $oldmainhead
9566 redrawtags $mainheadid
9571 proc listrefs {id} {
9572 global idtags idheads idotherrefs
9575 if {[info exists idtags($id)]} {
9579 if {[info exists idheads($id)]} {
9583 if {[info exists idotherrefs($id)]} {
9584 set z $idotherrefs($id)
9586 return [list $x $y $z]
9589 proc showtag {tag isnew} {
9590 global ctext tagcontents tagids linknum tagobjid
9593 addtohistory [list showtag $tag 0]
9595 $ctext conf -state normal
9599 if {![info exists tagcontents($tag)]} {
9601 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9604 if {[info exists tagcontents($tag)]} {
9605 set text $tagcontents($tag)
9607 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9609 appendwithlinks $text {}
9610 $ctext conf -state disabled
9622 if {[info exists gitktmpdir]} {
9623 catch {file delete -force $gitktmpdir}
9627 proc mkfontdisp {font top which} {
9628 global fontattr fontpref $font
9630 set fontpref($font) [set $font]
9631 button $top.${font}but -text $which -font optionfont \
9632 -command [list choosefont $font $which]
9633 label $top.$font -relief flat -font $font \
9634 -text $fontattr($font,family) -justify left
9635 grid x $top.${font}but $top.$font -sticky w
9638 proc choosefont {font which} {
9639 global fontparam fontlist fonttop fontattr
9641 set fontparam(which) $which
9642 set fontparam(font) $font
9643 set fontparam(family) [font actual $font -family]
9644 set fontparam(size) $fontattr($font,size)
9645 set fontparam(weight) $fontattr($font,weight)
9646 set fontparam(slant) $fontattr($font,slant)
9649 if {![winfo exists $top]} {
9651 eval font config sample [font actual $font]
9653 wm title $top [mc "Gitk font chooser"]
9654 label $top.l -textvariable fontparam(which)
9655 pack $top.l -side top
9656 set fontlist [lsort [font families]]
9658 listbox $top.f.fam -listvariable fontlist \
9659 -yscrollcommand [list $top.f.sb set]
9660 bind $top.f.fam <<ListboxSelect>> selfontfam
9661 scrollbar $top.f.sb -command [list $top.f.fam yview]
9662 pack $top.f.sb -side right -fill y
9663 pack $top.f.fam -side left -fill both -expand 1
9664 pack $top.f -side top -fill both -expand 1
9666 spinbox $top.g.size -from 4 -to 40 -width 4 \
9667 -textvariable fontparam(size) \
9668 -validatecommand {string is integer -strict %s}
9669 checkbutton $top.g.bold -padx 5 \
9670 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9671 -variable fontparam(weight) -onvalue bold -offvalue normal
9672 checkbutton $top.g.ital -padx 5 \
9673 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9674 -variable fontparam(slant) -onvalue italic -offvalue roman
9675 pack $top.g.size $top.g.bold $top.g.ital -side left
9676 pack $top.g -side top
9677 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9679 $top.c create text 100 25 -anchor center -text $which -font sample \
9680 -fill black -tags text
9681 bind $top.c <Configure> [list centertext $top.c]
9682 pack $top.c -side top -fill x
9684 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9685 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9686 bind $top <Key-Return> fontok
9687 bind $top <Key-Escape> fontcan
9688 grid $top.buts.ok $top.buts.can
9689 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9690 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9691 pack $top.buts -side bottom -fill x
9692 trace add variable fontparam write chg_fontparam
9695 $top.c itemconf text -text $which
9697 set i [lsearch -exact $fontlist $fontparam(family)]
9699 $top.f.fam selection set $i
9704 proc centertext {w} {
9705 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9709 global fontparam fontpref prefstop
9711 set f $fontparam(font)
9712 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9713 if {$fontparam(weight) eq "bold"} {
9714 lappend fontpref($f) "bold"
9716 if {$fontparam(slant) eq "italic"} {
9717 lappend fontpref($f) "italic"
9720 $w conf -text $fontparam(family) -font $fontpref($f)
9726 global fonttop fontparam
9728 if {[info exists fonttop]} {
9729 catch {destroy $fonttop}
9730 catch {font delete sample}
9736 proc selfontfam {} {
9737 global fonttop fontparam
9739 set i [$fonttop.f.fam curselection]
9741 set fontparam(family) [$fonttop.f.fam get $i]
9745 proc chg_fontparam {v sub op} {
9748 font config sample -$sub $fontparam($sub)
9752 global maxwidth maxgraphpct
9753 global oldprefs prefstop showneartags showlocalchanges
9754 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
9755 global tabstop limitdiffs autoselect extdifftool perfile_attrs
9759 if {[winfo exists $top]} {
9763 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9764 limitdiffs tabstop perfile_attrs} {
9765 set oldprefs($v) [set $v]
9768 wm title $top [mc "Gitk preferences"]
9769 label $top.ldisp -text [mc "Commit list display options"]
9770 grid $top.ldisp - -sticky w -pady 10
9771 label $top.spacer -text " "
9772 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9774 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9775 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9776 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9778 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9779 grid x $top.maxpctl $top.maxpct -sticky w
9780 frame $top.showlocal
9781 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9782 checkbutton $top.showlocal.b -variable showlocalchanges
9783 pack $top.showlocal.b $top.showlocal.l -side left
9784 grid x $top.showlocal -sticky w
9785 frame $top.autoselect
9786 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9787 checkbutton $top.autoselect.b -variable autoselect
9788 pack $top.autoselect.b $top.autoselect.l -side left
9789 grid x $top.autoselect -sticky w
9791 label $top.ddisp -text [mc "Diff display options"]
9792 grid $top.ddisp - -sticky w -pady 10
9793 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9794 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9795 grid x $top.tabstopl $top.tabstop -sticky w
9797 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9798 checkbutton $top.ntag.b -variable showneartags
9799 pack $top.ntag.b $top.ntag.l -side left
9800 grid x $top.ntag -sticky w
9802 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9803 checkbutton $top.ldiff.b -variable limitdiffs
9804 pack $top.ldiff.b $top.ldiff.l -side left
9805 grid x $top.ldiff -sticky w
9807 label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
9808 checkbutton $top.lattr.b -variable perfile_attrs
9809 pack $top.lattr.b $top.lattr.l -side left
9810 grid x $top.lattr -sticky w
9812 entry $top.extdifft -textvariable extdifftool
9814 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9816 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9817 -command choose_extdiff
9818 pack $top.extdifff.l $top.extdifff.b -side left
9819 grid x $top.extdifff $top.extdifft -sticky w
9821 label $top.cdisp -text [mc "Colors: press to choose"]
9822 grid $top.cdisp - -sticky w -pady 10
9823 label $top.bg -padx 40 -relief sunk -background $bgcolor
9824 button $top.bgbut -text [mc "Background"] -font optionfont \
9825 -command [list choosecolor bgcolor {} $top.bg background setbg]
9826 grid x $top.bgbut $top.bg -sticky w
9827 label $top.fg -padx 40 -relief sunk -background $fgcolor
9828 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9829 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9830 grid x $top.fgbut $top.fg -sticky w
9831 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9832 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9833 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9834 [list $ctext tag conf d0 -foreground]]
9835 grid x $top.diffoldbut $top.diffold -sticky w
9836 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9837 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9838 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9839 [list $ctext tag conf d1 -foreground]]
9840 grid x $top.diffnewbut $top.diffnew -sticky w
9841 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9842 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9843 -command [list choosecolor diffcolors 2 $top.hunksep \
9844 "diff hunk header" \
9845 [list $ctext tag conf hunksep -foreground]]
9846 grid x $top.hunksepbut $top.hunksep -sticky w
9847 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
9848 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
9849 -command [list choosecolor markbgcolor {} $top.markbgsep \
9850 [mc "marked line background"] \
9851 [list $ctext tag conf omark -background]]
9852 grid x $top.markbgbut $top.markbgsep -sticky w
9853 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9854 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9855 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9856 grid x $top.selbgbut $top.selbgsep -sticky w
9858 label $top.cfont -text [mc "Fonts: press to choose"]
9859 grid $top.cfont - -sticky w -pady 10
9860 mkfontdisp mainfont $top [mc "Main font"]
9861 mkfontdisp textfont $top [mc "Diff display font"]
9862 mkfontdisp uifont $top [mc "User interface font"]
9865 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9866 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9867 bind $top <Key-Return> prefsok
9868 bind $top <Key-Escape> prefscan
9869 grid $top.buts.ok $top.buts.can
9870 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9871 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9872 grid $top.buts - - -pady 10 -sticky ew
9873 bind $top <Visibility> "focus $top.buts.ok"
9876 proc choose_extdiff {} {
9879 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9881 set extdifftool $prog
9885 proc choosecolor {v vi w x cmd} {
9888 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9889 -title [mc "Gitk: choose color for %s" $x]]
9890 if {$c eq {}} return
9891 $w conf -background $c
9897 global bglist cflist
9899 $w configure -selectbackground $c
9901 $cflist tag configure highlight \
9902 -background [$cflist cget -selectbackground]
9903 allcanvs itemconf secsel -fill $c
9910 $w conf -background $c
9918 $w conf -foreground $c
9920 allcanvs itemconf text -fill $c
9921 $canv itemconf circle -outline $c
9925 global oldprefs prefstop
9927 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9928 limitdiffs tabstop perfile_attrs} {
9930 set $v $oldprefs($v)
9932 catch {destroy $prefstop}
9938 global maxwidth maxgraphpct
9939 global oldprefs prefstop showneartags showlocalchanges
9940 global fontpref mainfont textfont uifont
9941 global limitdiffs treediffs perfile_attrs
9943 catch {destroy $prefstop}
9947 if {$mainfont ne $fontpref(mainfont)} {
9948 set mainfont $fontpref(mainfont)
9949 parsefont mainfont $mainfont
9950 eval font configure mainfont [fontflags mainfont]
9951 eval font configure mainfontbold [fontflags mainfont 1]
9955 if {$textfont ne $fontpref(textfont)} {
9956 set textfont $fontpref(textfont)
9957 parsefont textfont $textfont
9958 eval font configure textfont [fontflags textfont]
9959 eval font configure textfontbold [fontflags textfont 1]
9961 if {$uifont ne $fontpref(uifont)} {
9962 set uifont $fontpref(uifont)
9963 parsefont uifont $uifont
9964 eval font configure uifont [fontflags uifont]
9967 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9968 if {$showlocalchanges} {
9974 if {$limitdiffs != $oldprefs(limitdiffs) ||
9975 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
9976 # treediffs elements are limited by path;
9977 # won't have encodings cached if perfile_attrs was just turned on
9978 catch {unset treediffs}
9980 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9981 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9983 } elseif {$showneartags != $oldprefs(showneartags) ||
9984 $limitdiffs != $oldprefs(limitdiffs)} {
9989 proc formatdate {d} {
9990 global datetimeformat
9992 set d [clock format $d -format $datetimeformat]
9997 # This list of encoding names and aliases is distilled from
9998 # http://www.iana.org/assignments/character-sets.
9999 # Not all of them are supported by Tcl.
10000 set encoding_aliases {
10001 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10002 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10003 { ISO-10646-UTF-1 csISO10646UTF1 }
10004 { ISO_646.basic:1983 ref csISO646basic1983 }
10005 { INVARIANT csINVARIANT }
10006 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10007 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10008 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10009 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10010 { NATS-DANO iso-ir-9-1 csNATSDANO }
10011 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10012 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10013 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10014 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10015 { ISO-2022-KR csISO2022KR }
10017 { ISO-2022-JP csISO2022JP }
10018 { ISO-2022-JP-2 csISO2022JP2 }
10019 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10020 csISO13JISC6220jp }
10021 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10022 { IT iso-ir-15 ISO646-IT csISO15Italian }
10023 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10024 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10025 { greek7-old iso-ir-18 csISO18Greek7Old }
10026 { latin-greek iso-ir-19 csISO19LatinGreek }
10027 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10028 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10029 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10030 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10031 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10032 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10033 { INIS iso-ir-49 csISO49INIS }
10034 { INIS-8 iso-ir-50 csISO50INIS8 }
10035 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10036 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10037 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10038 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10039 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10040 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10041 csISO60Norwegian1 }
10042 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10043 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10044 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10045 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10046 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10047 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10048 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10049 { greek7 iso-ir-88 csISO88Greek7 }
10050 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10051 { iso-ir-90 csISO90 }
10052 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10053 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10054 csISO92JISC62991984b }
10055 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10056 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10057 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10058 csISO95JIS62291984handadd }
10059 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10060 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10061 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10062 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10063 CP819 csISOLatin1 }
10064 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10065 { T.61-7bit iso-ir-102 csISO102T617bit }
10066 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10067 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10068 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10069 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10070 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10071 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10072 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10073 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10074 arabic csISOLatinArabic }
10075 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10076 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10077 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10078 greek greek8 csISOLatinGreek }
10079 { T.101-G2 iso-ir-128 csISO128T101G2 }
10080 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10082 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10083 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10084 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10085 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10086 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10087 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10088 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10089 csISOLatinCyrillic }
10090 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10091 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10092 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10093 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10094 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10095 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10096 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10097 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10098 { ISO_10367-box iso-ir-155 csISO10367Box }
10099 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10100 { latin-lap lap iso-ir-158 csISO158Lap }
10101 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10102 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10105 { JIS_X0201 X0201 csHalfWidthKatakana }
10106 { KSC5636 ISO646-KR csKSC5636 }
10107 { ISO-10646-UCS-2 csUnicode }
10108 { ISO-10646-UCS-4 csUCS4 }
10109 { DEC-MCS dec csDECMCS }
10110 { hp-roman8 roman8 r8 csHPRoman8 }
10111 { macintosh mac csMacintosh }
10112 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10114 { IBM038 EBCDIC-INT cp038 csIBM038 }
10115 { IBM273 CP273 csIBM273 }
10116 { IBM274 EBCDIC-BE CP274 csIBM274 }
10117 { IBM275 EBCDIC-BR cp275 csIBM275 }
10118 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10119 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10120 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10121 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10122 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10123 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10124 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10125 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10126 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10127 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10128 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10129 { IBM437 cp437 437 csPC8CodePage437 }
10130 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10131 { IBM775 cp775 csPC775Baltic }
10132 { IBM850 cp850 850 csPC850Multilingual }
10133 { IBM851 cp851 851 csIBM851 }
10134 { IBM852 cp852 852 csPCp852 }
10135 { IBM855 cp855 855 csIBM855 }
10136 { IBM857 cp857 857 csIBM857 }
10137 { IBM860 cp860 860 csIBM860 }
10138 { IBM861 cp861 861 cp-is csIBM861 }
10139 { IBM862 cp862 862 csPC862LatinHebrew }
10140 { IBM863 cp863 863 csIBM863 }
10141 { IBM864 cp864 csIBM864 }
10142 { IBM865 cp865 865 csIBM865 }
10143 { IBM866 cp866 866 csIBM866 }
10144 { IBM868 CP868 cp-ar csIBM868 }
10145 { IBM869 cp869 869 cp-gr csIBM869 }
10146 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10147 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10148 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10149 { IBM891 cp891 csIBM891 }
10150 { IBM903 cp903 csIBM903 }
10151 { IBM904 cp904 904 csIBBM904 }
10152 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10153 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10154 { IBM1026 CP1026 csIBM1026 }
10155 { EBCDIC-AT-DE csIBMEBCDICATDE }
10156 { EBCDIC-AT-DE-A csEBCDICATDEA }
10157 { EBCDIC-CA-FR csEBCDICCAFR }
10158 { EBCDIC-DK-NO csEBCDICDKNO }
10159 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10160 { EBCDIC-FI-SE csEBCDICFISE }
10161 { EBCDIC-FI-SE-A csEBCDICFISEA }
10162 { EBCDIC-FR csEBCDICFR }
10163 { EBCDIC-IT csEBCDICIT }
10164 { EBCDIC-PT csEBCDICPT }
10165 { EBCDIC-ES csEBCDICES }
10166 { EBCDIC-ES-A csEBCDICESA }
10167 { EBCDIC-ES-S csEBCDICESS }
10168 { EBCDIC-UK csEBCDICUK }
10169 { EBCDIC-US csEBCDICUS }
10170 { UNKNOWN-8BIT csUnknown8BiT }
10171 { MNEMONIC csMnemonic }
10173 { VISCII csVISCII }
10176 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10177 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10178 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10179 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10180 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10181 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10182 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10183 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10184 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10185 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10186 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10187 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10188 { IBM1047 IBM-1047 }
10189 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10190 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10191 { UNICODE-1-1 csUnicode11 }
10192 { CESU-8 csCESU-8 }
10193 { BOCU-1 csBOCU-1 }
10194 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10195 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10197 { ISO-8859-15 ISO_8859-15 Latin-9 }
10198 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10199 { GBK CP936 MS936 windows-936 }
10200 { JIS_Encoding csJISEncoding }
10201 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10202 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10204 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10205 { ISO-10646-UCS-Basic csUnicodeASCII }
10206 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10207 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10208 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10209 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10210 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10211 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10212 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10213 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10214 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10215 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10216 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10217 { Ventura-US csVenturaUS }
10218 { Ventura-International csVenturaInternational }
10219 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10220 { PC8-Turkish csPC8Turkish }
10221 { IBM-Symbols csIBMSymbols }
10222 { IBM-Thai csIBMThai }
10223 { HP-Legal csHPLegal }
10224 { HP-Pi-font csHPPiFont }
10225 { HP-Math8 csHPMath8 }
10226 { Adobe-Symbol-Encoding csHPPSMath }
10227 { HP-DeskTop csHPDesktop }
10228 { Ventura-Math csVenturaMath }
10229 { Microsoft-Publishing csMicrosoftPublishing }
10230 { Windows-31J csWindows31J }
10231 { GB2312 csGB2312 }
10235 proc tcl_encoding {enc} {
10236 global encoding_aliases tcl_encoding_cache
10237 if {[info exists tcl_encoding_cache($enc)]} {
10238 return $tcl_encoding_cache($enc)
10240 set names [encoding names]
10241 set lcnames [string tolower $names]
10242 set enc [string tolower $enc]
10243 set i [lsearch -exact $lcnames $enc]
10245 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10246 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10247 set i [lsearch -exact $lcnames $encx]
10251 foreach l $encoding_aliases {
10252 set ll [string tolower $l]
10253 if {[lsearch -exact $ll $enc] < 0} continue
10254 # look through the aliases for one that tcl knows about
10256 set i [lsearch -exact $lcnames $e]
10258 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10259 set i [lsearch -exact $lcnames $ex]
10269 set tclenc [lindex $names $i]
10271 set tcl_encoding_cache($enc) $tclenc
10275 proc gitattr {path attr default} {
10276 global path_attr_cache
10277 if {[info exists path_attr_cache($attr,$path)]} {
10278 set r $path_attr_cache($attr,$path)
10280 set r "unspecified"
10281 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10282 regexp "(.*): encoding: (.*)" $line m f r
10284 set path_attr_cache($attr,$path) $r
10286 if {$r eq "unspecified"} {
10292 proc cache_gitattr {attr pathlist} {
10293 global path_attr_cache
10295 foreach path $pathlist {
10296 if {![info exists path_attr_cache($attr,$path)]} {
10297 lappend newlist $path
10301 if {[tk windowingsystem] == "win32"} {
10302 # windows has a 32k limit on the arguments to a command...
10305 while {$newlist ne {}} {
10306 set head [lrange $newlist 0 [expr {$lim - 1}]]
10307 set newlist [lrange $newlist $lim end]
10308 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10309 foreach row [split $rlist "\n"] {
10310 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10311 if {[string index $path 0] eq "\""} {
10312 set path [encoding convertfrom [lindex $path 0]]
10314 set path_attr_cache($attr,$path) $value
10321 proc get_path_encoding {path} {
10322 global gui_encoding perfile_attrs
10323 set tcl_enc $gui_encoding
10324 if {$path ne {} && $perfile_attrs} {
10325 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10333 # First check that Tcl/Tk is recent enough
10334 if {[catch {package require Tk 8.4} err]} {
10335 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10336 Gitk requires at least Tcl/Tk 8.4."]
10341 set wrcomcmd "git diff-tree --stdin -p --pretty"
10345 set gitencoding [exec git config --get i18n.commitencoding]
10347 if {$gitencoding == ""} {
10348 set gitencoding "utf-8"
10350 set tclencoding [tcl_encoding $gitencoding]
10351 if {$tclencoding == {}} {
10352 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10355 set gui_encoding [encoding system]
10357 set enc [exec git config --get gui.encoding]
10359 set tclenc [tcl_encoding $enc]
10360 if {$tclenc ne {}} {
10361 set gui_encoding $tclenc
10363 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10368 set mainfont {Helvetica 9}
10369 set textfont {Courier 9}
10370 set uifont {Helvetica 9 bold}
10372 set findmergefiles 0
10380 set cmitmode "patch"
10381 set wrapcomment "none"
10385 set showlocalchanges 1
10387 set datetimeformat "%Y-%m-%d %H:%M:%S"
10389 set perfile_attrs 0
10391 set extdifftool "meld"
10393 set colors {green red blue magenta darkgrey brown orange}
10396 set diffcolors {red "#00a000" blue}
10399 set selectbgcolor gray85
10400 set markbgcolor "#e0e0ff"
10402 set circlecolors {white blue gray blue blue}
10404 # button for popping up context menus
10405 if {[tk windowingsystem] eq "aqua"} {
10406 set ctxbut <Button-2>
10408 set ctxbut <Button-3>
10411 ## For msgcat loading, first locate the installation location.
10412 if { [info exists ::env(GITK_MSGSDIR)] } {
10413 ## Msgsdir was manually set in the environment.
10414 set gitk_msgsdir $::env(GITK_MSGSDIR)
10416 ## Let's guess the prefix from argv0.
10417 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10418 set gitk_libdir [file join $gitk_prefix share gitk lib]
10419 set gitk_msgsdir [file join $gitk_libdir msgs]
10423 ## Internationalization (i18n) through msgcat and gettext. See
10424 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10425 package require msgcat
10426 namespace import ::msgcat::mc
10427 ## And eventually load the actual message catalog
10428 ::msgcat::mcload $gitk_msgsdir
10430 catch {source ~/.gitk}
10432 font create optionfont -family sans-serif -size -12
10434 parsefont mainfont $mainfont
10435 eval font create mainfont [fontflags mainfont]
10436 eval font create mainfontbold [fontflags mainfont 1]
10438 parsefont textfont $textfont
10439 eval font create textfont [fontflags textfont]
10440 eval font create textfontbold [fontflags textfont 1]
10442 parsefont uifont $uifont
10443 eval font create uifont [fontflags uifont]
10447 # check that we can find a .git directory somewhere...
10448 if {[catch {set gitdir [gitdir]}]} {
10449 show_error {} . [mc "Cannot find a git repository here."]
10452 if {![file isdirectory $gitdir]} {
10453 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10458 set selectheadid {}
10461 set cmdline_files {}
10463 set revtreeargscmd {}
10464 foreach arg $argv {
10465 switch -glob -- $arg {
10468 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10471 "--select-commit=*" {
10472 set selecthead [string range $arg 16 end]
10475 set revtreeargscmd [string range $arg 10 end]
10478 lappend revtreeargs $arg
10484 if {$selecthead eq "HEAD"} {
10488 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10489 # no -- on command line, but some arguments (other than --argscmd)
10491 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10492 set cmdline_files [split $f "\n"]
10493 set n [llength $cmdline_files]
10494 set revtreeargs [lrange $revtreeargs 0 end-$n]
10495 # Unfortunately git rev-parse doesn't produce an error when
10496 # something is both a revision and a filename. To be consistent
10497 # with git log and git rev-list, check revtreeargs for filenames.
10498 foreach arg $revtreeargs {
10499 if {[file exists $arg]} {
10500 show_error {} . [mc "Ambiguous argument '%s': both revision\
10501 and filename" $arg]
10506 # unfortunately we get both stdout and stderr in $err,
10507 # so look for "fatal:".
10508 set i [string first "fatal:" $err]
10510 set err [string range $err [expr {$i + 6}] end]
10512 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10517 set nullid "0000000000000000000000000000000000000000"
10518 set nullid2 "0000000000000000000000000000000000000001"
10519 set nullfile "/dev/null"
10521 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10528 set highlight_paths {}
10530 set searchdirn -forwards
10532 set boldnamerows {}
10533 set diffelide {0 0}
10534 set markingmatches 0
10535 set linkentercount 0
10536 set need_redisplay 0
10543 set selectedhlview [mc "None"]
10544 set highlight_related [mc "None"]
10545 set highlight_files {}
10546 set viewfiles(0) {}
10549 set viewargscmd(0) {}
10551 set selectedline {}
10559 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10562 # wait for the window to become visible
10563 tkwait visibility .
10564 wm title . "[file tail $argv0]: [file tail [pwd]]"
10567 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10568 # create a view for the files/dirs specified on the command line
10572 set viewname(1) [mc "Command line"]
10573 set viewfiles(1) $cmdline_files
10574 set viewargs(1) $revtreeargs
10575 set viewargscmd(1) $revtreeargscmd
10579 .bar.view entryconf [mca "Edit view..."] -state normal
10580 .bar.view entryconf [mca "Delete view"] -state normal
10583 if {[info exists permviews]} {
10584 foreach v $permviews {
10587 set viewname($n) [lindex $v 0]
10588 set viewfiles($n) [lindex $v 1]
10589 set viewargs($n) [lindex $v 2]
10590 set viewargscmd($n) [lindex $v 3]