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"
1752 proc error_popup msg
{
1756 show_error
$w $w $msg
1759 proc confirm_popup msg
{
1765 message
$w.m
-text $msg -justify center
-aspect 400
1766 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1767 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1768 pack
$w.ok
-side left
-fill x
1769 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1770 pack
$w.cancel
-side right
-fill x
1771 bind $w <Visibility
> "grab $w; focus $w"
1776 proc setoptions
{} {
1777 option add
*Panedwindow.showHandle
1 startupFile
1778 option add
*Panedwindow.sashRelief raised startupFile
1779 option add
*Button.font uifont startupFile
1780 option add
*Checkbutton.font uifont startupFile
1781 option add
*Radiobutton.font uifont startupFile
1782 option add
*Menu.font uifont startupFile
1783 option add
*Menubutton.font uifont startupFile
1784 option add
*Label.font uifont startupFile
1785 option add
*Message.font uifont startupFile
1786 option add
*Entry.font uifont startupFile
1789 # Make a menu and submenus.
1790 # m is the window name for the menu, items is the list of menu items to add.
1791 # Each item is a list {mc label type description options...}
1792 # mc is ignored; it's so we can put mc there to alert xgettext
1793 # label is the string that appears in the menu
1794 # type is cascade, command or radiobutton (should add checkbutton)
1795 # description depends on type; it's the sublist for cascade, the
1796 # command to invoke for command, or {variable value} for radiobutton
1797 proc makemenu
{m items
} {
1800 set name
[mc
[lindex
$i 1]]
1801 set type [lindex
$i 2]
1802 set thing
[lindex
$i 3]
1803 set params
[list
$type]
1805 set u
[string first
"&" [string map
{&& x
} $name]]
1806 lappend params
-label [string map
{&& & & {}} $name]
1808 lappend params
-underline $u
1813 set submenu
[string tolower
[string map
{& ""} [lindex
$i 1]]]
1814 lappend params
-menu $m.
$submenu
1817 lappend params
-command $thing
1820 lappend params
-variable [lindex
$thing 0] \
1821 -value [lindex
$thing 1]
1824 eval $m add
$params [lrange
$i 4 end
]
1825 if {$type eq
"cascade"} {
1826 makemenu
$m.
$submenu $thing
1831 # translate string and remove ampersands
1833 return [string map
{&& & & {}} [mc
$str]]
1836 proc makewindow
{} {
1837 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1839 global findtype findtypemenu findloc findstring fstring geometry
1840 global entries sha1entry sha1string sha1but
1841 global diffcontextstring diffcontext
1843 global maincursor textcursor curtextcursor
1844 global rowctxmenu fakerowmenu mergemax wrapcomment
1845 global highlight_files gdttype
1846 global searchstring sstring
1847 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1848 global headctxmenu progresscanv progressitem progresscoords statusw
1849 global fprogitem fprogcoord lastprogupdate progupdatepending
1850 global rprogitem rprogcoord rownumsel numcommits
1853 # The "mc" arguments here are purely so that xgettext
1854 # sees the following string as needing to be translated
1856 {mc
"File" cascade
{
1857 {mc
"Update" command updatecommits
-accelerator F5
}
1858 {mc
"Reload" command reloadcommits
}
1859 {mc
"Reread references" command rereadrefs
}
1860 {mc
"List references" command showrefs
}
1861 {mc
"Quit" command doquit
}
1863 {mc
"Edit" cascade
{
1864 {mc
"Preferences" command doprefs
}
1866 {mc
"View" cascade
{
1867 {mc
"New view..." command {newview
0}}
1868 {mc
"Edit view..." command editview
-state disabled
}
1869 {mc
"Delete view" command delview
-state disabled
}
1871 {mc
"All files" radiobutton
{selectedview
0} -command {showview
0}}
1873 {mc
"Help" cascade
{
1874 {mc
"About gitk" command about
}
1875 {mc
"Key bindings" command keys
}
1878 . configure
-menu .bar
1880 # the gui has upper and lower half, parts of a paned window.
1881 panedwindow .ctop
-orient vertical
1883 # possibly use assumed geometry
1884 if {![info exists geometry
(pwsash0
)]} {
1885 set geometry
(topheight
) [expr {15 * $linespc}]
1886 set geometry
(topwidth
) [expr {80 * $charspc}]
1887 set geometry
(botheight
) [expr {15 * $linespc}]
1888 set geometry
(botwidth
) [expr {50 * $charspc}]
1889 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1890 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1893 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1894 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1896 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1898 # create three canvases
1899 set cscroll .tf.histframe.csb
1900 set canv .tf.histframe.pwclist.canv
1902 -selectbackground $selectbgcolor \
1903 -background $bgcolor -bd 0 \
1904 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1905 .tf.histframe.pwclist add
$canv
1906 set canv2 .tf.histframe.pwclist.canv2
1908 -selectbackground $selectbgcolor \
1909 -background $bgcolor -bd 0 -yscrollincr $linespc
1910 .tf.histframe.pwclist add
$canv2
1911 set canv3 .tf.histframe.pwclist.canv3
1913 -selectbackground $selectbgcolor \
1914 -background $bgcolor -bd 0 -yscrollincr $linespc
1915 .tf.histframe.pwclist add
$canv3
1916 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1917 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1919 # a scroll bar to rule them
1920 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1921 pack
$cscroll -side right
-fill y
1922 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1923 lappend bglist
$canv $canv2 $canv3
1924 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1926 # we have two button bars at bottom of top frame. Bar 1
1928 frame .tf.lbar
-height 15
1930 set sha1entry .tf.bar.sha1
1931 set entries
$sha1entry
1932 set sha1but .tf.bar.sha1label
1933 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
1934 -command gotocommit
-width 8
1935 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1936 pack .tf.bar.sha1label
-side left
1937 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1938 trace add variable sha1string
write sha1change
1939 pack
$sha1entry -side left
-pady 2
1941 image create bitmap bm-left
-data {
1942 #define left_width 16
1943 #define left_height 16
1944 static unsigned char left_bits
[] = {
1945 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1946 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1947 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1949 image create bitmap bm-right
-data {
1950 #define right_width 16
1951 #define right_height 16
1952 static unsigned char right_bits
[] = {
1953 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1954 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1955 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1957 button .tf.bar.leftbut
-image bm-left
-command goback \
1958 -state disabled
-width 26
1959 pack .tf.bar.leftbut
-side left
-fill y
1960 button .tf.bar.rightbut
-image bm-right
-command goforw \
1961 -state disabled
-width 26
1962 pack .tf.bar.rightbut
-side left
-fill y
1964 label .tf.bar.rowlabel
-text [mc
"Row"]
1966 label .tf.bar.rownum
-width 7 -font textfont
-textvariable rownumsel \
1967 -relief sunken
-anchor e
1968 label .tf.bar.rowlabel2
-text "/"
1969 label .tf.bar.numcommits
-width 7 -font textfont
-textvariable numcommits \
1970 -relief sunken
-anchor e
1971 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1974 trace add variable selectedline
write selectedline_change
1976 # Status label and progress bar
1977 set statusw .tf.bar.status
1978 label
$statusw -width 15 -relief sunken
1979 pack
$statusw -side left
-padx 5
1980 set h
[expr {[font metrics uifont
-linespace] + 2}]
1981 set progresscanv .tf.bar.progress
1982 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1983 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1984 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1985 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1986 pack
$progresscanv -side right
-expand 1 -fill x
1987 set progresscoords
{0 0}
1990 bind $progresscanv <Configure
> adjustprogress
1991 set lastprogupdate
[clock clicks
-milliseconds]
1992 set progupdatepending
0
1994 # build up the bottom bar of upper window
1995 label .tf.lbar.flabel
-text "[mc "Find
"] "
1996 button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
1997 button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
1998 label .tf.lbar.flab2
-text " [mc "commit
"] "
1999 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2001 set gdttype
[mc
"containing:"]
2002 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
2003 [mc
"containing:"] \
2004 [mc
"touching paths:"] \
2005 [mc
"adding/removing string:"]]
2006 trace add variable gdttype
write gdttype_change
2007 pack .tf.lbar.gdttype
-side left
-fill y
2010 set fstring .tf.lbar.findstring
2011 lappend entries
$fstring
2012 entry
$fstring -width 30 -font textfont
-textvariable findstring
2013 trace add variable findstring
write find_change
2014 set findtype
[mc
"Exact"]
2015 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
2016 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
2017 trace add variable findtype
write findcom_change
2018 set findloc
[mc
"All fields"]
2019 tk_optionMenu .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
2020 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
2021 trace add variable findloc
write find_change
2022 pack .tf.lbar.findloc
-side right
2023 pack .tf.lbar.findtype
-side right
2024 pack
$fstring -side left
-expand 1 -fill x
2026 # Finish putting the upper half of the viewer together
2027 pack .tf.lbar
-in .tf
-side bottom
-fill x
2028 pack .tf.bar
-in .tf
-side bottom
-fill x
2029 pack .tf.histframe
-fill both
-side top
-expand 1
2031 .ctop paneconfigure .tf
-height $geometry(topheight
)
2032 .ctop paneconfigure .tf
-width $geometry(topwidth
)
2034 # now build up the bottom
2035 panedwindow .pwbottom
-orient horizontal
2037 # lower left, a text box over search bar, scroll bar to the right
2038 # if we know window height, then that will set the lower text height, otherwise
2039 # we set lower text height which will drive window height
2040 if {[info exists geometry
(main
)]} {
2041 frame .bleft
-width $geometry(botwidth
)
2043 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
2049 button .bleft.top.search
-text [mc
"Search"] -command dosearch
2050 pack .bleft.top.search
-side left
-padx 5
2051 set sstring .bleft.top.sstring
2052 entry
$sstring -width 20 -font textfont
-textvariable searchstring
2053 lappend entries
$sstring
2054 trace add variable searchstring
write incrsearch
2055 pack
$sstring -side left
-expand 1 -fill x
2056 radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
2057 -command changediffdisp
-variable diffelide
-value {0 0}
2058 radiobutton .bleft.mid.old
-text [mc
"Old version"] \
2059 -command changediffdisp
-variable diffelide
-value {0 1}
2060 radiobutton .bleft.mid.new
-text [mc
"New version"] \
2061 -command changediffdisp
-variable diffelide
-value {1 0}
2062 label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
2063 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
2064 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
2065 -from 1 -increment 1 -to 10000000 \
2066 -validate all
-validatecommand "diffcontextvalidate %P" \
2067 -textvariable diffcontextstring
2068 .bleft.mid.diffcontext
set $diffcontext
2069 trace add variable diffcontextstring
write diffcontextchange
2070 lappend entries .bleft.mid.diffcontext
2071 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
2072 checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
2073 -command changeignorespace
-variable ignorespace
2074 pack .bleft.mid.ignspace
-side left
-padx 5
2075 set ctext .bleft.bottom.ctext
2076 text
$ctext -background $bgcolor -foreground $fgcolor \
2077 -state disabled
-font textfont \
2078 -yscrollcommand scrolltext
-wrap none \
2079 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2081 $ctext conf
-tabstyle wordprocessor
2083 scrollbar .bleft.bottom.sb
-command "$ctext yview"
2084 scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h \
2086 pack .bleft.top
-side top
-fill x
2087 pack .bleft.mid
-side top
-fill x
2088 grid
$ctext .bleft.bottom.sb
-sticky nsew
2089 grid .bleft.bottom.sbhorizontal
-sticky ew
2090 grid columnconfigure .bleft.bottom
0 -weight 1
2091 grid rowconfigure .bleft.bottom
0 -weight 1
2092 grid rowconfigure .bleft.bottom
1 -weight 0
2093 pack .bleft.bottom
-side top
-fill both
-expand 1
2094 lappend bglist
$ctext
2095 lappend fglist
$ctext
2097 $ctext tag conf comment
-wrap $wrapcomment
2098 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
2099 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
2100 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
2101 $ctext tag conf dresult
-fore [lindex
$diffcolors 1]
2102 $ctext tag conf m0
-fore red
2103 $ctext tag conf m1
-fore blue
2104 $ctext tag conf m2
-fore green
2105 $ctext tag conf m3
-fore purple
2106 $ctext tag conf
m4 -fore brown
2107 $ctext tag conf m5
-fore "#009090"
2108 $ctext tag conf m6
-fore magenta
2109 $ctext tag conf m7
-fore "#808000"
2110 $ctext tag conf m8
-fore "#009000"
2111 $ctext tag conf m9
-fore "#ff0080"
2112 $ctext tag conf m10
-fore cyan
2113 $ctext tag conf m11
-fore "#b07070"
2114 $ctext tag conf m12
-fore "#70b0f0"
2115 $ctext tag conf m13
-fore "#70f0b0"
2116 $ctext tag conf m14
-fore "#f0b070"
2117 $ctext tag conf m15
-fore "#ff70b0"
2118 $ctext tag conf mmax
-fore darkgrey
2120 $ctext tag conf mresult
-font textfontbold
2121 $ctext tag conf msep
-font textfontbold
2122 $ctext tag conf found
-back yellow
2124 .pwbottom add .bleft
2125 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2130 radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2131 -command reselectline
-variable cmitmode
-value "patch"
2132 radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2133 -command reselectline
-variable cmitmode
-value "tree"
2134 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2135 pack .bright.mode
-side top
-fill x
2136 set cflist .bright.cfiles
2137 set indent
[font measure mainfont
"nn"]
2139 -selectbackground $selectbgcolor \
2140 -background $bgcolor -foreground $fgcolor \
2142 -tabs [list
$indent [expr {2 * $indent}]] \
2143 -yscrollcommand ".bright.sb set" \
2144 -cursor [. cget
-cursor] \
2145 -spacing1 1 -spacing3 1
2146 lappend bglist
$cflist
2147 lappend fglist
$cflist
2148 scrollbar .bright.sb
-command "$cflist yview"
2149 pack .bright.sb
-side right
-fill y
2150 pack
$cflist -side left
-fill both
-expand 1
2151 $cflist tag configure highlight \
2152 -background [$cflist cget
-selectbackground]
2153 $cflist tag configure bold
-font mainfontbold
2155 .pwbottom add .bright
2158 # restore window width & height if known
2159 if {[info exists geometry
(main
)]} {
2160 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2161 if {$w > [winfo screenwidth .
]} {
2162 set w
[winfo screenwidth .
]
2164 if {$h > [winfo screenheight .
]} {
2165 set h
[winfo screenheight .
]
2167 wm geometry .
"${w}x$h"
2171 if {[tk windowingsystem
] eq
{aqua
}} {
2177 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2178 pack .ctop
-fill both
-expand 1
2179 bindall
<1> {selcanvline
%W
%x
%y
}
2180 #bindall <B1-Motion> {selcanvline %W %x %y}
2181 if {[tk windowingsystem
] == "win32"} {
2182 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2183 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2185 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2186 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2187 if {[tk windowingsystem
] eq
"aqua"} {
2188 bindall
<MouseWheel
> {
2189 set delta
[expr {- (%D
)}]
2190 allcanvs yview scroll
$delta units
2194 bindall
<2> "canvscan mark %W %x %y"
2195 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
2196 bindkey
<Home
> selfirstline
2197 bindkey
<End
> sellastline
2198 bind .
<Key-Up
> "selnextline -1"
2199 bind .
<Key-Down
> "selnextline 1"
2200 bind .
<Shift-Key-Up
> "dofind -1 0"
2201 bind .
<Shift-Key-Down
> "dofind 1 0"
2202 bindkey
<Key-Right
> "goforw"
2203 bindkey
<Key-Left
> "goback"
2204 bind .
<Key-Prior
> "selnextpage -1"
2205 bind .
<Key-Next
> "selnextpage 1"
2206 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2207 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2208 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2209 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2210 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2211 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2212 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2213 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2214 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2215 bindkey p
"selnextline -1"
2216 bindkey n
"selnextline 1"
2219 bindkey i
"selnextline -1"
2220 bindkey k
"selnextline 1"
2224 bindkey d
"$ctext yview scroll 18 units"
2225 bindkey u
"$ctext yview scroll -18 units"
2226 bindkey
/ {dofind
1 1}
2227 bindkey
<Key-Return
> {dofind
1 1}
2228 bindkey ?
{dofind
-1 1}
2230 bindkey
<F5
> updatecommits
2231 bind .
<$M1B-q> doquit
2232 bind .
<$M1B-f> {dofind
1 1}
2233 bind .
<$M1B-g> {dofind
1 0}
2234 bind .
<$M1B-r> dosearchback
2235 bind .
<$M1B-s> dosearch
2236 bind .
<$M1B-equal> {incrfont
1}
2237 bind .
<$M1B-plus> {incrfont
1}
2238 bind .
<$M1B-KP_Add> {incrfont
1}
2239 bind .
<$M1B-minus> {incrfont
-1}
2240 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2241 wm protocol . WM_DELETE_WINDOW doquit
2242 bind .
<Destroy
> {stop_backends
}
2243 bind .
<Button-1
> "click %W"
2244 bind $fstring <Key-Return
> {dofind
1 1}
2245 bind $sha1entry <Key-Return
> {gotocommit
; break}
2246 bind $sha1entry <<PasteSelection>> clearsha1
2247 bind $cflist <1> {sel_flist %W %x %y; break}
2248 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2249 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2251 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2252 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2254 set maincursor [. cget -cursor]
2255 set textcursor [$ctext cget -cursor]
2256 set curtextcursor $textcursor
2258 set rowctxmenu .rowctxmenu
2259 makemenu $rowctxmenu {
2260 {mc "Diff this -> selected" command {diffvssel 0}}
2261 {mc "Diff selected -> this" command {diffvssel 1}}
2262 {mc "Make patch" command mkpatch}
2263 {mc "Create tag" command mktag}
2264 {mc "Write commit to file" command writecommit}
2265 {mc "Create new branch" command mkbranch}
2266 {mc "Cherry-pick this commit" command cherrypick}
2267 {mc "Reset HEAD branch to here" command resethead}
2269 $rowctxmenu configure -tearoff 0
2271 set fakerowmenu .fakerowmenu
2272 makemenu $fakerowmenu {
2273 {mc "Diff this -> selected" command {diffvssel 0}}
2274 {mc "Diff selected -> this" command {diffvssel 1}}
2275 {mc "Make patch" command mkpatch}
2277 $fakerowmenu configure -tearoff 0
2279 set headctxmenu .headctxmenu
2280 makemenu $headctxmenu {
2281 {mc "Check out this branch" command cobranch}
2282 {mc "Remove this branch" command rmbranch}
2284 $headctxmenu configure -tearoff 0
2287 set flist_menu .flistctxmenu
2288 makemenu $flist_menu {
2289 {mc "Highlight this too" command {flist_hl 0}}
2290 {mc "Highlight this only" command {flist_hl 1}}
2291 {mc "External diff" command {external_diff}}
2292 {mc "Blame parent commit" command {external_blame 1}}
2294 $flist_menu configure -tearoff 0
2297 set diff_menu .diffctxmenu
2298 makemenu $diff_menu {
2299 {mc "Show origin of this line" command show_line_source}
2300 {mc "Run git gui blame on this line" command {external_blame_diff}}
2302 $diff_menu configure -tearoff 0
2305 # Windows sends all mouse wheel events to the current focused window, not
2306 # the one where the mouse hovers, so bind those events here and redirect
2307 # to the correct window
2308 proc windows_mousewheel_redirector {W X Y D} {
2309 global canv canv2 canv3
2310 set w [winfo containing -displayof $W $X $Y]
2312 set u [expr {$D < 0 ? 5 : -5}]
2313 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2314 allcanvs yview scroll $u units
2317 $w yview scroll $u units
2323 # Update row number label when selectedline changes
2324 proc selectedline_change {n1 n2 op} {
2325 global selectedline rownumsel
2327 if {$selectedline eq {}} {
2330 set rownumsel [expr {$selectedline + 1}]
2334 # mouse-2 makes all windows scan vertically, but only the one
2335 # the cursor is in scans horizontally
2336 proc canvscan {op w x y} {
2337 global canv canv2 canv3
2338 foreach c [list $canv $canv2 $canv3] {
2347 proc scrollcanv {cscroll f0 f1} {
2348 $cscroll set $f0 $f1
2353 # when we make a key binding for the toplevel, make sure
2354 # it doesn't get triggered when that key is pressed in the
2355 # find string entry widget.
2356 proc bindkey {ev script} {
2359 set escript [bind Entry $ev]
2360 if {$escript == {}} {
2361 set escript [bind Entry <Key>]
2363 foreach e $entries {
2364 bind $e $ev "$escript; break"
2368 # set the focus back to the toplevel for any click outside
2371 global ctext entries
2372 foreach e [concat $entries $ctext] {
2373 if {$w == $e} return
2378 # Adjust the progress bar for a change in requested extent or canvas size
2379 proc adjustprogress {} {
2380 global progresscanv progressitem progresscoords
2381 global fprogitem fprogcoord lastprogupdate progupdatepending
2382 global rprogitem rprogcoord
2384 set w [expr {[winfo width $progresscanv] - 4}]
2385 set x0 [expr {$w * [lindex $progresscoords 0]}]
2386 set x1 [expr {$w * [lindex $progresscoords 1]}]
2387 set h [winfo height $progresscanv]
2388 $progresscanv coords $progressitem $x0 0 $x1 $h
2389 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2390 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2391 set now [clock clicks -milliseconds]
2392 if {$now >= $lastprogupdate + 100} {
2393 set progupdatepending 0
2395 } elseif {!$progupdatepending} {
2396 set progupdatepending 1
2397 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2401 proc doprogupdate {} {
2402 global lastprogupdate progupdatepending
2404 if {$progupdatepending} {
2405 set progupdatepending 0
2406 set lastprogupdate [clock clicks -milliseconds]
2411 proc savestuff {w} {
2412 global canv canv2 canv3 mainfont textfont uifont tabstop
2413 global stuffsaved findmergefiles maxgraphpct
2414 global maxwidth showneartags showlocalchanges
2415 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2416 global cmitmode wrapcomment datetimeformat limitdiffs
2417 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2418 global autoselect extdifftool perfile_attrs markbgcolor
2420 if {$stuffsaved} return
2421 if {![winfo viewable .]} return
2423 set f [open "~/.gitk-new" w]
2424 puts $f [list set mainfont $mainfont]
2425 puts $f [list set textfont $textfont]
2426 puts $f [list set uifont $uifont]
2427 puts $f [list set tabstop $tabstop]
2428 puts $f [list set findmergefiles $findmergefiles]
2429 puts $f [list set maxgraphpct $maxgraphpct]
2430 puts $f [list set maxwidth $maxwidth]
2431 puts $f [list set cmitmode $cmitmode]
2432 puts $f [list set wrapcomment $wrapcomment]
2433 puts $f [list set autoselect $autoselect]
2434 puts $f [list set showneartags $showneartags]
2435 puts $f [list set showlocalchanges $showlocalchanges]
2436 puts $f [list set datetimeformat $datetimeformat]
2437 puts $f [list set limitdiffs $limitdiffs]
2438 puts $f [list set bgcolor $bgcolor]
2439 puts $f [list set fgcolor $fgcolor]
2440 puts $f [list set colors $colors]
2441 puts $f [list set diffcolors $diffcolors]
2442 puts $f [list set markbgcolor $markbgcolor]
2443 puts $f [list set diffcontext $diffcontext]
2444 puts $f [list set selectbgcolor $selectbgcolor]
2445 puts $f [list set extdifftool $extdifftool]
2446 puts $f [list set perfile_attrs $perfile_attrs]
2448 puts $f "set geometry(main) [wm geometry .]"
2449 puts $f "set geometry(topwidth) [winfo width .tf]"
2450 puts $f "set geometry(topheight) [winfo height .tf]"
2451 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2452 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2453 puts $f "set geometry(botwidth) [winfo width .bleft]"
2454 puts $f "set geometry(botheight) [winfo height .bleft]"
2456 puts -nonewline $f "set permviews {"
2457 for {set v 0} {$v < $nextviewnum} {incr v} {
2458 if {$viewperm($v)} {
2459 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2464 file rename -force "~/.gitk-new" "~/.gitk"
2469 proc resizeclistpanes {win w} {
2471 if {[info exists oldwidth($win)]} {
2472 set s0 [$win sash coord 0]
2473 set s1 [$win sash coord 1]
2475 set sash0 [expr {int($w/2 - 2)}]
2476 set sash1 [expr {int($w*5/6 - 2)}]
2478 set factor [expr {1.0 * $w / $oldwidth($win)}]
2479 set sash0 [expr {int($factor * [lindex $s0 0])}]
2480 set sash1 [expr {int($factor * [lindex $s1 0])}]
2484 if {$sash1 < $sash0 + 20} {
2485 set sash1 [expr {$sash0 + 20}]
2487 if {$sash1 > $w - 10} {
2488 set sash1 [expr {$w - 10}]
2489 if {$sash0 > $sash1 - 20} {
2490 set sash0 [expr {$sash1 - 20}]
2494 $win sash place 0 $sash0 [lindex $s0 1]
2495 $win sash place 1 $sash1 [lindex $s1 1]
2497 set oldwidth($win) $w
2500 proc resizecdetpanes {win w} {
2502 if {[info exists oldwidth($win)]} {
2503 set s0 [$win sash coord 0]
2505 set sash0 [expr {int($w*3/4 - 2)}]
2507 set factor [expr {1.0 * $w / $oldwidth($win)}]
2508 set sash0 [expr {int($factor * [lindex $s0 0])}]
2512 if {$sash0 > $w - 15} {
2513 set sash0 [expr {$w - 15}]
2516 $win sash place 0 $sash0 [lindex $s0 1]
2518 set oldwidth($win) $w
2521 proc allcanvs args {
2522 global canv canv2 canv3
2528 proc bindall {event action} {
2529 global canv canv2 canv3
2530 bind $canv $event $action
2531 bind $canv2 $event $action
2532 bind $canv3 $event $action
2538 if {[winfo exists $w]} {
2543 wm title $w [mc "About gitk"]
2544 message $w.m -text [mc "
2545 Gitk - a commit viewer for git
2547 Copyright © 2005-2008 Paul Mackerras
2549 Use and redistribute under the terms of the GNU General Public License"] \
2550 -justify center -aspect 400 -border 2 -bg white -relief groove
2551 pack $w.m -side top -fill x -padx 2 -pady 2
2552 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2553 pack $w.ok -side bottom
2554 bind $w <Visibility> "focus $w.ok"
2555 bind $w <Key-Escape> "destroy $w"
2556 bind $w <Key-Return> "destroy $w"
2561 if {[winfo exists $w]} {
2565 if {[tk windowingsystem] eq {aqua}} {
2571 wm title $w [mc "Gitk key bindings"]
2572 message $w.m -text "
2573 [mc "Gitk key bindings:"]
2575 [mc "<%s-Q> Quit" $M1T]
2576 [mc "<Home> Move to first commit"]
2577 [mc "<End> Move to last commit"]
2578 [mc "<Up>, p, i Move up one commit"]
2579 [mc "<Down>, n, k Move down one commit"]
2580 [mc "<Left>, z, j Go back in history list"]
2581 [mc "<Right>, x, l Go forward in history list"]
2582 [mc "<PageUp> Move up one page in commit list"]
2583 [mc "<PageDown> Move down one page in commit list"]
2584 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2585 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2586 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2587 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2588 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2589 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2590 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2591 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2592 [mc "<Delete>, b Scroll diff view up one page"]
2593 [mc "<Backspace> Scroll diff view up one page"]
2594 [mc "<Space> Scroll diff view down one page"]
2595 [mc "u Scroll diff view up 18 lines"]
2596 [mc "d Scroll diff view down 18 lines"]
2597 [mc "<%s-F> Find" $M1T]
2598 [mc "<%s-G> Move to next find hit" $M1T]
2599 [mc "<Return> Move to next find hit"]
2600 [mc "/ Move to next find hit, or redo find"]
2601 [mc "? Move to previous find hit"]
2602 [mc "f Scroll diff view to next file"]
2603 [mc "<%s-S> Search for next hit in diff view" $M1T]
2604 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2605 [mc "<%s-KP+> Increase font size" $M1T]
2606 [mc "<%s-plus> Increase font size" $M1T]
2607 [mc "<%s-KP-> Decrease font size" $M1T]
2608 [mc "<%s-minus> Decrease font size" $M1T]
2611 -justify left -bg white -border 2 -relief groove
2612 pack $w.m -side top -fill both -padx 2 -pady 2
2613 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2614 pack $w.ok -side bottom
2615 bind $w <Visibility> "focus $w.ok"
2616 bind $w <Key-Escape> "destroy $w"
2617 bind $w <Key-Return> "destroy $w"
2620 # Procedures for manipulating the file list window at the
2621 # bottom right of the overall window.
2623 proc treeview {w l openlevs} {
2624 global treecontents treediropen treeheight treeparent treeindex
2634 set treecontents() {}
2635 $w conf -state normal
2637 while {[string range $f 0 $prefixend] ne $prefix} {
2638 if {$lev <= $openlevs} {
2639 $w mark set e:$treeindex($prefix) "end -1c"
2640 $w mark gravity e:$treeindex($prefix) left
2642 set treeheight($prefix) $ht
2643 incr ht [lindex $htstack end]
2644 set htstack [lreplace $htstack end end]
2645 set prefixend [lindex $prefendstack end]
2646 set prefendstack [lreplace $prefendstack end end]
2647 set prefix [string range $prefix 0 $prefixend]
2650 set tail [string range $f [expr {$prefixend+1}] end]
2651 while {[set slash [string first "/" $tail]] >= 0} {
2654 lappend prefendstack $prefixend
2655 incr prefixend [expr {$slash + 1}]
2656 set d [string range $tail 0 $slash]
2657 lappend treecontents($prefix) $d
2658 set oldprefix $prefix
2660 set treecontents($prefix) {}
2661 set treeindex($prefix) [incr ix]
2662 set treeparent($prefix) $oldprefix
2663 set tail [string range $tail [expr {$slash+1}] end]
2664 if {$lev <= $openlevs} {
2666 set treediropen($prefix) [expr {$lev < $openlevs}]
2667 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2668 $w mark set d:$ix "end -1c"
2669 $w mark gravity d:$ix left
2671 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2673 $w image create end -align center -image $bm -padx 1 \
2675 $w insert end $d [highlight_tag $prefix]
2676 $w mark set s:$ix "end -1c"
2677 $w mark gravity s:$ix left
2682 if {$lev <= $openlevs} {
2685 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2687 $w insert end $tail [highlight_tag $f]
2689 lappend treecontents($prefix) $tail
2692 while {$htstack ne {}} {
2693 set treeheight($prefix) $ht
2694 incr ht [lindex $htstack end]
2695 set htstack [lreplace $htstack end end]
2696 set prefixend [lindex $prefendstack end]
2697 set prefendstack [lreplace $prefendstack end end]
2698 set prefix [string range $prefix 0 $prefixend]
2700 $w conf -state disabled
2703 proc linetoelt {l} {
2704 global treeheight treecontents
2709 foreach e $treecontents($prefix) {
2714 if {[string index $e end] eq "/"} {
2715 set n $treeheight($prefix$e)
2727 proc highlight_tree {y prefix} {
2728 global treeheight treecontents cflist
2730 foreach e $treecontents($prefix) {
2732 if {[highlight_tag $path] ne {}} {
2733 $cflist tag add bold $y.0 "$y.0 lineend"
2736 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2737 set y [highlight_tree $y $path]
2743 proc treeclosedir {w dir} {
2744 global treediropen treeheight treeparent treeindex
2746 set ix $treeindex($dir)
2747 $w conf -state normal
2748 $w delete s:$ix e:$ix
2749 set treediropen($dir) 0
2750 $w image configure a:$ix -image tri-rt
2751 $w conf -state disabled
2752 set n [expr {1 - $treeheight($dir)}]
2753 while {$dir ne {}} {
2754 incr treeheight($dir) $n
2755 set dir $treeparent($dir)
2759 proc treeopendir {w dir} {
2760 global treediropen treeheight treeparent treecontents treeindex
2762 set ix $treeindex($dir)
2763 $w conf -state normal
2764 $w image configure a:$ix -image tri-dn
2765 $w mark set e:$ix s:$ix
2766 $w mark gravity e:$ix right
2769 set n [llength $treecontents($dir)]
2770 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2773 incr treeheight($x) $n
2775 foreach e $treecontents($dir) {
2777 if {[string index $e end] eq "/"} {
2778 set iy $treeindex($de)
2779 $w mark set d:$iy e:$ix
2780 $w mark gravity d:$iy left
2781 $w insert e:$ix $str
2782 set treediropen($de) 0
2783 $w image create e:$ix -align center -image tri-rt -padx 1 \
2785 $w insert e:$ix $e [highlight_tag $de]
2786 $w mark set s:$iy e:$ix
2787 $w mark gravity s:$iy left
2788 set treeheight($de) 1
2790 $w insert e:$ix $str
2791 $w insert e:$ix $e [highlight_tag $de]
2794 $w mark gravity e:$ix right
2795 $w conf -state disabled
2796 set treediropen($dir) 1
2797 set top [lindex [split [$w index @0,0] .] 0]
2798 set ht [$w cget -height]
2799 set l [lindex [split [$w index s:$ix] .] 0]
2802 } elseif {$l + $n + 1 > $top + $ht} {
2803 set top [expr {$l + $n + 2 - $ht}]
2811 proc treeclick {w x y} {
2812 global treediropen cmitmode ctext cflist cflist_top
2814 if {$cmitmode ne "tree"} return
2815 if {![info exists cflist_top]} return
2816 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2817 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2818 $cflist tag add highlight $l.0 "$l.0 lineend"
2824 set e [linetoelt $l]
2825 if {[string index $e end] ne "/"} {
2827 } elseif {$treediropen($e)} {
2834 proc setfilelist {id} {
2835 global treefilelist cflist jump_to_here
2837 treeview $cflist $treefilelist($id) 0
2838 if {$jump_to_here ne {}} {
2839 set f [lindex $jump_to_here 0]
2840 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2846 image create bitmap tri-rt -background black -foreground blue -data {
2847 #define tri-rt_width 13
2848 #define tri-rt_height 13
2849 static unsigned char tri-rt_bits[] = {
2850 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2851 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2854 #define tri-rt-mask_width 13
2855 #define tri-rt-mask_height 13
2856 static unsigned char tri-rt-mask_bits[] = {
2857 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2858 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2861 image create bitmap tri-dn -background black -foreground blue -data {
2862 #define tri-dn_width 13
2863 #define tri-dn_height 13
2864 static unsigned char tri-dn_bits[] = {
2865 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2866 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2869 #define tri-dn-mask_width 13
2870 #define tri-dn-mask_height 13
2871 static unsigned char tri-dn-mask_bits[] = {
2872 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2873 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2877 image create bitmap reficon-T -background black -foreground yellow -data {
2878 #define tagicon_width 13
2879 #define tagicon_height 9
2880 static unsigned char tagicon_bits[] = {
2881 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2882 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2884 #define tagicon-mask_width 13
2885 #define tagicon-mask_height 9
2886 static unsigned char tagicon-mask_bits[] = {
2887 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2888 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2891 #define headicon_width 13
2892 #define headicon_height 9
2893 static unsigned char headicon_bits[] = {
2894 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2895 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2898 #define headicon-mask_width 13
2899 #define headicon-mask_height 9
2900 static unsigned char headicon-mask_bits[] = {
2901 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2902 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2904 image create bitmap reficon-H -background black -foreground green \
2905 -data $rectdata -maskdata $rectmask
2906 image create bitmap reficon-o -background black -foreground "#ddddff" \
2907 -data $rectdata -maskdata $rectmask
2909 proc init_flist {first} {
2910 global cflist cflist_top difffilestart
2912 $cflist conf -state normal
2913 $cflist delete 0.0 end
2915 $cflist insert end $first
2917 $cflist tag add highlight 1.0 "1.0 lineend"
2919 catch {unset cflist_top}
2921 $cflist conf -state disabled
2922 set difffilestart {}
2925 proc highlight_tag {f} {
2926 global highlight_paths
2928 foreach p $highlight_paths {
2929 if {[string match $p $f]} {
2936 proc highlight_filelist {} {
2937 global cmitmode cflist
2939 $cflist conf -state normal
2940 if {$cmitmode ne "tree"} {
2941 set end [lindex [split [$cflist index end] .] 0]
2942 for {set l 2} {$l < $end} {incr l} {
2943 set line [$cflist get $l.0 "$l.0 lineend"]
2944 if {[highlight_tag $line] ne {}} {
2945 $cflist tag add bold $l.0 "$l.0 lineend"
2951 $cflist conf -state disabled
2954 proc unhighlight_filelist {} {
2957 $cflist conf -state normal
2958 $cflist tag remove bold 1.0 end
2959 $cflist conf -state disabled
2962 proc add_flist {fl} {
2965 $cflist conf -state normal
2967 $cflist insert end "\n"
2968 $cflist insert end $f [highlight_tag $f]
2970 $cflist conf -state disabled
2973 proc sel_flist {w x y} {
2974 global ctext difffilestart cflist cflist_top cmitmode
2976 if {$cmitmode eq "tree"} return
2977 if {![info exists cflist_top]} return
2978 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2979 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2980 $cflist tag add highlight $l.0 "$l.0 lineend"
2985 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2989 proc pop_flist_menu {w X Y x y} {
2990 global ctext cflist cmitmode flist_menu flist_menu_file
2991 global treediffs diffids
2994 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2996 if {$cmitmode eq "tree"} {
2997 set e [linetoelt $l]
2998 if {[string index $e end] eq "/"} return
3000 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3002 set flist_menu_file $e
3003 set xdiffstate "normal"
3004 if {$cmitmode eq "tree"} {
3005 set xdiffstate "disabled"
3007 # Disable "External diff" item in tree mode
3008 $flist_menu entryconf 2 -state $xdiffstate
3009 tk_popup $flist_menu $X $Y
3012 proc find_ctext_fileinfo {line} {
3013 global ctext_file_names ctext_file_lines
3015 set ok [bsearch $ctext_file_lines $line]
3016 set tline [lindex $ctext_file_lines $ok]
3018 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3021 return [list [lindex $ctext_file_names $ok] $tline]
3025 proc pop_diff_menu {w X Y x y} {
3026 global ctext diff_menu flist_menu_file
3027 global diff_menu_txtpos diff_menu_line
3028 global diff_menu_filebase
3030 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3031 set diff_menu_line [lindex $diff_menu_txtpos 0]
3032 # don't pop up the menu on hunk-separator or file-separator lines
3033 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3037 set f [find_ctext_fileinfo $diff_menu_line]
3038 if {$f eq {}} return
3039 set flist_menu_file [lindex $f 0]
3040 set diff_menu_filebase [lindex $f 1]
3041 tk_popup $diff_menu $X $Y
3044 proc flist_hl {only} {
3045 global flist_menu_file findstring gdttype
3047 set x [shellquote $flist_menu_file]
3048 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3051 append findstring " " $x
3053 set gdttype [mc "touching paths:"]
3056 proc save_file_from_commit {filename output what} {
3059 if {[catch {exec git show $filename -- > $output} err]} {
3060 if {[string match "fatal: bad revision *" $err]} {
3063 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3069 proc external_diff_get_one_file {diffid filename diffdir} {
3070 global nullid nullid2 nullfile
3073 if {$diffid == $nullid} {
3074 set difffile [file join [file dirname $gitdir] $filename]
3075 if {[file exists $difffile]} {
3080 if {$diffid == $nullid2} {
3081 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3082 return [save_file_from_commit :$filename $difffile index]
3084 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3085 return [save_file_from_commit $diffid:$filename $difffile \
3089 proc external_diff {} {
3090 global gitktmpdir nullid nullid2
3091 global flist_menu_file
3094 global gitdir extdifftool
3096 if {[llength $diffids] == 1} {
3097 # no reference commit given
3098 set diffidto [lindex $diffids 0]
3099 if {$diffidto eq $nullid} {
3100 # diffing working copy with index
3101 set diffidfrom $nullid2
3102 } elseif {$diffidto eq $nullid2} {
3103 # diffing index with HEAD
3104 set diffidfrom "HEAD"
3106 # use first parent commit
3107 global parentlist selectedline
3108 set diffidfrom [lindex $parentlist $selectedline 0]
3111 set diffidfrom [lindex $diffids 0]
3112 set diffidto [lindex $diffids 1]
3115 # make sure that several diffs wont collide
3116 if {![info exists gitktmpdir]} {
3117 set gitktmpdir [file join [file dirname $gitdir] \
3118 [format ".gitk-tmp.%s" [pid]]]
3119 if {[catch {file mkdir $gitktmpdir} err]} {
3120 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3127 set diffdir [file join $gitktmpdir $diffnum]
3128 if {[catch {file mkdir $diffdir} err]} {
3129 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3133 # gather files to diff
3134 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3135 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3137 if {$difffromfile ne {} && $difftofile ne {}} {
3138 set cmd [concat | [shellsplit $extdifftool] \
3139 [list $difffromfile $difftofile]]
3140 if {[catch {set fl [open $cmd r]} err]} {
3141 file delete -force $diffdir
3142 error_popup "$extdifftool: [mc "command failed:"] $err"
3144 fconfigure $fl -blocking 0
3145 filerun $fl [list delete_at_eof $fl $diffdir]
3150 proc find_hunk_blamespec {base line} {
3153 # Find and parse the hunk header
3154 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3155 if {$s_lix eq {}} return
3157 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3158 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3159 s_line old_specs osz osz1 new_line nsz]} {
3163 # base lines for the parents
3164 set base_lines [list $new_line]
3165 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3166 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3167 old_spec old_line osz]} {
3170 lappend base_lines $old_line
3173 # Now scan the lines to determine offset within the hunk
3174 set max_parent [expr {[llength $base_lines]-2}]
3176 set s_lno [lindex [split $s_lix "."] 0]
3178 # Determine if the line is removed
3179 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3180 if {[string match {[-+ ]*} $chunk]} {
3181 set removed_idx [string first "-" $chunk]
3182 # Choose a parent index
3183 if {$removed_idx >= 0} {
3184 set parent $removed_idx
3186 set unchanged_idx [string first " " $chunk]
3187 if {$unchanged_idx >= 0} {
3188 set parent $unchanged_idx
3190 # blame the current commit
3194 # then count other lines that belong to it
3195 for {set i $line} {[incr i -1] > $s_lno} {} {
3196 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3197 # Determine if the line is removed
3198 set removed_idx [string first "-" $chunk]
3200 set code [string index $chunk $parent]
3201 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3205 if {$removed_idx < 0} {
3215 incr dline [lindex $base_lines $parent]
3216 return [list $parent $dline]
3219 proc external_blame_diff {} {
3220 global currentid cmitmode
3221 global diff_menu_txtpos diff_menu_line
3222 global diff_menu_filebase flist_menu_file
3224 if {$cmitmode eq "tree"} {
3226 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3228 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3230 set parent_idx [lindex $hinfo 0]
3231 set line [lindex $hinfo 1]
3238 external_blame $parent_idx $line
3241 proc external_blame {parent_idx {line {}}} {
3242 global flist_menu_file
3243 global nullid nullid2
3244 global parentlist selectedline currentid
3246 if {$parent_idx > 0} {
3247 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3249 set base_commit $currentid
3252 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3253 error_popup [mc "No such commit"]
3257 set cmdline [list git gui blame]
3258 if {$line ne {} && $line > 1} {
3259 lappend cmdline "--line=$line"
3261 lappend cmdline $base_commit $flist_menu_file
3262 if {[catch {eval exec $cmdline &} err]} {
3263 error_popup "[mc "git gui blame: command failed:"] $err"
3267 proc show_line_source {} {
3268 global cmitmode currentid parents curview blamestuff blameinst
3269 global diff_menu_line diff_menu_filebase flist_menu_file
3271 if {$cmitmode eq "tree"} {
3273 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3275 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3276 if {$h eq {}} return
3277 set pi [lindex $h 0]
3279 mark_ctext_line $diff_menu_line
3282 set id [lindex $parents($curview,$currentid) [expr {$pi - 1}]]
3283 set line [lindex $h 1]
3286 set f [open [list | git blame -p -L$line,+1 $id -- $flist_menu_file] r]
3288 error_popup [mc "Couldn't start git blame: %s" $err]
3291 fconfigure $f -blocking 0
3292 set i [reg_instance $f]
3293 set blamestuff($i) {}
3295 filerun $f [list read_line_source $f $i]
3298 proc stopblaming {} {
3301 if {[info exists blameinst]} {
3302 stop_instance $blameinst
3307 proc read_line_source {fd inst} {
3308 global blamestuff curview commfd blameinst
3310 while {[gets $fd line] >= 0} {
3311 lappend blamestuff($inst) $line
3318 fconfigure $fd -blocking 1
3319 if {[catch {close $fd} err]} {
3320 error_popup [mc "Error running git blame: %s" $err]
3325 set line [split [lindex $blamestuff($inst) 0] " "]
3326 set id [lindex $line 0]
3327 set lnum [lindex $line 1]
3328 if {[string length $id] == 40 && [string is xdigit $id] &&
3329 [string is digit -strict $lnum]} {
3330 # look for "filename" line
3331 foreach l $blamestuff($inst) {
3332 if {[string match "filename *" $l]} {
3333 set fname [string range $l 9 end]
3339 # all looks good, select it
3340 if {[commitinview $id $curview]} {
3341 selectline [rowofcommit $id] 1 [list $fname $lnum]
3343 error_popup [mc "That line comes from commit %s, \
3344 which is not in this view" [shortids $id]]
3347 puts "oops couldn't parse git blame output"
3352 # delete $dir when we see eof on $f (presumably because the child has exited)
3353 proc delete_at_eof {f dir} {
3354 while {[gets $f line] >= 0} {}
3356 if {[catch {close $f} err]} {
3357 error_popup "[mc "External diff viewer failed:"] $err"
3359 file delete -force $dir
3365 # Functions for adding and removing shell-type quoting
3367 proc shellquote {str} {
3368 if {![string match "*\['\"\\ \t]*" $str]} {
3371 if {![string match "*\['\"\\]*" $str]} {
3374 if {![string match "*'*" $str]} {
3377 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3380 proc shellarglist {l} {
3386 append str [shellquote $a]
3391 proc shelldequote {str} {
3396 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3397 append ret [string range $str $used end]
3398 set used [string length $str]
3401 set first [lindex $first 0]
3402 set ch [string index $str $first]
3403 if {$first > $used} {
3404 append ret [string range $str $used [expr {$first - 1}]]
3407 if {$ch eq " " || $ch eq "\t"} break
3410 set first [string first "'" $str $used]
3412 error "unmatched single-quote"
3414 append ret [string range $str $used [expr {$first - 1}]]
3419 if {$used >= [string length $str]} {
3420 error "trailing backslash"
3422 append ret [string index $str $used]
3427 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3428 error "unmatched double-quote"
3430 set first [lindex $first 0]
3431 set ch [string index $str $first]
3432 if {$first > $used} {
3433 append ret [string range $str $used [expr {$first - 1}]]
3436 if {$ch eq "\""} break
3438 append ret [string index $str $used]
3442 return [list $used $ret]
3445 proc shellsplit {str} {
3448 set str [string trimleft $str]
3449 if {$str eq {}} break
3450 set dq [shelldequote $str]
3451 set n [lindex $dq 0]
3452 set word [lindex $dq 1]
3453 set str [string range $str $n end]
3459 # Code to implement multiple views
3461 proc newview {ishighlight} {
3462 global nextviewnum newviewname newviewperm newishighlight
3463 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3465 set newishighlight $ishighlight
3467 if {[winfo exists $top]} {
3471 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3472 set newviewperm($nextviewnum) 0
3473 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3474 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3475 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3480 global viewname viewperm newviewname newviewperm
3481 global viewargs newviewargs viewargscmd newviewargscmd
3483 set top .gitkvedit-$curview
3484 if {[winfo exists $top]} {
3488 set newviewname($curview) $viewname($curview)
3489 set newviewperm($curview) $viewperm($curview)
3490 set newviewargs($curview) [shellarglist $viewargs($curview)]
3491 set newviewargscmd($curview) $viewargscmd($curview)
3492 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3495 proc vieweditor {top n title} {
3496 global newviewname newviewperm viewfiles bgcolor
3499 wm title $top $title
3500 label $top.nl -text [mc "Name"]
3501 entry $top.name -width 20 -textvariable newviewname($n)
3502 grid $top.nl $top.name -sticky w -pady 5
3503 checkbutton $top.perm -text [mc "Remember this view"] \
3504 -variable newviewperm($n)
3505 grid $top.perm - -pady 5 -sticky w
3506 message $top.al -aspect 1000 \
3507 -text [mc "Commits to include (arguments to git log):"]
3508 grid $top.al - -sticky w -pady 5
3509 entry $top.args -width 50 -textvariable newviewargs($n) \
3510 -background $bgcolor
3511 grid $top.args - -sticky ew -padx 5
3513 message $top.ac -aspect 1000 \
3514 -text [mc "Command to generate more commits to include:"]
3515 grid $top.ac - -sticky w -pady 5
3516 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3518 grid $top.argscmd - -sticky ew -padx 5
3520 message $top.l -aspect 1000 \
3521 -text [mc "Enter files and directories to include, one per line:"]
3522 grid $top.l - -sticky w
3523 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3524 if {[info exists viewfiles($n)]} {
3525 foreach f $viewfiles($n) {
3526 $top.t insert end $f
3527 $top.t insert end "\n"
3529 $top.t delete {end - 1c} end
3530 $top.t mark set insert 0.0
3532 grid $top.t - -sticky ew -padx 5
3534 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3535 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3536 grid $top.buts.ok $top.buts.can
3537 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3538 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3539 grid $top.buts - -pady 10 -sticky ew
3543 proc doviewmenu {m first cmd op argv} {
3544 set nmenu [$m index end]
3545 for {set i $first} {$i <= $nmenu} {incr i} {
3546 if {[$m entrycget $i -command] eq $cmd} {
3547 eval $m $op $i $argv
3553 proc allviewmenus {n op args} {
3556 doviewmenu .bar.view 5 [list showview $n] $op $args
3557 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3560 proc newviewok {top n} {
3561 global nextviewnum newviewperm newviewname newishighlight
3562 global viewname viewfiles viewperm selectedview curview
3563 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3566 set newargs [shellsplit $newviewargs($n)]
3568 error_popup "[mc "Error in commit selection arguments:"] $err"
3574 foreach f [split [$top.t get 0.0 end] "\n"] {
3575 set ft [string trim $f]
3580 if {![info exists viewfiles($n)]} {
3581 # creating a new view
3583 set viewname($n) $newviewname($n)
3584 set viewperm($n) $newviewperm($n)
3585 set viewfiles($n) $files
3586 set viewargs($n) $newargs
3587 set viewargscmd($n) $newviewargscmd($n)
3589 if {!$newishighlight} {
3592 run addvhighlight $n
3595 # editing an existing view
3596 set viewperm($n) $newviewperm($n)
3597 if {$newviewname($n) ne $viewname($n)} {
3598 set viewname($n) $newviewname($n)
3599 doviewmenu .bar.view 5 [list showview $n] \
3600 entryconf [list -label $viewname($n)]
3601 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3602 # entryconf [list -label $viewname($n) -value $viewname($n)]
3604 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3605 $newviewargscmd($n) ne $viewargscmd($n)} {
3606 set viewfiles($n) $files
3607 set viewargs($n) $newargs
3608 set viewargscmd($n) $newviewargscmd($n)
3609 if {$curview == $n} {
3614 catch {destroy $top}
3618 global curview viewperm hlview selectedhlview
3620 if {$curview == 0} return
3621 if {[info exists hlview] && $hlview == $curview} {
3622 set selectedhlview [mc "None"]
3625 allviewmenus $curview delete
3626 set viewperm($curview) 0
3630 proc addviewmenu {n} {
3631 global viewname viewhlmenu
3633 .bar.view add radiobutton -label $viewname($n) \
3634 -command [list showview $n] -variable selectedview -value $n
3635 #$viewhlmenu add radiobutton -label $viewname($n) \
3636 # -command [list addvhighlight $n] -variable selectedhlview
3640 global curview cached_commitrow ordertok
3641 global displayorder parentlist rowidlist rowisopt rowfinal
3642 global colormap rowtextx nextcolor canvxmax
3643 global numcommits viewcomplete
3644 global selectedline currentid canv canvy0
3646 global pending_select mainheadid
3649 global hlview selectedhlview commitinterest
3651 if {$n == $curview} return
3653 set ymax [lindex [$canv cget -scrollregion] 3]
3654 set span [$canv yview]
3655 set ytop [expr {[lindex $span 0] * $ymax}]
3656 set ybot [expr {[lindex $span 1] * $ymax}]
3657 set yscreen [expr {($ybot - $ytop) / 2}]
3658 if {$selectedline ne {}} {
3659 set selid $currentid
3660 set y [yc $selectedline]
3661 if {$ytop < $y && $y < $ybot} {
3662 set yscreen [expr {$y - $ytop}]
3664 } elseif {[info exists pending_select]} {
3665 set selid $pending_select
3666 unset pending_select
3670 catch {unset treediffs}
3672 if {[info exists hlview] && $hlview == $n} {
3674 set selectedhlview [mc "None"]
3676 catch {unset commitinterest}
3677 catch {unset cached_commitrow}
3678 catch {unset ordertok}
3682 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3683 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3686 if {![info exists viewcomplete($n)]} {
3696 set numcommits $commitidx($n)
3698 catch {unset colormap}
3699 catch {unset rowtextx}
3701 set canvxmax [$canv cget -width]
3707 if {$selid ne {} && [commitinview $selid $n]} {
3708 set row [rowofcommit $selid]
3709 # try to get the selected row in the same position on the screen
3710 set ymax [lindex [$canv cget -scrollregion] 3]
3711 set ytop [expr {[yc $row] - $yscreen}]
3715 set yf [expr {$ytop * 1.0 / $ymax}]
3717 allcanvs yview moveto $yf
3721 } elseif {!$viewcomplete($n)} {
3722 reset_pending_select $selid
3724 reset_pending_select {}
3726 if {[commitinview $pending_select $curview]} {
3727 selectline [rowofcommit $pending_select] 1
3729 set row [first_real_row]
3730 if {$row < $numcommits} {
3735 if {!$viewcomplete($n)} {
3736 if {$numcommits == 0} {
3737 show_status [mc "Reading commits..."]
3739 } elseif {$numcommits == 0} {
3740 show_status [mc "No commits selected"]
3744 # Stuff relating to the highlighting facility
3746 proc ishighlighted {id} {
3747 global vhighlights fhighlights nhighlights rhighlights
3749 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3750 return $nhighlights($id)
3752 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3753 return $vhighlights($id)
3755 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3756 return $fhighlights($id)
3758 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3759 return $rhighlights($id)
3764 proc bolden {row font} {
3765 global canv linehtag selectedline boldrows
3767 lappend boldrows $row
3768 $canv itemconf $linehtag($row) -font $font
3769 if {$row == $selectedline} {
3771 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3772 -outline {{}} -tags secsel \
3773 -fill [$canv cget -selectbackground]]
3778 proc bolden_name {row font} {
3779 global canv2 linentag selectedline boldnamerows
3781 lappend boldnamerows $row
3782 $canv2 itemconf $linentag($row) -font $font
3783 if {$row == $selectedline} {
3784 $canv2 delete secsel
3785 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3786 -outline {{}} -tags secsel \
3787 -fill [$canv2 cget -selectbackground]]
3796 foreach row $boldrows {
3797 if {![ishighlighted [commitonrow $row]]} {
3798 bolden $row mainfont
3800 lappend stillbold $row
3803 set boldrows $stillbold
3806 proc addvhighlight {n} {
3807 global hlview viewcomplete curview vhl_done commitidx
3809 if {[info exists hlview]} {
3813 if {$n != $curview && ![info exists viewcomplete($n)]} {
3816 set vhl_done $commitidx($hlview)
3817 if {$vhl_done > 0} {
3822 proc delvhighlight {} {
3823 global hlview vhighlights
3825 if {![info exists hlview]} return
3827 catch {unset vhighlights}
3831 proc vhighlightmore {} {
3832 global hlview vhl_done commitidx vhighlights curview
3834 set max $commitidx($hlview)
3835 set vr [visiblerows]
3836 set r0 [lindex $vr 0]
3837 set r1 [lindex $vr 1]
3838 for {set i $vhl_done} {$i < $max} {incr i} {
3839 set id [commitonrow $i $hlview]
3840 if {[commitinview $id $curview]} {
3841 set row [rowofcommit $id]
3842 if {$r0 <= $row && $row <= $r1} {
3843 if {![highlighted $row]} {
3844 bolden $row mainfontbold
3846 set vhighlights($id) 1
3854 proc askvhighlight {row id} {
3855 global hlview vhighlights iddrawn
3857 if {[commitinview $id $hlview]} {
3858 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3859 bolden $row mainfontbold
3861 set vhighlights($id) 1
3863 set vhighlights($id) 0
3867 proc hfiles_change {} {
3868 global highlight_files filehighlight fhighlights fh_serial
3869 global highlight_paths gdttype
3871 if {[info exists filehighlight]} {
3872 # delete previous highlights
3873 catch {close $filehighlight}
3875 catch {unset fhighlights}
3877 unhighlight_filelist
3879 set highlight_paths {}
3880 after cancel do_file_hl $fh_serial
3882 if {$highlight_files ne {}} {
3883 after 300 do_file_hl $fh_serial
3887 proc gdttype_change {name ix op} {
3888 global gdttype highlight_files findstring findpattern
3891 if {$findstring ne {}} {
3892 if {$gdttype eq [mc "containing:"]} {
3893 if {$highlight_files ne {}} {
3894 set highlight_files {}
3899 if {$findpattern ne {}} {
3903 set highlight_files $findstring
3908 # enable/disable findtype/findloc menus too
3911 proc find_change {name ix op} {
3912 global gdttype findstring highlight_files
3915 if {$gdttype eq [mc "containing:"]} {
3918 if {$highlight_files ne $findstring} {
3919 set highlight_files $findstring
3926 proc findcom_change args {
3927 global nhighlights boldnamerows
3928 global findpattern findtype findstring gdttype
3931 # delete previous highlights, if any
3932 foreach row $boldnamerows {
3933 bolden_name $row mainfont
3936 catch {unset nhighlights}
3939 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3941 } elseif {$findtype eq [mc "Regexp"]} {
3942 set findpattern $findstring
3944 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3946 set findpattern "*$e*"
3950 proc makepatterns {l} {
3953 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3954 if {[string index $ee end] eq "/"} {
3964 proc do_file_hl {serial} {
3965 global highlight_files filehighlight highlight_paths gdttype fhl_list
3967 if {$gdttype eq [mc "touching paths:"]} {
3968 if {[catch {set paths [shellsplit $highlight_files]}]} return
3969 set highlight_paths [makepatterns $paths]
3971 set gdtargs [concat -- $paths]
3972 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3973 set gdtargs [list "-S$highlight_files"]
3975 # must be "containing:", i.e. we're searching commit info
3978 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3979 set filehighlight [open $cmd r+]
3980 fconfigure $filehighlight -blocking 0
3981 filerun $filehighlight readfhighlight
3987 proc flushhighlights {} {
3988 global filehighlight fhl_list
3990 if {[info exists filehighlight]} {
3992 puts $filehighlight ""
3993 flush $filehighlight
3997 proc askfilehighlight {row id} {
3998 global filehighlight fhighlights fhl_list
4000 lappend fhl_list $id
4001 set fhighlights($id) -1
4002 puts $filehighlight $id
4005 proc readfhighlight {} {
4006 global filehighlight fhighlights curview iddrawn
4007 global fhl_list find_dirn
4009 if {![info exists filehighlight]} {
4013 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4014 set line [string trim $line]
4015 set i [lsearch -exact $fhl_list $line]
4016 if {$i < 0} continue
4017 for {set j 0} {$j < $i} {incr j} {
4018 set id [lindex $fhl_list $j]
4019 set fhighlights($id) 0
4021 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4022 if {$line eq {}} continue
4023 if {![commitinview $line $curview]} continue
4024 set row [rowofcommit $line]
4025 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4026 bolden $row mainfontbold
4028 set fhighlights($line) 1
4030 if {[eof $filehighlight]} {
4032 puts "oops, git diff-tree died"
4033 catch {close $filehighlight}
4037 if {[info exists find_dirn]} {
4043 proc doesmatch {f} {
4044 global findtype findpattern
4046 if {$findtype eq [mc "Regexp"]} {
4047 return [regexp $findpattern $f]
4048 } elseif {$findtype eq [mc "IgnCase"]} {
4049 return [string match -nocase $findpattern $f]
4051 return [string match $findpattern $f]
4055 proc askfindhighlight {row id} {
4056 global nhighlights commitinfo iddrawn
4058 global markingmatches
4060 if {![info exists commitinfo($id)]} {
4063 set info $commitinfo($id)
4065 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4066 foreach f $info ty $fldtypes {
4067 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4069 if {$ty eq [mc "Author"]} {
4076 if {$isbold && [info exists iddrawn($id)]} {
4077 if {![ishighlighted $id]} {
4078 bolden $row mainfontbold
4080 bolden_name $row mainfontbold
4083 if {$markingmatches} {
4084 markrowmatches $row $id
4087 set nhighlights($id) $isbold
4090 proc markrowmatches {row id} {
4091 global canv canv2 linehtag linentag commitinfo findloc
4093 set headline [lindex $commitinfo($id) 0]
4094 set author [lindex $commitinfo($id) 1]
4095 $canv delete match$row
4096 $canv2 delete match$row
4097 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4098 set m [findmatches $headline]
4100 markmatches $canv $row $headline $linehtag($row) $m \
4101 [$canv itemcget $linehtag($row) -font] $row
4104 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4105 set m [findmatches $author]
4107 markmatches $canv2 $row $author $linentag($row) $m \
4108 [$canv2 itemcget $linentag($row) -font] $row
4113 proc vrel_change {name ix op} {
4114 global highlight_related
4117 if {$highlight_related ne [mc "None"]} {
4122 # prepare for testing whether commits are descendents or ancestors of a
4123 proc rhighlight_sel {a} {
4124 global descendent desc_todo ancestor anc_todo
4125 global highlight_related
4127 catch {unset descendent}
4128 set desc_todo [list $a]
4129 catch {unset ancestor}
4130 set anc_todo [list $a]
4131 if {$highlight_related ne [mc "None"]} {
4137 proc rhighlight_none {} {
4140 catch {unset rhighlights}
4144 proc is_descendent {a} {
4145 global curview children descendent desc_todo
4148 set la [rowofcommit $a]
4152 for {set i 0} {$i < [llength $todo]} {incr i} {
4153 set do [lindex $todo $i]
4154 if {[rowofcommit $do] < $la} {
4155 lappend leftover $do
4158 foreach nk $children($v,$do) {
4159 if {![info exists descendent($nk)]} {
4160 set descendent($nk) 1
4168 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4172 set descendent($a) 0
4173 set desc_todo $leftover
4176 proc is_ancestor {a} {
4177 global curview parents ancestor anc_todo
4180 set la [rowofcommit $a]
4184 for {set i 0} {$i < [llength $todo]} {incr i} {
4185 set do [lindex $todo $i]
4186 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4187 lappend leftover $do
4190 foreach np $parents($v,$do) {
4191 if {![info exists ancestor($np)]} {
4200 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4205 set anc_todo $leftover
4208 proc askrelhighlight {row id} {
4209 global descendent highlight_related iddrawn rhighlights
4210 global selectedline ancestor
4212 if {$selectedline eq {}} return
4214 if {$highlight_related eq [mc "Descendant"] ||
4215 $highlight_related eq [mc "Not descendant"]} {
4216 if {![info exists descendent($id)]} {
4219 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4222 } elseif {$highlight_related eq [mc "Ancestor"] ||
4223 $highlight_related eq [mc "Not ancestor"]} {
4224 if {![info exists ancestor($id)]} {
4227 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4231 if {[info exists iddrawn($id)]} {
4232 if {$isbold && ![ishighlighted $id]} {
4233 bolden $row mainfontbold
4236 set rhighlights($id) $isbold
4239 # Graph layout functions
4241 proc shortids {ids} {
4244 if {[llength $id] > 1} {
4245 lappend res [shortids $id]
4246 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4247 lappend res [string range $id 0 7]
4258 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4259 if {($n & $mask) != 0} {
4260 set ret [concat $ret $o]
4262 set o [concat $o $o]
4267 proc ordertoken {id} {
4268 global ordertok curview varcid varcstart varctok curview parents children
4269 global nullid nullid2
4271 if {[info exists ordertok($id)]} {
4272 return $ordertok($id)
4277 if {[info exists varcid($curview,$id)]} {
4278 set a $varcid($curview,$id)
4279 set p [lindex $varcstart($curview) $a]
4281 set p [lindex $children($curview,$id) 0]
4283 if {[info exists ordertok($p)]} {
4284 set tok $ordertok($p)
4287 set id [first_real_child $curview,$p]
4290 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4293 if {[llength $parents($curview,$id)] == 1} {
4294 lappend todo [list $p {}]
4296 set j [lsearch -exact $parents($curview,$id) $p]
4298 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4300 lappend todo [list $p [strrep $j]]
4303 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4304 set p [lindex $todo $i 0]
4305 append tok [lindex $todo $i 1]
4306 set ordertok($p) $tok
4308 set ordertok($origid) $tok
4312 # Work out where id should go in idlist so that order-token
4313 # values increase from left to right
4314 proc idcol {idlist id {i 0}} {
4315 set t [ordertoken $id]
4319 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4320 if {$i > [llength $idlist]} {
4321 set i [llength $idlist]
4323 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4326 if {$t > [ordertoken [lindex $idlist $i]]} {
4327 while {[incr i] < [llength $idlist] &&
4328 $t >= [ordertoken [lindex $idlist $i]]} {}
4334 proc initlayout {} {
4335 global rowidlist rowisopt rowfinal displayorder parentlist
4336 global numcommits canvxmax canv
4338 global colormap rowtextx
4347 set canvxmax [$canv cget -width]
4348 catch {unset colormap}
4349 catch {unset rowtextx}
4353 proc setcanvscroll {} {
4354 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4355 global lastscrollset lastscrollrows
4357 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4358 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4359 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4360 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4361 set lastscrollset [clock clicks -milliseconds]
4362 set lastscrollrows $numcommits
4365 proc visiblerows {} {
4366 global canv numcommits linespc
4368 set ymax [lindex [$canv cget -scrollregion] 3]
4369 if {$ymax eq {} || $ymax == 0} return
4371 set y0 [expr {int([lindex $f 0] * $ymax)}]
4372 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4376 set y1 [expr {int([lindex $f 1] * $ymax)}]
4377 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4378 if {$r1 >= $numcommits} {
4379 set r1 [expr {$numcommits - 1}]
4381 return [list $r0 $r1]
4384 proc layoutmore {} {
4385 global commitidx viewcomplete curview
4386 global numcommits pending_select curview
4387 global lastscrollset lastscrollrows
4389 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4390 [clock clicks -milliseconds] - $lastscrollset > 500} {
4393 if {[info exists pending_select] &&
4394 [commitinview $pending_select $curview]} {
4396 selectline [rowofcommit $pending_select] 1
4401 proc doshowlocalchanges {} {
4402 global curview mainheadid
4404 if {$mainheadid eq {}} return
4405 if {[commitinview $mainheadid $curview]} {
4408 interestedin $mainheadid dodiffindex
4412 proc dohidelocalchanges {} {
4413 global nullid nullid2 lserial curview
4415 if {[commitinview $nullid $curview]} {
4416 removefakerow $nullid
4418 if {[commitinview $nullid2 $curview]} {
4419 removefakerow $nullid2
4424 # spawn off a process to do git diff-index --cached HEAD
4425 proc dodiffindex {} {
4426 global lserial showlocalchanges
4429 if {!$showlocalchanges || !$isworktree} return
4431 set fd [open "|git diff-index --cached HEAD" r]
4432 fconfigure $fd -blocking 0
4433 set i [reg_instance $fd]
4434 filerun $fd [list readdiffindex $fd $lserial $i]
4437 proc readdiffindex {fd serial inst} {
4438 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4441 if {[gets $fd line] < 0} {
4447 # we only need to see one line and we don't really care what it says...
4450 if {$serial != $lserial} {
4454 # now see if there are any local changes not checked in to the index
4455 set fd [open "|git diff-files" r]
4456 fconfigure $fd -blocking 0
4457 set i [reg_instance $fd]
4458 filerun $fd [list readdifffiles $fd $serial $i]
4460 if {$isdiff && ![commitinview $nullid2 $curview]} {
4461 # add the line for the changes in the index to the graph
4462 set hl [mc "Local changes checked in to index but not committed"]
4463 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4464 set commitdata($nullid2) "\n $hl\n"
4465 if {[commitinview $nullid $curview]} {
4466 removefakerow $nullid
4468 insertfakerow $nullid2 $mainheadid
4469 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4470 removefakerow $nullid2
4475 proc readdifffiles {fd serial inst} {
4476 global mainheadid nullid nullid2 curview
4477 global commitinfo commitdata lserial
4480 if {[gets $fd line] < 0} {
4486 # we only need to see one line and we don't really care what it says...
4489 if {$serial != $lserial} {
4493 if {$isdiff && ![commitinview $nullid $curview]} {
4494 # add the line for the local diff to the graph
4495 set hl [mc "Local uncommitted changes, not checked in to index"]
4496 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4497 set commitdata($nullid) "\n $hl\n"
4498 if {[commitinview $nullid2 $curview]} {
4503 insertfakerow $nullid $p
4504 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4505 removefakerow $nullid
4510 proc nextuse {id row} {
4511 global curview children
4513 if {[info exists children($curview,$id)]} {
4514 foreach kid $children($curview,$id) {
4515 if {![commitinview $kid $curview]} {
4518 if {[rowofcommit $kid] > $row} {
4519 return [rowofcommit $kid]
4523 if {[commitinview $id $curview]} {
4524 return [rowofcommit $id]
4529 proc prevuse {id row} {
4530 global curview children
4533 if {[info exists children($curview,$id)]} {
4534 foreach kid $children($curview,$id) {
4535 if {![commitinview $kid $curview]} break
4536 if {[rowofcommit $kid] < $row} {
4537 set ret [rowofcommit $kid]
4544 proc make_idlist {row} {
4545 global displayorder parentlist uparrowlen downarrowlen mingaplen
4546 global commitidx curview children
4548 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4552 set ra [expr {$row - $downarrowlen}]
4556 set rb [expr {$row + $uparrowlen}]
4557 if {$rb > $commitidx($curview)} {
4558 set rb $commitidx($curview)
4560 make_disporder $r [expr {$rb + 1}]
4562 for {} {$r < $ra} {incr r} {
4563 set nextid [lindex $displayorder [expr {$r + 1}]]
4564 foreach p [lindex $parentlist $r] {
4565 if {$p eq $nextid} continue
4566 set rn [nextuse $p $r]
4568 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4569 lappend ids [list [ordertoken $p] $p]
4573 for {} {$r < $row} {incr r} {
4574 set nextid [lindex $displayorder [expr {$r + 1}]]
4575 foreach p [lindex $parentlist $r] {
4576 if {$p eq $nextid} continue
4577 set rn [nextuse $p $r]
4578 if {$rn < 0 || $rn >= $row} {
4579 lappend ids [list [ordertoken $p] $p]
4583 set id [lindex $displayorder $row]
4584 lappend ids [list [ordertoken $id] $id]
4586 foreach p [lindex $parentlist $r] {
4587 set firstkid [lindex $children($curview,$p) 0]
4588 if {[rowofcommit $firstkid] < $row} {
4589 lappend ids [list [ordertoken $p] $p]
4593 set id [lindex $displayorder $r]
4595 set firstkid [lindex $children($curview,$id) 0]
4596 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4597 lappend ids [list [ordertoken $id] $id]
4602 foreach idx [lsort -unique $ids] {
4603 lappend idlist [lindex $idx 1]
4608 proc rowsequal {a b} {
4609 while {[set i [lsearch -exact $a {}]] >= 0} {
4610 set a [lreplace $a $i $i]
4612 while {[set i [lsearch -exact $b {}]] >= 0} {
4613 set b [lreplace $b $i $i]
4615 return [expr {$a eq $b}]
4618 proc makeupline {id row rend col} {
4619 global rowidlist uparrowlen downarrowlen mingaplen
4621 for {set r $rend} {1} {set r $rstart} {
4622 set rstart [prevuse $id $r]
4623 if {$rstart < 0} return
4624 if {$rstart < $row} break
4626 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4627 set rstart [expr {$rend - $uparrowlen - 1}]
4629 for {set r $rstart} {[incr r] <= $row} {} {
4630 set idlist [lindex $rowidlist $r]
4631 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4632 set col [idcol $idlist $id $col]
4633 lset rowidlist $r [linsert $idlist $col $id]
4639 proc layoutrows {row endrow} {
4640 global rowidlist rowisopt rowfinal displayorder
4641 global uparrowlen downarrowlen maxwidth mingaplen
4642 global children parentlist
4643 global commitidx viewcomplete curview
4645 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4648 set rm1 [expr {$row - 1}]
4649 foreach id [lindex $rowidlist $rm1] {
4654 set final [lindex $rowfinal $rm1]
4656 for {} {$row < $endrow} {incr row} {
4657 set rm1 [expr {$row - 1}]
4658 if {$rm1 < 0 || $idlist eq {}} {
4659 set idlist [make_idlist $row]
4662 set id [lindex $displayorder $rm1]
4663 set col [lsearch -exact $idlist $id]
4664 set idlist [lreplace $idlist $col $col]
4665 foreach p [lindex $parentlist $rm1] {
4666 if {[lsearch -exact $idlist $p] < 0} {
4667 set col [idcol $idlist $p $col]
4668 set idlist [linsert $idlist $col $p]
4669 # if not the first child, we have to insert a line going up
4670 if {$id ne [lindex $children($curview,$p) 0]} {
4671 makeupline $p $rm1 $row $col
4675 set id [lindex $displayorder $row]
4676 if {$row > $downarrowlen} {
4677 set termrow [expr {$row - $downarrowlen - 1}]
4678 foreach p [lindex $parentlist $termrow] {
4679 set i [lsearch -exact $idlist $p]
4680 if {$i < 0} continue
4681 set nr [nextuse $p $termrow]
4682 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4683 set idlist [lreplace $idlist $i $i]
4687 set col [lsearch -exact $idlist $id]
4689 set col [idcol $idlist $id]
4690 set idlist [linsert $idlist $col $id]
4691 if {$children($curview,$id) ne {}} {
4692 makeupline $id $rm1 $row $col
4695 set r [expr {$row + $uparrowlen - 1}]
4696 if {$r < $commitidx($curview)} {
4698 foreach p [lindex $parentlist $r] {
4699 if {[lsearch -exact $idlist $p] >= 0} continue
4700 set fk [lindex $children($curview,$p) 0]
4701 if {[rowofcommit $fk] < $row} {
4702 set x [idcol $idlist $p $x]
4703 set idlist [linsert $idlist $x $p]
4706 if {[incr r] < $commitidx($curview)} {
4707 set p [lindex $displayorder $r]
4708 if {[lsearch -exact $idlist $p] < 0} {
4709 set fk [lindex $children($curview,$p) 0]
4710 if {$fk ne {} && [rowofcommit $fk] < $row} {
4711 set x [idcol $idlist $p $x]
4712 set idlist [linsert $idlist $x $p]
4718 if {$final && !$viewcomplete($curview) &&
4719 $row + $uparrowlen + $mingaplen + $downarrowlen
4720 >= $commitidx($curview)} {
4723 set l [llength $rowidlist]
4725 lappend rowidlist $idlist
4727 lappend rowfinal $final
4728 } elseif {$row < $l} {
4729 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4730 lset rowidlist $row $idlist
4733 lset rowfinal $row $final
4735 set pad [ntimes [expr {$row - $l}] {}]
4736 set rowidlist [concat $rowidlist $pad]
4737 lappend rowidlist $idlist
4738 set rowfinal [concat $rowfinal $pad]
4739 lappend rowfinal $final
4740 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4746 proc changedrow {row} {
4747 global displayorder iddrawn rowisopt need_redisplay
4749 set l [llength $rowisopt]
4751 lset rowisopt $row 0
4752 if {$row + 1 < $l} {
4753 lset rowisopt [expr {$row + 1}] 0
4754 if {$row + 2 < $l} {
4755 lset rowisopt [expr {$row + 2}] 0
4759 set id [lindex $displayorder $row]
4760 if {[info exists iddrawn($id)]} {
4761 set need_redisplay 1
4765 proc insert_pad {row col npad} {
4768 set pad [ntimes $npad {}]
4769 set idlist [lindex $rowidlist $row]
4770 set bef [lrange $idlist 0 [expr {$col - 1}]]
4771 set aft [lrange $idlist $col end]
4772 set i [lsearch -exact $aft {}]
4774 set aft [lreplace $aft $i $i]
4776 lset rowidlist $row [concat $bef $pad $aft]
4780 proc optimize_rows {row col endrow} {
4781 global rowidlist rowisopt displayorder curview children
4786 for {} {$row < $endrow} {incr row; set col 0} {
4787 if {[lindex $rowisopt $row]} continue
4789 set y0 [expr {$row - 1}]
4790 set ym [expr {$row - 2}]
4791 set idlist [lindex $rowidlist $row]
4792 set previdlist [lindex $rowidlist $y0]
4793 if {$idlist eq {} || $previdlist eq {}} continue
4795 set pprevidlist [lindex $rowidlist $ym]
4796 if {$pprevidlist eq {}} continue
4802 for {} {$col < [llength $idlist]} {incr col} {
4803 set id [lindex $idlist $col]
4804 if {[lindex $previdlist $col] eq $id} continue
4809 set x0 [lsearch -exact $previdlist $id]
4810 if {$x0 < 0} continue
4811 set z [expr {$x0 - $col}]
4815 set xm [lsearch -exact $pprevidlist $id]
4817 set z0 [expr {$xm - $x0}]
4821 # if row y0 is the first child of $id then it's not an arrow
4822 if {[lindex $children($curview,$id) 0] ne
4823 [lindex $displayorder $y0]} {
4827 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4828 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4831 # Looking at lines from this row to the previous row,
4832 # make them go straight up if they end in an arrow on
4833 # the previous row; otherwise make them go straight up
4835 if {$z < -1 || ($z < 0 && $isarrow)} {
4836 # Line currently goes left too much;
4837 # insert pads in the previous row, then optimize it
4838 set npad [expr {-1 - $z + $isarrow}]
4839 insert_pad $y0 $x0 $npad
4841 optimize_rows $y0 $x0 $row
4843 set previdlist [lindex $rowidlist $y0]
4844 set x0 [lsearch -exact $previdlist $id]
4845 set z [expr {$x0 - $col}]
4847 set pprevidlist [lindex $rowidlist $ym]
4848 set xm [lsearch -exact $pprevidlist $id]
4849 set z0 [expr {$xm - $x0}]
4851 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4852 # Line currently goes right too much;
4853 # insert pads in this line
4854 set npad [expr {$z - 1 + $isarrow}]
4855 insert_pad $row $col $npad
4856 set idlist [lindex $rowidlist $row]
4858 set z [expr {$x0 - $col}]
4861 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4862 # this line links to its first child on row $row-2
4863 set id [lindex $displayorder $ym]
4864 set xc [lsearch -exact $pprevidlist $id]
4866 set z0 [expr {$xc - $x0}]
4869 # avoid lines jigging left then immediately right
4870 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4871 insert_pad $y0 $x0 1
4873 optimize_rows $y0 $x0 $row
4874 set previdlist [lindex $rowidlist $y0]
4878 # Find the first column that doesn't have a line going right
4879 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4880 set id [lindex $idlist $col]
4881 if {$id eq {}} break
4882 set x0 [lsearch -exact $previdlist $id]
4884 # check if this is the link to the first child
4885 set kid [lindex $displayorder $y0]
4886 if {[lindex $children($curview,$id) 0] eq $kid} {
4887 # it is, work out offset to child
4888 set x0 [lsearch -exact $previdlist $kid]
4891 if {$x0 <= $col} break
4893 # Insert a pad at that column as long as it has a line and
4894 # isn't the last column
4895 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4896 set idlist [linsert $idlist $col {}]
4897 lset rowidlist $row $idlist
4905 global canvx0 linespc
4906 return [expr {$canvx0 + $col * $linespc}]
4910 global canvy0 linespc
4911 return [expr {$canvy0 + $row * $linespc}]
4914 proc linewidth {id} {
4915 global thickerline lthickness
4918 if {[info exists thickerline] && $id eq $thickerline} {
4919 set wid [expr {2 * $lthickness}]
4924 proc rowranges {id} {
4925 global curview children uparrowlen downarrowlen
4928 set kids $children($curview,$id)
4934 foreach child $kids {
4935 if {![commitinview $child $curview]} break
4936 set row [rowofcommit $child]
4937 if {![info exists prev]} {
4938 lappend ret [expr {$row + 1}]
4940 if {$row <= $prevrow} {
4941 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4943 # see if the line extends the whole way from prevrow to row
4944 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4945 [lsearch -exact [lindex $rowidlist \
4946 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4947 # it doesn't, see where it ends
4948 set r [expr {$prevrow + $downarrowlen}]
4949 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4950 while {[incr r -1] > $prevrow &&
4951 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4953 while {[incr r] <= $row &&
4954 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4958 # see where it starts up again
4959 set r [expr {$row - $uparrowlen}]
4960 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4961 while {[incr r] < $row &&
4962 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4964 while {[incr r -1] >= $prevrow &&
4965 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4971 if {$child eq $id} {
4980 proc drawlineseg {id row endrow arrowlow} {
4981 global rowidlist displayorder iddrawn linesegs
4982 global canv colormap linespc curview maxlinelen parentlist
4984 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4985 set le [expr {$row + 1}]
4988 set c [lsearch -exact [lindex $rowidlist $le] $id]
4994 set x [lindex $displayorder $le]
4999 if {[info exists iddrawn($x)] || $le == $endrow} {
5000 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5016 if {[info exists linesegs($id)]} {
5017 set lines $linesegs($id)
5019 set r0 [lindex $li 0]
5021 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5031 set li [lindex $lines [expr {$i-1}]]
5032 set r1 [lindex $li 1]
5033 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5038 set x [lindex $cols [expr {$le - $row}]]
5039 set xp [lindex $cols [expr {$le - 1 - $row}]]
5040 set dir [expr {$xp - $x}]
5042 set ith [lindex $lines $i 2]
5043 set coords [$canv coords $ith]
5044 set ah [$canv itemcget $ith -arrow]
5045 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5046 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5047 if {$x2 ne {} && $x - $x2 == $dir} {
5048 set coords [lrange $coords 0 end-2]
5051 set coords [list [xc $le $x] [yc $le]]
5054 set itl [lindex $lines [expr {$i-1}] 2]
5055 set al [$canv itemcget $itl -arrow]
5056 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5057 } elseif {$arrowlow} {
5058 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5059 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5063 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5064 for {set y $le} {[incr y -1] > $row} {} {
5066 set xp [lindex $cols [expr {$y - 1 - $row}]]
5067 set ndir [expr {$xp - $x}]
5068 if {$dir != $ndir || $xp < 0} {
5069 lappend coords [xc $y $x] [yc $y]
5075 # join parent line to first child
5076 set ch [lindex $displayorder $row]
5077 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5079 puts "oops: drawlineseg: child $ch not on row $row"
5080 } elseif {$xc != $x} {
5081 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5082 set d [expr {int(0.5 * $linespc)}]
5085 set x2 [expr {$x1 - $d}]
5087 set x2 [expr {$x1 + $d}]
5090 set y1 [expr {$y2 + $d}]
5091 lappend coords $x1 $y1 $x2 $y2
5092 } elseif {$xc < $x - 1} {
5093 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5094 } elseif {$xc > $x + 1} {
5095 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5099 lappend coords [xc $row $x] [yc $row]
5101 set xn [xc $row $xp]
5103 lappend coords $xn $yn
5107 set t [$canv create line $coords -width [linewidth $id] \
5108 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5111 set lines [linsert $lines $i [list $row $le $t]]
5113 $canv coords $ith $coords
5114 if {$arrow ne $ah} {
5115 $canv itemconf $ith -arrow $arrow
5117 lset lines $i 0 $row
5120 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5121 set ndir [expr {$xo - $xp}]
5122 set clow [$canv coords $itl]
5123 if {$dir == $ndir} {
5124 set clow [lrange $clow 2 end]
5126 set coords [concat $coords $clow]
5128 lset lines [expr {$i-1}] 1 $le
5130 # coalesce two pieces
5132 set b [lindex $lines [expr {$i-1}] 0]
5133 set e [lindex $lines $i 1]
5134 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5136 $canv coords $itl $coords
5137 if {$arrow ne $al} {
5138 $canv itemconf $itl -arrow $arrow
5142 set linesegs($id) $lines
5146 proc drawparentlinks {id row} {
5147 global rowidlist canv colormap curview parentlist
5148 global idpos linespc
5150 set rowids [lindex $rowidlist $row]
5151 set col [lsearch -exact $rowids $id]
5152 if {$col < 0} return
5153 set olds [lindex $parentlist $row]
5154 set row2 [expr {$row + 1}]
5155 set x [xc $row $col]
5158 set d [expr {int(0.5 * $linespc)}]
5159 set ymid [expr {$y + $d}]
5160 set ids [lindex $rowidlist $row2]
5161 # rmx = right-most X coord used
5164 set i [lsearch -exact $ids $p]
5166 puts "oops, parent $p of $id not in list"
5169 set x2 [xc $row2 $i]
5173 set j [lsearch -exact $rowids $p]
5175 # drawlineseg will do this one for us
5179 # should handle duplicated parents here...
5180 set coords [list $x $y]
5182 # if attaching to a vertical segment, draw a smaller
5183 # slant for visual distinctness
5186 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5188 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5190 } elseif {$i < $col && $i < $j} {
5191 # segment slants towards us already
5192 lappend coords [xc $row $j] $y
5194 if {$i < $col - 1} {
5195 lappend coords [expr {$x2 + $linespc}] $y
5196 } elseif {$i > $col + 1} {
5197 lappend coords [expr {$x2 - $linespc}] $y
5199 lappend coords $x2 $y2
5202 lappend coords $x2 $y2
5204 set t [$canv create line $coords -width [linewidth $p] \
5205 -fill $colormap($p) -tags lines.$p]
5209 if {$rmx > [lindex $idpos($id) 1]} {
5210 lset idpos($id) 1 $rmx
5215 proc drawlines {id} {
5218 $canv itemconf lines.$id -width [linewidth $id]
5221 proc drawcmittext {id row col} {
5222 global linespc canv canv2 canv3 fgcolor curview
5223 global cmitlisted commitinfo rowidlist parentlist
5224 global rowtextx idpos idtags idheads idotherrefs
5225 global linehtag linentag linedtag selectedline
5226 global canvxmax boldrows boldnamerows fgcolor
5227 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5229 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5230 set listed $cmitlisted($curview,$id)
5231 if {$id eq $nullid} {
5233 } elseif {$id eq $nullid2} {
5235 } elseif {$id eq $mainheadid} {
5238 set ofill [lindex $circlecolors $listed]
5240 set x [xc $row $col]
5242 set orad [expr {$linespc / 3}]
5244 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5245 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5246 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5247 } elseif {$listed == 3} {
5248 # triangle pointing left for left-side commits
5249 set t [$canv create polygon \
5250 [expr {$x - $orad}] $y \
5251 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5252 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5253 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5255 # triangle pointing right for right-side commits
5256 set t [$canv create polygon \
5257 [expr {$x + $orad - 1}] $y \
5258 [expr {$x - $orad}] [expr {$y - $orad}] \
5259 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5260 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5262 set circleitem($row) $t
5264 $canv bind $t <1> {selcanvline {} %x %y}
5265 set rmx [llength [lindex $rowidlist $row]]
5266 set olds [lindex $parentlist $row]
5268 set nextids [lindex $rowidlist [expr {$row + 1}]]
5270 set i [lsearch -exact $nextids $p]
5276 set xt [xc $row $rmx]
5277 set rowtextx($row) $xt
5278 set idpos($id) [list $x $xt $y]
5279 if {[info exists idtags($id)] || [info exists idheads($id)]
5280 || [info exists idotherrefs($id)]} {
5281 set xt [drawtags $id $x $xt $y]
5283 set headline [lindex $commitinfo($id) 0]
5284 set name [lindex $commitinfo($id) 1]
5285 set date [lindex $commitinfo($id) 2]
5286 set date [formatdate $date]
5289 set isbold [ishighlighted $id]
5291 lappend boldrows $row
5292 set font mainfontbold
5294 lappend boldnamerows $row
5295 set nfont mainfontbold
5298 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
5299 -text $headline -font $font -tags text]
5300 $canv bind $linehtag($row) $ctxbut "rowmenu %X %Y $id"
5301 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5302 -text $name -font $nfont -tags text]
5303 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5304 -text $date -font mainfont -tags text]
5305 if {$selectedline == $row} {
5308 set xr [expr {$xt + [font measure $font $headline]}]
5309 if {$xr > $canvxmax} {
5315 proc drawcmitrow {row} {
5316 global displayorder rowidlist nrows_drawn
5317 global iddrawn markingmatches
5318 global commitinfo numcommits
5319 global filehighlight fhighlights findpattern nhighlights
5320 global hlview vhighlights
5321 global highlight_related rhighlights
5323 if {$row >= $numcommits} return
5325 set id [lindex $displayorder $row]
5326 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5327 askvhighlight $row $id
5329 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5330 askfilehighlight $row $id
5332 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5333 askfindhighlight $row $id
5335 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5336 askrelhighlight $row $id
5338 if {![info exists iddrawn($id)]} {
5339 set col [lsearch -exact [lindex $rowidlist $row] $id]
5341 puts "oops, row $row id $id not in list"
5344 if {![info exists commitinfo($id)]} {
5348 drawcmittext $id $row $col
5352 if {$markingmatches} {
5353 markrowmatches $row $id
5357 proc drawcommits {row {endrow {}}} {
5358 global numcommits iddrawn displayorder curview need_redisplay
5359 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5364 if {$endrow eq {}} {
5367 if {$endrow >= $numcommits} {
5368 set endrow [expr {$numcommits - 1}]
5371 set rl1 [expr {$row - $downarrowlen - 3}]
5375 set ro1 [expr {$row - 3}]
5379 set r2 [expr {$endrow + $uparrowlen + 3}]
5380 if {$r2 > $numcommits} {
5383 for {set r $rl1} {$r < $r2} {incr r} {
5384 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5388 set rl1 [expr {$r + 1}]
5394 optimize_rows $ro1 0 $r2
5395 if {$need_redisplay || $nrows_drawn > 2000} {
5400 # make the lines join to already-drawn rows either side
5401 set r [expr {$row - 1}]
5402 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5405 set er [expr {$endrow + 1}]
5406 if {$er >= $numcommits ||
5407 ![info exists iddrawn([lindex $displayorder $er])]} {
5410 for {} {$r <= $er} {incr r} {
5411 set id [lindex $displayorder $r]
5412 set wasdrawn [info exists iddrawn($id)]
5414 if {$r == $er} break
5415 set nextid [lindex $displayorder [expr {$r + 1}]]
5416 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5417 drawparentlinks $id $r
5419 set rowids [lindex $rowidlist $r]
5420 foreach lid $rowids {
5421 if {$lid eq {}} continue
5422 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5424 # see if this is the first child of any of its parents
5425 foreach p [lindex $parentlist $r] {
5426 if {[lsearch -exact $rowids $p] < 0} {
5427 # make this line extend up to the child
5428 set lineend($p) [drawlineseg $p $r $er 0]
5432 set lineend($lid) [drawlineseg $lid $r $er 1]
5438 proc undolayout {row} {
5439 global uparrowlen mingaplen downarrowlen
5440 global rowidlist rowisopt rowfinal need_redisplay
5442 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5446 if {[llength $rowidlist] > $r} {
5448 set rowidlist [lrange $rowidlist 0 $r]
5449 set rowfinal [lrange $rowfinal 0 $r]
5450 set rowisopt [lrange $rowisopt 0 $r]
5451 set need_redisplay 1
5456 proc drawvisible {} {
5457 global canv linespc curview vrowmod selectedline targetrow targetid
5458 global need_redisplay cscroll numcommits
5460 set fs [$canv yview]
5461 set ymax [lindex [$canv cget -scrollregion] 3]
5462 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5463 set f0 [lindex $fs 0]
5464 set f1 [lindex $fs 1]
5465 set y0 [expr {int($f0 * $ymax)}]
5466 set y1 [expr {int($f1 * $ymax)}]
5468 if {[info exists targetid]} {
5469 if {[commitinview $targetid $curview]} {
5470 set r [rowofcommit $targetid]
5471 if {$r != $targetrow} {
5472 # Fix up the scrollregion and change the scrolling position
5473 # now that our target row has moved.
5474 set diff [expr {($r - $targetrow) * $linespc}]
5477 set ymax [lindex [$canv cget -scrollregion] 3]
5480 set f0 [expr {$y0 / $ymax}]
5481 set f1 [expr {$y1 / $ymax}]
5482 allcanvs yview moveto $f0
5483 $cscroll set $f0 $f1
5484 set need_redisplay 1
5491 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5492 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5493 if {$endrow >= $vrowmod($curview)} {
5494 update_arcrows $curview
5496 if {$selectedline ne {} &&
5497 $row <= $selectedline && $selectedline <= $endrow} {
5498 set targetrow $selectedline
5499 } elseif {[info exists targetid]} {
5500 set targetrow [expr {int(($row + $endrow) / 2)}]
5502 if {[info exists targetrow]} {
5503 if {$targetrow >= $numcommits} {
5504 set targetrow [expr {$numcommits - 1}]
5506 set targetid [commitonrow $targetrow]
5508 drawcommits $row $endrow
5511 proc clear_display {} {
5512 global iddrawn linesegs need_redisplay nrows_drawn
5513 global vhighlights fhighlights nhighlights rhighlights
5514 global linehtag linentag linedtag boldrows boldnamerows
5517 catch {unset iddrawn}
5518 catch {unset linesegs}
5519 catch {unset linehtag}
5520 catch {unset linentag}
5521 catch {unset linedtag}
5524 catch {unset vhighlights}
5525 catch {unset fhighlights}
5526 catch {unset nhighlights}
5527 catch {unset rhighlights}
5528 set need_redisplay 0
5532 proc findcrossings {id} {
5533 global rowidlist parentlist numcommits displayorder
5537 foreach {s e} [rowranges $id] {
5538 if {$e >= $numcommits} {
5539 set e [expr {$numcommits - 1}]
5541 if {$e <= $s} continue
5542 for {set row $e} {[incr row -1] >= $s} {} {
5543 set x [lsearch -exact [lindex $rowidlist $row] $id]
5545 set olds [lindex $parentlist $row]
5546 set kid [lindex $displayorder $row]
5547 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5548 if {$kidx < 0} continue
5549 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5551 set px [lsearch -exact $nextrow $p]
5552 if {$px < 0} continue
5553 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5554 if {[lsearch -exact $ccross $p] >= 0} continue
5555 if {$x == $px + ($kidx < $px? -1: 1)} {
5557 } elseif {[lsearch -exact $cross $p] < 0} {
5564 return [concat $ccross {{}} $cross]
5567 proc assigncolor {id} {
5568 global colormap colors nextcolor
5569 global parents children children curview
5571 if {[info exists colormap($id)]} return
5572 set ncolors [llength $colors]
5573 if {[info exists children($curview,$id)]} {
5574 set kids $children($curview,$id)
5578 if {[llength $kids] == 1} {
5579 set child [lindex $kids 0]
5580 if {[info exists colormap($child)]
5581 && [llength $parents($curview,$child)] == 1} {
5582 set colormap($id) $colormap($child)
5588 foreach x [findcrossings $id] {
5590 # delimiter between corner crossings and other crossings
5591 if {[llength $badcolors] >= $ncolors - 1} break
5592 set origbad $badcolors
5594 if {[info exists colormap($x)]
5595 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5596 lappend badcolors $colormap($x)
5599 if {[llength $badcolors] >= $ncolors} {
5600 set badcolors $origbad
5602 set origbad $badcolors
5603 if {[llength $badcolors] < $ncolors - 1} {
5604 foreach child $kids {
5605 if {[info exists colormap($child)]
5606 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5607 lappend badcolors $colormap($child)
5609 foreach p $parents($curview,$child) {
5610 if {[info exists colormap($p)]
5611 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5612 lappend badcolors $colormap($p)
5616 if {[llength $badcolors] >= $ncolors} {
5617 set badcolors $origbad
5620 for {set i 0} {$i <= $ncolors} {incr i} {
5621 set c [lindex $colors $nextcolor]
5622 if {[incr nextcolor] >= $ncolors} {
5625 if {[lsearch -exact $badcolors $c]} break
5627 set colormap($id) $c
5630 proc bindline {t id} {
5633 $canv bind $t <Enter> "lineenter %x %y $id"
5634 $canv bind $t <Motion> "linemotion %x %y $id"
5635 $canv bind $t <Leave> "lineleave $id"
5636 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5639 proc drawtags {id x xt y1} {
5640 global idtags idheads idotherrefs mainhead
5641 global linespc lthickness
5642 global canv rowtextx curview fgcolor bgcolor ctxbut
5647 if {[info exists idtags($id)]} {
5648 set marks $idtags($id)
5649 set ntags [llength $marks]
5651 if {[info exists idheads($id)]} {
5652 set marks [concat $marks $idheads($id)]
5653 set nheads [llength $idheads($id)]
5655 if {[info exists idotherrefs($id)]} {
5656 set marks [concat $marks $idotherrefs($id)]
5662 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5663 set yt [expr {$y1 - 0.5 * $linespc}]
5664 set yb [expr {$yt + $linespc - 1}]
5668 foreach tag $marks {
5670 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5671 set wid [font measure mainfontbold $tag]
5673 set wid [font measure mainfont $tag]
5677 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5679 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5680 -width $lthickness -fill black -tags tag.$id]
5682 foreach tag $marks x $xvals wid $wvals {
5683 set xl [expr {$x + $delta}]
5684 set xr [expr {$x + $delta + $wid + $lthickness}]
5686 if {[incr ntags -1] >= 0} {
5688 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5689 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5690 -width 1 -outline black -fill yellow -tags tag.$id]
5691 $canv bind $t <1> [list showtag $tag 1]
5692 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5694 # draw a head or other ref
5695 if {[incr nheads -1] >= 0} {
5697 if {$tag eq $mainhead} {
5698 set font mainfontbold
5703 set xl [expr {$xl - $delta/2}]
5704 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5705 -width 1 -outline black -fill $col -tags tag.$id
5706 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5707 set rwid [font measure mainfont $remoteprefix]
5708 set xi [expr {$x + 1}]
5709 set yti [expr {$yt + 1}]
5710 set xri [expr {$x + $rwid}]
5711 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5712 -width 0 -fill "#ffddaa" -tags tag.$id
5715 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5716 -font $font -tags [list tag.$id text]]
5718 $canv bind $t <1> [list showtag $tag 1]
5719 } elseif {$nheads >= 0} {
5720 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
5726 proc xcoord {i level ln} {
5727 global canvx0 xspc1 xspc2
5729 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5730 if {$i > 0 && $i == $level} {
5731 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5732 } elseif {$i > $level} {
5733 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5738 proc show_status {msg} {
5742 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5743 -tags text -fill $fgcolor
5746 # Don't change the text pane cursor if it is currently the hand cursor,
5747 # showing that we are over a sha1 ID link.
5748 proc settextcursor {c} {
5749 global ctext curtextcursor
5751 if {[$ctext cget -cursor] == $curtextcursor} {
5752 $ctext config -cursor $c
5754 set curtextcursor $c
5757 proc nowbusy {what {name {}}} {
5758 global isbusy busyname statusw
5760 if {[array names isbusy] eq {}} {
5761 . config -cursor watch
5765 set busyname($what) $name
5767 $statusw conf -text $name
5771 proc notbusy {what} {
5772 global isbusy maincursor textcursor busyname statusw
5776 if {$busyname($what) ne {} &&
5777 [$statusw cget -text] eq $busyname($what)} {
5778 $statusw conf -text {}
5781 if {[array names isbusy] eq {}} {
5782 . config -cursor $maincursor
5783 settextcursor $textcursor
5787 proc findmatches {f} {
5788 global findtype findstring
5789 if {$findtype == [mc "Regexp"]} {
5790 set matches [regexp -indices -all -inline $findstring $f]
5793 if {$findtype == [mc "IgnCase"]} {
5794 set f [string tolower $f]
5795 set fs [string tolower $fs]
5799 set l [string length $fs]
5800 while {[set j [string first $fs $f $i]] >= 0} {
5801 lappend matches [list $j [expr {$j+$l-1}]]
5802 set i [expr {$j + $l}]
5808 proc dofind {{dirn 1} {wrap 1}} {
5809 global findstring findstartline findcurline selectedline numcommits
5810 global gdttype filehighlight fh_serial find_dirn findallowwrap
5812 if {[info exists find_dirn]} {
5813 if {$find_dirn == $dirn} return
5817 if {$findstring eq {} || $numcommits == 0} return
5818 if {$selectedline eq {}} {
5819 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5821 set findstartline $selectedline
5823 set findcurline $findstartline
5824 nowbusy finding [mc "Searching"]
5825 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5826 after cancel do_file_hl $fh_serial
5827 do_file_hl $fh_serial
5830 set findallowwrap $wrap
5834 proc stopfinding {} {
5835 global find_dirn findcurline fprogcoord
5837 if {[info exists find_dirn]} {
5848 global commitdata commitinfo numcommits findpattern findloc
5849 global findstartline findcurline findallowwrap
5850 global find_dirn gdttype fhighlights fprogcoord
5851 global curview varcorder vrownum varccommits vrowmod
5853 if {![info exists find_dirn]} {
5856 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5859 if {$find_dirn > 0} {
5861 if {$l >= $numcommits} {
5864 if {$l <= $findstartline} {
5865 set lim [expr {$findstartline + 1}]
5868 set moretodo $findallowwrap
5875 if {$l >= $findstartline} {
5876 set lim [expr {$findstartline - 1}]
5879 set moretodo $findallowwrap
5882 set n [expr {($lim - $l) * $find_dirn}]
5887 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5888 update_arcrows $curview
5892 set ai [bsearch $vrownum($curview) $l]
5893 set a [lindex $varcorder($curview) $ai]
5894 set arow [lindex $vrownum($curview) $ai]
5895 set ids [lindex $varccommits($curview,$a)]
5896 set arowend [expr {$arow + [llength $ids]}]
5897 if {$gdttype eq [mc "containing:"]} {
5898 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5899 if {$l < $arow || $l >= $arowend} {
5901 set a [lindex $varcorder($curview) $ai]
5902 set arow [lindex $vrownum($curview) $ai]
5903 set ids [lindex $varccommits($curview,$a)]
5904 set arowend [expr {$arow + [llength $ids]}]
5906 set id [lindex $ids [expr {$l - $arow}]]
5907 # shouldn't happen unless git log doesn't give all the commits...
5908 if {![info exists commitdata($id)] ||
5909 ![doesmatch $commitdata($id)]} {
5912 if {![info exists commitinfo($id)]} {
5915 set info $commitinfo($id)
5916 foreach f $info ty $fldtypes {
5917 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5926 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5927 if {$l < $arow || $l >= $arowend} {
5929 set a [lindex $varcorder($curview) $ai]
5930 set arow [lindex $vrownum($curview) $ai]
5931 set ids [lindex $varccommits($curview,$a)]
5932 set arowend [expr {$arow + [llength $ids]}]
5934 set id [lindex $ids [expr {$l - $arow}]]
5935 if {![info exists fhighlights($id)]} {
5936 # this sets fhighlights($id) to -1
5937 askfilehighlight $l $id
5939 if {$fhighlights($id) > 0} {
5943 if {$fhighlights($id) < 0} {
5946 set findcurline [expr {$l - $find_dirn}]
5951 if {$found || ($domore && !$moretodo)} {
5967 set findcurline [expr {$l - $find_dirn}]
5969 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5973 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5978 proc findselectline {l} {
5979 global findloc commentend ctext findcurline markingmatches gdttype
5981 set markingmatches 1
5984 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5985 # highlight the matches in the comments
5986 set f [$ctext get 1.0 $commentend]
5987 set matches [findmatches $f]
5988 foreach match $matches {
5989 set start [lindex $match 0]
5990 set end [expr {[lindex $match 1] + 1}]
5991 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5997 # mark the bits of a headline or author that match a find string
5998 proc markmatches {canv l str tag matches font row} {
6001 set bbox [$canv bbox $tag]
6002 set x0 [lindex $bbox 0]
6003 set y0 [lindex $bbox 1]
6004 set y1 [lindex $bbox 3]
6005 foreach match $matches {
6006 set start [lindex $match 0]
6007 set end [lindex $match 1]
6008 if {$start > $end} continue
6009 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6010 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6011 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6012 [expr {$x0+$xlen+2}] $y1 \
6013 -outline {} -tags [list match$l matches] -fill yellow]
6015 if {$row == $selectedline} {
6016 $canv raise $t secsel
6021 proc unmarkmatches {} {
6022 global markingmatches
6024 allcanvs delete matches
6025 set markingmatches 0
6029 proc selcanvline {w x y} {
6030 global canv canvy0 ctext linespc
6032 set ymax [lindex [$canv cget -scrollregion] 3]
6033 if {$ymax == {}} return
6034 set yfrac [lindex [$canv yview] 0]
6035 set y [expr {$y + $yfrac * $ymax}]
6036 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6041 set xmax [lindex [$canv cget -scrollregion] 2]
6042 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6043 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6049 proc commit_descriptor {p} {
6051 if {![info exists commitinfo($p)]} {
6055 if {[llength $commitinfo($p)] > 1} {
6056 set l [lindex $commitinfo($p) 0]
6061 # append some text to the ctext widget, and make any SHA1 ID
6062 # that we know about be a clickable link.
6063 proc appendwithlinks {text tags} {
6064 global ctext linknum curview
6066 set start [$ctext index "end - 1c"]
6067 $ctext insert end $text $tags
6068 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6072 set linkid [string range $text $s $e]
6074 $ctext tag delete link$linknum
6075 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6076 setlink $linkid link$linknum
6081 proc setlink {id lk} {
6082 global curview ctext pendinglinks
6085 if {[string length $id] < 40} {
6086 set matches [longid $id]
6087 if {[llength $matches] > 0} {
6088 if {[llength $matches] > 1} return
6090 set id [lindex $matches 0]
6093 set known [commitinview $id $curview]
6096 $ctext tag conf $lk -foreground blue -underline 1
6097 $ctext tag bind $lk <1> [list selbyid $id]
6098 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6099 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6101 lappend pendinglinks($id) $lk
6102 interestedin $id {makelink %P}
6106 proc makelink {id} {
6109 if {![info exists pendinglinks($id)]} return
6110 foreach lk $pendinglinks($id) {
6113 unset pendinglinks($id)
6116 proc linkcursor {w inc} {
6117 global linkentercount curtextcursor
6119 if {[incr linkentercount $inc] > 0} {
6120 $w configure -cursor hand2
6122 $w configure -cursor $curtextcursor
6123 if {$linkentercount < 0} {
6124 set linkentercount 0
6129 proc viewnextline {dir} {
6133 set ymax [lindex [$canv cget -scrollregion] 3]
6134 set wnow [$canv yview]
6135 set wtop [expr {[lindex $wnow 0] * $ymax}]
6136 set newtop [expr {$wtop + $dir * $linespc}]
6139 } elseif {$newtop > $ymax} {
6142 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6145 # add a list of tag or branch names at position pos
6146 # returns the number of names inserted
6147 proc appendrefs {pos ids var} {
6148 global ctext linknum curview $var maxrefs
6150 if {[catch {$ctext index $pos}]} {
6153 $ctext conf -state normal
6154 $ctext delete $pos "$pos lineend"
6157 foreach tag [set $var\($id\)] {
6158 lappend tags [list $tag $id]
6161 if {[llength $tags] > $maxrefs} {
6162 $ctext insert $pos "many ([llength $tags])"
6164 set tags [lsort -index 0 -decreasing $tags]
6167 set id [lindex $ti 1]
6170 $ctext tag delete $lk
6171 $ctext insert $pos $sep
6172 $ctext insert $pos [lindex $ti 0] $lk
6177 $ctext conf -state disabled
6178 return [llength $tags]
6181 # called when we have finished computing the nearby tags
6182 proc dispneartags {delay} {
6183 global selectedline currentid showneartags tagphase
6185 if {$selectedline eq {} || !$showneartags} return
6186 after cancel dispnexttag
6188 after 200 dispnexttag
6191 after idle dispnexttag
6196 proc dispnexttag {} {
6197 global selectedline currentid showneartags tagphase ctext
6199 if {$selectedline eq {} || !$showneartags} return
6200 switch -- $tagphase {
6202 set dtags [desctags $currentid]
6204 appendrefs precedes $dtags idtags
6208 set atags [anctags $currentid]
6210 appendrefs follows $atags idtags
6214 set dheads [descheads $currentid]
6215 if {$dheads ne {}} {
6216 if {[appendrefs branch $dheads idheads] > 1
6217 && [$ctext get "branch -3c"] eq "h"} {
6218 # turn "Branch" into "Branches"
6219 $ctext conf -state normal
6220 $ctext insert "branch -2c" "es"
6221 $ctext conf -state disabled
6226 if {[incr tagphase] <= 2} {
6227 after idle dispnexttag
6231 proc make_secsel {l} {
6232 global linehtag linentag linedtag canv canv2 canv3
6234 if {![info exists linehtag($l)]} return
6236 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
6237 -tags secsel -fill [$canv cget -selectbackground]]
6239 $canv2 delete secsel
6240 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
6241 -tags secsel -fill [$canv2 cget -selectbackground]]
6243 $canv3 delete secsel
6244 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
6245 -tags secsel -fill [$canv3 cget -selectbackground]]
6249 proc selectline {l isnew {desired_loc {}}} {
6250 global canv ctext commitinfo selectedline
6251 global canvy0 linespc parents children curview
6252 global currentid sha1entry
6253 global commentend idtags linknum
6254 global mergemax numcommits pending_select
6255 global cmitmode showneartags allcommits
6256 global targetrow targetid lastscrollrows
6257 global autoselect jump_to_here
6259 catch {unset pending_select}
6264 if {$l < 0 || $l >= $numcommits} return
6265 set id [commitonrow $l]
6270 if {$lastscrollrows < $numcommits} {
6274 set y [expr {$canvy0 + $l * $linespc}]
6275 set ymax [lindex [$canv cget -scrollregion] 3]
6276 set ytop [expr {$y - $linespc - 1}]
6277 set ybot [expr {$y + $linespc + 1}]
6278 set wnow [$canv yview]
6279 set wtop [expr {[lindex $wnow 0] * $ymax}]
6280 set wbot [expr {[lindex $wnow 1] * $ymax}]
6281 set wh [expr {$wbot - $wtop}]
6283 if {$ytop < $wtop} {
6284 if {$ybot < $wtop} {
6285 set newtop [expr {$y - $wh / 2.0}]
6288 if {$newtop > $wtop - $linespc} {
6289 set newtop [expr {$wtop - $linespc}]
6292 } elseif {$ybot > $wbot} {
6293 if {$ytop > $wbot} {
6294 set newtop [expr {$y - $wh / 2.0}]
6296 set newtop [expr {$ybot - $wh}]
6297 if {$newtop < $wtop + $linespc} {
6298 set newtop [expr {$wtop + $linespc}]
6302 if {$newtop != $wtop} {
6306 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6313 addtohistory [list selbyid $id]
6316 $sha1entry delete 0 end
6317 $sha1entry insert 0 $id
6319 $sha1entry selection from 0
6320 $sha1entry selection to end
6324 $ctext conf -state normal
6327 if {![info exists commitinfo($id)]} {
6330 set info $commitinfo($id)
6331 set date [formatdate [lindex $info 2]]
6332 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6333 set date [formatdate [lindex $info 4]]
6334 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6335 if {[info exists idtags($id)]} {
6336 $ctext insert end [mc "Tags:"]
6337 foreach tag $idtags($id) {
6338 $ctext insert end " $tag"
6340 $ctext insert end "\n"
6344 set olds $parents($curview,$id)
6345 if {[llength $olds] > 1} {
6348 if {$np >= $mergemax} {
6353 $ctext insert end "[mc "Parent"]: " $tag
6354 appendwithlinks [commit_descriptor $p] {}
6359 append headers "[mc "Parent"]: [commit_descriptor $p]"
6363 foreach c $children($curview,$id) {
6364 append headers "[mc "Child"]: [commit_descriptor $c]"
6367 # make anything that looks like a SHA1 ID be a clickable link
6368 appendwithlinks $headers {}
6369 if {$showneartags} {
6370 if {![info exists allcommits]} {
6373 $ctext insert end "[mc "Branch"]: "
6374 $ctext mark set branch "end -1c"
6375 $ctext mark gravity branch left
6376 $ctext insert end "\n[mc "Follows"]: "
6377 $ctext mark set follows "end -1c"
6378 $ctext mark gravity follows left
6379 $ctext insert end "\n[mc "Precedes"]: "
6380 $ctext mark set precedes "end -1c"
6381 $ctext mark gravity precedes left
6382 $ctext insert end "\n"
6385 $ctext insert end "\n"
6386 set comment [lindex $info 5]
6387 if {[string first "\r" $comment] >= 0} {
6388 set comment [string map {"\r" "\n "} $comment]
6390 appendwithlinks $comment {comment}
6392 $ctext tag remove found 1.0 end
6393 $ctext conf -state disabled
6394 set commentend [$ctext index "end - 1c"]
6396 set jump_to_here $desired_loc
6397 init_flist [mc "Comments"]
6398 if {$cmitmode eq "tree"} {
6400 } elseif {[llength $olds] <= 1} {
6407 proc selfirstline {} {
6412 proc sellastline {} {
6415 set l [expr {$numcommits - 1}]
6419 proc selnextline {dir} {
6422 if {$selectedline eq {}} return
6423 set l [expr {$selectedline + $dir}]
6428 proc selnextpage {dir} {
6429 global canv linespc selectedline numcommits
6431 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6435 allcanvs yview scroll [expr {$dir * $lpp}] units
6437 if {$selectedline eq {}} return
6438 set l [expr {$selectedline + $dir * $lpp}]
6441 } elseif {$l >= $numcommits} {
6442 set l [expr $numcommits - 1]
6448 proc unselectline {} {
6449 global selectedline currentid
6452 catch {unset currentid}
6453 allcanvs delete secsel
6457 proc reselectline {} {
6460 if {$selectedline ne {}} {
6461 selectline $selectedline 0
6465 proc addtohistory {cmd} {
6466 global history historyindex curview
6468 set elt [list $curview $cmd]
6469 if {$historyindex > 0
6470 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6474 if {$historyindex < [llength $history]} {
6475 set history [lreplace $history $historyindex end $elt]
6477 lappend history $elt
6480 if {$historyindex > 1} {
6481 .tf.bar.leftbut conf -state normal
6483 .tf.bar.leftbut conf -state disabled
6485 .tf.bar.rightbut conf -state disabled
6491 set view [lindex $elt 0]
6492 set cmd [lindex $elt 1]
6493 if {$curview != $view} {
6500 global history historyindex
6503 if {$historyindex > 1} {
6504 incr historyindex -1
6505 godo [lindex $history [expr {$historyindex - 1}]]
6506 .tf.bar.rightbut conf -state normal
6508 if {$historyindex <= 1} {
6509 .tf.bar.leftbut conf -state disabled
6514 global history historyindex
6517 if {$historyindex < [llength $history]} {
6518 set cmd [lindex $history $historyindex]
6521 .tf.bar.leftbut conf -state normal
6523 if {$historyindex >= [llength $history]} {
6524 .tf.bar.rightbut conf -state disabled
6529 global treefilelist treeidlist diffids diffmergeid treepending
6530 global nullid nullid2
6533 catch {unset diffmergeid}
6534 if {![info exists treefilelist($id)]} {
6535 if {![info exists treepending]} {
6536 if {$id eq $nullid} {
6537 set cmd [list | git ls-files]
6538 } elseif {$id eq $nullid2} {
6539 set cmd [list | git ls-files --stage -t]
6541 set cmd [list | git ls-tree -r $id]
6543 if {[catch {set gtf [open $cmd r]}]} {
6547 set treefilelist($id) {}
6548 set treeidlist($id) {}
6549 fconfigure $gtf -blocking 0 -encoding binary
6550 filerun $gtf [list gettreeline $gtf $id]
6557 proc gettreeline {gtf id} {
6558 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6561 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6562 if {$diffids eq $nullid} {
6565 set i [string first "\t" $line]
6566 if {$i < 0} continue
6567 set fname [string range $line [expr {$i+1}] end]
6568 set line [string range $line 0 [expr {$i-1}]]
6569 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6570 set sha1 [lindex $line 2]
6571 lappend treeidlist($id) $sha1
6573 if {[string index $fname 0] eq "\""} {
6574 set fname [lindex $fname 0]
6576 set fname [encoding convertfrom $fname]
6577 lappend treefilelist($id) $fname
6580 return [expr {$nl >= 1000? 2: 1}]
6584 if {$cmitmode ne "tree"} {
6585 if {![info exists diffmergeid]} {
6586 gettreediffs $diffids
6588 } elseif {$id ne $diffids} {
6597 global treefilelist treeidlist diffids nullid nullid2
6598 global ctext_file_names ctext_file_lines
6599 global ctext commentend
6601 set i [lsearch -exact $treefilelist($diffids) $f]
6603 puts "oops, $f not in list for id $diffids"
6606 if {$diffids eq $nullid} {
6607 if {[catch {set bf [open $f r]} err]} {
6608 puts "oops, can't read $f: $err"
6612 set blob [lindex $treeidlist($diffids) $i]
6613 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6614 puts "oops, error reading blob $blob: $err"
6618 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6619 filerun $bf [list getblobline $bf $diffids]
6620 $ctext config -state normal
6621 clear_ctext $commentend
6622 lappend ctext_file_names $f
6623 lappend ctext_file_lines [lindex [split $commentend "."] 0]
6624 $ctext insert end "\n"
6625 $ctext insert end "$f\n" filesep
6626 $ctext config -state disabled
6627 $ctext yview $commentend
6631 proc getblobline {bf id} {
6632 global diffids cmitmode ctext
6634 if {$id ne $diffids || $cmitmode ne "tree"} {
6638 $ctext config -state normal
6640 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6641 $ctext insert end "$line\n"
6644 global jump_to_here ctext_file_names commentend
6646 # delete last newline
6647 $ctext delete "end - 2c" "end - 1c"
6649 if {$jump_to_here ne {} &&
6650 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6651 set lnum [expr {[lindex $jump_to_here 1] +
6652 [lindex [split $commentend .] 0]}]
6653 mark_ctext_line $lnum
6657 $ctext config -state disabled
6658 return [expr {$nl >= 1000? 2: 1}]
6661 proc mark_ctext_line {lnum} {
6662 global ctext markbgcolor
6664 $ctext tag delete omark
6665 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
6666 $ctext tag conf omark -background $markbgcolor
6670 proc mergediff {id} {
6672 global diffids treediffs
6673 global parents curview
6677 set treediffs($id) {}
6678 set np [llength $parents($curview,$id)]
6683 proc startdiff {ids} {
6684 global treediffs diffids treepending diffmergeid nullid nullid2
6688 catch {unset diffmergeid}
6689 if {![info exists treediffs($ids)] ||
6690 [lsearch -exact $ids $nullid] >= 0 ||
6691 [lsearch -exact $ids $nullid2] >= 0} {
6692 if {![info exists treepending]} {
6700 proc path_filter {filter name} {
6702 set l [string length $p]
6703 if {[string index $p end] eq "/"} {
6704 if {[string compare -length $l $p $name] == 0} {
6708 if {[string compare -length $l $p $name] == 0 &&
6709 ([string length $name] == $l ||
6710 [string index $name $l] eq "/")} {
6718 proc addtocflist {ids} {
6721 add_flist $treediffs($ids)
6725 proc diffcmd {ids flags} {
6726 global nullid nullid2
6728 set i [lsearch -exact $ids $nullid]
6729 set j [lsearch -exact $ids $nullid2]
6731 if {[llength $ids] > 1 && $j < 0} {
6732 # comparing working directory with some specific revision
6733 set cmd [concat | git diff-index $flags]
6735 lappend cmd -R [lindex $ids 1]
6737 lappend cmd [lindex $ids 0]
6740 # comparing working directory with index
6741 set cmd [concat | git diff-files $flags]
6746 } elseif {$j >= 0} {
6747 set cmd [concat | git diff-index --cached $flags]
6748 if {[llength $ids] > 1} {
6749 # comparing index with specific revision
6751 lappend cmd -R [lindex $ids 1]
6753 lappend cmd [lindex $ids 0]
6756 # comparing index with HEAD
6760 set cmd [concat | git diff-tree -r $flags $ids]
6765 proc gettreediffs {ids} {
6766 global treediff treepending
6768 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6770 set treepending $ids
6772 fconfigure $gdtf -blocking 0 -encoding binary
6773 filerun $gdtf [list gettreediffline $gdtf $ids]
6776 proc gettreediffline {gdtf ids} {
6777 global treediff treediffs treepending diffids diffmergeid
6778 global cmitmode vfilelimit curview limitdiffs perfile_attrs
6783 if {$perfile_attrs} {
6784 # cache_gitattr is slow, and even slower on win32 where we
6785 # have to invoke it for only about 30 paths at a time
6787 if {[tk windowingsystem] == "win32"} {
6791 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
6792 set i [string first "\t" $line]
6794 set file [string range $line [expr {$i+1}] end]
6795 if {[string index $file 0] eq "\""} {
6796 set file [lindex $file 0]
6798 set file [encoding convertfrom $file]
6799 lappend treediff $file
6800 lappend sublist $file
6803 if {$perfile_attrs} {
6804 cache_gitattr encoding $sublist
6807 return [expr {$nr >= $max? 2: 1}]
6810 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6812 foreach f $treediff {
6813 if {[path_filter $vfilelimit($curview) $f]} {
6817 set treediffs($ids) $flist
6819 set treediffs($ids) $treediff
6822 if {$cmitmode eq "tree"} {
6824 } elseif {$ids != $diffids} {
6825 if {![info exists diffmergeid]} {
6826 gettreediffs $diffids
6834 # empty string or positive integer
6835 proc diffcontextvalidate {v} {
6836 return [regexp {^(|[1-9][0-9]*)$} $v]
6839 proc diffcontextchange {n1 n2 op} {
6840 global diffcontextstring diffcontext
6842 if {[string is integer -strict $diffcontextstring]} {
6843 if {$diffcontextstring > 0} {
6844 set diffcontext $diffcontextstring
6850 proc changeignorespace {} {
6854 proc getblobdiffs {ids} {
6855 global blobdifffd diffids env
6856 global diffinhdr treediffs
6859 global limitdiffs vfilelimit curview
6860 global diffencoding targetline diffnparents
6862 set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
6866 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6867 set cmd [concat $cmd -- $vfilelimit($curview)]
6869 if {[catch {set bdf [open $cmd r]} err]} {
6870 error_popup [mc "Error getting diffs: %s" $err]
6876 set diffencoding [get_path_encoding {}]
6877 fconfigure $bdf -blocking 0 -encoding binary
6878 set blobdifffd($ids) $bdf
6879 filerun $bdf [list getblobdiffline $bdf $diffids]
6882 proc setinlist {var i val} {
6885 while {[llength [set $var]] < $i} {
6888 if {[llength [set $var]] == $i} {
6895 proc makediffhdr {fname ids} {
6896 global ctext curdiffstart treediffs diffencoding
6897 global ctext_file_names jump_to_here targetline diffline
6899 set fname [encoding convertfrom $fname]
6900 set diffencoding [get_path_encoding $fname]
6901 set i [lsearch -exact $treediffs($ids) $fname]
6903 setinlist difffilestart $i $curdiffstart
6905 set ctext_file_names [lreplace $ctext_file_names end end $fname]
6906 set l [expr {(78 - [string length $fname]) / 2}]
6907 set pad [string range "----------------------------------------" 1 $l]
6908 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6910 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
6911 set targetline [lindex $jump_to_here 1]
6916 proc getblobdiffline {bdf ids} {
6917 global diffids blobdifffd ctext curdiffstart
6918 global diffnexthead diffnextnote difffilestart
6919 global ctext_file_names ctext_file_lines
6920 global diffinhdr treediffs mergemax diffnparents
6921 global diffencoding jump_to_here targetline diffline
6924 $ctext conf -state normal
6925 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6926 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6930 if {![string compare -length 5 "diff " $line]} {
6931 if {![regexp {^diff (--cc|--git) } $line m type]} {
6932 set line [encoding convertfrom $line]
6933 $ctext insert end "$line\n" hunksep
6936 # start of a new file
6938 $ctext insert end "\n"
6939 set curdiffstart [$ctext index "end - 1c"]
6940 lappend ctext_file_names ""
6941 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
6942 $ctext insert end "\n" filesep
6944 if {$type eq "--cc"} {
6945 # start of a new file in a merge diff
6946 set fname [string range $line 10 end]
6947 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
6948 lappend treediffs($ids) $fname
6949 add_flist [list $fname]
6953 set line [string range $line 11 end]
6954 # If the name hasn't changed the length will be odd,
6955 # the middle char will be a space, and the two bits either
6956 # side will be a/name and b/name, or "a/name" and "b/name".
6957 # If the name has changed we'll get "rename from" and
6958 # "rename to" or "copy from" and "copy to" lines following
6959 # this, and we'll use them to get the filenames.
6960 # This complexity is necessary because spaces in the
6961 # filename(s) don't get escaped.
6962 set l [string length $line]
6963 set i [expr {$l / 2}]
6964 if {!(($l & 1) && [string index $line $i] eq " " &&
6965 [string range $line 2 [expr {$i - 1}]] eq \
6966 [string range $line [expr {$i + 3}] end])} {
6969 # unescape if quoted and chop off the a/ from the front
6970 if {[string index $line 0] eq "\""} {
6971 set fname [string range [lindex $line 0] 2 end]
6973 set fname [string range $line 2 [expr {$i - 1}]]
6976 makediffhdr $fname $ids
6978 } elseif {![string compare -length 2 "@@" $line]} {
6979 regexp {^@@+} $line ats
6980 set line [encoding convertfrom $diffencoding $line]
6981 $ctext insert end "$line\n" hunksep
6982 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
6985 set diffnparents [expr {[string length $ats] - 1}]
6988 } elseif {$diffinhdr} {
6989 if {![string compare -length 12 "rename from " $line]} {
6990 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6991 if {[string index $fname 0] eq "\""} {
6992 set fname [lindex $fname 0]
6994 set fname [encoding convertfrom $fname]
6995 set i [lsearch -exact $treediffs($ids) $fname]
6997 setinlist difffilestart $i $curdiffstart
6999 } elseif {![string compare -length 10 $line "rename to "] ||
7000 ![string compare -length 8 $line "copy to "]} {
7001 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7002 if {[string index $fname 0] eq "\""} {
7003 set fname [lindex $fname 0]
7005 makediffhdr $fname $ids
7006 } elseif {[string compare -length 3 $line "---"] == 0} {
7009 } elseif {[string compare -length 3 $line "+++"] == 0} {
7013 $ctext insert end "$line\n" filesep
7016 set line [encoding convertfrom $diffencoding $line]
7017 # parse the prefix - one ' ', '-' or '+' for each parent
7018 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7019 set tag [expr {$diffnparents > 1? "m": "d"}]
7020 if {[string trim $prefix " -+"] eq {}} {
7021 # prefix only has " ", "-" and "+" in it: normal diff line
7022 set num [string first "-" $prefix]
7024 # removed line, first parent with line is $num
7025 if {$num >= $mergemax} {
7028 $ctext insert end "$line\n" $tag$num
7031 if {[string first "+" $prefix] >= 0} {
7033 lappend tags ${tag}result
7034 if {$diffnparents > 1} {
7035 set num [string first " " $prefix]
7037 if {$num >= $mergemax} {
7044 if {$targetline ne {}} {
7045 if {$diffline == $targetline} {
7046 set seehere [$ctext index "end - 1 chars"]
7052 $ctext insert end "$line\n" $tags
7055 # "\ No newline at end of file",
7056 # or something else we don't recognize
7057 $ctext insert end "$line\n" hunksep
7061 if {[info exists seehere]} {
7062 mark_ctext_line [lindex [split $seehere .] 0]
7064 $ctext conf -state disabled
7069 return [expr {$nr >= 1000? 2: 1}]
7072 proc changediffdisp {} {
7073 global ctext diffelide
7075 $ctext tag conf d0 -elide [lindex $diffelide 0]
7076 $ctext tag conf dresult -elide [lindex $diffelide 1]
7079 proc highlightfile {loc cline} {
7080 global ctext cflist cflist_top
7083 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7084 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7085 $cflist see $cline.0
7086 set cflist_top $cline
7090 global difffilestart ctext cmitmode
7092 if {$cmitmode eq "tree"} return
7095 set here [$ctext index @0,0]
7096 foreach loc $difffilestart {
7097 if {[$ctext compare $loc >= $here]} {
7098 highlightfile $prev $prevline
7104 highlightfile $prev $prevline
7108 global difffilestart ctext cmitmode
7110 if {$cmitmode eq "tree"} return
7111 set here [$ctext index @0,0]
7113 foreach loc $difffilestart {
7115 if {[$ctext compare $loc > $here]} {
7116 highlightfile $loc $line
7122 proc clear_ctext {{first 1.0}} {
7123 global ctext smarktop smarkbot
7124 global ctext_file_names ctext_file_lines
7127 set l [lindex [split $first .] 0]
7128 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7131 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7134 $ctext delete $first end
7135 if {$first eq "1.0"} {
7136 catch {unset pendinglinks}
7138 set ctext_file_names {}
7139 set ctext_file_lines {}
7142 proc settabs {{firstab {}}} {
7143 global firsttabstop tabstop ctext have_tk85
7145 if {$firstab ne {} && $have_tk85} {
7146 set firsttabstop $firstab
7148 set w [font measure textfont "0"]
7149 if {$firsttabstop != 0} {
7150 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7151 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7152 } elseif {$have_tk85 || $tabstop != 8} {
7153 $ctext conf -tabs [expr {$tabstop * $w}]
7155 $ctext conf -tabs {}
7159 proc incrsearch {name ix op} {
7160 global ctext searchstring searchdirn
7162 $ctext tag remove found 1.0 end
7163 if {[catch {$ctext index anchor}]} {
7164 # no anchor set, use start of selection, or of visible area
7165 set sel [$ctext tag ranges sel]
7167 $ctext mark set anchor [lindex $sel 0]
7168 } elseif {$searchdirn eq "-forwards"} {
7169 $ctext mark set anchor @0,0
7171 $ctext mark set anchor @0,[winfo height $ctext]
7174 if {$searchstring ne {}} {
7175 set here [$ctext search $searchdirn -- $searchstring anchor]
7184 global sstring ctext searchstring searchdirn
7187 $sstring icursor end
7188 set searchdirn -forwards
7189 if {$searchstring ne {}} {
7190 set sel [$ctext tag ranges sel]
7192 set start "[lindex $sel 0] + 1c"
7193 } elseif {[catch {set start [$ctext index anchor]}]} {
7196 set match [$ctext search -count mlen -- $searchstring $start]
7197 $ctext tag remove sel 1.0 end
7203 set mend "$match + $mlen c"
7204 $ctext tag add sel $match $mend
7205 $ctext mark unset anchor
7209 proc dosearchback {} {
7210 global sstring ctext searchstring searchdirn
7213 $sstring icursor end
7214 set searchdirn -backwards
7215 if {$searchstring ne {}} {
7216 set sel [$ctext tag ranges sel]
7218 set start [lindex $sel 0]
7219 } elseif {[catch {set start [$ctext index anchor]}]} {
7220 set start @0,[winfo height $ctext]
7222 set match [$ctext search -backwards -count ml -- $searchstring $start]
7223 $ctext tag remove sel 1.0 end
7229 set mend "$match + $ml c"
7230 $ctext tag add sel $match $mend
7231 $ctext mark unset anchor
7235 proc searchmark {first last} {
7236 global ctext searchstring
7240 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7241 if {$match eq {}} break
7242 set mend "$match + $mlen c"
7243 $ctext tag add found $match $mend
7247 proc searchmarkvisible {doall} {
7248 global ctext smarktop smarkbot
7250 set topline [lindex [split [$ctext index @0,0] .] 0]
7251 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7252 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7253 # no overlap with previous
7254 searchmark $topline $botline
7255 set smarktop $topline
7256 set smarkbot $botline
7258 if {$topline < $smarktop} {
7259 searchmark $topline [expr {$smarktop-1}]
7260 set smarktop $topline
7262 if {$botline > $smarkbot} {
7263 searchmark [expr {$smarkbot+1}] $botline
7264 set smarkbot $botline
7269 proc scrolltext {f0 f1} {
7272 .bleft.bottom.sb set $f0 $f1
7273 if {$searchstring ne {}} {
7279 global linespc charspc canvx0 canvy0
7280 global xspc1 xspc2 lthickness
7282 set linespc [font metrics mainfont -linespace]
7283 set charspc [font measure mainfont "m"]
7284 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7285 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7286 set lthickness [expr {int($linespc / 9) + 1}]
7287 set xspc1(0) $linespc
7295 set ymax [lindex [$canv cget -scrollregion] 3]
7296 if {$ymax eq {} || $ymax == 0} return
7297 set span [$canv yview]
7300 allcanvs yview moveto [lindex $span 0]
7302 if {$selectedline ne {}} {
7303 selectline $selectedline 0
7304 allcanvs yview moveto [lindex $span 0]
7308 proc parsefont {f n} {
7311 set fontattr($f,family) [lindex $n 0]
7313 if {$s eq {} || $s == 0} {
7316 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7318 set fontattr($f,size) $s
7319 set fontattr($f,weight) normal
7320 set fontattr($f,slant) roman
7321 foreach style [lrange $n 2 end] {
7324 "bold" {set fontattr($f,weight) $style}
7326 "italic" {set fontattr($f,slant) $style}
7331 proc fontflags {f {isbold 0}} {
7334 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7335 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7336 -slant $fontattr($f,slant)]
7342 set n [list $fontattr($f,family) $fontattr($f,size)]
7343 if {$fontattr($f,weight) eq "bold"} {
7346 if {$fontattr($f,slant) eq "italic"} {
7352 proc incrfont {inc} {
7353 global mainfont textfont ctext canv cflist showrefstop
7354 global stopped entries fontattr
7357 set s $fontattr(mainfont,size)
7362 set fontattr(mainfont,size) $s
7363 font config mainfont -size $s
7364 font config mainfontbold -size $s
7365 set mainfont [fontname mainfont]
7366 set s $fontattr(textfont,size)
7371 set fontattr(textfont,size) $s
7372 font config textfont -size $s
7373 font config textfontbold -size $s
7374 set textfont [fontname textfont]
7381 global sha1entry sha1string
7382 if {[string length $sha1string] == 40} {
7383 $sha1entry delete 0 end
7387 proc sha1change {n1 n2 op} {
7388 global sha1string currentid sha1but
7389 if {$sha1string == {}
7390 || ([info exists currentid] && $sha1string == $currentid)} {
7395 if {[$sha1but cget -state] == $state} return
7396 if {$state == "normal"} {
7397 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7399 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7403 proc gotocommit {} {
7404 global sha1string tagids headids curview varcid
7406 if {$sha1string == {}
7407 || ([info exists currentid] && $sha1string == $currentid)} return
7408 if {[info exists tagids($sha1string)]} {
7409 set id $tagids($sha1string)
7410 } elseif {[info exists headids($sha1string)]} {
7411 set id $headids($sha1string)
7413 set id [string tolower $sha1string]
7414 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7415 set matches [longid $id]
7416 if {$matches ne {}} {
7417 if {[llength $matches] > 1} {
7418 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7421 set id [lindex $matches 0]
7425 if {[commitinview $id $curview]} {
7426 selectline [rowofcommit $id] 1
7429 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7430 set msg [mc "SHA1 id %s is not known" $sha1string]
7432 set msg [mc "Tag/Head %s is not known" $sha1string]
7437 proc lineenter {x y id} {
7438 global hoverx hovery hoverid hovertimer
7439 global commitinfo canv
7441 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7445 if {[info exists hovertimer]} {
7446 after cancel $hovertimer
7448 set hovertimer [after 500 linehover]
7452 proc linemotion {x y id} {
7453 global hoverx hovery hoverid hovertimer
7455 if {[info exists hoverid] && $id == $hoverid} {
7458 if {[info exists hovertimer]} {
7459 after cancel $hovertimer
7461 set hovertimer [after 500 linehover]
7465 proc lineleave {id} {
7466 global hoverid hovertimer canv
7468 if {[info exists hoverid] && $id == $hoverid} {
7470 if {[info exists hovertimer]} {
7471 after cancel $hovertimer
7479 global hoverx hovery hoverid hovertimer
7480 global canv linespc lthickness
7483 set text [lindex $commitinfo($hoverid) 0]
7484 set ymax [lindex [$canv cget -scrollregion] 3]
7485 if {$ymax == {}} return
7486 set yfrac [lindex [$canv yview] 0]
7487 set x [expr {$hoverx + 2 * $linespc}]
7488 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7489 set x0 [expr {$x - 2 * $lthickness}]
7490 set y0 [expr {$y - 2 * $lthickness}]
7491 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7492 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7493 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7494 -fill \#ffff80 -outline black -width 1 -tags hover]
7496 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7501 proc clickisonarrow {id y} {
7504 set ranges [rowranges $id]
7505 set thresh [expr {2 * $lthickness + 6}]
7506 set n [expr {[llength $ranges] - 1}]
7507 for {set i 1} {$i < $n} {incr i} {
7508 set row [lindex $ranges $i]
7509 if {abs([yc $row] - $y) < $thresh} {
7516 proc arrowjump {id n y} {
7519 # 1 <-> 2, 3 <-> 4, etc...
7520 set n [expr {(($n - 1) ^ 1) + 1}]
7521 set row [lindex [rowranges $id] $n]
7523 set ymax [lindex [$canv cget -scrollregion] 3]
7524 if {$ymax eq {} || $ymax <= 0} return
7525 set view [$canv yview]
7526 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7527 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7531 allcanvs yview moveto $yfrac
7534 proc lineclick {x y id isnew} {
7535 global ctext commitinfo children canv thickerline curview
7537 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7542 # draw this line thicker than normal
7546 set ymax [lindex [$canv cget -scrollregion] 3]
7547 if {$ymax eq {}} return
7548 set yfrac [lindex [$canv yview] 0]
7549 set y [expr {$y + $yfrac * $ymax}]
7551 set dirn [clickisonarrow $id $y]
7553 arrowjump $id $dirn $y
7558 addtohistory [list lineclick $x $y $id 0]
7560 # fill the details pane with info about this line
7561 $ctext conf -state normal
7564 $ctext insert end "[mc "Parent"]:\t"
7565 $ctext insert end $id link0
7567 set info $commitinfo($id)
7568 $ctext insert end "\n\t[lindex $info 0]\n"
7569 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7570 set date [formatdate [lindex $info 2]]
7571 $ctext insert end "\t[mc "Date"]:\t$date\n"
7572 set kids $children($curview,$id)
7574 $ctext insert end "\n[mc "Children"]:"
7576 foreach child $kids {
7578 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7579 set info $commitinfo($child)
7580 $ctext insert end "\n\t"
7581 $ctext insert end $child link$i
7582 setlink $child link$i
7583 $ctext insert end "\n\t[lindex $info 0]"
7584 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7585 set date [formatdate [lindex $info 2]]
7586 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7589 $ctext conf -state disabled
7593 proc normalline {} {
7595 if {[info exists thickerline]} {
7604 if {[commitinview $id $curview]} {
7605 selectline [rowofcommit $id] 1
7611 if {![info exists startmstime]} {
7612 set startmstime [clock clicks -milliseconds]
7614 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7617 proc rowmenu {x y id} {
7618 global rowctxmenu selectedline rowmenuid curview
7619 global nullid nullid2 fakerowmenu mainhead
7623 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7628 if {$id ne $nullid && $id ne $nullid2} {
7629 set menu $rowctxmenu
7630 if {$mainhead ne {}} {
7631 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7633 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7636 set menu $fakerowmenu
7638 $menu entryconfigure [mca "Diff this -> selected"] -state $state
7639 $menu entryconfigure [mca "Diff selected -> this"] -state $state
7640 $menu entryconfigure [mca "Make patch"] -state $state
7641 tk_popup $menu $x $y
7644 proc diffvssel {dirn} {
7645 global rowmenuid selectedline
7647 if {$selectedline eq {}} return
7649 set oldid [commitonrow $selectedline]
7650 set newid $rowmenuid
7652 set oldid $rowmenuid
7653 set newid [commitonrow $selectedline]
7655 addtohistory [list doseldiff $oldid $newid]
7656 doseldiff $oldid $newid
7659 proc doseldiff {oldid newid} {
7663 $ctext conf -state normal
7665 init_flist [mc "Top"]
7666 $ctext insert end "[mc "From"] "
7667 $ctext insert end $oldid link0
7668 setlink $oldid link0
7669 $ctext insert end "\n "
7670 $ctext insert end [lindex $commitinfo($oldid) 0]
7671 $ctext insert end "\n\n[mc "To"] "
7672 $ctext insert end $newid link1
7673 setlink $newid link1
7674 $ctext insert end "\n "
7675 $ctext insert end [lindex $commitinfo($newid) 0]
7676 $ctext insert end "\n"
7677 $ctext conf -state disabled
7678 $ctext tag remove found 1.0 end
7679 startdiff [list $oldid $newid]
7683 global rowmenuid currentid commitinfo patchtop patchnum
7685 if {![info exists currentid]} return
7686 set oldid $currentid
7687 set oldhead [lindex $commitinfo($oldid) 0]
7688 set newid $rowmenuid
7689 set newhead [lindex $commitinfo($newid) 0]
7692 catch {destroy $top}
7694 label $top.title -text [mc "Generate patch"]
7695 grid $top.title - -pady 10
7696 label $top.from -text [mc "From:"]
7697 entry $top.fromsha1 -width 40 -relief flat
7698 $top.fromsha1 insert 0 $oldid
7699 $top.fromsha1 conf -state readonly
7700 grid $top.from $top.fromsha1 -sticky w
7701 entry $top.fromhead -width 60 -relief flat
7702 $top.fromhead insert 0 $oldhead
7703 $top.fromhead conf -state readonly
7704 grid x $top.fromhead -sticky w
7705 label $top.to -text [mc "To:"]
7706 entry $top.tosha1 -width 40 -relief flat
7707 $top.tosha1 insert 0 $newid
7708 $top.tosha1 conf -state readonly
7709 grid $top.to $top.tosha1 -sticky w
7710 entry $top.tohead -width 60 -relief flat
7711 $top.tohead insert 0 $newhead
7712 $top.tohead conf -state readonly
7713 grid x $top.tohead -sticky w
7714 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7715 grid $top.rev x -pady 10
7716 label $top.flab -text [mc "Output file:"]
7717 entry $top.fname -width 60
7718 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7720 grid $top.flab $top.fname -sticky w
7722 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7723 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7724 grid $top.buts.gen $top.buts.can
7725 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7726 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7727 grid $top.buts - -pady 10 -sticky ew
7731 proc mkpatchrev {} {
7734 set oldid [$patchtop.fromsha1 get]
7735 set oldhead [$patchtop.fromhead get]
7736 set newid [$patchtop.tosha1 get]
7737 set newhead [$patchtop.tohead get]
7738 foreach e [list fromsha1 fromhead tosha1 tohead] \
7739 v [list $newid $newhead $oldid $oldhead] {
7740 $patchtop.$e conf -state normal
7741 $patchtop.$e delete 0 end
7742 $patchtop.$e insert 0 $v
7743 $patchtop.$e conf -state readonly
7748 global patchtop nullid nullid2
7750 set oldid [$patchtop.fromsha1 get]
7751 set newid [$patchtop.tosha1 get]
7752 set fname [$patchtop.fname get]
7753 set cmd [diffcmd [list $oldid $newid] -p]
7754 # trim off the initial "|"
7755 set cmd [lrange $cmd 1 end]
7756 lappend cmd >$fname &
7757 if {[catch {eval exec $cmd} err]} {
7758 error_popup "[mc "Error creating patch:"] $err"
7760 catch {destroy $patchtop}
7764 proc mkpatchcan {} {
7767 catch {destroy $patchtop}
7772 global rowmenuid mktagtop commitinfo
7776 catch {destroy $top}
7778 label $top.title -text [mc "Create tag"]
7779 grid $top.title - -pady 10
7780 label $top.id -text [mc "ID:"]
7781 entry $top.sha1 -width 40 -relief flat
7782 $top.sha1 insert 0 $rowmenuid
7783 $top.sha1 conf -state readonly
7784 grid $top.id $top.sha1 -sticky w
7785 entry $top.head -width 60 -relief flat
7786 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7787 $top.head conf -state readonly
7788 grid x $top.head -sticky w
7789 label $top.tlab -text [mc "Tag name:"]
7790 entry $top.tag -width 60
7791 grid $top.tlab $top.tag -sticky w
7793 button $top.buts.gen -text [mc "Create"] -command mktaggo
7794 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7795 grid $top.buts.gen $top.buts.can
7796 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7797 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7798 grid $top.buts - -pady 10 -sticky ew
7803 global mktagtop env tagids idtags
7805 set id [$mktagtop.sha1 get]
7806 set tag [$mktagtop.tag get]
7808 error_popup [mc "No tag name specified"]
7811 if {[info exists tagids($tag)]} {
7812 error_popup [mc "Tag \"%s\" already exists" $tag]
7816 exec git tag $tag $id
7818 error_popup "[mc "Error creating tag:"] $err"
7822 set tagids($tag) $id
7823 lappend idtags($id) $tag
7830 proc redrawtags {id} {
7831 global canv linehtag idpos currentid curview cmitlisted
7832 global canvxmax iddrawn circleitem mainheadid circlecolors
7834 if {![commitinview $id $curview]} return
7835 if {![info exists iddrawn($id)]} return
7836 set row [rowofcommit $id]
7837 if {$id eq $mainheadid} {
7840 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7842 $canv itemconf $circleitem($row) -fill $ofill
7843 $canv delete tag.$id
7844 set xt [eval drawtags $id $idpos($id)]
7845 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7846 set text [$canv itemcget $linehtag($row) -text]
7847 set font [$canv itemcget $linehtag($row) -font]
7848 set xr [expr {$xt + [font measure $font $text]}]
7849 if {$xr > $canvxmax} {
7853 if {[info exists currentid] && $currentid == $id} {
7861 catch {destroy $mktagtop}
7870 proc writecommit {} {
7871 global rowmenuid wrcomtop commitinfo wrcomcmd
7873 set top .writecommit
7875 catch {destroy $top}
7877 label $top.title -text [mc "Write commit to file"]
7878 grid $top.title - -pady 10
7879 label $top.id -text [mc "ID:"]
7880 entry $top.sha1 -width 40 -relief flat
7881 $top.sha1 insert 0 $rowmenuid
7882 $top.sha1 conf -state readonly
7883 grid $top.id $top.sha1 -sticky w
7884 entry $top.head -width 60 -relief flat
7885 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7886 $top.head conf -state readonly
7887 grid x $top.head -sticky w
7888 label $top.clab -text [mc "Command:"]
7889 entry $top.cmd -width 60 -textvariable wrcomcmd
7890 grid $top.clab $top.cmd -sticky w -pady 10
7891 label $top.flab -text [mc "Output file:"]
7892 entry $top.fname -width 60
7893 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7894 grid $top.flab $top.fname -sticky w
7896 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7897 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7898 grid $top.buts.gen $top.buts.can
7899 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7900 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7901 grid $top.buts - -pady 10 -sticky ew
7908 set id [$wrcomtop.sha1 get]
7909 set cmd "echo $id | [$wrcomtop.cmd get]"
7910 set fname [$wrcomtop.fname get]
7911 if {[catch {exec sh -c $cmd >$fname &} err]} {
7912 error_popup "[mc "Error writing commit:"] $err"
7914 catch {destroy $wrcomtop}
7921 catch {destroy $wrcomtop}
7926 global rowmenuid mkbrtop
7929 catch {destroy $top}
7931 label $top.title -text [mc "Create new branch"]
7932 grid $top.title - -pady 10
7933 label $top.id -text [mc "ID:"]
7934 entry $top.sha1 -width 40 -relief flat
7935 $top.sha1 insert 0 $rowmenuid
7936 $top.sha1 conf -state readonly
7937 grid $top.id $top.sha1 -sticky w
7938 label $top.nlab -text [mc "Name:"]
7939 entry $top.name -width 40
7940 bind $top.name <Key-Return> "[list mkbrgo $top]"
7941 grid $top.nlab $top.name -sticky w
7943 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7944 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7945 grid $top.buts.go $top.buts.can
7946 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7947 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7948 grid $top.buts - -pady 10 -sticky ew
7953 global headids idheads
7955 set name [$top.name get]
7956 set id [$top.sha1 get]
7960 error_popup [mc "Please specify a name for the new branch"]
7963 if {[info exists headids($name)]} {
7964 if {![confirm_popup [mc \
7965 "Branch '%s' already exists. Overwrite?" $name]]} {
7968 set old_id $headids($name)
7971 catch {destroy $top}
7972 lappend cmdargs $name $id
7976 eval exec git branch $cmdargs
7982 if {$old_id ne {}} {
7988 set headids($name) $id
7989 lappend idheads($id) $name
7998 proc cherrypick {} {
7999 global rowmenuid curview
8000 global mainhead mainheadid
8002 set oldhead [exec git rev-parse HEAD]
8003 set dheads [descheads $rowmenuid]
8004 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8005 set ok [confirm_popup [mc "Commit %s is already\
8006 included in branch %s -- really re-apply it?" \
8007 [string range $rowmenuid 0 7] $mainhead]]
8010 nowbusy cherrypick [mc "Cherry-picking"]
8012 # Unfortunately git-cherry-pick writes stuff to stderr even when
8013 # no error occurs, and exec takes that as an indication of error...
8014 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8019 set newhead [exec git rev-parse HEAD]
8020 if {$newhead eq $oldhead} {
8022 error_popup [mc "No changes committed"]
8025 addnewchild $newhead $oldhead
8026 if {[commitinview $oldhead $curview]} {
8027 insertrow $newhead $oldhead $curview
8028 if {$mainhead ne {}} {
8029 movehead $newhead $mainhead
8030 movedhead $newhead $mainhead
8032 set mainheadid $newhead
8041 global mainhead rowmenuid confirm_ok resettype
8044 set w ".confirmreset"
8047 wm title $w [mc "Confirm reset"]
8048 message $w.m -text \
8049 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8050 -justify center -aspect 1000
8051 pack $w.m -side top -fill x -padx 20 -pady 20
8052 frame $w.f -relief sunken -border 2
8053 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8054 grid $w.f.rt -sticky w
8056 radiobutton $w.f.soft -value soft -variable resettype -justify left \
8057 -text [mc "Soft: Leave working tree and index untouched"]
8058 grid $w.f.soft -sticky w
8059 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8060 -text [mc "Mixed: Leave working tree untouched, reset index"]
8061 grid $w.f.mixed -sticky w
8062 radiobutton $w.f.hard -value hard -variable resettype -justify left \
8063 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8064 grid $w.f.hard -sticky w
8065 pack $w.f -side top -fill x
8066 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8067 pack $w.ok -side left -fill x -padx 20 -pady 20
8068 button $w.cancel -text [mc Cancel] -command "destroy $w"
8069 pack $w.cancel -side right -fill x -padx 20 -pady 20
8070 bind $w <Visibility> "grab $w; focus $w"
8072 if {!$confirm_ok} return
8073 if {[catch {set fd [open \
8074 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8078 filerun $fd [list readresetstat $fd]
8079 nowbusy reset [mc "Resetting"]
8084 proc readresetstat {fd} {
8085 global mainhead mainheadid showlocalchanges rprogcoord
8087 if {[gets $fd line] >= 0} {
8088 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8089 set rprogcoord [expr {1.0 * $m / $n}]
8097 if {[catch {close $fd} err]} {
8100 set oldhead $mainheadid
8101 set newhead [exec git rev-parse HEAD]
8102 if {$newhead ne $oldhead} {
8103 movehead $newhead $mainhead
8104 movedhead $newhead $mainhead
8105 set mainheadid $newhead
8109 if {$showlocalchanges} {
8115 # context menu for a head
8116 proc headmenu {x y id head} {
8117 global headmenuid headmenuhead headctxmenu mainhead
8121 set headmenuhead $head
8123 if {$head eq $mainhead} {
8126 $headctxmenu entryconfigure 0 -state $state
8127 $headctxmenu entryconfigure 1 -state $state
8128 tk_popup $headctxmenu $x $y
8132 global headmenuid headmenuhead headids
8133 global showlocalchanges mainheadid
8135 # check the tree is clean first??
8136 nowbusy checkout [mc "Checking out"]
8140 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8144 if {$showlocalchanges} {
8148 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8152 proc readcheckoutstat {fd newhead newheadid} {
8153 global mainhead mainheadid headids showlocalchanges progresscoords
8155 if {[gets $fd line] >= 0} {
8156 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8157 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8162 set progresscoords {0 0}
8165 if {[catch {close $fd} err]} {
8168 set oldmainid $mainheadid
8169 set mainhead $newhead
8170 set mainheadid $newheadid
8171 redrawtags $oldmainid
8172 redrawtags $newheadid
8174 if {$showlocalchanges} {
8180 global headmenuid headmenuhead mainhead
8183 set head $headmenuhead
8185 # this check shouldn't be needed any more...
8186 if {$head eq $mainhead} {
8187 error_popup [mc "Cannot delete the currently checked-out branch"]
8190 set dheads [descheads $id]
8191 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8192 # the stuff on this branch isn't on any other branch
8193 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8194 branch.\nReally delete branch %s?" $head $head]]} return
8198 if {[catch {exec git branch -D $head} err]} {
8203 removehead $id $head
8204 removedhead $id $head
8211 # Display a list of tags and heads
8213 global showrefstop bgcolor fgcolor selectbgcolor
8214 global bglist fglist reflistfilter reflist maincursor
8217 set showrefstop $top
8218 if {[winfo exists $top]} {
8224 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8225 text $top.list -background $bgcolor -foreground $fgcolor \
8226 -selectbackground $selectbgcolor -font mainfont \
8227 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8228 -width 30 -height 20 -cursor $maincursor \
8229 -spacing1 1 -spacing3 1 -state disabled
8230 $top.list tag configure highlight -background $selectbgcolor
8231 lappend bglist $top.list
8232 lappend fglist $top.list
8233 scrollbar $top.ysb -command "$top.list yview" -orient vertical
8234 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8235 grid $top.list $top.ysb -sticky nsew
8236 grid $top.xsb x -sticky ew
8238 label $top.f.l -text "[mc "Filter"]: "
8239 entry $top.f.e -width 20 -textvariable reflistfilter
8240 set reflistfilter "*"
8241 trace add variable reflistfilter write reflistfilter_change
8242 pack $top.f.e -side right -fill x -expand 1
8243 pack $top.f.l -side left
8244 grid $top.f - -sticky ew -pady 2
8245 button $top.close -command [list destroy $top] -text [mc "Close"]
8247 grid columnconfigure $top 0 -weight 1
8248 grid rowconfigure $top 0 -weight 1
8249 bind $top.list <1> {break}
8250 bind $top.list <B1-Motion> {break}
8251 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8256 proc sel_reflist {w x y} {
8257 global showrefstop reflist headids tagids otherrefids
8259 if {![winfo exists $showrefstop]} return
8260 set l [lindex [split [$w index "@$x,$y"] "."] 0]
8261 set ref [lindex $reflist [expr {$l-1}]]
8262 set n [lindex $ref 0]
8263 switch -- [lindex $ref 1] {
8264 "H" {selbyid $headids($n)}
8265 "T" {selbyid $tagids($n)}
8266 "o" {selbyid $otherrefids($n)}
8268 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8271 proc unsel_reflist {} {
8274 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8275 $showrefstop.list tag remove highlight 0.0 end
8278 proc reflistfilter_change {n1 n2 op} {
8279 global reflistfilter
8281 after cancel refill_reflist
8282 after 200 refill_reflist
8285 proc refill_reflist {} {
8286 global reflist reflistfilter showrefstop headids tagids otherrefids
8289 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8291 foreach n [array names headids] {
8292 if {[string match $reflistfilter $n]} {
8293 if {[commitinview $headids($n) $curview]} {
8294 lappend refs [list $n H]
8296 interestedin $headids($n) {run refill_reflist}
8300 foreach n [array names tagids] {
8301 if {[string match $reflistfilter $n]} {
8302 if {[commitinview $tagids($n) $curview]} {
8303 lappend refs [list $n T]
8305 interestedin $tagids($n) {run refill_reflist}
8309 foreach n [array names otherrefids] {
8310 if {[string match $reflistfilter $n]} {
8311 if {[commitinview $otherrefids($n) $curview]} {
8312 lappend refs [list $n o]
8314 interestedin $otherrefids($n) {run refill_reflist}
8318 set refs [lsort -index 0 $refs]
8319 if {$refs eq $reflist} return
8321 # Update the contents of $showrefstop.list according to the
8322 # differences between $reflist (old) and $refs (new)
8323 $showrefstop.list conf -state normal
8324 $showrefstop.list insert end "\n"
8327 while {$i < [llength $reflist] || $j < [llength $refs]} {
8328 if {$i < [llength $reflist]} {
8329 if {$j < [llength $refs]} {
8330 set cmp [string compare [lindex $reflist $i 0] \
8331 [lindex $refs $j 0]]
8333 set cmp [string compare [lindex $reflist $i 1] \
8334 [lindex $refs $j 1]]
8344 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8352 set l [expr {$j + 1}]
8353 $showrefstop.list image create $l.0 -align baseline \
8354 -image reficon-[lindex $refs $j 1] -padx 2
8355 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8361 # delete last newline
8362 $showrefstop.list delete end-2c end-1c
8363 $showrefstop.list conf -state disabled
8366 # Stuff for finding nearby tags
8367 proc getallcommits {} {
8368 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8369 global idheads idtags idotherrefs allparents tagobjid
8371 if {![info exists allcommits]} {
8377 set allccache [file join [gitdir] "gitk.cache"]
8379 set f [open $allccache r]
8388 set cmd [list | git rev-list --parents]
8389 set allcupdate [expr {$seeds ne {}}]
8393 set refs [concat [array names idheads] [array names idtags] \
8394 [array names idotherrefs]]
8397 foreach name [array names tagobjid] {
8398 lappend tagobjs $tagobjid($name)
8400 foreach id [lsort -unique $refs] {
8401 if {![info exists allparents($id)] &&
8402 [lsearch -exact $tagobjs $id] < 0} {
8413 set fd [open [concat $cmd $ids] r]
8414 fconfigure $fd -blocking 0
8417 filerun $fd [list getallclines $fd]
8423 # Since most commits have 1 parent and 1 child, we group strings of
8424 # such commits into "arcs" joining branch/merge points (BMPs), which
8425 # are commits that either don't have 1 parent or don't have 1 child.
8427 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8428 # arcout(id) - outgoing arcs for BMP
8429 # arcids(a) - list of IDs on arc including end but not start
8430 # arcstart(a) - BMP ID at start of arc
8431 # arcend(a) - BMP ID at end of arc
8432 # growing(a) - arc a is still growing
8433 # arctags(a) - IDs out of arcids (excluding end) that have tags
8434 # archeads(a) - IDs out of arcids (excluding end) that have heads
8435 # The start of an arc is at the descendent end, so "incoming" means
8436 # coming from descendents, and "outgoing" means going towards ancestors.
8438 proc getallclines {fd} {
8439 global allparents allchildren idtags idheads nextarc
8440 global arcnos arcids arctags arcout arcend arcstart archeads growing
8441 global seeds allcommits cachedarcs allcupdate
8444 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8445 set id [lindex $line 0]
8446 if {[info exists allparents($id)]} {
8451 set olds [lrange $line 1 end]
8452 set allparents($id) $olds
8453 if {![info exists allchildren($id)]} {
8454 set allchildren($id) {}
8459 if {[llength $olds] == 1 && [llength $a] == 1} {
8460 lappend arcids($a) $id
8461 if {[info exists idtags($id)]} {
8462 lappend arctags($a) $id
8464 if {[info exists idheads($id)]} {
8465 lappend archeads($a) $id
8467 if {[info exists allparents($olds)]} {
8468 # seen parent already
8469 if {![info exists arcout($olds)]} {
8472 lappend arcids($a) $olds
8473 set arcend($a) $olds
8476 lappend allchildren($olds) $id
8477 lappend arcnos($olds) $a
8481 foreach a $arcnos($id) {
8482 lappend arcids($a) $id
8489 lappend allchildren($p) $id
8490 set a [incr nextarc]
8491 set arcstart($a) $id
8498 if {[info exists allparents($p)]} {
8499 # seen it already, may need to make a new branch
8500 if {![info exists arcout($p)]} {
8503 lappend arcids($a) $p
8507 lappend arcnos($p) $a
8512 global cached_dheads cached_dtags cached_atags
8513 catch {unset cached_dheads}
8514 catch {unset cached_dtags}
8515 catch {unset cached_atags}
8518 return [expr {$nid >= 1000? 2: 1}]
8522 fconfigure $fd -blocking 1
8525 # got an error reading the list of commits
8526 # if we were updating, try rereading the whole thing again
8532 error_popup "[mc "Error reading commit topology information;\
8533 branch and preceding/following tag information\
8534 will be incomplete."]\n($err)"
8537 if {[incr allcommits -1] == 0} {
8547 proc recalcarc {a} {
8548 global arctags archeads arcids idtags idheads
8552 foreach id [lrange $arcids($a) 0 end-1] {
8553 if {[info exists idtags($id)]} {
8556 if {[info exists idheads($id)]} {
8561 set archeads($a) $ah
8565 global arcnos arcids nextarc arctags archeads idtags idheads
8566 global arcstart arcend arcout allparents growing
8569 if {[llength $a] != 1} {
8570 puts "oops splitarc called but [llength $a] arcs already"
8574 set i [lsearch -exact $arcids($a) $p]
8576 puts "oops splitarc $p not in arc $a"
8579 set na [incr nextarc]
8580 if {[info exists arcend($a)]} {
8581 set arcend($na) $arcend($a)
8583 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8584 set j [lsearch -exact $arcnos($l) $a]
8585 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8587 set tail [lrange $arcids($a) [expr {$i+1}] end]
8588 set arcids($a) [lrange $arcids($a) 0 $i]
8590 set arcstart($na) $p
8592 set arcids($na) $tail
8593 if {[info exists growing($a)]} {
8599 if {[llength $arcnos($id)] == 1} {
8602 set j [lsearch -exact $arcnos($id) $a]
8603 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8607 # reconstruct tags and heads lists
8608 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8613 set archeads($na) {}
8617 # Update things for a new commit added that is a child of one
8618 # existing commit. Used when cherry-picking.
8619 proc addnewchild {id p} {
8620 global allparents allchildren idtags nextarc
8621 global arcnos arcids arctags arcout arcend arcstart archeads growing
8622 global seeds allcommits
8624 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8625 set allparents($id) [list $p]
8626 set allchildren($id) {}
8629 lappend allchildren($p) $id
8630 set a [incr nextarc]
8631 set arcstart($a) $id
8634 set arcids($a) [list $p]
8636 if {![info exists arcout($p)]} {
8639 lappend arcnos($p) $a
8640 set arcout($id) [list $a]
8643 # This implements a cache for the topology information.
8644 # The cache saves, for each arc, the start and end of the arc,
8645 # the ids on the arc, and the outgoing arcs from the end.
8646 proc readcache {f} {
8647 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8648 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8653 if {$lim - $a > 500} {
8654 set lim [expr {$a + 500}]
8658 # finish reading the cache and setting up arctags, etc.
8660 if {$line ne "1"} {error "bad final version"}
8662 foreach id [array names idtags] {
8663 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8664 [llength $allparents($id)] == 1} {
8665 set a [lindex $arcnos($id) 0]
8666 if {$arctags($a) eq {}} {
8671 foreach id [array names idheads] {
8672 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8673 [llength $allparents($id)] == 1} {
8674 set a [lindex $arcnos($id) 0]
8675 if {$archeads($a) eq {}} {
8680 foreach id [lsort -unique $possible_seeds] {
8681 if {$arcnos($id) eq {}} {
8687 while {[incr a] <= $lim} {
8689 if {[llength $line] != 3} {error "bad line"}
8690 set s [lindex $line 0]
8692 lappend arcout($s) $a
8693 if {![info exists arcnos($s)]} {
8694 lappend possible_seeds $s
8697 set e [lindex $line 1]
8702 if {![info exists arcout($e)]} {
8706 set arcids($a) [lindex $line 2]
8707 foreach id $arcids($a) {
8708 lappend allparents($s) $id
8710 lappend arcnos($id) $a
8712 if {![info exists allparents($s)]} {
8713 set allparents($s) {}
8718 set nextarc [expr {$a - 1}]
8731 global nextarc cachedarcs possible_seeds
8735 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8736 # make sure it's an integer
8737 set cachedarcs [expr {int([lindex $line 1])}]
8738 if {$cachedarcs < 0} {error "bad number of arcs"}
8740 set possible_seeds {}
8748 proc dropcache {err} {
8749 global allcwait nextarc cachedarcs seeds
8751 #puts "dropping cache ($err)"
8752 foreach v {arcnos arcout arcids arcstart arcend growing \
8753 arctags archeads allparents allchildren} {
8764 proc writecache {f} {
8765 global cachearc cachedarcs allccache
8766 global arcstart arcend arcnos arcids arcout
8770 if {$lim - $a > 1000} {
8771 set lim [expr {$a + 1000}]
8774 while {[incr a] <= $lim} {
8775 if {[info exists arcend($a)]} {
8776 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8778 puts $f [list $arcstart($a) {} $arcids($a)]
8783 catch {file delete $allccache}
8784 #puts "writing cache failed ($err)"
8787 set cachearc [expr {$a - 1}]
8788 if {$a > $cachedarcs} {
8797 global nextarc cachedarcs cachearc allccache
8799 if {$nextarc == $cachedarcs} return
8801 set cachedarcs $nextarc
8803 set f [open $allccache w]
8804 puts $f [list 1 $cachedarcs]
8809 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8810 # or 0 if neither is true.
8811 proc anc_or_desc {a b} {
8812 global arcout arcstart arcend arcnos cached_isanc
8814 if {$arcnos($a) eq $arcnos($b)} {
8815 # Both are on the same arc(s); either both are the same BMP,
8816 # or if one is not a BMP, the other is also not a BMP or is
8817 # the BMP at end of the arc (and it only has 1 incoming arc).
8818 # Or both can be BMPs with no incoming arcs.
8819 if {$a eq $b || $arcnos($a) eq {}} {
8822 # assert {[llength $arcnos($a)] == 1}
8823 set arc [lindex $arcnos($a) 0]
8824 set i [lsearch -exact $arcids($arc) $a]
8825 set j [lsearch -exact $arcids($arc) $b]
8826 if {$i < 0 || $i > $j} {
8833 if {![info exists arcout($a)]} {
8834 set arc [lindex $arcnos($a) 0]
8835 if {[info exists arcend($arc)]} {
8836 set aend $arcend($arc)
8840 set a $arcstart($arc)
8844 if {![info exists arcout($b)]} {
8845 set arc [lindex $arcnos($b) 0]
8846 if {[info exists arcend($arc)]} {
8847 set bend $arcend($arc)
8851 set b $arcstart($arc)
8861 if {[info exists cached_isanc($a,$bend)]} {
8862 if {$cached_isanc($a,$bend)} {
8866 if {[info exists cached_isanc($b,$aend)]} {
8867 if {$cached_isanc($b,$aend)} {
8870 if {[info exists cached_isanc($a,$bend)]} {
8875 set todo [list $a $b]
8878 for {set i 0} {$i < [llength $todo]} {incr i} {
8879 set x [lindex $todo $i]
8880 if {$anc($x) eq {}} {
8883 foreach arc $arcnos($x) {
8884 set xd $arcstart($arc)
8886 set cached_isanc($a,$bend) 1
8887 set cached_isanc($b,$aend) 0
8889 } elseif {$xd eq $aend} {
8890 set cached_isanc($b,$aend) 1
8891 set cached_isanc($a,$bend) 0
8894 if {![info exists anc($xd)]} {
8895 set anc($xd) $anc($x)
8897 } elseif {$anc($xd) ne $anc($x)} {
8902 set cached_isanc($a,$bend) 0
8903 set cached_isanc($b,$aend) 0
8907 # This identifies whether $desc has an ancestor that is
8908 # a growing tip of the graph and which is not an ancestor of $anc
8909 # and returns 0 if so and 1 if not.
8910 # If we subsequently discover a tag on such a growing tip, and that
8911 # turns out to be a descendent of $anc (which it could, since we
8912 # don't necessarily see children before parents), then $desc
8913 # isn't a good choice to display as a descendent tag of
8914 # $anc (since it is the descendent of another tag which is
8915 # a descendent of $anc). Similarly, $anc isn't a good choice to
8916 # display as a ancestor tag of $desc.
8918 proc is_certain {desc anc} {
8919 global arcnos arcout arcstart arcend growing problems
8922 if {[llength $arcnos($anc)] == 1} {
8923 # tags on the same arc are certain
8924 if {$arcnos($desc) eq $arcnos($anc)} {
8927 if {![info exists arcout($anc)]} {
8928 # if $anc is partway along an arc, use the start of the arc instead
8929 set a [lindex $arcnos($anc) 0]
8930 set anc $arcstart($a)
8933 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8936 set a [lindex $arcnos($desc) 0]
8942 set anclist [list $x]
8946 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8947 set x [lindex $anclist $i]
8952 foreach a $arcout($x) {
8953 if {[info exists growing($a)]} {
8954 if {![info exists growanc($x)] && $dl($x)} {
8960 if {[info exists dl($y)]} {
8964 if {![info exists done($y)]} {
8967 if {[info exists growanc($x)]} {
8971 for {set k 0} {$k < [llength $xl]} {incr k} {
8972 set z [lindex $xl $k]
8973 foreach c $arcout($z) {
8974 if {[info exists arcend($c)]} {
8976 if {[info exists dl($v)] && $dl($v)} {
8978 if {![info exists done($v)]} {
8981 if {[info exists growanc($v)]} {
8991 } elseif {$y eq $anc || !$dl($x)} {
9002 foreach x [array names growanc] {
9011 proc validate_arctags {a} {
9012 global arctags idtags
9016 foreach id $arctags($a) {
9018 if {![info exists idtags($id)]} {
9019 set na [lreplace $na $i $i]
9026 proc validate_archeads {a} {
9027 global archeads idheads
9030 set na $archeads($a)
9031 foreach id $archeads($a) {
9033 if {![info exists idheads($id)]} {
9034 set na [lreplace $na $i $i]
9038 set archeads($a) $na
9041 # Return the list of IDs that have tags that are descendents of id,
9042 # ignoring IDs that are descendents of IDs already reported.
9043 proc desctags {id} {
9044 global arcnos arcstart arcids arctags idtags allparents
9045 global growing cached_dtags
9047 if {![info exists allparents($id)]} {
9050 set t1 [clock clicks -milliseconds]
9052 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9053 # part-way along an arc; check that arc first
9054 set a [lindex $arcnos($id) 0]
9055 if {$arctags($a) ne {}} {
9057 set i [lsearch -exact $arcids($a) $id]
9059 foreach t $arctags($a) {
9060 set j [lsearch -exact $arcids($a) $t]
9068 set id $arcstart($a)
9069 if {[info exists idtags($id)]} {
9073 if {[info exists cached_dtags($id)]} {
9074 return $cached_dtags($id)
9081 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9082 set id [lindex $todo $i]
9084 set ta [info exists hastaggedancestor($id)]
9088 # ignore tags on starting node
9089 if {!$ta && $i > 0} {
9090 if {[info exists idtags($id)]} {
9093 } elseif {[info exists cached_dtags($id)]} {
9094 set tagloc($id) $cached_dtags($id)
9098 foreach a $arcnos($id) {
9100 if {!$ta && $arctags($a) ne {}} {
9102 if {$arctags($a) ne {}} {
9103 lappend tagloc($id) [lindex $arctags($a) end]
9106 if {$ta || $arctags($a) ne {}} {
9107 set tomark [list $d]
9108 for {set j 0} {$j < [llength $tomark]} {incr j} {
9109 set dd [lindex $tomark $j]
9110 if {![info exists hastaggedancestor($dd)]} {
9111 if {[info exists done($dd)]} {
9112 foreach b $arcnos($dd) {
9113 lappend tomark $arcstart($b)
9115 if {[info exists tagloc($dd)]} {
9118 } elseif {[info exists queued($dd)]} {
9121 set hastaggedancestor($dd) 1
9125 if {![info exists queued($d)]} {
9128 if {![info exists hastaggedancestor($d)]} {
9135 foreach id [array names tagloc] {
9136 if {![info exists hastaggedancestor($id)]} {
9137 foreach t $tagloc($id) {
9138 if {[lsearch -exact $tags $t] < 0} {
9144 set t2 [clock clicks -milliseconds]
9147 # remove tags that are descendents of other tags
9148 for {set i 0} {$i < [llength $tags]} {incr i} {
9149 set a [lindex $tags $i]
9150 for {set j 0} {$j < $i} {incr j} {
9151 set b [lindex $tags $j]
9152 set r [anc_or_desc $a $b]
9154 set tags [lreplace $tags $j $j]
9157 } elseif {$r == -1} {
9158 set tags [lreplace $tags $i $i]
9165 if {[array names growing] ne {}} {
9166 # graph isn't finished, need to check if any tag could get
9167 # eclipsed by another tag coming later. Simply ignore any
9168 # tags that could later get eclipsed.
9171 if {[is_certain $t $origid]} {
9175 if {$tags eq $ctags} {
9176 set cached_dtags($origid) $tags
9181 set cached_dtags($origid) $tags
9183 set t3 [clock clicks -milliseconds]
9184 if {0 && $t3 - $t1 >= 100} {
9185 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9186 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9192 global arcnos arcids arcout arcend arctags idtags allparents
9193 global growing cached_atags
9195 if {![info exists allparents($id)]} {
9198 set t1 [clock clicks -milliseconds]
9200 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9201 # part-way along an arc; check that arc first
9202 set a [lindex $arcnos($id) 0]
9203 if {$arctags($a) ne {}} {
9205 set i [lsearch -exact $arcids($a) $id]
9206 foreach t $arctags($a) {
9207 set j [lsearch -exact $arcids($a) $t]
9213 if {![info exists arcend($a)]} {
9217 if {[info exists idtags($id)]} {
9221 if {[info exists cached_atags($id)]} {
9222 return $cached_atags($id)
9230 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9231 set id [lindex $todo $i]
9233 set td [info exists hastaggeddescendent($id)]
9237 # ignore tags on starting node
9238 if {!$td && $i > 0} {
9239 if {[info exists idtags($id)]} {
9242 } elseif {[info exists cached_atags($id)]} {
9243 set tagloc($id) $cached_atags($id)
9247 foreach a $arcout($id) {
9248 if {!$td && $arctags($a) ne {}} {
9250 if {$arctags($a) ne {}} {
9251 lappend tagloc($id) [lindex $arctags($a) 0]
9254 if {![info exists arcend($a)]} continue
9256 if {$td || $arctags($a) ne {}} {
9257 set tomark [list $d]
9258 for {set j 0} {$j < [llength $tomark]} {incr j} {
9259 set dd [lindex $tomark $j]
9260 if {![info exists hastaggeddescendent($dd)]} {
9261 if {[info exists done($dd)]} {
9262 foreach b $arcout($dd) {
9263 if {[info exists arcend($b)]} {
9264 lappend tomark $arcend($b)
9267 if {[info exists tagloc($dd)]} {
9270 } elseif {[info exists queued($dd)]} {
9273 set hastaggeddescendent($dd) 1
9277 if {![info exists queued($d)]} {
9280 if {![info exists hastaggeddescendent($d)]} {
9286 set t2 [clock clicks -milliseconds]
9289 foreach id [array names tagloc] {
9290 if {![info exists hastaggeddescendent($id)]} {
9291 foreach t $tagloc($id) {
9292 if {[lsearch -exact $tags $t] < 0} {
9299 # remove tags that are ancestors of other tags
9300 for {set i 0} {$i < [llength $tags]} {incr i} {
9301 set a [lindex $tags $i]
9302 for {set j 0} {$j < $i} {incr j} {
9303 set b [lindex $tags $j]
9304 set r [anc_or_desc $a $b]
9306 set tags [lreplace $tags $j $j]
9309 } elseif {$r == 1} {
9310 set tags [lreplace $tags $i $i]
9317 if {[array names growing] ne {}} {
9318 # graph isn't finished, need to check if any tag could get
9319 # eclipsed by another tag coming later. Simply ignore any
9320 # tags that could later get eclipsed.
9323 if {[is_certain $origid $t]} {
9327 if {$tags eq $ctags} {
9328 set cached_atags($origid) $tags
9333 set cached_atags($origid) $tags
9335 set t3 [clock clicks -milliseconds]
9336 if {0 && $t3 - $t1 >= 100} {
9337 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9338 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9343 # Return the list of IDs that have heads that are descendents of id,
9344 # including id itself if it has a head.
9345 proc descheads {id} {
9346 global arcnos arcstart arcids archeads idheads cached_dheads
9349 if {![info exists allparents($id)]} {
9353 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9354 # part-way along an arc; check it first
9355 set a [lindex $arcnos($id) 0]
9356 if {$archeads($a) ne {}} {
9357 validate_archeads $a
9358 set i [lsearch -exact $arcids($a) $id]
9359 foreach t $archeads($a) {
9360 set j [lsearch -exact $arcids($a) $t]
9365 set id $arcstart($a)
9371 for {set i 0} {$i < [llength $todo]} {incr i} {
9372 set id [lindex $todo $i]
9373 if {[info exists cached_dheads($id)]} {
9374 set ret [concat $ret $cached_dheads($id)]
9376 if {[info exists idheads($id)]} {
9379 foreach a $arcnos($id) {
9380 if {$archeads($a) ne {}} {
9381 validate_archeads $a
9382 if {$archeads($a) ne {}} {
9383 set ret [concat $ret $archeads($a)]
9387 if {![info exists seen($d)]} {
9394 set ret [lsort -unique $ret]
9395 set cached_dheads($origid) $ret
9396 return [concat $ret $aret]
9399 proc addedtag {id} {
9400 global arcnos arcout cached_dtags cached_atags
9402 if {![info exists arcnos($id)]} return
9403 if {![info exists arcout($id)]} {
9404 recalcarc [lindex $arcnos($id) 0]
9406 catch {unset cached_dtags}
9407 catch {unset cached_atags}
9410 proc addedhead {hid head} {
9411 global arcnos arcout cached_dheads
9413 if {![info exists arcnos($hid)]} return
9414 if {![info exists arcout($hid)]} {
9415 recalcarc [lindex $arcnos($hid) 0]
9417 catch {unset cached_dheads}
9420 proc removedhead {hid head} {
9421 global cached_dheads
9423 catch {unset cached_dheads}
9426 proc movedhead {hid head} {
9427 global arcnos arcout cached_dheads
9429 if {![info exists arcnos($hid)]} return
9430 if {![info exists arcout($hid)]} {
9431 recalcarc [lindex $arcnos($hid) 0]
9433 catch {unset cached_dheads}
9436 proc changedrefs {} {
9437 global cached_dheads cached_dtags cached_atags
9438 global arctags archeads arcnos arcout idheads idtags
9440 foreach id [concat [array names idheads] [array names idtags]] {
9441 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9442 set a [lindex $arcnos($id) 0]
9443 if {![info exists donearc($a)]} {
9449 catch {unset cached_dtags}
9450 catch {unset cached_atags}
9451 catch {unset cached_dheads}
9454 proc rereadrefs {} {
9455 global idtags idheads idotherrefs mainheadid
9457 set refids [concat [array names idtags] \
9458 [array names idheads] [array names idotherrefs]]
9459 foreach id $refids {
9460 if {![info exists ref($id)]} {
9461 set ref($id) [listrefs $id]
9464 set oldmainhead $mainheadid
9467 set refids [lsort -unique [concat $refids [array names idtags] \
9468 [array names idheads] [array names idotherrefs]]]
9469 foreach id $refids {
9470 set v [listrefs $id]
9471 if {![info exists ref($id)] || $ref($id) != $v} {
9475 if {$oldmainhead ne $mainheadid} {
9476 redrawtags $oldmainhead
9477 redrawtags $mainheadid
9482 proc listrefs {id} {
9483 global idtags idheads idotherrefs
9486 if {[info exists idtags($id)]} {
9490 if {[info exists idheads($id)]} {
9494 if {[info exists idotherrefs($id)]} {
9495 set z $idotherrefs($id)
9497 return [list $x $y $z]
9500 proc showtag {tag isnew} {
9501 global ctext tagcontents tagids linknum tagobjid
9504 addtohistory [list showtag $tag 0]
9506 $ctext conf -state normal
9510 if {![info exists tagcontents($tag)]} {
9512 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9515 if {[info exists tagcontents($tag)]} {
9516 set text $tagcontents($tag)
9518 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9520 appendwithlinks $text {}
9521 $ctext conf -state disabled
9533 if {[info exists gitktmpdir]} {
9534 catch {file delete -force $gitktmpdir}
9538 proc mkfontdisp {font top which} {
9539 global fontattr fontpref $font
9541 set fontpref($font) [set $font]
9542 button $top.${font}but -text $which -font optionfont \
9543 -command [list choosefont $font $which]
9544 label $top.$font -relief flat -font $font \
9545 -text $fontattr($font,family) -justify left
9546 grid x $top.${font}but $top.$font -sticky w
9549 proc choosefont {font which} {
9550 global fontparam fontlist fonttop fontattr
9552 set fontparam(which) $which
9553 set fontparam(font) $font
9554 set fontparam(family) [font actual $font -family]
9555 set fontparam(size) $fontattr($font,size)
9556 set fontparam(weight) $fontattr($font,weight)
9557 set fontparam(slant) $fontattr($font,slant)
9560 if {![winfo exists $top]} {
9562 eval font config sample [font actual $font]
9564 wm title $top [mc "Gitk font chooser"]
9565 label $top.l -textvariable fontparam(which)
9566 pack $top.l -side top
9567 set fontlist [lsort [font families]]
9569 listbox $top.f.fam -listvariable fontlist \
9570 -yscrollcommand [list $top.f.sb set]
9571 bind $top.f.fam <<ListboxSelect>> selfontfam
9572 scrollbar $top.f.sb -command [list $top.f.fam yview]
9573 pack $top.f.sb -side right -fill y
9574 pack $top.f.fam -side left -fill both -expand 1
9575 pack $top.f -side top -fill both -expand 1
9577 spinbox $top.g.size -from 4 -to 40 -width 4 \
9578 -textvariable fontparam(size) \
9579 -validatecommand {string is integer -strict %s}
9580 checkbutton $top.g.bold -padx 5 \
9581 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9582 -variable fontparam(weight) -onvalue bold -offvalue normal
9583 checkbutton $top.g.ital -padx 5 \
9584 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9585 -variable fontparam(slant) -onvalue italic -offvalue roman
9586 pack $top.g.size $top.g.bold $top.g.ital -side left
9587 pack $top.g -side top
9588 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9590 $top.c create text 100 25 -anchor center -text $which -font sample \
9591 -fill black -tags text
9592 bind $top.c <Configure> [list centertext $top.c]
9593 pack $top.c -side top -fill x
9595 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9596 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9597 grid $top.buts.ok $top.buts.can
9598 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9599 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9600 pack $top.buts -side bottom -fill x
9601 trace add variable fontparam write chg_fontparam
9604 $top.c itemconf text -text $which
9606 set i [lsearch -exact $fontlist $fontparam(family)]
9608 $top.f.fam selection set $i
9613 proc centertext {w} {
9614 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9618 global fontparam fontpref prefstop
9620 set f $fontparam(font)
9621 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9622 if {$fontparam(weight) eq "bold"} {
9623 lappend fontpref($f) "bold"
9625 if {$fontparam(slant) eq "italic"} {
9626 lappend fontpref($f) "italic"
9629 $w conf -text $fontparam(family) -font $fontpref($f)
9635 global fonttop fontparam
9637 if {[info exists fonttop]} {
9638 catch {destroy $fonttop}
9639 catch {font delete sample}
9645 proc selfontfam {} {
9646 global fonttop fontparam
9648 set i [$fonttop.f.fam curselection]
9650 set fontparam(family) [$fonttop.f.fam get $i]
9654 proc chg_fontparam {v sub op} {
9657 font config sample -$sub $fontparam($sub)
9661 global maxwidth maxgraphpct
9662 global oldprefs prefstop showneartags showlocalchanges
9663 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
9664 global tabstop limitdiffs autoselect extdifftool perfile_attrs
9668 if {[winfo exists $top]} {
9672 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9673 limitdiffs tabstop perfile_attrs} {
9674 set oldprefs($v) [set $v]
9677 wm title $top [mc "Gitk preferences"]
9678 label $top.ldisp -text [mc "Commit list display options"]
9679 grid $top.ldisp - -sticky w -pady 10
9680 label $top.spacer -text " "
9681 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9683 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9684 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9685 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9687 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9688 grid x $top.maxpctl $top.maxpct -sticky w
9689 frame $top.showlocal
9690 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9691 checkbutton $top.showlocal.b -variable showlocalchanges
9692 pack $top.showlocal.b $top.showlocal.l -side left
9693 grid x $top.showlocal -sticky w
9694 frame $top.autoselect
9695 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9696 checkbutton $top.autoselect.b -variable autoselect
9697 pack $top.autoselect.b $top.autoselect.l -side left
9698 grid x $top.autoselect -sticky w
9700 label $top.ddisp -text [mc "Diff display options"]
9701 grid $top.ddisp - -sticky w -pady 10
9702 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9703 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9704 grid x $top.tabstopl $top.tabstop -sticky w
9706 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9707 checkbutton $top.ntag.b -variable showneartags
9708 pack $top.ntag.b $top.ntag.l -side left
9709 grid x $top.ntag -sticky w
9711 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9712 checkbutton $top.ldiff.b -variable limitdiffs
9713 pack $top.ldiff.b $top.ldiff.l -side left
9714 grid x $top.ldiff -sticky w
9716 label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
9717 checkbutton $top.lattr.b -variable perfile_attrs
9718 pack $top.lattr.b $top.lattr.l -side left
9719 grid x $top.lattr -sticky w
9721 entry $top.extdifft -textvariable extdifftool
9723 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9725 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9726 -command choose_extdiff
9727 pack $top.extdifff.l $top.extdifff.b -side left
9728 grid x $top.extdifff $top.extdifft -sticky w
9730 label $top.cdisp -text [mc "Colors: press to choose"]
9731 grid $top.cdisp - -sticky w -pady 10
9732 label $top.bg -padx 40 -relief sunk -background $bgcolor
9733 button $top.bgbut -text [mc "Background"] -font optionfont \
9734 -command [list choosecolor bgcolor {} $top.bg background setbg]
9735 grid x $top.bgbut $top.bg -sticky w
9736 label $top.fg -padx 40 -relief sunk -background $fgcolor
9737 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9738 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9739 grid x $top.fgbut $top.fg -sticky w
9740 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9741 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9742 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9743 [list $ctext tag conf d0 -foreground]]
9744 grid x $top.diffoldbut $top.diffold -sticky w
9745 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9746 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9747 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9748 [list $ctext tag conf dresult -foreground]]
9749 grid x $top.diffnewbut $top.diffnew -sticky w
9750 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9751 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9752 -command [list choosecolor diffcolors 2 $top.hunksep \
9753 "diff hunk header" \
9754 [list $ctext tag conf hunksep -foreground]]
9755 grid x $top.hunksepbut $top.hunksep -sticky w
9756 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
9757 button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
9758 -command [list choosecolor markbgcolor {} $top.markbgsep \
9759 [mc "marked line background"] \
9760 [list $ctext tag conf omark -background]]
9761 grid x $top.markbgbut $top.markbgsep -sticky w
9762 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9763 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9764 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9765 grid x $top.selbgbut $top.selbgsep -sticky w
9767 label $top.cfont -text [mc "Fonts: press to choose"]
9768 grid $top.cfont - -sticky w -pady 10
9769 mkfontdisp mainfont $top [mc "Main font"]
9770 mkfontdisp textfont $top [mc "Diff display font"]
9771 mkfontdisp uifont $top [mc "User interface font"]
9774 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9775 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9776 grid $top.buts.ok $top.buts.can
9777 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9778 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9779 grid $top.buts - - -pady 10 -sticky ew
9780 bind $top <Visibility> "focus $top.buts.ok"
9783 proc choose_extdiff {} {
9786 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9788 set extdifftool $prog
9792 proc choosecolor {v vi w x cmd} {
9795 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9796 -title [mc "Gitk: choose color for %s" $x]]
9797 if {$c eq {}} return
9798 $w conf -background $c
9804 global bglist cflist
9806 $w configure -selectbackground $c
9808 $cflist tag configure highlight \
9809 -background [$cflist cget -selectbackground]
9810 allcanvs itemconf secsel -fill $c
9817 $w conf -background $c
9825 $w conf -foreground $c
9827 allcanvs itemconf text -fill $c
9828 $canv itemconf circle -outline $c
9832 global oldprefs prefstop
9834 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9835 limitdiffs tabstop perfile_attrs} {
9837 set $v $oldprefs($v)
9839 catch {destroy $prefstop}
9845 global maxwidth maxgraphpct
9846 global oldprefs prefstop showneartags showlocalchanges
9847 global fontpref mainfont textfont uifont
9848 global limitdiffs treediffs perfile_attrs
9850 catch {destroy $prefstop}
9854 if {$mainfont ne $fontpref(mainfont)} {
9855 set mainfont $fontpref(mainfont)
9856 parsefont mainfont $mainfont
9857 eval font configure mainfont [fontflags mainfont]
9858 eval font configure mainfontbold [fontflags mainfont 1]
9862 if {$textfont ne $fontpref(textfont)} {
9863 set textfont $fontpref(textfont)
9864 parsefont textfont $textfont
9865 eval font configure textfont [fontflags textfont]
9866 eval font configure textfontbold [fontflags textfont 1]
9868 if {$uifont ne $fontpref(uifont)} {
9869 set uifont $fontpref(uifont)
9870 parsefont uifont $uifont
9871 eval font configure uifont [fontflags uifont]
9874 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9875 if {$showlocalchanges} {
9881 if {$limitdiffs != $oldprefs(limitdiffs) ||
9882 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
9883 # treediffs elements are limited by path;
9884 # won't have encodings cached if perfile_attrs was just turned on
9885 catch {unset treediffs}
9887 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9888 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9890 } elseif {$showneartags != $oldprefs(showneartags) ||
9891 $limitdiffs != $oldprefs(limitdiffs)} {
9896 proc formatdate {d} {
9897 global datetimeformat
9899 set d [clock format $d -format $datetimeformat]
9904 # This list of encoding names and aliases is distilled from
9905 # http://www.iana.org/assignments/character-sets.
9906 # Not all of them are supported by Tcl.
9907 set encoding_aliases {
9908 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9909 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9910 { ISO-10646-UTF-1 csISO10646UTF1 }
9911 { ISO_646.basic:1983 ref csISO646basic1983 }
9912 { INVARIANT csINVARIANT }
9913 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9914 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9915 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9916 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9917 { NATS-DANO iso-ir-9-1 csNATSDANO }
9918 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9919 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9920 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9921 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9922 { ISO-2022-KR csISO2022KR }
9924 { ISO-2022-JP csISO2022JP }
9925 { ISO-2022-JP-2 csISO2022JP2 }
9926 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9928 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9929 { IT iso-ir-15 ISO646-IT csISO15Italian }
9930 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9931 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9932 { greek7-old iso-ir-18 csISO18Greek7Old }
9933 { latin-greek iso-ir-19 csISO19LatinGreek }
9934 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9935 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9936 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9937 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9938 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9939 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9940 { INIS iso-ir-49 csISO49INIS }
9941 { INIS-8 iso-ir-50 csISO50INIS8 }
9942 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9943 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9944 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9945 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9946 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9947 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9949 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9950 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9951 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9952 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9953 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9954 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9955 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9956 { greek7 iso-ir-88 csISO88Greek7 }
9957 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9958 { iso-ir-90 csISO90 }
9959 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9960 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9961 csISO92JISC62991984b }
9962 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9963 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9964 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9965 csISO95JIS62291984handadd }
9966 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9967 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9968 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9969 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9971 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9972 { T.61-7bit iso-ir-102 csISO102T617bit }
9973 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9974 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9975 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9976 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9977 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9978 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9979 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9980 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9981 arabic csISOLatinArabic }
9982 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9983 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9984 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9985 greek greek8 csISOLatinGreek }
9986 { T.101-G2 iso-ir-128 csISO128T101G2 }
9987 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9989 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9990 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9991 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9992 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9993 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9994 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9995 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9996 csISOLatinCyrillic }
9997 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9998 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9999 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10000 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10001 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10002 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10003 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10004 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10005 { ISO_10367-box iso-ir-155 csISO10367Box }
10006 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10007 { latin-lap lap iso-ir-158 csISO158Lap }
10008 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10009 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10012 { JIS_X0201 X0201 csHalfWidthKatakana }
10013 { KSC5636 ISO646-KR csKSC5636 }
10014 { ISO-10646-UCS-2 csUnicode }
10015 { ISO-10646-UCS-4 csUCS4 }
10016 { DEC-MCS dec csDECMCS }
10017 { hp-roman8 roman8 r8 csHPRoman8 }
10018 { macintosh mac csMacintosh }
10019 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10021 { IBM038 EBCDIC-INT cp038 csIBM038 }
10022 { IBM273 CP273 csIBM273 }
10023 { IBM274 EBCDIC-BE CP274 csIBM274 }
10024 { IBM275 EBCDIC-BR cp275 csIBM275 }
10025 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10026 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10027 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10028 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10029 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10030 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10031 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10032 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10033 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10034 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10035 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10036 { IBM437 cp437 437 csPC8CodePage437 }
10037 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10038 { IBM775 cp775 csPC775Baltic }
10039 { IBM850 cp850 850 csPC850Multilingual }
10040 { IBM851 cp851 851 csIBM851 }
10041 { IBM852 cp852 852 csPCp852 }
10042 { IBM855 cp855 855 csIBM855 }
10043 { IBM857 cp857 857 csIBM857 }
10044 { IBM860 cp860 860 csIBM860 }
10045 { IBM861 cp861 861 cp-is csIBM861 }
10046 { IBM862 cp862 862 csPC862LatinHebrew }
10047 { IBM863 cp863 863 csIBM863 }
10048 { IBM864 cp864 csIBM864 }
10049 { IBM865 cp865 865 csIBM865 }
10050 { IBM866 cp866 866 csIBM866 }
10051 { IBM868 CP868 cp-ar csIBM868 }
10052 { IBM869 cp869 869 cp-gr csIBM869 }
10053 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10054 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10055 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10056 { IBM891 cp891 csIBM891 }
10057 { IBM903 cp903 csIBM903 }
10058 { IBM904 cp904 904 csIBBM904 }
10059 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10060 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10061 { IBM1026 CP1026 csIBM1026 }
10062 { EBCDIC-AT-DE csIBMEBCDICATDE }
10063 { EBCDIC-AT-DE-A csEBCDICATDEA }
10064 { EBCDIC-CA-FR csEBCDICCAFR }
10065 { EBCDIC-DK-NO csEBCDICDKNO }
10066 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10067 { EBCDIC-FI-SE csEBCDICFISE }
10068 { EBCDIC-FI-SE-A csEBCDICFISEA }
10069 { EBCDIC-FR csEBCDICFR }
10070 { EBCDIC-IT csEBCDICIT }
10071 { EBCDIC-PT csEBCDICPT }
10072 { EBCDIC-ES csEBCDICES }
10073 { EBCDIC-ES-A csEBCDICESA }
10074 { EBCDIC-ES-S csEBCDICESS }
10075 { EBCDIC-UK csEBCDICUK }
10076 { EBCDIC-US csEBCDICUS }
10077 { UNKNOWN-8BIT csUnknown8BiT }
10078 { MNEMONIC csMnemonic }
10080 { VISCII csVISCII }
10083 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10084 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10085 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10086 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10087 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10088 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10089 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10090 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10091 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10092 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10093 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10094 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10095 { IBM1047 IBM-1047 }
10096 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10097 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10098 { UNICODE-1-1 csUnicode11 }
10099 { CESU-8 csCESU-8 }
10100 { BOCU-1 csBOCU-1 }
10101 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10102 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10104 { ISO-8859-15 ISO_8859-15 Latin-9 }
10105 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10106 { GBK CP936 MS936 windows-936 }
10107 { JIS_Encoding csJISEncoding }
10108 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10109 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10111 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10112 { ISO-10646-UCS-Basic csUnicodeASCII }
10113 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10114 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10115 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10116 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10117 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10118 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10119 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10120 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10121 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10122 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10123 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10124 { Ventura-US csVenturaUS }
10125 { Ventura-International csVenturaInternational }
10126 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10127 { PC8-Turkish csPC8Turkish }
10128 { IBM-Symbols csIBMSymbols }
10129 { IBM-Thai csIBMThai }
10130 { HP-Legal csHPLegal }
10131 { HP-Pi-font csHPPiFont }
10132 { HP-Math8 csHPMath8 }
10133 { Adobe-Symbol-Encoding csHPPSMath }
10134 { HP-DeskTop csHPDesktop }
10135 { Ventura-Math csVenturaMath }
10136 { Microsoft-Publishing csMicrosoftPublishing }
10137 { Windows-31J csWindows31J }
10138 { GB2312 csGB2312 }
10142 proc tcl_encoding {enc} {
10143 global encoding_aliases tcl_encoding_cache
10144 if {[info exists tcl_encoding_cache($enc)]} {
10145 return $tcl_encoding_cache($enc)
10147 set names [encoding names]
10148 set lcnames [string tolower $names]
10149 set enc [string tolower $enc]
10150 set i [lsearch -exact $lcnames $enc]
10152 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10153 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10154 set i [lsearch -exact $lcnames $encx]
10158 foreach l $encoding_aliases {
10159 set ll [string tolower $l]
10160 if {[lsearch -exact $ll $enc] < 0} continue
10161 # look through the aliases for one that tcl knows about
10163 set i [lsearch -exact $lcnames $e]
10165 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10166 set i [lsearch -exact $lcnames $ex]
10176 set tclenc [lindex $names $i]
10178 set tcl_encoding_cache($enc) $tclenc
10182 proc gitattr {path attr default} {
10183 global path_attr_cache
10184 if {[info exists path_attr_cache($attr,$path)]} {
10185 set r $path_attr_cache($attr,$path)
10187 set r "unspecified"
10188 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10189 regexp "(.*): encoding: (.*)" $line m f r
10191 set path_attr_cache($attr,$path) $r
10193 if {$r eq "unspecified"} {
10199 proc cache_gitattr {attr pathlist} {
10200 global path_attr_cache
10202 foreach path $pathlist {
10203 if {![info exists path_attr_cache($attr,$path)]} {
10204 lappend newlist $path
10208 if {[tk windowingsystem] == "win32"} {
10209 # windows has a 32k limit on the arguments to a command...
10212 while {$newlist ne {}} {
10213 set head [lrange $newlist 0 [expr {$lim - 1}]]
10214 set newlist [lrange $newlist $lim end]
10215 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10216 foreach row [split $rlist "\n"] {
10217 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10218 if {[string index $path 0] eq "\""} {
10219 set path [encoding convertfrom [lindex $path 0]]
10221 set path_attr_cache($attr,$path) $value
10228 proc get_path_encoding {path} {
10229 global gui_encoding perfile_attrs
10230 set tcl_enc $gui_encoding
10231 if {$path ne {} && $perfile_attrs} {
10232 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10240 # First check that Tcl/Tk is recent enough
10241 if {[catch {package require Tk 8.4} err]} {
10242 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10243 Gitk requires at least Tcl/Tk 8.4."]
10248 set wrcomcmd "git diff-tree --stdin -p --pretty"
10252 set gitencoding [exec git config --get i18n.commitencoding]
10254 if {$gitencoding == ""} {
10255 set gitencoding "utf-8"
10257 set tclencoding [tcl_encoding $gitencoding]
10258 if {$tclencoding == {}} {
10259 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10262 set gui_encoding [encoding system]
10264 set enc [exec git config --get gui.encoding]
10266 set tclenc [tcl_encoding $enc]
10267 if {$tclenc ne {}} {
10268 set gui_encoding $tclenc
10270 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10275 set mainfont {Helvetica 9}
10276 set textfont {Courier 9}
10277 set uifont {Helvetica 9 bold}
10279 set findmergefiles 0
10287 set cmitmode "patch"
10288 set wrapcomment "none"
10292 set showlocalchanges 1
10294 set datetimeformat "%Y-%m-%d %H:%M:%S"
10296 set perfile_attrs 0
10298 set extdifftool "meld"
10300 set colors {green red blue magenta darkgrey brown orange}
10303 set diffcolors {red "#00a000" blue}
10306 set selectbgcolor gray85
10307 set markbgcolor "#e0e0ff"
10309 set circlecolors {white blue gray blue blue}
10311 # button for popping up context menus
10312 if {[tk windowingsystem] eq "aqua"} {
10313 set ctxbut <Button-2>
10315 set ctxbut <Button-3>
10318 ## For msgcat loading, first locate the installation location.
10319 if { [info exists ::env(GITK_MSGSDIR)] } {
10320 ## Msgsdir was manually set in the environment.
10321 set gitk_msgsdir $::env(GITK_MSGSDIR)
10323 ## Let's guess the prefix from argv0.
10324 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10325 set gitk_libdir [file join $gitk_prefix share gitk lib]
10326 set gitk_msgsdir [file join $gitk_libdir msgs]
10330 ## Internationalization (i18n) through msgcat and gettext. See
10331 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10332 package require msgcat
10333 namespace import ::msgcat::mc
10334 ## And eventually load the actual message catalog
10335 ::msgcat::mcload $gitk_msgsdir
10337 catch {source ~/.gitk}
10339 font create optionfont -family sans-serif -size -12
10341 parsefont mainfont $mainfont
10342 eval font create mainfont [fontflags mainfont]
10343 eval font create mainfontbold [fontflags mainfont 1]
10345 parsefont textfont $textfont
10346 eval font create textfont [fontflags textfont]
10347 eval font create textfontbold [fontflags textfont 1]
10349 parsefont uifont $uifont
10350 eval font create uifont [fontflags uifont]
10354 # check that we can find a .git directory somewhere...
10355 if {[catch {set gitdir [gitdir]}]} {
10356 show_error {} . [mc "Cannot find a git repository here."]
10359 if {![file isdirectory $gitdir]} {
10360 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10365 set selectheadid {}
10368 set cmdline_files {}
10370 set revtreeargscmd {}
10371 foreach arg $argv {
10372 switch -glob -- $arg {
10375 set cmdline_files [lrange $argv [expr {$i + 1}] end]
10378 "--select-commit=*" {
10379 set selecthead [string range $arg 16 end]
10382 set revtreeargscmd [string range $arg 10 end]
10385 lappend revtreeargs $arg
10391 if {$selecthead eq "HEAD"} {
10395 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10396 # no -- on command line, but some arguments (other than --argscmd)
10398 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10399 set cmdline_files [split $f "\n"]
10400 set n [llength $cmdline_files]
10401 set revtreeargs [lrange $revtreeargs 0 end-$n]
10402 # Unfortunately git rev-parse doesn't produce an error when
10403 # something is both a revision and a filename. To be consistent
10404 # with git log and git rev-list, check revtreeargs for filenames.
10405 foreach arg $revtreeargs {
10406 if {[file exists $arg]} {
10407 show_error {} . [mc "Ambiguous argument '%s': both revision\
10408 and filename" $arg]
10413 # unfortunately we get both stdout and stderr in $err,
10414 # so look for "fatal:".
10415 set i [string first "fatal:" $err]
10417 set err [string range $err [expr {$i + 6}] end]
10419 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10424 set nullid "0000000000000000000000000000000000000000"
10425 set nullid2 "0000000000000000000000000000000000000001"
10426 set nullfile "/dev/null"
10428 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10435 set highlight_paths {}
10437 set searchdirn -forwards
10439 set boldnamerows {}
10440 set diffelide {0 0}
10441 set markingmatches 0
10442 set linkentercount 0
10443 set need_redisplay 0
10450 set selectedhlview [mc "None"]
10451 set highlight_related [mc "None"]
10452 set highlight_files {}
10453 set viewfiles(0) {}
10456 set viewargscmd(0) {}
10458 set selectedline {}
10466 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10469 # wait for the window to become visible
10470 tkwait visibility .
10471 wm title . "[file tail $argv0]: [file tail [pwd]]"
10474 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10475 # create a view for the files/dirs specified on the command line
10479 set viewname(1) [mc "Command line"]
10480 set viewfiles(1) $cmdline_files
10481 set viewargs(1) $revtreeargs
10482 set viewargscmd(1) $revtreeargscmd
10486 .bar.view entryconf [mca "Edit view..."] -state normal
10487 .bar.view entryconf [mca "Delete view"] -state normal
10490 if {[info exists permviews]} {
10491 foreach v $permviews {
10494 set viewname($n) [lindex $v 0]
10495 set viewfiles($n) [lindex $v 1]
10496 set viewargs($n) [lindex $v 2]
10497 set viewargscmd($n) [lindex $v 3]