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.
28 if {[info exists isonrunq
($script)]} return
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
{}
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]
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 repeat
[eval $script]
71 set t1
[clock clicks
-milliseconds]
72 set t
[expr {$t1 - $t0}]
73 set runq
[lrange
$runq 1 end
]
74 if {$repeat ne
{} && $repeat} {
75 if {$fd eq
{} ||
$repeat == 2} {
76 # script returns 1 if it wants to be readded
77 # file readers return 2 if they could do more straight away
78 lappend runq
[list
$fd $script]
80 fileevent
$fd readable
[list filereadable
$fd $script]
82 } elseif
{$fd eq
{}} {
83 unset isonrunq
($script)
86 if {$t1 - $tstart >= 80} break
93 proc reg_instance
{fd
} {
94 global commfd leftover loginstance
96 set i
[incr loginstance
]
102 proc unmerged_files
{files
} {
105 # find the list of unmerged files
109 set fd
[open
"| git ls-files -u" r
]
111 show_error
{} .
"[mc "Couldn
't get list of unmerged files:"] $err"
114 while {[gets $fd line] >= 0} {
115 set i [string first "\t" $line]
117 set fname [string range $line [expr {$i+1}] end]
118 if {[lsearch -exact $mlist $fname] >= 0} continue
120 if {$files eq {} || [path_filter $files $fname]} {
128 proc parseviewargs {n arglist} {
129 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
137 set origargs $arglist
141 foreach arg $arglist {
148 switch -glob -- $arg {
152 # remove from origargs in case we hit an unknown option
153 set origargs [lreplace $origargs $i $i]
156 # These request or affect diff output, which we don't want.
157 # Some could be used to set our defaults for diff display.
159 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163 "--ignore-space-change" - "-U*" - "--unified=*" {
164 lappend diffargs
$arg
166 # These cause our parsing of git log's output to fail, or else
167 # they're options we want to set ourselves, so ignore them.
168 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169 "--name-only" - "--name-status" - "--color" - "--color-words" -
170 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174 "--objects" - "--objects-edge" - "--reverse" {
176 # These are harmless, and some are even useful
177 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
178 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
179 "--full-history" - "--dense" - "--sparse" -
180 "--follow" - "--left-right" - "--encoding=*" {
183 # These mean that we get a subset of the commits
184 "--diff-filter=*" - "--no-merges" - "--unpacked" -
185 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
186 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
187 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
188 "--remove-empty" - "--first-parent" - "--cherry-pick" -
189 "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
193 # This appears to be the only one that has a value as a
194 # separate word following it
201 set notflag
[expr {!$notflag}]
209 # git rev-parse doesn't understand --merge
210 lappend revargs
--gitk-symmetric-diff-marker MERGE_HEAD...HEAD
212 # Other flag arguments including -<n>
214 if {[string is digit
-strict [string range
$arg 1 end
]]} {
217 # a flag argument that we don't recognize;
218 # that means we can't optimize
223 # Non-flag arguments specify commits or ranges of commits
225 if {[string match
"*...*" $arg]} {
226 lappend revargs
--gitk-symmetric-diff-marker
232 set vdflags
($n) $diffargs
233 set vflags
($n) $glflags
234 set vrevs
($n) $revargs
235 set vfiltered
($n) $filtered
236 set vorigargs
($n) $origargs
240 proc parseviewrevs
{view revs
} {
241 global vposids vnegids
246 if {[catch
{set ids
[eval exec git rev-parse
$revs]} err
]} {
247 # we get stdout followed by stderr in $err
248 # for an unknown rev, git rev-parse echoes it and then errors out
249 set errlines
[split $err "\n"]
251 for {set l
0} {$l < [llength
$errlines]} {incr l
} {
252 set line
[lindex
$errlines $l]
253 if {!([string length
$line] == 40 && [string is xdigit
$line])} {
254 if {[string match
"fatal:*" $line]} {
255 if {[string match
"fatal: ambiguous argument*" $line]
257 if {[llength
$badrev] == 1} {
258 set err
"unknown revision $badrev"
260 set err
"unknown revisions: [join $badrev ", "]"
263 set err
[join [lrange
$errlines $l end
] "\n"]
270 error_popup
"Error parsing revisions: $err"
277 foreach id
[split $ids "\n"] {
278 if {$id eq
"--gitk-symmetric-diff-marker"} {
280 } elseif
{[string match
"^*" $id]} {
287 lappend neg
[string range
$id 1 end
]
292 lset ret end
[lindex
$ret end
]...
$id
298 set vposids
($view) $pos
299 set vnegids
($view) $neg
303 # Start off a git log process and arrange to read its output
304 proc start_rev_list
{view
} {
305 global startmsecs commitidx viewcomplete curview
307 global viewargs viewargscmd viewfiles vfilelimit
308 global showlocalchanges commitinterest
309 global viewactive viewinstances vmergeonly
310 global pending_select mainheadid
311 global vcanopt vflags vrevs vorigargs
313 set startmsecs
[clock clicks
-milliseconds]
314 set commitidx
($view) 0
315 # these are set this way for the error exits
316 set viewcomplete
($view) 1
317 set viewactive
($view) 0
320 set args
$viewargs($view)
321 if {$viewargscmd($view) ne
{}} {
323 set str
[exec sh
-c $viewargscmd($view)]
325 error_popup
"Error executing --argscmd command: $err"
328 set args
[concat
$args [split $str "\n"]]
330 set vcanopt
($view) [parseviewargs
$view $args]
332 set files
$viewfiles($view)
333 if {$vmergeonly($view)} {
334 set files
[unmerged_files
$files]
337 if {$nr_unmerged == 0} {
338 error_popup
[mc
"No files selected: --merge specified but\
339 no files are unmerged."]
341 error_popup
[mc
"No files selected: --merge specified but\
342 no unmerged files are within file limit."]
347 set vfilelimit
($view) $files
349 if {$vcanopt($view)} {
350 set revs
[parseviewrevs
$view $vrevs($view)]
354 set args
[concat
$vflags($view) $revs]
356 set args
$vorigargs($view)
360 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
361 --boundary $args "--" $files] r
]
363 error_popup
"[mc "Error executing git log
:"] $err"
366 set i
[reg_instance
$fd]
367 set viewinstances
($view) [list
$i]
368 if {$showlocalchanges && $mainheadid ne
{}} {
369 lappend commitinterest
($mainheadid) {dodiffindex
}
371 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
372 if {$tclencoding != {}} {
373 fconfigure
$fd -encoding $tclencoding
375 filerun
$fd [list getcommitlines
$fd $i $view 0]
376 nowbusy
$view [mc
"Reading"]
377 if {$view == $curview} {
378 set pending_select
$mainheadid
380 set viewcomplete
($view) 0
381 set viewactive
($view) 1
385 proc stop_instance
{inst
} {
386 global commfd leftover
388 set fd
$commfd($inst)
392 if {$
::tcl_platform
(platform
) eq
{windows
}} {
401 unset leftover
($inst)
404 proc stop_backends
{} {
407 foreach inst
[array names commfd
] {
412 proc stop_rev_list
{view
} {
415 foreach inst
$viewinstances($view) {
418 set viewinstances
($view) {}
422 global canv curview need_redisplay viewactive
425 if {[start_rev_list
$curview]} {
426 show_status
[mc
"Reading commits..."]
429 show_status
[mc
"No commits selected"]
433 proc updatecommits
{} {
434 global curview vcanopt vorigargs vfilelimit viewinstances
435 global viewactive viewcomplete tclencoding
436 global startmsecs showneartags showlocalchanges
437 global mainheadid pending_select
439 global varcid vposids vnegids vflags vrevs
441 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
442 set oldmainid
$mainheadid
444 if {$showlocalchanges} {
445 if {$mainheadid ne
$oldmainid} {
448 if {[commitinview
$mainheadid $curview]} {
453 if {$vcanopt($view)} {
454 set oldpos
$vposids($view)
455 set oldneg
$vnegids($view)
456 set revs
[parseviewrevs
$view $vrevs($view)]
460 # note: getting the delta when negative refs change is hard,
461 # and could require multiple git log invocations, so in that
462 # case we ask git log for all the commits (not just the delta)
463 if {$oldneg eq
$vnegids($view)} {
466 # take out positive refs that we asked for before or
467 # that we have already seen
469 if {[string length
$rev] == 40} {
470 if {[lsearch
-exact $oldpos $rev] < 0
471 && ![info exists varcid
($view,$rev)]} {
476 lappend
$newrevs $rev
479 if {$npos == 0} return
481 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
483 set args
[concat
$vflags($view) $revs --not $oldpos]
485 set args
$vorigargs($view)
488 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
489 --boundary $args "--" $vfilelimit($view)] r
]
491 error_popup
"Error executing git log: $err"
494 if {$viewactive($view) == 0} {
495 set startmsecs
[clock clicks
-milliseconds]
497 set i
[reg_instance
$fd]
498 lappend viewinstances
($view) $i
499 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
500 if {$tclencoding != {}} {
501 fconfigure
$fd -encoding $tclencoding
503 filerun
$fd [list getcommitlines
$fd $i $view 1]
504 incr viewactive
($view)
505 set viewcomplete
($view) 0
506 set pending_select
$mainheadid
507 nowbusy
$view "Reading"
513 proc reloadcommits
{} {
514 global curview viewcomplete selectedline currentid thickerline
515 global showneartags treediffs commitinterest cached_commitrow
518 if {!$viewcomplete($curview)} {
519 stop_rev_list
$curview
523 catch
{unset currentid
}
524 catch
{unset thickerline
}
525 catch
{unset treediffs
}
532 catch
{unset commitinterest
}
533 catch
{unset cached_commitrow
}
534 catch
{unset targetid
}
540 # This makes a string representation of a positive integer which
541 # sorts as a string in numerical order
544 return [format
"%x" $n]
545 } elseif
{$n < 256} {
546 return [format
"x%.2x" $n]
547 } elseif
{$n < 65536} {
548 return [format
"y%.4x" $n]
550 return [format
"z%.8x" $n]
553 # Procedures used in reordering commits from git log (without
554 # --topo-order) into the order for display.
556 proc varcinit
{view
} {
557 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
558 global vtokmod varcmod vrowmod varcix vlastins
560 set varcstart
($view) {{}}
561 set vupptr
($view) {0}
562 set vdownptr
($view) {0}
563 set vleftptr
($view) {0}
564 set vbackptr
($view) {0}
565 set varctok
($view) {{}}
566 set varcrow
($view) {{}}
567 set vtokmod
($view) {}
570 set varcix
($view) {{}}
571 set vlastins
($view) {0}
574 proc resetvarcs
{view
} {
575 global varcid varccommits parents children vseedcount ordertok
577 foreach vid
[array names varcid
$view,*] {
582 # some commits might have children but haven't been seen yet
583 foreach vid
[array names children
$view,*] {
586 foreach va
[array names varccommits
$view,*] {
587 unset varccommits
($va)
589 foreach vd
[array names vseedcount
$view,*] {
590 unset vseedcount
($vd)
592 catch
{unset ordertok
}
595 # returns a list of the commits with no children
597 global vdownptr vleftptr varcstart
600 set a
[lindex
$vdownptr($v) 0]
602 lappend ret
[lindex
$varcstart($v) $a]
603 set a
[lindex
$vleftptr($v) $a]
608 proc newvarc
{view id
} {
609 global varcid varctok parents children vdatemode
610 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
611 global commitdata commitinfo vseedcount varccommits vlastins
613 set a
[llength
$varctok($view)]
615 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
616 if {![info exists commitinfo
($id)]} {
617 parsecommit
$id $commitdata($id) 1
619 set cdate
[lindex
$commitinfo($id) 4]
620 if {![string is integer
-strict $cdate]} {
623 if {![info exists vseedcount
($view,$cdate)]} {
624 set vseedcount
($view,$cdate) -1
626 set c
[incr vseedcount
($view,$cdate)]
627 set cdate
[expr {$cdate ^
0xffffffff}]
628 set tok
"s[strrep $cdate][strrep $c]"
633 if {[llength
$children($vid)] > 0} {
634 set kid
[lindex
$children($vid) end
]
635 set k
$varcid($view,$kid)
636 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
639 set tok
[lindex
$varctok($view) $k]
643 set i
[lsearch
-exact $parents($view,$ki) $id]
644 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
645 append tok
[strrep
$j]
647 set c
[lindex
$vlastins($view) $ka]
648 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
650 set b
[lindex
$vdownptr($view) $ka]
652 set b
[lindex
$vleftptr($view) $c]
654 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
656 set b
[lindex
$vleftptr($view) $c]
659 lset vdownptr
($view) $ka $a
660 lappend vbackptr
($view) 0
662 lset vleftptr
($view) $c $a
663 lappend vbackptr
($view) $c
665 lset vlastins
($view) $ka $a
666 lappend vupptr
($view) $ka
667 lappend vleftptr
($view) $b
669 lset vbackptr
($view) $b $a
671 lappend varctok
($view) $tok
672 lappend varcstart
($view) $id
673 lappend vdownptr
($view) 0
674 lappend varcrow
($view) {}
675 lappend varcix
($view) {}
676 set varccommits
($view,$a) {}
677 lappend vlastins
($view) 0
681 proc splitvarc
{p v
} {
682 global varcid varcstart varccommits varctok
683 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
685 set oa
$varcid($v,$p)
686 set ac
$varccommits($v,$oa)
687 set i
[lsearch
-exact $varccommits($v,$oa) $p]
689 set na
[llength
$varctok($v)]
690 # "%" sorts before "0"...
691 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
692 lappend varctok
($v) $tok
693 lappend varcrow
($v) {}
694 lappend varcix
($v) {}
695 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
696 set varccommits
($v,$na) [lrange
$ac $i end
]
697 lappend varcstart
($v) $p
698 foreach id
$varccommits($v,$na) {
699 set varcid
($v,$id) $na
701 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
702 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
703 lset vdownptr
($v) $oa $na
704 lset vlastins
($v) $oa 0
705 lappend vupptr
($v) $oa
706 lappend vleftptr
($v) 0
707 lappend vbackptr
($v) 0
708 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
709 lset vupptr
($v) $b $na
713 proc renumbervarc
{a v
} {
714 global parents children varctok varcstart varccommits
715 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
717 set t1
[clock clicks
-milliseconds]
723 if {[info exists isrelated
($a)]} {
725 set id
[lindex
$varccommits($v,$a) end
]
726 foreach p
$parents($v,$id) {
727 if {[info exists varcid
($v,$p)]} {
728 set isrelated
($varcid($v,$p)) 1
733 set b
[lindex
$vdownptr($v) $a]
736 set b
[lindex
$vleftptr($v) $a]
738 set a
[lindex
$vupptr($v) $a]
744 if {![info exists kidchanged
($a)]} continue
745 set id
[lindex
$varcstart($v) $a]
746 if {[llength
$children($v,$id)] > 1} {
747 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
750 set oldtok
[lindex
$varctok($v) $a]
751 if {!$vdatemode($v)} {
757 set kid
[last_real_child
$v,$id]
759 set k
$varcid($v,$kid)
760 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
763 set tok
[lindex
$varctok($v) $k]
767 set i
[lsearch
-exact $parents($v,$ki) $id]
768 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
769 append tok
[strrep
$j]
771 if {$tok eq
$oldtok} {
774 set id
[lindex
$varccommits($v,$a) end
]
775 foreach p
$parents($v,$id) {
776 if {[info exists varcid
($v,$p)]} {
777 set kidchanged
($varcid($v,$p)) 1
782 lset varctok
($v) $a $tok
783 set b
[lindex
$vupptr($v) $a]
785 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
788 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
791 set c
[lindex
$vbackptr($v) $a]
792 set d
[lindex
$vleftptr($v) $a]
794 lset vdownptr
($v) $b $d
796 lset vleftptr
($v) $c $d
799 lset vbackptr
($v) $d $c
801 if {[lindex
$vlastins($v) $b] == $a} {
802 lset vlastins
($v) $b $c
804 lset vupptr
($v) $a $ka
805 set c
[lindex
$vlastins($v) $ka]
807 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
809 set b
[lindex
$vdownptr($v) $ka]
811 set b
[lindex
$vleftptr($v) $c]
814 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
816 set b
[lindex
$vleftptr($v) $c]
819 lset vdownptr
($v) $ka $a
820 lset vbackptr
($v) $a 0
822 lset vleftptr
($v) $c $a
823 lset vbackptr
($v) $a $c
825 lset vleftptr
($v) $a $b
827 lset vbackptr
($v) $b $a
829 lset vlastins
($v) $ka $a
832 foreach id
[array names sortkids
] {
833 if {[llength
$children($v,$id)] > 1} {
834 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
838 set t2
[clock clicks
-milliseconds]
839 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
842 # Fix up the graph after we have found out that in view $v,
843 # $p (a commit that we have already seen) is actually the parent
844 # of the last commit in arc $a.
845 proc fix_reversal
{p a v
} {
846 global varcid varcstart varctok vupptr
848 set pa
$varcid($v,$p)
849 if {$p ne
[lindex
$varcstart($v) $pa]} {
851 set pa
$varcid($v,$p)
853 # seeds always need to be renumbered
854 if {[lindex
$vupptr($v) $pa] == 0 ||
855 [string compare
[lindex
$varctok($v) $a] \
856 [lindex
$varctok($v) $pa]] > 0} {
861 proc insertrow
{id p v
} {
862 global cmitlisted children parents varcid varctok vtokmod
863 global varccommits ordertok commitidx numcommits curview
864 global targetid targetrow
868 set cmitlisted
($vid) 1
869 set children
($vid) {}
870 set parents
($vid) [list
$p]
871 set a
[newvarc
$v $id]
873 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
876 lappend varccommits
($v,$a) $id
878 if {[llength
[lappend children
($vp) $id]] > 1} {
879 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
880 catch
{unset ordertok
}
882 fix_reversal
$p $a $v
884 if {$v == $curview} {
885 set numcommits
$commitidx($v)
887 if {[info exists targetid
]} {
888 if {![comes_before
$targetid $p]} {
895 proc insertfakerow
{id p
} {
896 global varcid varccommits parents children cmitlisted
897 global commitidx varctok vtokmod targetid targetrow curview numcommits
901 set i
[lsearch
-exact $varccommits($v,$a) $p]
903 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
906 set children
($v,$id) {}
907 set parents
($v,$id) [list
$p]
908 set varcid
($v,$id) $a
909 lappend children
($v,$p) $id
910 set cmitlisted
($v,$id) 1
911 set numcommits
[incr commitidx
($v)]
912 # note we deliberately don't update varcstart($v) even if $i == 0
913 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
915 if {[info exists targetid
]} {
916 if {![comes_before
$targetid $p]} {
924 proc removefakerow
{id
} {
925 global varcid varccommits parents children commitidx
926 global varctok vtokmod cmitlisted currentid selectedline
927 global targetid curview numcommits
930 if {[llength
$parents($v,$id)] != 1} {
931 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
934 set p
[lindex
$parents($v,$id) 0]
935 set a
$varcid($v,$id)
936 set i
[lsearch
-exact $varccommits($v,$a) $id]
938 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
942 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
943 unset parents
($v,$id)
944 unset children
($v,$id)
945 unset cmitlisted
($v,$id)
946 set numcommits
[incr commitidx
($v) -1]
947 set j
[lsearch
-exact $children($v,$p) $id]
949 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
952 if {[info exist currentid
] && $id eq
$currentid} {
956 if {[info exists targetid
] && $targetid eq
$id} {
963 proc first_real_child
{vp
} {
964 global children nullid nullid2
966 foreach id
$children($vp) {
967 if {$id ne
$nullid && $id ne
$nullid2} {
974 proc last_real_child
{vp
} {
975 global children nullid nullid2
977 set kids
$children($vp)
978 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
979 set id
[lindex
$kids $i]
980 if {$id ne
$nullid && $id ne
$nullid2} {
987 proc vtokcmp
{v a b
} {
988 global varctok varcid
990 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
991 [lindex
$varctok($v) $varcid($v,$b)]]
994 # This assumes that if lim is not given, the caller has checked that
995 # arc a's token is less than $vtokmod($v)
996 proc modify_arc
{v a
{lim
{}}} {
997 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1000 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
1003 set r
[lindex
$varcrow($v) $a]
1004 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
1007 set vtokmod
($v) [lindex
$varctok($v) $a]
1009 if {$v == $curview} {
1010 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
1011 set a
[lindex
$vupptr($v) $a]
1017 set lim
[llength
$varccommits($v,$a)]
1019 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1026 proc update_arcrows
{v
} {
1027 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1028 global varcid vrownum varcorder varcix varccommits
1029 global vupptr vdownptr vleftptr varctok
1030 global displayorder parentlist curview cached_commitrow
1032 if {$vrowmod($v) == $commitidx($v)} return
1033 if {$v == $curview} {
1034 if {[llength
$displayorder] > $vrowmod($v)} {
1035 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1036 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1038 catch
{unset cached_commitrow
}
1040 set narctot
[expr {[llength
$varctok($v)] - 1}]
1042 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1043 # go up the tree until we find something that has a row number,
1044 # or we get to a seed
1045 set a
[lindex
$vupptr($v) $a]
1048 set a
[lindex
$vdownptr($v) 0]
1051 set varcorder
($v) [list
$a]
1052 lset varcix
($v) $a 0
1053 lset varcrow
($v) $a 0
1057 set arcn
[lindex
$varcix($v) $a]
1058 if {[llength
$vrownum($v)] > $arcn + 1} {
1059 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1060 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1062 set row
[lindex
$varcrow($v) $a]
1066 incr row
[llength
$varccommits($v,$a)]
1067 # go down if possible
1068 set b
[lindex
$vdownptr($v) $a]
1070 # if not, go left, or go up until we can go left
1072 set b
[lindex
$vleftptr($v) $a]
1074 set a
[lindex
$vupptr($v) $a]
1080 lappend vrownum
($v) $row
1081 lappend varcorder
($v) $a
1082 lset varcix
($v) $a $arcn
1083 lset varcrow
($v) $a $row
1085 set vtokmod
($v) [lindex
$varctok($v) $p]
1087 set vrowmod
($v) $row
1088 if {[info exists currentid
]} {
1089 set selectedline
[rowofcommit
$currentid]
1093 # Test whether view $v contains commit $id
1094 proc commitinview
{id v
} {
1097 return [info exists varcid
($v,$id)]
1100 # Return the row number for commit $id in the current view
1101 proc rowofcommit
{id
} {
1102 global varcid varccommits varcrow curview cached_commitrow
1103 global varctok vtokmod
1106 if {![info exists varcid
($v,$id)]} {
1107 puts
"oops rowofcommit no arc for [shortids $id]"
1110 set a
$varcid($v,$id)
1111 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1114 if {[info exists cached_commitrow
($id)]} {
1115 return $cached_commitrow($id)
1117 set i
[lsearch
-exact $varccommits($v,$a) $id]
1119 puts
"oops didn't find commit [shortids $id] in arc $a"
1122 incr i
[lindex
$varcrow($v) $a]
1123 set cached_commitrow
($id) $i
1127 # Returns 1 if a is on an earlier row than b, otherwise 0
1128 proc comes_before
{a b
} {
1129 global varcid varctok curview
1132 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1133 ![info exists varcid
($v,$b)]} {
1136 if {$varcid($v,$a) != $varcid($v,$b)} {
1137 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1138 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1140 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1143 proc bsearch
{l elt
} {
1144 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1149 while {$hi - $lo > 1} {
1150 set mid
[expr {int
(($lo + $hi) / 2)}]
1151 set t
[lindex
$l $mid]
1154 } elseif
{$elt > $t} {
1163 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1164 proc make_disporder
{start end
} {
1165 global vrownum curview commitidx displayorder parentlist
1166 global varccommits varcorder parents vrowmod varcrow
1167 global d_valid_start d_valid_end
1169 if {$end > $vrowmod($curview)} {
1170 update_arcrows
$curview
1172 set ai
[bsearch
$vrownum($curview) $start]
1173 set start
[lindex
$vrownum($curview) $ai]
1174 set narc
[llength
$vrownum($curview)]
1175 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1176 set a
[lindex
$varcorder($curview) $ai]
1177 set l
[llength
$displayorder]
1178 set al
[llength
$varccommits($curview,$a)]
1179 if {$l < $r + $al} {
1181 set pad
[ntimes
[expr {$r - $l}] {}]
1182 set displayorder
[concat
$displayorder $pad]
1183 set parentlist
[concat
$parentlist $pad]
1184 } elseif
{$l > $r} {
1185 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1186 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1188 foreach id
$varccommits($curview,$a) {
1189 lappend displayorder
$id
1190 lappend parentlist
$parents($curview,$id)
1192 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1194 foreach id
$varccommits($curview,$a) {
1195 lset displayorder
$i $id
1196 lset parentlist
$i $parents($curview,$id)
1204 proc commitonrow
{row
} {
1207 set id
[lindex
$displayorder $row]
1209 make_disporder
$row [expr {$row + 1}]
1210 set id
[lindex
$displayorder $row]
1215 proc closevarcs
{v
} {
1216 global varctok varccommits varcid parents children
1217 global cmitlisted commitidx commitinterest vtokmod
1219 set missing_parents
0
1221 set narcs
[llength
$varctok($v)]
1222 for {set a
1} {$a < $narcs} {incr a
} {
1223 set id
[lindex
$varccommits($v,$a) end
]
1224 foreach p
$parents($v,$id) {
1225 if {[info exists varcid
($v,$p)]} continue
1226 # add p as a new commit
1227 incr missing_parents
1228 set cmitlisted
($v,$p) 0
1229 set parents
($v,$p) {}
1230 if {[llength
$children($v,$p)] == 1 &&
1231 [llength
$parents($v,$id)] == 1} {
1234 set b
[newvarc
$v $p]
1236 set varcid
($v,$p) $b
1237 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1240 lappend varccommits
($v,$b) $p
1242 if {[info exists commitinterest
($p)]} {
1243 foreach
script $commitinterest($p) {
1244 lappend scripts
[string map
[list
"%I" $p] $script]
1246 unset commitinterest
($id)
1250 if {$missing_parents > 0} {
1251 foreach s
$scripts {
1257 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1258 # Assumes we already have an arc for $rwid.
1259 proc rewrite_commit
{v id rwid
} {
1260 global children parents varcid varctok vtokmod varccommits
1262 foreach ch
$children($v,$id) {
1263 # make $rwid be $ch's parent in place of $id
1264 set i
[lsearch
-exact $parents($v,$ch) $id]
1266 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1268 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1269 # add $ch to $rwid's children and sort the list if necessary
1270 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1271 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1272 $children($v,$rwid)]
1274 # fix the graph after joining $id to $rwid
1275 set a
$varcid($v,$ch)
1276 fix_reversal
$rwid $a $v
1277 # parentlist is wrong for the last element of arc $a
1278 # even if displayorder is right, hence the 3rd arg here
1279 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1283 proc getcommitlines
{fd inst view updating
} {
1284 global cmitlisted commitinterest leftover
1285 global commitidx commitdata vdatemode
1286 global parents children curview hlview
1287 global idpending ordertok
1288 global varccommits varcid varctok vtokmod vfilelimit
1290 set stuff
[read $fd 500000]
1291 # git log doesn't terminate the last commit with a null...
1292 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1299 global commfd viewcomplete viewactive viewname
1300 global viewinstances
1302 set i
[lsearch
-exact $viewinstances($view) $inst]
1304 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1306 # set it blocking so we wait for the process to terminate
1307 fconfigure
$fd -blocking 1
1308 if {[catch
{close
$fd} err
]} {
1310 if {$view != $curview} {
1311 set fv
" for the \"$viewname($view)\" view"
1313 if {[string range
$err 0 4] == "usage"} {
1314 set err
"Gitk: error reading commits$fv:\
1315 bad arguments to git log."
1316 if {$viewname($view) eq
"Command line"} {
1318 " (Note: arguments to gitk are passed to git log\
1319 to allow selection of commits to be displayed.)"
1322 set err
"Error reading commits$fv: $err"
1326 if {[incr viewactive
($view) -1] <= 0} {
1327 set viewcomplete
($view) 1
1328 # Check if we have seen any ids listed as parents that haven't
1329 # appeared in the list
1333 if {$view == $curview} {
1342 set i
[string first
"\0" $stuff $start]
1344 append leftover
($inst) [string range
$stuff $start end
]
1348 set cmit
$leftover($inst)
1349 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1350 set leftover
($inst) {}
1352 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1354 set start
[expr {$i + 1}]
1355 set j
[string first
"\n" $cmit]
1358 if {$j >= 0 && [string match
"commit *" $cmit]} {
1359 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1360 if {[string match
{[-^
<>]*} $ids]} {
1361 switch
-- [string index
$ids 0] {
1367 set ids
[string range
$ids 1 end
]
1371 if {[string length
$id] != 40} {
1379 if {[string length
$shortcmit] > 80} {
1380 set shortcmit
"[string range $shortcmit 0 80]..."
1382 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1385 set id [lindex $ids 0]
1388 if {!$listed && $updating && ![info exists varcid($vid)] &&
1389 $vfilelimit($view) ne {}} {
1390 # git log doesn't rewrite parents
for unlisted commits
1391 # when doing path limiting, so work around that here
1392 # by working out the rewritten parent with git rev-list
1393 # and if we already know about it, using the rewritten
1394 # parent as a substitute parent for $id's children.
1396 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1397 $id -- $vfilelimit($view)]
1399 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1400 # use $rwid in place of $id
1401 rewrite_commit
$view $id $rwid
1408 if {[info exists varcid
($vid)]} {
1409 if {$cmitlisted($vid) ||
!$listed} continue
1413 set olds
[lrange
$ids 1 end
]
1417 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1418 set cmitlisted
($vid) $listed
1419 set parents
($vid) $olds
1420 if {![info exists children
($vid)]} {
1421 set children
($vid) {}
1422 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1423 set k
[lindex
$children($vid) 0]
1424 if {[llength
$parents($view,$k)] == 1 &&
1425 (!$vdatemode($view) ||
1426 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1427 set a
$varcid($view,$k)
1432 set a
[newvarc
$view $id]
1434 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1437 if {![info exists varcid
($vid)]} {
1439 lappend varccommits
($view,$a) $id
1440 incr commitidx
($view)
1445 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1447 if {[llength
[lappend children
($vp) $id]] > 1 &&
1448 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1449 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1451 catch
{unset ordertok
}
1453 if {[info exists varcid
($view,$p)]} {
1454 fix_reversal
$p $a $view
1460 if {[info exists commitinterest
($id)]} {
1461 foreach
script $commitinterest($id) {
1462 lappend scripts
[string map
[list
"%I" $id] $script]
1464 unset commitinterest
($id)
1469 global numcommits hlview
1471 if {$view == $curview} {
1472 set numcommits
$commitidx($view)
1475 if {[info exists hlview
] && $view == $hlview} {
1476 # we never actually get here...
1479 foreach s
$scripts {
1486 proc chewcommits
{} {
1487 global curview hlview viewcomplete
1488 global pending_select
1491 if {$viewcomplete($curview)} {
1492 global commitidx varctok
1493 global numcommits startmsecs
1495 if {[info exists pending_select
]} {
1496 set row
[first_real_row
]
1499 if {$commitidx($curview) > 0} {
1500 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1501 #puts "overall $ms ms for $numcommits commits"
1502 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1504 show_status
[mc
"No commits selected"]
1511 proc readcommit
{id
} {
1512 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1513 parsecommit
$id $contents 0
1516 proc parsecommit
{id contents listed
} {
1517 global commitinfo cdate
1526 set hdrend
[string first
"\n\n" $contents]
1528 # should never happen...
1529 set hdrend
[string length
$contents]
1531 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1532 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1533 foreach line
[split $header "\n"] {
1534 set tag
[lindex
$line 0]
1535 if {$tag == "author"} {
1536 set audate
[lindex
$line end-1
]
1537 set auname
[lrange
$line 1 end-2
]
1538 } elseif
{$tag == "committer"} {
1539 set comdate
[lindex
$line end-1
]
1540 set comname
[lrange
$line 1 end-2
]
1544 # take the first non-blank line of the comment as the headline
1545 set headline
[string trimleft
$comment]
1546 set i
[string first
"\n" $headline]
1548 set headline
[string range
$headline 0 $i]
1550 set headline
[string trimright
$headline]
1551 set i
[string first
"\r" $headline]
1553 set headline
[string trimright
[string range
$headline 0 $i]]
1556 # git log indents the comment by 4 spaces;
1557 # if we got this via git cat-file, add the indentation
1559 foreach line
[split $comment "\n"] {
1560 append newcomment
" "
1561 append newcomment
$line
1562 append newcomment
"\n"
1564 set comment
$newcomment
1566 if {$comdate != {}} {
1567 set cdate
($id) $comdate
1569 set commitinfo
($id) [list
$headline $auname $audate \
1570 $comname $comdate $comment]
1573 proc getcommit
{id
} {
1574 global commitdata commitinfo
1576 if {[info exists commitdata
($id)]} {
1577 parsecommit
$id $commitdata($id) 1
1580 if {![info exists commitinfo
($id)]} {
1581 set commitinfo
($id) [list
[mc
"No commit information available"]]
1588 global tagids idtags headids idheads tagobjid
1589 global otherrefids idotherrefs mainhead mainheadid
1591 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1594 set refd
[open
[list | git show-ref
-d] r
]
1595 while {[gets
$refd line
] >= 0} {
1596 if {[string index
$line 40] ne
" "} continue
1597 set id
[string range
$line 0 39]
1598 set ref
[string range
$line 41 end
]
1599 if {![string match
"refs/*" $ref]} continue
1600 set name
[string range
$ref 5 end
]
1601 if {[string match
"remotes/*" $name]} {
1602 if {![string match
"*/HEAD" $name]} {
1603 set headids
($name) $id
1604 lappend idheads
($id) $name
1606 } elseif
{[string match
"heads/*" $name]} {
1607 set name
[string range
$name 6 end
]
1608 set headids
($name) $id
1609 lappend idheads
($id) $name
1610 } elseif
{[string match
"tags/*" $name]} {
1611 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1612 # which is what we want since the former is the commit ID
1613 set name
[string range
$name 5 end
]
1614 if {[string match
"*^{}" $name]} {
1615 set name
[string range
$name 0 end-3
]
1617 set tagobjid
($name) $id
1619 set tagids
($name) $id
1620 lappend idtags
($id) $name
1622 set otherrefids
($name) $id
1623 lappend idotherrefs
($id) $name
1630 set mainheadid
[exec git rev-parse HEAD
]
1631 set thehead
[exec git symbolic-ref HEAD
]
1632 if {[string match
"refs/heads/*" $thehead]} {
1633 set mainhead
[string range
$thehead 11 end
]
1638 # skip over fake commits
1639 proc first_real_row
{} {
1640 global nullid nullid2 numcommits
1642 for {set row
0} {$row < $numcommits} {incr row
} {
1643 set id
[commitonrow
$row]
1644 if {$id ne
$nullid && $id ne
$nullid2} {
1651 # update things for a head moved to a child of its previous location
1652 proc movehead
{id name
} {
1653 global headids idheads
1655 removehead
$headids($name) $name
1656 set headids
($name) $id
1657 lappend idheads
($id) $name
1660 # update things when a head has been removed
1661 proc removehead
{id name
} {
1662 global headids idheads
1664 if {$idheads($id) eq
$name} {
1667 set i
[lsearch
-exact $idheads($id) $name]
1669 set idheads
($id) [lreplace
$idheads($id) $i $i]
1672 unset headids
($name)
1675 proc show_error
{w top msg
} {
1676 message
$w.m
-text $msg -justify center
-aspect 400
1677 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1678 button
$w.ok
-text [mc OK
] -command "destroy $top"
1679 pack
$w.ok
-side bottom
-fill x
1680 bind $top <Visibility
> "grab $top; focus $top"
1681 bind $top <Key-Return
> "destroy $top"
1685 proc error_popup msg
{
1689 show_error
$w $w $msg
1692 proc confirm_popup msg
{
1698 message
$w.m
-text $msg -justify center
-aspect 400
1699 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1700 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1701 pack
$w.ok
-side left
-fill x
1702 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1703 pack
$w.cancel
-side right
-fill x
1704 bind $w <Visibility
> "grab $w; focus $w"
1709 proc setoptions
{} {
1710 option add
*Panedwindow.showHandle
1 startupFile
1711 option add
*Panedwindow.sashRelief raised startupFile
1712 option add
*Button.font uifont startupFile
1713 option add
*Checkbutton.font uifont startupFile
1714 option add
*Radiobutton.font uifont startupFile
1715 option add
*Menu.font uifont startupFile
1716 option add
*Menubutton.font uifont startupFile
1717 option add
*Label.font uifont startupFile
1718 option add
*Message.font uifont startupFile
1719 option add
*Entry.font uifont startupFile
1722 proc makewindow
{} {
1723 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1725 global findtype findtypemenu findloc findstring fstring geometry
1726 global entries sha1entry sha1string sha1but
1727 global diffcontextstring diffcontext
1729 global maincursor textcursor curtextcursor
1730 global rowctxmenu fakerowmenu mergemax wrapcomment
1731 global highlight_files gdttype
1732 global searchstring sstring
1733 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1734 global headctxmenu progresscanv progressitem progresscoords statusw
1735 global fprogitem fprogcoord lastprogupdate progupdatepending
1736 global rprogitem rprogcoord rownumsel numcommits
1740 .bar add cascade
-label [mc
"File"] -menu .bar.
file
1742 .bar.
file add
command -label [mc
"Update"] -command updatecommits
1743 .bar.
file add
command -label [mc
"Reload"] -command reloadcommits
1744 .bar.
file add
command -label [mc
"Reread references"] -command rereadrefs
1745 .bar.
file add
command -label [mc
"List references"] -command showrefs
1746 .bar.
file add
command -label [mc
"Quit"] -command doquit
1748 .bar add cascade
-label [mc
"Edit"] -menu .bar.edit
1749 .bar.edit add
command -label [mc
"Preferences"] -command doprefs
1752 .bar add cascade
-label [mc
"View"] -menu .bar.view
1753 .bar.view add
command -label [mc
"New view..."] -command {newview
0}
1754 .bar.view add
command -label [mc
"Edit view..."] -command editview \
1756 .bar.view add
command -label [mc
"Delete view"] -command delview
-state disabled
1757 .bar.view add separator
1758 .bar.view add radiobutton
-label [mc
"All files"] -command {showview
0} \
1759 -variable selectedview
-value 0
1762 .bar add cascade
-label [mc
"Help"] -menu .bar.
help
1763 .bar.
help add
command -label [mc
"About gitk"] -command about
1764 .bar.
help add
command -label [mc
"Key bindings"] -command keys
1766 . configure
-menu .bar
1768 # the gui has upper and lower half, parts of a paned window.
1769 panedwindow .ctop
-orient vertical
1771 # possibly use assumed geometry
1772 if {![info exists geometry
(pwsash0
)]} {
1773 set geometry
(topheight
) [expr {15 * $linespc}]
1774 set geometry
(topwidth
) [expr {80 * $charspc}]
1775 set geometry
(botheight
) [expr {15 * $linespc}]
1776 set geometry
(botwidth
) [expr {50 * $charspc}]
1777 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1778 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1781 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1782 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1784 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1786 # create three canvases
1787 set cscroll .tf.histframe.csb
1788 set canv .tf.histframe.pwclist.canv
1790 -selectbackground $selectbgcolor \
1791 -background $bgcolor -bd 0 \
1792 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1793 .tf.histframe.pwclist add
$canv
1794 set canv2 .tf.histframe.pwclist.canv2
1796 -selectbackground $selectbgcolor \
1797 -background $bgcolor -bd 0 -yscrollincr $linespc
1798 .tf.histframe.pwclist add
$canv2
1799 set canv3 .tf.histframe.pwclist.canv3
1801 -selectbackground $selectbgcolor \
1802 -background $bgcolor -bd 0 -yscrollincr $linespc
1803 .tf.histframe.pwclist add
$canv3
1804 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1805 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1807 # a scroll bar to rule them
1808 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1809 pack
$cscroll -side right
-fill y
1810 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1811 lappend bglist
$canv $canv2 $canv3
1812 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1814 # we have two button bars at bottom of top frame. Bar 1
1816 frame .tf.lbar
-height 15
1818 set sha1entry .tf.bar.sha1
1819 set entries
$sha1entry
1820 set sha1but .tf.bar.sha1label
1821 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
1822 -command gotocommit
-width 8
1823 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1824 pack .tf.bar.sha1label
-side left
1825 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1826 trace add variable sha1string
write sha1change
1827 pack
$sha1entry -side left
-pady 2
1829 image create bitmap bm-left
-data {
1830 #define left_width 16
1831 #define left_height 16
1832 static unsigned char left_bits
[] = {
1833 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1834 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1835 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1837 image create bitmap bm-right
-data {
1838 #define right_width 16
1839 #define right_height 16
1840 static unsigned char right_bits
[] = {
1841 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1842 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1843 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1845 button .tf.bar.leftbut
-image bm-left
-command goback \
1846 -state disabled
-width 26
1847 pack .tf.bar.leftbut
-side left
-fill y
1848 button .tf.bar.rightbut
-image bm-right
-command goforw \
1849 -state disabled
-width 26
1850 pack .tf.bar.rightbut
-side left
-fill y
1852 label .tf.bar.rowlabel
-text [mc
"Row"]
1854 label .tf.bar.rownum
-width 7 -font textfont
-textvariable rownumsel \
1855 -relief sunken
-anchor e
1856 label .tf.bar.rowlabel2
-text "/"
1857 label .tf.bar.numcommits
-width 7 -font textfont
-textvariable numcommits \
1858 -relief sunken
-anchor e
1859 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1862 trace add variable selectedline
write selectedline_change
1864 # Status label and progress bar
1865 set statusw .tf.bar.status
1866 label
$statusw -width 15 -relief sunken
1867 pack
$statusw -side left
-padx 5
1868 set h
[expr {[font metrics uifont
-linespace] + 2}]
1869 set progresscanv .tf.bar.progress
1870 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1871 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1872 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1873 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1874 pack
$progresscanv -side right
-expand 1 -fill x
1875 set progresscoords
{0 0}
1878 bind $progresscanv <Configure
> adjustprogress
1879 set lastprogupdate
[clock clicks
-milliseconds]
1880 set progupdatepending
0
1882 # build up the bottom bar of upper window
1883 label .tf.lbar.flabel
-text "[mc "Find
"] "
1884 button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
1885 button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
1886 label .tf.lbar.flab2
-text " [mc "commit
"] "
1887 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1889 set gdttype
[mc
"containing:"]
1890 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1891 [mc
"containing:"] \
1892 [mc
"touching paths:"] \
1893 [mc
"adding/removing string:"]]
1894 trace add variable gdttype
write gdttype_change
1895 pack .tf.lbar.gdttype
-side left
-fill y
1898 set fstring .tf.lbar.findstring
1899 lappend entries
$fstring
1900 entry
$fstring -width 30 -font textfont
-textvariable findstring
1901 trace add variable findstring
write find_change
1902 set findtype
[mc
"Exact"]
1903 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1904 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
1905 trace add variable findtype
write findcom_change
1906 set findloc
[mc
"All fields"]
1907 tk_optionMenu .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
1908 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
1909 trace add variable findloc
write find_change
1910 pack .tf.lbar.findloc
-side right
1911 pack .tf.lbar.findtype
-side right
1912 pack
$fstring -side left
-expand 1 -fill x
1914 # Finish putting the upper half of the viewer together
1915 pack .tf.lbar
-in .tf
-side bottom
-fill x
1916 pack .tf.bar
-in .tf
-side bottom
-fill x
1917 pack .tf.histframe
-fill both
-side top
-expand 1
1919 .ctop paneconfigure .tf
-height $geometry(topheight
)
1920 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1922 # now build up the bottom
1923 panedwindow .pwbottom
-orient horizontal
1925 # lower left, a text box over search bar, scroll bar to the right
1926 # if we know window height, then that will set the lower text height, otherwise
1927 # we set lower text height which will drive window height
1928 if {[info exists geometry
(main
)]} {
1929 frame .bleft
-width $geometry(botwidth
)
1931 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
1937 button .bleft.top.search
-text [mc
"Search"] -command dosearch
1938 pack .bleft.top.search
-side left
-padx 5
1939 set sstring .bleft.top.sstring
1940 entry
$sstring -width 20 -font textfont
-textvariable searchstring
1941 lappend entries
$sstring
1942 trace add variable searchstring
write incrsearch
1943 pack
$sstring -side left
-expand 1 -fill x
1944 radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
1945 -command changediffdisp
-variable diffelide
-value {0 0}
1946 radiobutton .bleft.mid.old
-text [mc
"Old version"] \
1947 -command changediffdisp
-variable diffelide
-value {0 1}
1948 radiobutton .bleft.mid.new
-text [mc
"New version"] \
1949 -command changediffdisp
-variable diffelide
-value {1 0}
1950 label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
1951 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
1952 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
1953 -from 1 -increment 1 -to 10000000 \
1954 -validate all
-validatecommand "diffcontextvalidate %P" \
1955 -textvariable diffcontextstring
1956 .bleft.mid.diffcontext
set $diffcontext
1957 trace add variable diffcontextstring
write diffcontextchange
1958 lappend entries .bleft.mid.diffcontext
1959 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
1960 checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
1961 -command changeignorespace
-variable ignorespace
1962 pack .bleft.mid.ignspace
-side left
-padx 5
1963 set ctext .bleft.bottom.ctext
1964 text
$ctext -background $bgcolor -foreground $fgcolor \
1965 -state disabled
-font textfont \
1966 -yscrollcommand scrolltext
-wrap none \
1967 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1969 $ctext conf
-tabstyle wordprocessor
1971 scrollbar .bleft.bottom.sb
-command "$ctext yview"
1972 scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h \
1974 pack .bleft.top
-side top
-fill x
1975 pack .bleft.mid
-side top
-fill x
1976 grid
$ctext .bleft.bottom.sb
-sticky nsew
1977 grid .bleft.bottom.sbhorizontal
-sticky ew
1978 grid columnconfigure .bleft.bottom
0 -weight 1
1979 grid rowconfigure .bleft.bottom
0 -weight 1
1980 grid rowconfigure .bleft.bottom
1 -weight 0
1981 pack .bleft.bottom
-side top
-fill both
-expand 1
1982 lappend bglist
$ctext
1983 lappend fglist
$ctext
1985 $ctext tag conf comment
-wrap $wrapcomment
1986 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
1987 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
1988 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
1989 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
1990 $ctext tag conf m0
-fore red
1991 $ctext tag conf m1
-fore blue
1992 $ctext tag conf m2
-fore green
1993 $ctext tag conf m3
-fore purple
1994 $ctext tag conf
m4 -fore brown
1995 $ctext tag conf m5
-fore "#009090"
1996 $ctext tag conf m6
-fore magenta
1997 $ctext tag conf m7
-fore "#808000"
1998 $ctext tag conf m8
-fore "#009000"
1999 $ctext tag conf m9
-fore "#ff0080"
2000 $ctext tag conf m10
-fore cyan
2001 $ctext tag conf m11
-fore "#b07070"
2002 $ctext tag conf m12
-fore "#70b0f0"
2003 $ctext tag conf m13
-fore "#70f0b0"
2004 $ctext tag conf m14
-fore "#f0b070"
2005 $ctext tag conf m15
-fore "#ff70b0"
2006 $ctext tag conf mmax
-fore darkgrey
2008 $ctext tag conf mresult
-font textfontbold
2009 $ctext tag conf msep
-font textfontbold
2010 $ctext tag conf found
-back yellow
2012 .pwbottom add .bleft
2013 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2018 radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2019 -command reselectline
-variable cmitmode
-value "patch"
2020 radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2021 -command reselectline
-variable cmitmode
-value "tree"
2022 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2023 pack .bright.mode
-side top
-fill x
2024 set cflist .bright.cfiles
2025 set indent
[font measure mainfont
"nn"]
2027 -selectbackground $selectbgcolor \
2028 -background $bgcolor -foreground $fgcolor \
2030 -tabs [list
$indent [expr {2 * $indent}]] \
2031 -yscrollcommand ".bright.sb set" \
2032 -cursor [. cget
-cursor] \
2033 -spacing1 1 -spacing3 1
2034 lappend bglist
$cflist
2035 lappend fglist
$cflist
2036 scrollbar .bright.sb
-command "$cflist yview"
2037 pack .bright.sb
-side right
-fill y
2038 pack
$cflist -side left
-fill both
-expand 1
2039 $cflist tag configure highlight \
2040 -background [$cflist cget
-selectbackground]
2041 $cflist tag configure bold
-font mainfontbold
2043 .pwbottom add .bright
2046 # restore window width & height if known
2047 if {[info exists geometry
(main
)]} {
2048 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2049 if {$w > [winfo screenwidth .
]} {
2050 set w
[winfo screenwidth .
]
2052 if {$h > [winfo screenheight .
]} {
2053 set h
[winfo screenheight .
]
2055 wm geometry .
"${w}x$h"
2059 if {[tk windowingsystem
] eq
{aqua
}} {
2065 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2066 pack .ctop
-fill both
-expand 1
2067 bindall
<1> {selcanvline
%W
%x
%y
}
2068 #bindall <B1-Motion> {selcanvline %W %x %y}
2069 if {[tk windowingsystem
] == "win32"} {
2070 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2071 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2073 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2074 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2075 if {[tk windowingsystem
] eq
"aqua"} {
2076 bindall
<MouseWheel
> {
2077 set delta
[expr {- (%D
)}]
2078 allcanvs yview scroll
$delta units
2082 bindall
<2> "canvscan mark %W %x %y"
2083 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
2084 bindkey
<Home
> selfirstline
2085 bindkey
<End
> sellastline
2086 bind .
<Key-Up
> "selnextline -1"
2087 bind .
<Key-Down
> "selnextline 1"
2088 bind .
<Shift-Key-Up
> "dofind -1 0"
2089 bind .
<Shift-Key-Down
> "dofind 1 0"
2090 bindkey
<Key-Right
> "goforw"
2091 bindkey
<Key-Left
> "goback"
2092 bind .
<Key-Prior
> "selnextpage -1"
2093 bind .
<Key-Next
> "selnextpage 1"
2094 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2095 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2096 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2097 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2098 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2099 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2100 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2101 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2102 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2103 bindkey p
"selnextline -1"
2104 bindkey n
"selnextline 1"
2107 bindkey i
"selnextline -1"
2108 bindkey k
"selnextline 1"
2112 bindkey d
"$ctext yview scroll 18 units"
2113 bindkey u
"$ctext yview scroll -18 units"
2114 bindkey
/ {dofind
1 1}
2115 bindkey
<Key-Return
> {dofind
1 1}
2116 bindkey ?
{dofind
-1 1}
2118 bindkey
<F5
> updatecommits
2119 bind .
<$M1B-q> doquit
2120 bind .
<$M1B-f> {dofind
1 1}
2121 bind .
<$M1B-g> {dofind
1 0}
2122 bind .
<$M1B-r> dosearchback
2123 bind .
<$M1B-s> dosearch
2124 bind .
<$M1B-equal> {incrfont
1}
2125 bind .
<$M1B-plus> {incrfont
1}
2126 bind .
<$M1B-KP_Add> {incrfont
1}
2127 bind .
<$M1B-minus> {incrfont
-1}
2128 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2129 wm protocol . WM_DELETE_WINDOW doquit
2130 bind .
<Destroy
> {stop_backends
}
2131 bind .
<Button-1
> "click %W"
2132 bind $fstring <Key-Return
> {dofind
1 1}
2133 bind $sha1entry <Key-Return
> gotocommit
2134 bind $sha1entry <<PasteSelection>> clearsha1
2135 bind $cflist <1> {sel_flist %W %x %y; break}
2136 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2137 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2138 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
2140 set maincursor [. cget -cursor]
2141 set textcursor [$ctext cget -cursor]
2142 set curtextcursor $textcursor
2144 set rowctxmenu .rowctxmenu
2145 menu $rowctxmenu -tearoff 0
2146 $rowctxmenu add command -label [mc "Diff this -> selected"] \
2147 -command {diffvssel 0}
2148 $rowctxmenu add command -label [mc "Diff selected -> this"] \
2149 -command {diffvssel 1}
2150 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2151 $rowctxmenu add command -label [mc "Create tag"] -command mktag
2152 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2153 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2154 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2156 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2159 set fakerowmenu .fakerowmenu
2160 menu $fakerowmenu -tearoff 0
2161 $fakerowmenu add command -label [mc "Diff this -> selected"] \
2162 -command {diffvssel 0}
2163 $fakerowmenu add command -label [mc "Diff selected -> this"] \
2164 -command {diffvssel 1}
2165 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2166 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2167 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2168 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2170 set headctxmenu .headctxmenu
2171 menu $headctxmenu -tearoff 0
2172 $headctxmenu add command -label [mc "Check out this branch"] \
2174 $headctxmenu add command -label [mc "Remove this branch"] \
2178 set flist_menu .flistctxmenu
2179 menu $flist_menu -tearoff 0
2180 $flist_menu add command -label [mc "Highlight this too"] \
2181 -command {flist_hl 0}
2182 $flist_menu add command -label [mc "Highlight this only"] \
2183 -command {flist_hl 1}
2184 $flist_menu add command -label [mc "External diff"] \
2185 -command {external_diff}
2188 # Windows sends all mouse wheel events to the current focused window, not
2189 # the one where the mouse hovers, so bind those events here and redirect
2190 # to the correct window
2191 proc windows_mousewheel_redirector {W X Y D} {
2192 global canv canv2 canv3
2193 set w [winfo containing -displayof $W $X $Y]
2195 set u [expr {$D < 0 ? 5 : -5}]
2196 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2197 allcanvs yview scroll $u units
2200 $w yview scroll $u units
2206 # Update row number label when selectedline changes
2207 proc selectedline_change {n1 n2 op} {
2208 global selectedline rownumsel
2210 if {$selectedline eq {}} {
2213 set rownumsel [expr {$selectedline + 1}]
2217 # mouse-2 makes all windows scan vertically, but only the one
2218 # the cursor is in scans horizontally
2219 proc canvscan {op w x y} {
2220 global canv canv2 canv3
2221 foreach c [list $canv $canv2 $canv3] {
2230 proc scrollcanv {cscroll f0 f1} {
2231 $cscroll set $f0 $f1
2236 # when we make a key binding for the toplevel, make sure
2237 # it doesn't get triggered when that key is pressed in the
2238 # find string entry widget.
2239 proc bindkey {ev script} {
2242 set escript [bind Entry $ev]
2243 if {$escript == {}} {
2244 set escript [bind Entry <Key>]
2246 foreach e $entries {
2247 bind $e $ev "$escript; break"
2251 # set the focus back to the toplevel for any click outside
2254 global ctext entries
2255 foreach e [concat $entries $ctext] {
2256 if {$w == $e} return
2261 # Adjust the progress bar for a change in requested extent or canvas size
2262 proc adjustprogress {} {
2263 global progresscanv progressitem progresscoords
2264 global fprogitem fprogcoord lastprogupdate progupdatepending
2265 global rprogitem rprogcoord
2267 set w [expr {[winfo width $progresscanv] - 4}]
2268 set x0 [expr {$w * [lindex $progresscoords 0]}]
2269 set x1 [expr {$w * [lindex $progresscoords 1]}]
2270 set h [winfo height $progresscanv]
2271 $progresscanv coords $progressitem $x0 0 $x1 $h
2272 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2273 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2274 set now [clock clicks -milliseconds]
2275 if {$now >= $lastprogupdate + 100} {
2276 set progupdatepending 0
2278 } elseif {!$progupdatepending} {
2279 set progupdatepending 1
2280 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2284 proc doprogupdate {} {
2285 global lastprogupdate progupdatepending
2287 if {$progupdatepending} {
2288 set progupdatepending 0
2289 set lastprogupdate [clock clicks -milliseconds]
2294 proc savestuff {w} {
2295 global canv canv2 canv3 mainfont textfont uifont tabstop
2296 global stuffsaved findmergefiles maxgraphpct
2297 global maxwidth showneartags showlocalchanges
2298 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2299 global cmitmode wrapcomment datetimeformat limitdiffs
2300 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2301 global autoselect extdifftool
2303 if {$stuffsaved} return
2304 if {![winfo viewable .]} return
2306 set f [open "~/.gitk-new" w]
2307 puts $f [list set mainfont $mainfont]
2308 puts $f [list set textfont $textfont]
2309 puts $f [list set uifont $uifont]
2310 puts $f [list set tabstop $tabstop]
2311 puts $f [list set findmergefiles $findmergefiles]
2312 puts $f [list set maxgraphpct $maxgraphpct]
2313 puts $f [list set maxwidth $maxwidth]
2314 puts $f [list set cmitmode $cmitmode]
2315 puts $f [list set wrapcomment $wrapcomment]
2316 puts $f [list set autoselect $autoselect]
2317 puts $f [list set showneartags $showneartags]
2318 puts $f [list set showlocalchanges $showlocalchanges]
2319 puts $f [list set datetimeformat $datetimeformat]
2320 puts $f [list set limitdiffs $limitdiffs]
2321 puts $f [list set bgcolor $bgcolor]
2322 puts $f [list set fgcolor $fgcolor]
2323 puts $f [list set colors $colors]
2324 puts $f [list set diffcolors $diffcolors]
2325 puts $f [list set diffcontext $diffcontext]
2326 puts $f [list set selectbgcolor $selectbgcolor]
2327 puts $f [list set extdifftool $extdifftool]
2329 puts $f "set geometry(main) [wm geometry .]"
2330 puts $f "set geometry(topwidth) [winfo width .tf]"
2331 puts $f "set geometry(topheight) [winfo height .tf]"
2332 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2333 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2334 puts $f "set geometry(botwidth) [winfo width .bleft]"
2335 puts $f "set geometry(botheight) [winfo height .bleft]"
2337 puts -nonewline $f "set permviews {"
2338 for {set v 0} {$v < $nextviewnum} {incr v} {
2339 if {$viewperm($v)} {
2340 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2345 file rename -force "~/.gitk-new" "~/.gitk"
2350 proc resizeclistpanes {win w} {
2352 if {[info exists oldwidth($win)]} {
2353 set s0 [$win sash coord 0]
2354 set s1 [$win sash coord 1]
2356 set sash0 [expr {int($w/2 - 2)}]
2357 set sash1 [expr {int($w*5/6 - 2)}]
2359 set factor [expr {1.0 * $w / $oldwidth($win)}]
2360 set sash0 [expr {int($factor * [lindex $s0 0])}]
2361 set sash1 [expr {int($factor * [lindex $s1 0])}]
2365 if {$sash1 < $sash0 + 20} {
2366 set sash1 [expr {$sash0 + 20}]
2368 if {$sash1 > $w - 10} {
2369 set sash1 [expr {$w - 10}]
2370 if {$sash0 > $sash1 - 20} {
2371 set sash0 [expr {$sash1 - 20}]
2375 $win sash place 0 $sash0 [lindex $s0 1]
2376 $win sash place 1 $sash1 [lindex $s1 1]
2378 set oldwidth($win) $w
2381 proc resizecdetpanes {win w} {
2383 if {[info exists oldwidth($win)]} {
2384 set s0 [$win sash coord 0]
2386 set sash0 [expr {int($w*3/4 - 2)}]
2388 set factor [expr {1.0 * $w / $oldwidth($win)}]
2389 set sash0 [expr {int($factor * [lindex $s0 0])}]
2393 if {$sash0 > $w - 15} {
2394 set sash0 [expr {$w - 15}]
2397 $win sash place 0 $sash0 [lindex $s0 1]
2399 set oldwidth($win) $w
2402 proc allcanvs args {
2403 global canv canv2 canv3
2409 proc bindall {event action} {
2410 global canv canv2 canv3
2411 bind $canv $event $action
2412 bind $canv2 $event $action
2413 bind $canv3 $event $action
2419 if {[winfo exists $w]} {
2424 wm title $w [mc "About gitk"]
2425 message $w.m -text [mc "
2426 Gitk - a commit viewer for git
2428 Copyright © 2005-2008 Paul Mackerras
2430 Use and redistribute under the terms of the GNU General Public License"] \
2431 -justify center -aspect 400 -border 2 -bg white -relief groove
2432 pack $w.m -side top -fill x -padx 2 -pady 2
2433 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2434 pack $w.ok -side bottom
2435 bind $w <Visibility> "focus $w.ok"
2436 bind $w <Key-Escape> "destroy $w"
2437 bind $w <Key-Return> "destroy $w"
2442 if {[winfo exists $w]} {
2446 if {[tk windowingsystem] eq {aqua}} {
2452 wm title $w [mc "Gitk key bindings"]
2453 message $w.m -text "
2454 [mc "Gitk key bindings:"]
2456 [mc "<%s-Q> Quit" $M1T]
2457 [mc "<Home> Move to first commit"]
2458 [mc "<End> Move to last commit"]
2459 [mc "<Up>, p, i Move up one commit"]
2460 [mc "<Down>, n, k Move down one commit"]
2461 [mc "<Left>, z, j Go back in history list"]
2462 [mc "<Right>, x, l Go forward in history list"]
2463 [mc "<PageUp> Move up one page in commit list"]
2464 [mc "<PageDown> Move down one page in commit list"]
2465 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2466 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2467 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2468 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2469 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2470 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2471 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2472 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2473 [mc "<Delete>, b Scroll diff view up one page"]
2474 [mc "<Backspace> Scroll diff view up one page"]
2475 [mc "<Space> Scroll diff view down one page"]
2476 [mc "u Scroll diff view up 18 lines"]
2477 [mc "d Scroll diff view down 18 lines"]
2478 [mc "<%s-F> Find" $M1T]
2479 [mc "<%s-G> Move to next find hit" $M1T]
2480 [mc "<Return> Move to next find hit"]
2481 [mc "/ Move to next find hit, or redo find"]
2482 [mc "? Move to previous find hit"]
2483 [mc "f Scroll diff view to next file"]
2484 [mc "<%s-S> Search for next hit in diff view" $M1T]
2485 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2486 [mc "<%s-KP+> Increase font size" $M1T]
2487 [mc "<%s-plus> Increase font size" $M1T]
2488 [mc "<%s-KP-> Decrease font size" $M1T]
2489 [mc "<%s-minus> Decrease font size" $M1T]
2492 -justify left -bg white -border 2 -relief groove
2493 pack $w.m -side top -fill both -padx 2 -pady 2
2494 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2495 pack $w.ok -side bottom
2496 bind $w <Visibility> "focus $w.ok"
2497 bind $w <Key-Escape> "destroy $w"
2498 bind $w <Key-Return> "destroy $w"
2501 # Procedures for manipulating the file list window at the
2502 # bottom right of the overall window.
2504 proc treeview {w l openlevs} {
2505 global treecontents treediropen treeheight treeparent treeindex
2515 set treecontents() {}
2516 $w conf -state normal
2518 while {[string range $f 0 $prefixend] ne $prefix} {
2519 if {$lev <= $openlevs} {
2520 $w mark set e:$treeindex($prefix) "end -1c"
2521 $w mark gravity e:$treeindex($prefix) left
2523 set treeheight($prefix) $ht
2524 incr ht [lindex $htstack end]
2525 set htstack [lreplace $htstack end end]
2526 set prefixend [lindex $prefendstack end]
2527 set prefendstack [lreplace $prefendstack end end]
2528 set prefix [string range $prefix 0 $prefixend]
2531 set tail [string range $f [expr {$prefixend+1}] end]
2532 while {[set slash [string first "/" $tail]] >= 0} {
2535 lappend prefendstack $prefixend
2536 incr prefixend [expr {$slash + 1}]
2537 set d [string range $tail 0 $slash]
2538 lappend treecontents($prefix) $d
2539 set oldprefix $prefix
2541 set treecontents($prefix) {}
2542 set treeindex($prefix) [incr ix]
2543 set treeparent($prefix) $oldprefix
2544 set tail [string range $tail [expr {$slash+1}] end]
2545 if {$lev <= $openlevs} {
2547 set treediropen($prefix) [expr {$lev < $openlevs}]
2548 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2549 $w mark set d:$ix "end -1c"
2550 $w mark gravity d:$ix left
2552 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2554 $w image create end -align center -image $bm -padx 1 \
2556 $w insert end $d [highlight_tag $prefix]
2557 $w mark set s:$ix "end -1c"
2558 $w mark gravity s:$ix left
2563 if {$lev <= $openlevs} {
2566 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2568 $w insert end $tail [highlight_tag $f]
2570 lappend treecontents($prefix) $tail
2573 while {$htstack ne {}} {
2574 set treeheight($prefix) $ht
2575 incr ht [lindex $htstack end]
2576 set htstack [lreplace $htstack end end]
2577 set prefixend [lindex $prefendstack end]
2578 set prefendstack [lreplace $prefendstack end end]
2579 set prefix [string range $prefix 0 $prefixend]
2581 $w conf -state disabled
2584 proc linetoelt {l} {
2585 global treeheight treecontents
2590 foreach e $treecontents($prefix) {
2595 if {[string index $e end] eq "/"} {
2596 set n $treeheight($prefix$e)
2608 proc highlight_tree {y prefix} {
2609 global treeheight treecontents cflist
2611 foreach e $treecontents($prefix) {
2613 if {[highlight_tag $path] ne {}} {
2614 $cflist tag add bold $y.0 "$y.0 lineend"
2617 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2618 set y [highlight_tree $y $path]
2624 proc treeclosedir {w dir} {
2625 global treediropen treeheight treeparent treeindex
2627 set ix $treeindex($dir)
2628 $w conf -state normal
2629 $w delete s:$ix e:$ix
2630 set treediropen($dir) 0
2631 $w image configure a:$ix -image tri-rt
2632 $w conf -state disabled
2633 set n [expr {1 - $treeheight($dir)}]
2634 while {$dir ne {}} {
2635 incr treeheight($dir) $n
2636 set dir $treeparent($dir)
2640 proc treeopendir {w dir} {
2641 global treediropen treeheight treeparent treecontents treeindex
2643 set ix $treeindex($dir)
2644 $w conf -state normal
2645 $w image configure a:$ix -image tri-dn
2646 $w mark set e:$ix s:$ix
2647 $w mark gravity e:$ix right
2650 set n [llength $treecontents($dir)]
2651 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2654 incr treeheight($x) $n
2656 foreach e $treecontents($dir) {
2658 if {[string index $e end] eq "/"} {
2659 set iy $treeindex($de)
2660 $w mark set d:$iy e:$ix
2661 $w mark gravity d:$iy left
2662 $w insert e:$ix $str
2663 set treediropen($de) 0
2664 $w image create e:$ix -align center -image tri-rt -padx 1 \
2666 $w insert e:$ix $e [highlight_tag $de]
2667 $w mark set s:$iy e:$ix
2668 $w mark gravity s:$iy left
2669 set treeheight($de) 1
2671 $w insert e:$ix $str
2672 $w insert e:$ix $e [highlight_tag $de]
2675 $w mark gravity e:$ix left
2676 $w conf -state disabled
2677 set treediropen($dir) 1
2678 set top [lindex [split [$w index @0,0] .] 0]
2679 set ht [$w cget -height]
2680 set l [lindex [split [$w index s:$ix] .] 0]
2683 } elseif {$l + $n + 1 > $top + $ht} {
2684 set top [expr {$l + $n + 2 - $ht}]
2692 proc treeclick {w x y} {
2693 global treediropen cmitmode ctext cflist cflist_top
2695 if {$cmitmode ne "tree"} return
2696 if {![info exists cflist_top]} return
2697 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2698 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2699 $cflist tag add highlight $l.0 "$l.0 lineend"
2705 set e [linetoelt $l]
2706 if {[string index $e end] ne "/"} {
2708 } elseif {$treediropen($e)} {
2715 proc setfilelist {id} {
2716 global treefilelist cflist
2718 treeview $cflist $treefilelist($id) 0
2721 image create bitmap tri-rt -background black -foreground blue -data {
2722 #define tri-rt_width 13
2723 #define tri-rt_height 13
2724 static unsigned char tri-rt_bits[] = {
2725 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2726 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2729 #define tri-rt-mask_width 13
2730 #define tri-rt-mask_height 13
2731 static unsigned char tri-rt-mask_bits[] = {
2732 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2733 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2736 image create bitmap tri-dn -background black -foreground blue -data {
2737 #define tri-dn_width 13
2738 #define tri-dn_height 13
2739 static unsigned char tri-dn_bits[] = {
2740 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2741 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2744 #define tri-dn-mask_width 13
2745 #define tri-dn-mask_height 13
2746 static unsigned char tri-dn-mask_bits[] = {
2747 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2748 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2752 image create bitmap reficon-T -background black -foreground yellow -data {
2753 #define tagicon_width 13
2754 #define tagicon_height 9
2755 static unsigned char tagicon_bits[] = {
2756 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2757 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2759 #define tagicon-mask_width 13
2760 #define tagicon-mask_height 9
2761 static unsigned char tagicon-mask_bits[] = {
2762 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2763 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2766 #define headicon_width 13
2767 #define headicon_height 9
2768 static unsigned char headicon_bits[] = {
2769 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2770 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2773 #define headicon-mask_width 13
2774 #define headicon-mask_height 9
2775 static unsigned char headicon-mask_bits[] = {
2776 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2777 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2779 image create bitmap reficon-H -background black -foreground green \
2780 -data $rectdata -maskdata $rectmask
2781 image create bitmap reficon-o -background black -foreground "#ddddff" \
2782 -data $rectdata -maskdata $rectmask
2784 proc init_flist {first} {
2785 global cflist cflist_top difffilestart
2787 $cflist conf -state normal
2788 $cflist delete 0.0 end
2790 $cflist insert end $first
2792 $cflist tag add highlight 1.0 "1.0 lineend"
2794 catch {unset cflist_top}
2796 $cflist conf -state disabled
2797 set difffilestart {}
2800 proc highlight_tag {f} {
2801 global highlight_paths
2803 foreach p $highlight_paths {
2804 if {[string match $p $f]} {
2811 proc highlight_filelist {} {
2812 global cmitmode cflist
2814 $cflist conf -state normal
2815 if {$cmitmode ne "tree"} {
2816 set end [lindex [split [$cflist index end] .] 0]
2817 for {set l 2} {$l < $end} {incr l} {
2818 set line [$cflist get $l.0 "$l.0 lineend"]
2819 if {[highlight_tag $line] ne {}} {
2820 $cflist tag add bold $l.0 "$l.0 lineend"
2826 $cflist conf -state disabled
2829 proc unhighlight_filelist {} {
2832 $cflist conf -state normal
2833 $cflist tag remove bold 1.0 end
2834 $cflist conf -state disabled
2837 proc add_flist {fl} {
2840 $cflist conf -state normal
2842 $cflist insert end "\n"
2843 $cflist insert end $f [highlight_tag $f]
2845 $cflist conf -state disabled
2848 proc sel_flist {w x y} {
2849 global ctext difffilestart cflist cflist_top cmitmode
2851 if {$cmitmode eq "tree"} return
2852 if {![info exists cflist_top]} return
2853 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2854 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2855 $cflist tag add highlight $l.0 "$l.0 lineend"
2860 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2864 proc pop_flist_menu {w X Y x y} {
2865 global ctext cflist cmitmode flist_menu flist_menu_file
2866 global treediffs diffids
2869 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2871 if {$cmitmode eq "tree"} {
2872 set e [linetoelt $l]
2873 if {[string index $e end] eq "/"} return
2875 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2877 set flist_menu_file $e
2878 set xdiffstate "normal"
2879 if {$cmitmode eq "tree"} {
2880 set xdiffstate "disabled"
2882 # Disable "External diff" item in tree mode
2883 $flist_menu entryconf 2 -state $xdiffstate
2884 tk_popup $flist_menu $X $Y
2887 proc flist_hl {only} {
2888 global flist_menu_file findstring gdttype
2890 set x [shellquote $flist_menu_file]
2891 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2894 append findstring " " $x
2896 set gdttype [mc "touching paths:"]
2899 proc save_file_from_commit {filename output what} {
2902 if {[catch {exec git show $filename -- > $output} err]} {
2903 if {[string match "fatal: bad revision *" $err]} {
2906 error_popup "Error getting \"$filename\" from $what: $err"
2912 proc external_diff_get_one_file {diffid filename diffdir} {
2913 global nullid nullid2 nullfile
2916 if {$diffid == $nullid} {
2917 set difffile [file join [file dirname $gitdir] $filename]
2918 if {[file exists $difffile]} {
2923 if {$diffid == $nullid2} {
2924 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2925 return [save_file_from_commit :$filename $difffile index]
2927 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2928 return [save_file_from_commit $diffid:$filename $difffile \
2932 proc external_diff {} {
2933 global gitktmpdir nullid nullid2
2934 global flist_menu_file
2937 global gitdir extdifftool
2939 if {[llength $diffids] == 1} {
2940 # no reference commit given
2941 set diffidto [lindex $diffids 0]
2942 if {$diffidto eq $nullid} {
2943 # diffing working copy with index
2944 set diffidfrom $nullid2
2945 } elseif {$diffidto eq $nullid2} {
2946 # diffing index with HEAD
2947 set diffidfrom "HEAD"
2949 # use first parent commit
2950 global parentlist selectedline
2951 set diffidfrom [lindex $parentlist $selectedline 0]
2954 set diffidfrom [lindex $diffids 0]
2955 set diffidto [lindex $diffids 1]
2958 # make sure that several diffs wont collide
2959 if {![info exists gitktmpdir]} {
2960 set gitktmpdir [file join [file dirname $gitdir] \
2961 [format ".gitk-tmp.%s" [pid]]]
2962 if {[catch {file mkdir $gitktmpdir} err]} {
2963 error_popup "Error creating temporary directory $gitktmpdir: $err"
2970 set diffdir [file join $gitktmpdir $diffnum]
2971 if {[catch {file mkdir $diffdir} err]} {
2972 error_popup "Error creating temporary directory $diffdir: $err"
2976 # gather files to diff
2977 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
2978 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
2980 if {$difffromfile ne {} && $difftofile ne {}} {
2981 set cmd [concat | [shellsplit $extdifftool] \
2982 [list $difffromfile $difftofile]]
2983 if {[catch {set fl [open $cmd r]} err]} {
2984 file delete -force $diffdir
2985 error_popup [mc "$extdifftool: command failed: $err"]
2987 fconfigure $fl -blocking 0
2988 filerun $fl [list delete_at_eof $fl $diffdir]
2993 # delete $dir when we see eof on $f (presumably because the child has exited)
2994 proc delete_at_eof {f dir} {
2995 while {[gets $f line] >= 0} {}
2997 if {[catch {close $f} err]} {
2998 error_popup "External diff viewer failed: $err"
3000 file delete -force $dir
3006 # Functions for adding and removing shell-type quoting
3008 proc shellquote {str} {
3009 if {![string match "*\['\"\\ \t]*" $str]} {
3012 if {![string match "*\['\"\\]*" $str]} {
3015 if {![string match "*'*" $str]} {
3018 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3021 proc shellarglist {l} {
3027 append str [shellquote $a]
3032 proc shelldequote {str} {
3037 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3038 append ret [string range $str $used end]
3039 set used [string length $str]
3042 set first [lindex $first 0]
3043 set ch [string index $str $first]
3044 if {$first > $used} {
3045 append ret [string range $str $used [expr {$first - 1}]]
3048 if {$ch eq " " || $ch eq "\t"} break
3051 set first [string first "'" $str $used]
3053 error "unmatched single-quote"
3055 append ret [string range $str $used [expr {$first - 1}]]
3060 if {$used >= [string length $str]} {
3061 error "trailing backslash"
3063 append ret [string index $str $used]
3068 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3069 error "unmatched double-quote"
3071 set first [lindex $first 0]
3072 set ch [string index $str $first]
3073 if {$first > $used} {
3074 append ret [string range $str $used [expr {$first - 1}]]
3077 if {$ch eq "\""} break
3079 append ret [string index $str $used]
3083 return [list $used $ret]
3086 proc shellsplit {str} {
3089 set str [string trimleft $str]
3090 if {$str eq {}} break
3091 set dq [shelldequote $str]
3092 set n [lindex $dq 0]
3093 set word [lindex $dq 1]
3094 set str [string range $str $n end]
3100 # Code to implement multiple views
3102 proc newview {ishighlight} {
3103 global nextviewnum newviewname newviewperm newishighlight
3104 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3106 set newishighlight $ishighlight
3108 if {[winfo exists $top]} {
3112 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3113 set newviewperm($nextviewnum) 0
3114 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3115 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3116 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3121 global viewname viewperm newviewname newviewperm
3122 global viewargs newviewargs viewargscmd newviewargscmd
3124 set top .gitkvedit-$curview
3125 if {[winfo exists $top]} {
3129 set newviewname($curview) $viewname($curview)
3130 set newviewperm($curview) $viewperm($curview)
3131 set newviewargs($curview) [shellarglist $viewargs($curview)]
3132 set newviewargscmd($curview) $viewargscmd($curview)
3133 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3136 proc vieweditor {top n title} {
3137 global newviewname newviewperm viewfiles bgcolor
3140 wm title $top $title
3141 label $top.nl -text [mc "Name"]
3142 entry $top.name -width 20 -textvariable newviewname($n)
3143 grid $top.nl $top.name -sticky w -pady 5
3144 checkbutton $top.perm -text [mc "Remember this view"] \
3145 -variable newviewperm($n)
3146 grid $top.perm - -pady 5 -sticky w
3147 message $top.al -aspect 1000 \
3148 -text [mc "Commits to include (arguments to git log):"]
3149 grid $top.al - -sticky w -pady 5
3150 entry $top.args -width 50 -textvariable newviewargs($n) \
3151 -background $bgcolor
3152 grid $top.args - -sticky ew -padx 5
3154 message $top.ac -aspect 1000 \
3155 -text [mc "Command to generate more commits to include:"]
3156 grid $top.ac - -sticky w -pady 5
3157 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3159 grid $top.argscmd - -sticky ew -padx 5
3161 message $top.l -aspect 1000 \
3162 -text [mc "Enter files and directories to include, one per line:"]
3163 grid $top.l - -sticky w
3164 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3165 if {[info exists viewfiles($n)]} {
3166 foreach f $viewfiles($n) {
3167 $top.t insert end $f
3168 $top.t insert end "\n"
3170 $top.t delete {end - 1c} end
3171 $top.t mark set insert 0.0
3173 grid $top.t - -sticky ew -padx 5
3175 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3176 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3177 grid $top.buts.ok $top.buts.can
3178 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3179 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3180 grid $top.buts - -pady 10 -sticky ew
3184 proc doviewmenu {m first cmd op argv} {
3185 set nmenu [$m index end]
3186 for {set i $first} {$i <= $nmenu} {incr i} {
3187 if {[$m entrycget $i -command] eq $cmd} {
3188 eval $m $op $i $argv
3194 proc allviewmenus {n op args} {
3197 doviewmenu .bar.view 5 [list showview $n] $op $args
3198 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3201 proc newviewok {top n} {
3202 global nextviewnum newviewperm newviewname newishighlight
3203 global viewname viewfiles viewperm selectedview curview
3204 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3207 set newargs [shellsplit $newviewargs($n)]
3209 error_popup "[mc "Error in commit selection arguments:"] $err"
3215 foreach f [split [$top.t get 0.0 end] "\n"] {
3216 set ft [string trim $f]
3221 if {![info exists viewfiles($n)]} {
3222 # creating a new view
3224 set viewname($n) $newviewname($n)
3225 set viewperm($n) $newviewperm($n)
3226 set viewfiles($n) $files
3227 set viewargs($n) $newargs
3228 set viewargscmd($n) $newviewargscmd($n)
3230 if {!$newishighlight} {
3233 run addvhighlight $n
3236 # editing an existing view
3237 set viewperm($n) $newviewperm($n)
3238 if {$newviewname($n) ne $viewname($n)} {
3239 set viewname($n) $newviewname($n)
3240 doviewmenu .bar.view 5 [list showview $n] \
3241 entryconf [list -label $viewname($n)]
3242 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3243 # entryconf [list -label $viewname($n) -value $viewname($n)]
3245 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3246 $newviewargscmd($n) ne $viewargscmd($n)} {
3247 set viewfiles($n) $files
3248 set viewargs($n) $newargs
3249 set viewargscmd($n) $newviewargscmd($n)
3250 if {$curview == $n} {
3255 catch {destroy $top}
3259 global curview viewperm hlview selectedhlview
3261 if {$curview == 0} return
3262 if {[info exists hlview] && $hlview == $curview} {
3263 set selectedhlview [mc "None"]
3266 allviewmenus $curview delete
3267 set viewperm($curview) 0
3271 proc addviewmenu {n} {
3272 global viewname viewhlmenu
3274 .bar.view add radiobutton -label $viewname($n) \
3275 -command [list showview $n] -variable selectedview -value $n
3276 #$viewhlmenu add radiobutton -label $viewname($n) \
3277 # -command [list addvhighlight $n] -variable selectedhlview
3281 global curview cached_commitrow ordertok
3282 global displayorder parentlist rowidlist rowisopt rowfinal
3283 global colormap rowtextx nextcolor canvxmax
3284 global numcommits viewcomplete
3285 global selectedline currentid canv canvy0
3287 global pending_select mainheadid
3290 global hlview selectedhlview commitinterest
3292 if {$n == $curview} return
3294 set ymax [lindex [$canv cget -scrollregion] 3]
3295 set span [$canv yview]
3296 set ytop [expr {[lindex $span 0] * $ymax}]
3297 set ybot [expr {[lindex $span 1] * $ymax}]
3298 set yscreen [expr {($ybot - $ytop) / 2}]
3299 if {$selectedline ne {}} {
3300 set selid $currentid
3301 set y [yc $selectedline]
3302 if {$ytop < $y && $y < $ybot} {
3303 set yscreen [expr {$y - $ytop}]
3305 } elseif {[info exists pending_select]} {
3306 set selid $pending_select
3307 unset pending_select
3311 catch {unset treediffs}
3313 if {[info exists hlview] && $hlview == $n} {
3315 set selectedhlview [mc "None"]
3317 catch {unset commitinterest}
3318 catch {unset cached_commitrow}
3319 catch {unset ordertok}
3323 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3324 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3327 if {![info exists viewcomplete($n)]} {
3329 set pending_select $selid
3340 set numcommits $commitidx($n)
3342 catch {unset colormap}
3343 catch {unset rowtextx}
3345 set canvxmax [$canv cget -width]
3351 if {$selid ne {} && [commitinview $selid $n]} {
3352 set row [rowofcommit $selid]
3353 # try to get the selected row in the same position on the screen
3354 set ymax [lindex [$canv cget -scrollregion] 3]
3355 set ytop [expr {[yc $row] - $yscreen}]
3359 set yf [expr {$ytop * 1.0 / $ymax}]
3361 allcanvs yview moveto $yf
3365 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
3366 selectline [rowofcommit $mainheadid] 1
3367 } elseif {!$viewcomplete($n)} {
3369 set pending_select $selid
3371 set pending_select $mainheadid
3374 set row [first_real_row]
3375 if {$row < $numcommits} {
3379 if {!$viewcomplete($n)} {
3380 if {$numcommits == 0} {
3381 show_status [mc "Reading commits..."]
3383 } elseif {$numcommits == 0} {
3384 show_status [mc "No commits selected"]
3388 # Stuff relating to the highlighting facility
3390 proc ishighlighted {id} {
3391 global vhighlights fhighlights nhighlights rhighlights
3393 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3394 return $nhighlights($id)
3396 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3397 return $vhighlights($id)
3399 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3400 return $fhighlights($id)
3402 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3403 return $rhighlights($id)
3408 proc bolden {row font} {
3409 global canv linehtag selectedline boldrows
3411 lappend boldrows $row
3412 $canv itemconf $linehtag($row) -font $font
3413 if {$row == $selectedline} {
3415 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3416 -outline {{}} -tags secsel \
3417 -fill [$canv cget -selectbackground]]
3422 proc bolden_name {row font} {
3423 global canv2 linentag selectedline boldnamerows
3425 lappend boldnamerows $row
3426 $canv2 itemconf $linentag($row) -font $font
3427 if {$row == $selectedline} {
3428 $canv2 delete secsel
3429 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3430 -outline {{}} -tags secsel \
3431 -fill [$canv2 cget -selectbackground]]
3440 foreach row $boldrows {
3441 if {![ishighlighted [commitonrow $row]]} {
3442 bolden $row mainfont
3444 lappend stillbold $row
3447 set boldrows $stillbold
3450 proc addvhighlight {n} {
3451 global hlview viewcomplete curview vhl_done commitidx
3453 if {[info exists hlview]} {
3457 if {$n != $curview && ![info exists viewcomplete($n)]} {
3460 set vhl_done $commitidx($hlview)
3461 if {$vhl_done > 0} {
3466 proc delvhighlight {} {
3467 global hlview vhighlights
3469 if {![info exists hlview]} return
3471 catch {unset vhighlights}
3475 proc vhighlightmore {} {
3476 global hlview vhl_done commitidx vhighlights curview
3478 set max $commitidx($hlview)
3479 set vr [visiblerows]
3480 set r0 [lindex $vr 0]
3481 set r1 [lindex $vr 1]
3482 for {set i $vhl_done} {$i < $max} {incr i} {
3483 set id [commitonrow $i $hlview]
3484 if {[commitinview $id $curview]} {
3485 set row [rowofcommit $id]
3486 if {$r0 <= $row && $row <= $r1} {
3487 if {![highlighted $row]} {
3488 bolden $row mainfontbold
3490 set vhighlights($id) 1
3498 proc askvhighlight {row id} {
3499 global hlview vhighlights iddrawn
3501 if {[commitinview $id $hlview]} {
3502 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3503 bolden $row mainfontbold
3505 set vhighlights($id) 1
3507 set vhighlights($id) 0
3511 proc hfiles_change {} {
3512 global highlight_files filehighlight fhighlights fh_serial
3513 global highlight_paths gdttype
3515 if {[info exists filehighlight]} {
3516 # delete previous highlights
3517 catch {close $filehighlight}
3519 catch {unset fhighlights}
3521 unhighlight_filelist
3523 set highlight_paths {}
3524 after cancel do_file_hl $fh_serial
3526 if {$highlight_files ne {}} {
3527 after 300 do_file_hl $fh_serial
3531 proc gdttype_change {name ix op} {
3532 global gdttype highlight_files findstring findpattern
3535 if {$findstring ne {}} {
3536 if {$gdttype eq [mc "containing:"]} {
3537 if {$highlight_files ne {}} {
3538 set highlight_files {}
3543 if {$findpattern ne {}} {
3547 set highlight_files $findstring
3552 # enable/disable findtype/findloc menus too
3555 proc find_change {name ix op} {
3556 global gdttype findstring highlight_files
3559 if {$gdttype eq [mc "containing:"]} {
3562 if {$highlight_files ne $findstring} {
3563 set highlight_files $findstring
3570 proc findcom_change args {
3571 global nhighlights boldnamerows
3572 global findpattern findtype findstring gdttype
3575 # delete previous highlights, if any
3576 foreach row $boldnamerows {
3577 bolden_name $row mainfont
3580 catch {unset nhighlights}
3583 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3585 } elseif {$findtype eq [mc "Regexp"]} {
3586 set findpattern $findstring
3588 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3590 set findpattern "*$e*"
3594 proc makepatterns {l} {
3597 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3598 if {[string index $ee end] eq "/"} {
3608 proc do_file_hl {serial} {
3609 global highlight_files filehighlight highlight_paths gdttype fhl_list
3611 if {$gdttype eq [mc "touching paths:"]} {
3612 if {[catch {set paths [shellsplit $highlight_files]}]} return
3613 set highlight_paths [makepatterns $paths]
3615 set gdtargs [concat -- $paths]
3616 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3617 set gdtargs [list "-S$highlight_files"]
3619 # must be "containing:", i.e. we're searching commit info
3622 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3623 set filehighlight [open $cmd r+]
3624 fconfigure $filehighlight -blocking 0
3625 filerun $filehighlight readfhighlight
3631 proc flushhighlights {} {
3632 global filehighlight fhl_list
3634 if {[info exists filehighlight]} {
3636 puts $filehighlight ""
3637 flush $filehighlight
3641 proc askfilehighlight {row id} {
3642 global filehighlight fhighlights fhl_list
3644 lappend fhl_list $id
3645 set fhighlights($id) -1
3646 puts $filehighlight $id
3649 proc readfhighlight {} {
3650 global filehighlight fhighlights curview iddrawn
3651 global fhl_list find_dirn
3653 if {![info exists filehighlight]} {
3657 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3658 set line [string trim $line]
3659 set i [lsearch -exact $fhl_list $line]
3660 if {$i < 0} continue
3661 for {set j 0} {$j < $i} {incr j} {
3662 set id [lindex $fhl_list $j]
3663 set fhighlights($id) 0
3665 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3666 if {$line eq {}} continue
3667 if {![commitinview $line $curview]} continue
3668 set row [rowofcommit $line]
3669 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3670 bolden $row mainfontbold
3672 set fhighlights($line) 1
3674 if {[eof $filehighlight]} {
3676 puts "oops, git diff-tree died"
3677 catch {close $filehighlight}
3681 if {[info exists find_dirn]} {
3687 proc doesmatch {f} {
3688 global findtype findpattern
3690 if {$findtype eq [mc "Regexp"]} {
3691 return [regexp $findpattern $f]
3692 } elseif {$findtype eq [mc "IgnCase"]} {
3693 return [string match -nocase $findpattern $f]
3695 return [string match $findpattern $f]
3699 proc askfindhighlight {row id} {
3700 global nhighlights commitinfo iddrawn
3702 global markingmatches
3704 if {![info exists commitinfo($id)]} {
3707 set info $commitinfo($id)
3709 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3710 foreach f $info ty $fldtypes {
3711 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3713 if {$ty eq [mc "Author"]} {
3720 if {$isbold && [info exists iddrawn($id)]} {
3721 if {![ishighlighted $id]} {
3722 bolden $row mainfontbold
3724 bolden_name $row mainfontbold
3727 if {$markingmatches} {
3728 markrowmatches $row $id
3731 set nhighlights($id) $isbold
3734 proc markrowmatches {row id} {
3735 global canv canv2 linehtag linentag commitinfo findloc
3737 set headline [lindex $commitinfo($id) 0]
3738 set author [lindex $commitinfo($id) 1]
3739 $canv delete match$row
3740 $canv2 delete match$row
3741 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3742 set m [findmatches $headline]
3744 markmatches $canv $row $headline $linehtag($row) $m \
3745 [$canv itemcget $linehtag($row) -font] $row
3748 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3749 set m [findmatches $author]
3751 markmatches $canv2 $row $author $linentag($row) $m \
3752 [$canv2 itemcget $linentag($row) -font] $row
3757 proc vrel_change {name ix op} {
3758 global highlight_related
3761 if {$highlight_related ne [mc "None"]} {
3766 # prepare for testing whether commits are descendents or ancestors of a
3767 proc rhighlight_sel {a} {
3768 global descendent desc_todo ancestor anc_todo
3769 global highlight_related
3771 catch {unset descendent}
3772 set desc_todo [list $a]
3773 catch {unset ancestor}
3774 set anc_todo [list $a]
3775 if {$highlight_related ne [mc "None"]} {
3781 proc rhighlight_none {} {
3784 catch {unset rhighlights}
3788 proc is_descendent {a} {
3789 global curview children descendent desc_todo
3792 set la [rowofcommit $a]
3796 for {set i 0} {$i < [llength $todo]} {incr i} {
3797 set do [lindex $todo $i]
3798 if {[rowofcommit $do] < $la} {
3799 lappend leftover $do
3802 foreach nk $children($v,$do) {
3803 if {![info exists descendent($nk)]} {
3804 set descendent($nk) 1
3812 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3816 set descendent($a) 0
3817 set desc_todo $leftover
3820 proc is_ancestor {a} {
3821 global curview parents ancestor anc_todo
3824 set la [rowofcommit $a]
3828 for {set i 0} {$i < [llength $todo]} {incr i} {
3829 set do [lindex $todo $i]
3830 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3831 lappend leftover $do
3834 foreach np $parents($v,$do) {
3835 if {![info exists ancestor($np)]} {
3844 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3849 set anc_todo $leftover
3852 proc askrelhighlight {row id} {
3853 global descendent highlight_related iddrawn rhighlights
3854 global selectedline ancestor
3856 if {$selectedline eq {}} return
3858 if {$highlight_related eq [mc "Descendant"] ||
3859 $highlight_related eq [mc "Not descendant"]} {
3860 if {![info exists descendent($id)]} {
3863 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3866 } elseif {$highlight_related eq [mc "Ancestor"] ||
3867 $highlight_related eq [mc "Not ancestor"]} {
3868 if {![info exists ancestor($id)]} {
3871 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3875 if {[info exists iddrawn($id)]} {
3876 if {$isbold && ![ishighlighted $id]} {
3877 bolden $row mainfontbold
3880 set rhighlights($id) $isbold
3883 # Graph layout functions
3885 proc shortids {ids} {
3888 if {[llength $id] > 1} {
3889 lappend res [shortids $id]
3890 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3891 lappend res [string range $id 0 7]
3902 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3903 if {($n & $mask) != 0} {
3904 set ret [concat $ret $o]
3906 set o [concat $o $o]
3911 proc ordertoken {id} {
3912 global ordertok curview varcid varcstart varctok curview parents children
3913 global nullid nullid2
3915 if {[info exists ordertok($id)]} {
3916 return $ordertok($id)
3921 if {[info exists varcid($curview,$id)]} {
3922 set a $varcid($curview,$id)
3923 set p [lindex $varcstart($curview) $a]
3925 set p [lindex $children($curview,$id) 0]
3927 if {[info exists ordertok($p)]} {
3928 set tok $ordertok($p)
3931 set id [first_real_child $curview,$p]
3934 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3937 if {[llength $parents($curview,$id)] == 1} {
3938 lappend todo [list $p {}]
3940 set j [lsearch -exact $parents($curview,$id) $p]
3942 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3944 lappend todo [list $p [strrep $j]]
3947 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3948 set p [lindex $todo $i 0]
3949 append tok [lindex $todo $i 1]
3950 set ordertok($p) $tok
3952 set ordertok($origid) $tok
3956 # Work out where id should go in idlist so that order-token
3957 # values increase from left to right
3958 proc idcol {idlist id {i 0}} {
3959 set t [ordertoken $id]
3963 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3964 if {$i > [llength $idlist]} {
3965 set i [llength $idlist]
3967 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3970 if {$t > [ordertoken [lindex $idlist $i]]} {
3971 while {[incr i] < [llength $idlist] &&
3972 $t >= [ordertoken [lindex $idlist $i]]} {}
3978 proc initlayout {} {
3979 global rowidlist rowisopt rowfinal displayorder parentlist
3980 global numcommits canvxmax canv
3982 global colormap rowtextx
3991 set canvxmax [$canv cget -width]
3992 catch {unset colormap}
3993 catch {unset rowtextx}
3997 proc setcanvscroll {} {
3998 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3999 global lastscrollset lastscrollrows
4001 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4002 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4003 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4004 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4005 set lastscrollset [clock clicks -milliseconds]
4006 set lastscrollrows $numcommits
4009 proc visiblerows {} {
4010 global canv numcommits linespc
4012 set ymax [lindex [$canv cget -scrollregion] 3]
4013 if {$ymax eq {} || $ymax == 0} return
4015 set y0 [expr {int([lindex $f 0] * $ymax)}]
4016 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4020 set y1 [expr {int([lindex $f 1] * $ymax)}]
4021 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4022 if {$r1 >= $numcommits} {
4023 set r1 [expr {$numcommits - 1}]
4025 return [list $r0 $r1]
4028 proc layoutmore {} {
4029 global commitidx viewcomplete curview
4030 global numcommits pending_select curview
4031 global lastscrollset lastscrollrows commitinterest
4033 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4034 [clock clicks -milliseconds] - $lastscrollset > 500} {
4037 if {[info exists pending_select] &&
4038 [commitinview $pending_select $curview]} {
4039 selectline [rowofcommit $pending_select] 1
4044 proc doshowlocalchanges {} {
4045 global curview mainheadid
4047 if {$mainheadid eq {}} return
4048 if {[commitinview $mainheadid $curview]} {
4051 lappend commitinterest($mainheadid) {dodiffindex}
4055 proc dohidelocalchanges {} {
4056 global nullid nullid2 lserial curview
4058 if {[commitinview $nullid $curview]} {
4059 removefakerow $nullid
4061 if {[commitinview $nullid2 $curview]} {
4062 removefakerow $nullid2
4067 # spawn off a process to do git diff-index --cached HEAD
4068 proc dodiffindex {} {
4069 global lserial showlocalchanges
4072 if {!$showlocalchanges || !$isworktree} return
4074 set fd [open "|git diff-index --cached HEAD" r]
4075 fconfigure $fd -blocking 0
4076 set i [reg_instance $fd]
4077 filerun $fd [list readdiffindex $fd $lserial $i]
4080 proc readdiffindex {fd serial inst} {
4081 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4084 if {[gets $fd line] < 0} {
4090 # we only need to see one line and we don't really care what it says...
4093 if {$serial != $lserial} {
4097 # now see if there are any local changes not checked in to the index
4098 set fd [open "|git diff-files" r]
4099 fconfigure $fd -blocking 0
4100 set i [reg_instance $fd]
4101 filerun $fd [list readdifffiles $fd $serial $i]
4103 if {$isdiff && ![commitinview $nullid2 $curview]} {
4104 # add the line for the changes in the index to the graph
4105 set hl [mc "Local changes checked in to index but not committed"]
4106 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4107 set commitdata($nullid2) "\n $hl\n"
4108 if {[commitinview $nullid $curview]} {
4109 removefakerow $nullid
4111 insertfakerow $nullid2 $mainheadid
4112 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4113 removefakerow $nullid2
4118 proc readdifffiles {fd serial inst} {
4119 global mainheadid nullid nullid2 curview
4120 global commitinfo commitdata lserial
4123 if {[gets $fd line] < 0} {
4129 # we only need to see one line and we don't really care what it says...
4132 if {$serial != $lserial} {
4136 if {$isdiff && ![commitinview $nullid $curview]} {
4137 # add the line for the local diff to the graph
4138 set hl [mc "Local uncommitted changes, not checked in to index"]
4139 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4140 set commitdata($nullid) "\n $hl\n"
4141 if {[commitinview $nullid2 $curview]} {
4146 insertfakerow $nullid $p
4147 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4148 removefakerow $nullid
4153 proc nextuse {id row} {
4154 global curview children
4156 if {[info exists children($curview,$id)]} {
4157 foreach kid $children($curview,$id) {
4158 if {![commitinview $kid $curview]} {
4161 if {[rowofcommit $kid] > $row} {
4162 return [rowofcommit $kid]
4166 if {[commitinview $id $curview]} {
4167 return [rowofcommit $id]
4172 proc prevuse {id row} {
4173 global curview children
4176 if {[info exists children($curview,$id)]} {
4177 foreach kid $children($curview,$id) {
4178 if {![commitinview $kid $curview]} break
4179 if {[rowofcommit $kid] < $row} {
4180 set ret [rowofcommit $kid]
4187 proc make_idlist {row} {
4188 global displayorder parentlist uparrowlen downarrowlen mingaplen
4189 global commitidx curview children
4191 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4195 set ra [expr {$row - $downarrowlen}]
4199 set rb [expr {$row + $uparrowlen}]
4200 if {$rb > $commitidx($curview)} {
4201 set rb $commitidx($curview)
4203 make_disporder $r [expr {$rb + 1}]
4205 for {} {$r < $ra} {incr r} {
4206 set nextid [lindex $displayorder [expr {$r + 1}]]
4207 foreach p [lindex $parentlist $r] {
4208 if {$p eq $nextid} continue
4209 set rn [nextuse $p $r]
4211 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4212 lappend ids [list [ordertoken $p] $p]
4216 for {} {$r < $row} {incr r} {
4217 set nextid [lindex $displayorder [expr {$r + 1}]]
4218 foreach p [lindex $parentlist $r] {
4219 if {$p eq $nextid} continue
4220 set rn [nextuse $p $r]
4221 if {$rn < 0 || $rn >= $row} {
4222 lappend ids [list [ordertoken $p] $p]
4226 set id [lindex $displayorder $row]
4227 lappend ids [list [ordertoken $id] $id]
4229 foreach p [lindex $parentlist $r] {
4230 set firstkid [lindex $children($curview,$p) 0]
4231 if {[rowofcommit $firstkid] < $row} {
4232 lappend ids [list [ordertoken $p] $p]
4236 set id [lindex $displayorder $r]
4238 set firstkid [lindex $children($curview,$id) 0]
4239 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4240 lappend ids [list [ordertoken $id] $id]
4245 foreach idx [lsort -unique $ids] {
4246 lappend idlist [lindex $idx 1]
4251 proc rowsequal {a b} {
4252 while {[set i [lsearch -exact $a {}]] >= 0} {
4253 set a [lreplace $a $i $i]
4255 while {[set i [lsearch -exact $b {}]] >= 0} {
4256 set b [lreplace $b $i $i]
4258 return [expr {$a eq $b}]
4261 proc makeupline {id row rend col} {
4262 global rowidlist uparrowlen downarrowlen mingaplen
4264 for {set r $rend} {1} {set r $rstart} {
4265 set rstart [prevuse $id $r]
4266 if {$rstart < 0} return
4267 if {$rstart < $row} break
4269 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4270 set rstart [expr {$rend - $uparrowlen - 1}]
4272 for {set r $rstart} {[incr r] <= $row} {} {
4273 set idlist [lindex $rowidlist $r]
4274 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4275 set col [idcol $idlist $id $col]
4276 lset rowidlist $r [linsert $idlist $col $id]
4282 proc layoutrows {row endrow} {
4283 global rowidlist rowisopt rowfinal displayorder
4284 global uparrowlen downarrowlen maxwidth mingaplen
4285 global children parentlist
4286 global commitidx viewcomplete curview
4288 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4291 set rm1 [expr {$row - 1}]
4292 foreach id [lindex $rowidlist $rm1] {
4297 set final [lindex $rowfinal $rm1]
4299 for {} {$row < $endrow} {incr row} {
4300 set rm1 [expr {$row - 1}]
4301 if {$rm1 < 0 || $idlist eq {}} {
4302 set idlist [make_idlist $row]
4305 set id [lindex $displayorder $rm1]
4306 set col [lsearch -exact $idlist $id]
4307 set idlist [lreplace $idlist $col $col]
4308 foreach p [lindex $parentlist $rm1] {
4309 if {[lsearch -exact $idlist $p] < 0} {
4310 set col [idcol $idlist $p $col]
4311 set idlist [linsert $idlist $col $p]
4312 # if not the first child, we have to insert a line going up
4313 if {$id ne [lindex $children($curview,$p) 0]} {
4314 makeupline $p $rm1 $row $col
4318 set id [lindex $displayorder $row]
4319 if {$row > $downarrowlen} {
4320 set termrow [expr {$row - $downarrowlen - 1}]
4321 foreach p [lindex $parentlist $termrow] {
4322 set i [lsearch -exact $idlist $p]
4323 if {$i < 0} continue
4324 set nr [nextuse $p $termrow]
4325 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4326 set idlist [lreplace $idlist $i $i]
4330 set col [lsearch -exact $idlist $id]
4332 set col [idcol $idlist $id]
4333 set idlist [linsert $idlist $col $id]
4334 if {$children($curview,$id) ne {}} {
4335 makeupline $id $rm1 $row $col
4338 set r [expr {$row + $uparrowlen - 1}]
4339 if {$r < $commitidx($curview)} {
4341 foreach p [lindex $parentlist $r] {
4342 if {[lsearch -exact $idlist $p] >= 0} continue
4343 set fk [lindex $children($curview,$p) 0]
4344 if {[rowofcommit $fk] < $row} {
4345 set x [idcol $idlist $p $x]
4346 set idlist [linsert $idlist $x $p]
4349 if {[incr r] < $commitidx($curview)} {
4350 set p [lindex $displayorder $r]
4351 if {[lsearch -exact $idlist $p] < 0} {
4352 set fk [lindex $children($curview,$p) 0]
4353 if {$fk ne {} && [rowofcommit $fk] < $row} {
4354 set x [idcol $idlist $p $x]
4355 set idlist [linsert $idlist $x $p]
4361 if {$final && !$viewcomplete($curview) &&
4362 $row + $uparrowlen + $mingaplen + $downarrowlen
4363 >= $commitidx($curview)} {
4366 set l [llength $rowidlist]
4368 lappend rowidlist $idlist
4370 lappend rowfinal $final
4371 } elseif {$row < $l} {
4372 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4373 lset rowidlist $row $idlist
4376 lset rowfinal $row $final
4378 set pad [ntimes [expr {$row - $l}] {}]
4379 set rowidlist [concat $rowidlist $pad]
4380 lappend rowidlist $idlist
4381 set rowfinal [concat $rowfinal $pad]
4382 lappend rowfinal $final
4383 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4389 proc changedrow {row} {
4390 global displayorder iddrawn rowisopt need_redisplay
4392 set l [llength $rowisopt]
4394 lset rowisopt $row 0
4395 if {$row + 1 < $l} {
4396 lset rowisopt [expr {$row + 1}] 0
4397 if {$row + 2 < $l} {
4398 lset rowisopt [expr {$row + 2}] 0
4402 set id [lindex $displayorder $row]
4403 if {[info exists iddrawn($id)]} {
4404 set need_redisplay 1
4408 proc insert_pad {row col npad} {
4411 set pad [ntimes $npad {}]
4412 set idlist [lindex $rowidlist $row]
4413 set bef [lrange $idlist 0 [expr {$col - 1}]]
4414 set aft [lrange $idlist $col end]
4415 set i [lsearch -exact $aft {}]
4417 set aft [lreplace $aft $i $i]
4419 lset rowidlist $row [concat $bef $pad $aft]
4423 proc optimize_rows {row col endrow} {
4424 global rowidlist rowisopt displayorder curview children
4429 for {} {$row < $endrow} {incr row; set col 0} {
4430 if {[lindex $rowisopt $row]} continue
4432 set y0 [expr {$row - 1}]
4433 set ym [expr {$row - 2}]
4434 set idlist [lindex $rowidlist $row]
4435 set previdlist [lindex $rowidlist $y0]
4436 if {$idlist eq {} || $previdlist eq {}} continue
4438 set pprevidlist [lindex $rowidlist $ym]
4439 if {$pprevidlist eq {}} continue
4445 for {} {$col < [llength $idlist]} {incr col} {
4446 set id [lindex $idlist $col]
4447 if {[lindex $previdlist $col] eq $id} continue
4452 set x0 [lsearch -exact $previdlist $id]
4453 if {$x0 < 0} continue
4454 set z [expr {$x0 - $col}]
4458 set xm [lsearch -exact $pprevidlist $id]
4460 set z0 [expr {$xm - $x0}]
4464 # if row y0 is the first child of $id then it's not an arrow
4465 if {[lindex $children($curview,$id) 0] ne
4466 [lindex $displayorder $y0]} {
4470 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4471 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4474 # Looking at lines from this row to the previous row,
4475 # make them go straight up if they end in an arrow on
4476 # the previous row; otherwise make them go straight up
4478 if {$z < -1 || ($z < 0 && $isarrow)} {
4479 # Line currently goes left too much;
4480 # insert pads in the previous row, then optimize it
4481 set npad [expr {-1 - $z + $isarrow}]
4482 insert_pad $y0 $x0 $npad
4484 optimize_rows $y0 $x0 $row
4486 set previdlist [lindex $rowidlist $y0]
4487 set x0 [lsearch -exact $previdlist $id]
4488 set z [expr {$x0 - $col}]
4490 set pprevidlist [lindex $rowidlist $ym]
4491 set xm [lsearch -exact $pprevidlist $id]
4492 set z0 [expr {$xm - $x0}]
4494 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4495 # Line currently goes right too much;
4496 # insert pads in this line
4497 set npad [expr {$z - 1 + $isarrow}]
4498 insert_pad $row $col $npad
4499 set idlist [lindex $rowidlist $row]
4501 set z [expr {$x0 - $col}]
4504 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4505 # this line links to its first child on row $row-2
4506 set id [lindex $displayorder $ym]
4507 set xc [lsearch -exact $pprevidlist $id]
4509 set z0 [expr {$xc - $x0}]
4512 # avoid lines jigging left then immediately right
4513 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4514 insert_pad $y0 $x0 1
4516 optimize_rows $y0 $x0 $row
4517 set previdlist [lindex $rowidlist $y0]
4521 # Find the first column that doesn't have a line going right
4522 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4523 set id [lindex $idlist $col]
4524 if {$id eq {}} break
4525 set x0 [lsearch -exact $previdlist $id]
4527 # check if this is the link to the first child
4528 set kid [lindex $displayorder $y0]
4529 if {[lindex $children($curview,$id) 0] eq $kid} {
4530 # it is, work out offset to child
4531 set x0 [lsearch -exact $previdlist $kid]
4534 if {$x0 <= $col} break
4536 # Insert a pad at that column as long as it has a line and
4537 # isn't the last column
4538 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4539 set idlist [linsert $idlist $col {}]
4540 lset rowidlist $row $idlist
4548 global canvx0 linespc
4549 return [expr {$canvx0 + $col * $linespc}]
4553 global canvy0 linespc
4554 return [expr {$canvy0 + $row * $linespc}]
4557 proc linewidth {id} {
4558 global thickerline lthickness
4561 if {[info exists thickerline] && $id eq $thickerline} {
4562 set wid [expr {2 * $lthickness}]
4567 proc rowranges {id} {
4568 global curview children uparrowlen downarrowlen
4571 set kids $children($curview,$id)
4577 foreach child $kids {
4578 if {![commitinview $child $curview]} break
4579 set row [rowofcommit $child]
4580 if {![info exists prev]} {
4581 lappend ret [expr {$row + 1}]
4583 if {$row <= $prevrow} {
4584 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4586 # see if the line extends the whole way from prevrow to row
4587 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4588 [lsearch -exact [lindex $rowidlist \
4589 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4590 # it doesn't, see where it ends
4591 set r [expr {$prevrow + $downarrowlen}]
4592 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4593 while {[incr r -1] > $prevrow &&
4594 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4596 while {[incr r] <= $row &&
4597 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4601 # see where it starts up again
4602 set r [expr {$row - $uparrowlen}]
4603 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4604 while {[incr r] < $row &&
4605 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4607 while {[incr r -1] >= $prevrow &&
4608 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4614 if {$child eq $id} {
4623 proc drawlineseg {id row endrow arrowlow} {
4624 global rowidlist displayorder iddrawn linesegs
4625 global canv colormap linespc curview maxlinelen parentlist
4627 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4628 set le [expr {$row + 1}]
4631 set c [lsearch -exact [lindex $rowidlist $le] $id]
4637 set x [lindex $displayorder $le]
4642 if {[info exists iddrawn($x)] || $le == $endrow} {
4643 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4659 if {[info exists linesegs($id)]} {
4660 set lines $linesegs($id)
4662 set r0 [lindex $li 0]
4664 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4674 set li [lindex $lines [expr {$i-1}]]
4675 set r1 [lindex $li 1]
4676 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4681 set x [lindex $cols [expr {$le - $row}]]
4682 set xp [lindex $cols [expr {$le - 1 - $row}]]
4683 set dir [expr {$xp - $x}]
4685 set ith [lindex $lines $i 2]
4686 set coords [$canv coords $ith]
4687 set ah [$canv itemcget $ith -arrow]
4688 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4689 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4690 if {$x2 ne {} && $x - $x2 == $dir} {
4691 set coords [lrange $coords 0 end-2]
4694 set coords [list [xc $le $x] [yc $le]]
4697 set itl [lindex $lines [expr {$i-1}] 2]
4698 set al [$canv itemcget $itl -arrow]
4699 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4700 } elseif {$arrowlow} {
4701 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4702 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4706 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4707 for {set y $le} {[incr y -1] > $row} {} {
4709 set xp [lindex $cols [expr {$y - 1 - $row}]]
4710 set ndir [expr {$xp - $x}]
4711 if {$dir != $ndir || $xp < 0} {
4712 lappend coords [xc $y $x] [yc $y]
4718 # join parent line to first child
4719 set ch [lindex $displayorder $row]
4720 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4722 puts "oops: drawlineseg: child $ch not on row $row"
4723 } elseif {$xc != $x} {
4724 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4725 set d [expr {int(0.5 * $linespc)}]
4728 set x2 [expr {$x1 - $d}]
4730 set x2 [expr {$x1 + $d}]
4733 set y1 [expr {$y2 + $d}]
4734 lappend coords $x1 $y1 $x2 $y2
4735 } elseif {$xc < $x - 1} {
4736 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4737 } elseif {$xc > $x + 1} {
4738 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4742 lappend coords [xc $row $x] [yc $row]
4744 set xn [xc $row $xp]
4746 lappend coords $xn $yn
4750 set t [$canv create line $coords -width [linewidth $id] \
4751 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4754 set lines [linsert $lines $i [list $row $le $t]]
4756 $canv coords $ith $coords
4757 if {$arrow ne $ah} {
4758 $canv itemconf $ith -arrow $arrow
4760 lset lines $i 0 $row
4763 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4764 set ndir [expr {$xo - $xp}]
4765 set clow [$canv coords $itl]
4766 if {$dir == $ndir} {
4767 set clow [lrange $clow 2 end]
4769 set coords [concat $coords $clow]
4771 lset lines [expr {$i-1}] 1 $le
4773 # coalesce two pieces
4775 set b [lindex $lines [expr {$i-1}] 0]
4776 set e [lindex $lines $i 1]
4777 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4779 $canv coords $itl $coords
4780 if {$arrow ne $al} {
4781 $canv itemconf $itl -arrow $arrow
4785 set linesegs($id) $lines
4789 proc drawparentlinks {id row} {
4790 global rowidlist canv colormap curview parentlist
4791 global idpos linespc
4793 set rowids [lindex $rowidlist $row]
4794 set col [lsearch -exact $rowids $id]
4795 if {$col < 0} return
4796 set olds [lindex $parentlist $row]
4797 set row2 [expr {$row + 1}]
4798 set x [xc $row $col]
4801 set d [expr {int(0.5 * $linespc)}]
4802 set ymid [expr {$y + $d}]
4803 set ids [lindex $rowidlist $row2]
4804 # rmx = right-most X coord used
4807 set i [lsearch -exact $ids $p]
4809 puts "oops, parent $p of $id not in list"
4812 set x2 [xc $row2 $i]
4816 set j [lsearch -exact $rowids $p]
4818 # drawlineseg will do this one for us
4822 # should handle duplicated parents here...
4823 set coords [list $x $y]
4825 # if attaching to a vertical segment, draw a smaller
4826 # slant for visual distinctness
4829 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4831 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4833 } elseif {$i < $col && $i < $j} {
4834 # segment slants towards us already
4835 lappend coords [xc $row $j] $y
4837 if {$i < $col - 1} {
4838 lappend coords [expr {$x2 + $linespc}] $y
4839 } elseif {$i > $col + 1} {
4840 lappend coords [expr {$x2 - $linespc}] $y
4842 lappend coords $x2 $y2
4845 lappend coords $x2 $y2
4847 set t [$canv create line $coords -width [linewidth $p] \
4848 -fill $colormap($p) -tags lines.$p]
4852 if {$rmx > [lindex $idpos($id) 1]} {
4853 lset idpos($id) 1 $rmx
4858 proc drawlines {id} {
4861 $canv itemconf lines.$id -width [linewidth $id]
4864 proc drawcmittext {id row col} {
4865 global linespc canv canv2 canv3 fgcolor curview
4866 global cmitlisted commitinfo rowidlist parentlist
4867 global rowtextx idpos idtags idheads idotherrefs
4868 global linehtag linentag linedtag selectedline
4869 global canvxmax boldrows boldnamerows fgcolor
4870 global mainheadid nullid nullid2 circleitem circlecolors
4872 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4873 set listed $cmitlisted($curview,$id)
4874 if {$id eq $nullid} {
4876 } elseif {$id eq $nullid2} {
4878 } elseif {$id eq $mainheadid} {
4881 set ofill [lindex $circlecolors $listed]
4883 set x [xc $row $col]
4885 set orad [expr {$linespc / 3}]
4887 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4888 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4889 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4890 } elseif {$listed == 3} {
4891 # triangle pointing left for left-side commits
4892 set t [$canv create polygon \
4893 [expr {$x - $orad}] $y \
4894 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4895 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4896 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4898 # triangle pointing right for right-side commits
4899 set t [$canv create polygon \
4900 [expr {$x + $orad - 1}] $y \
4901 [expr {$x - $orad}] [expr {$y - $orad}] \
4902 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4903 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4905 set circleitem($row) $t
4907 $canv bind $t <1> {selcanvline {} %x %y}
4908 set rmx [llength [lindex $rowidlist $row]]
4909 set olds [lindex $parentlist $row]
4911 set nextids [lindex $rowidlist [expr {$row + 1}]]
4913 set i [lsearch -exact $nextids $p]
4919 set xt [xc $row $rmx]
4920 set rowtextx($row) $xt
4921 set idpos($id) [list $x $xt $y]
4922 if {[info exists idtags($id)] || [info exists idheads($id)]
4923 || [info exists idotherrefs($id)]} {
4924 set xt [drawtags $id $x $xt $y]
4926 set headline [lindex $commitinfo($id) 0]
4927 set name [lindex $commitinfo($id) 1]
4928 set date [lindex $commitinfo($id) 2]
4929 set date [formatdate $date]
4932 set isbold [ishighlighted $id]
4934 lappend boldrows $row
4935 set font mainfontbold
4937 lappend boldnamerows $row
4938 set nfont mainfontbold
4941 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4942 -text $headline -font $font -tags text]
4943 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4944 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4945 -text $name -font $nfont -tags text]
4946 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4947 -text $date -font mainfont -tags text]
4948 if {$selectedline == $row} {
4951 set xr [expr {$xt + [font measure $font $headline]}]
4952 if {$xr > $canvxmax} {
4958 proc drawcmitrow {row} {
4959 global displayorder rowidlist nrows_drawn
4960 global iddrawn markingmatches
4961 global commitinfo numcommits
4962 global filehighlight fhighlights findpattern nhighlights
4963 global hlview vhighlights
4964 global highlight_related rhighlights
4966 if {$row >= $numcommits} return
4968 set id [lindex $displayorder $row]
4969 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4970 askvhighlight $row $id
4972 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4973 askfilehighlight $row $id
4975 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4976 askfindhighlight $row $id
4978 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4979 askrelhighlight $row $id
4981 if {![info exists iddrawn($id)]} {
4982 set col [lsearch -exact [lindex $rowidlist $row] $id]
4984 puts "oops, row $row id $id not in list"
4987 if {![info exists commitinfo($id)]} {
4991 drawcmittext $id $row $col
4995 if {$markingmatches} {
4996 markrowmatches $row $id
5000 proc drawcommits {row {endrow {}}} {
5001 global numcommits iddrawn displayorder curview need_redisplay
5002 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5007 if {$endrow eq {}} {
5010 if {$endrow >= $numcommits} {
5011 set endrow [expr {$numcommits - 1}]
5014 set rl1 [expr {$row - $downarrowlen - 3}]
5018 set ro1 [expr {$row - 3}]
5022 set r2 [expr {$endrow + $uparrowlen + 3}]
5023 if {$r2 > $numcommits} {
5026 for {set r $rl1} {$r < $r2} {incr r} {
5027 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5031 set rl1 [expr {$r + 1}]
5037 optimize_rows $ro1 0 $r2
5038 if {$need_redisplay || $nrows_drawn > 2000} {
5043 # make the lines join to already-drawn rows either side
5044 set r [expr {$row - 1}]
5045 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5048 set er [expr {$endrow + 1}]
5049 if {$er >= $numcommits ||
5050 ![info exists iddrawn([lindex $displayorder $er])]} {
5053 for {} {$r <= $er} {incr r} {
5054 set id [lindex $displayorder $r]
5055 set wasdrawn [info exists iddrawn($id)]
5057 if {$r == $er} break
5058 set nextid [lindex $displayorder [expr {$r + 1}]]
5059 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5060 drawparentlinks $id $r
5062 set rowids [lindex $rowidlist $r]
5063 foreach lid $rowids {
5064 if {$lid eq {}} continue
5065 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5067 # see if this is the first child of any of its parents
5068 foreach p [lindex $parentlist $r] {
5069 if {[lsearch -exact $rowids $p] < 0} {
5070 # make this line extend up to the child
5071 set lineend($p) [drawlineseg $p $r $er 0]
5075 set lineend($lid) [drawlineseg $lid $r $er 1]
5081 proc undolayout {row} {
5082 global uparrowlen mingaplen downarrowlen
5083 global rowidlist rowisopt rowfinal need_redisplay
5085 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5089 if {[llength $rowidlist] > $r} {
5091 set rowidlist [lrange $rowidlist 0 $r]
5092 set rowfinal [lrange $rowfinal 0 $r]
5093 set rowisopt [lrange $rowisopt 0 $r]
5094 set need_redisplay 1
5099 proc drawvisible {} {
5100 global canv linespc curview vrowmod selectedline targetrow targetid
5101 global need_redisplay cscroll numcommits
5103 set fs [$canv yview]
5104 set ymax [lindex [$canv cget -scrollregion] 3]
5105 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5106 set f0 [lindex $fs 0]
5107 set f1 [lindex $fs 1]
5108 set y0 [expr {int($f0 * $ymax)}]
5109 set y1 [expr {int($f1 * $ymax)}]
5111 if {[info exists targetid]} {
5112 if {[commitinview $targetid $curview]} {
5113 set r [rowofcommit $targetid]
5114 if {$r != $targetrow} {
5115 # Fix up the scrollregion and change the scrolling position
5116 # now that our target row has moved.
5117 set diff [expr {($r - $targetrow) * $linespc}]
5120 set ymax [lindex [$canv cget -scrollregion] 3]
5123 set f0 [expr {$y0 / $ymax}]
5124 set f1 [expr {$y1 / $ymax}]
5125 allcanvs yview moveto $f0
5126 $cscroll set $f0 $f1
5127 set need_redisplay 1
5134 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5135 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5136 if {$endrow >= $vrowmod($curview)} {
5137 update_arcrows $curview
5139 if {$selectedline ne {} &&
5140 $row <= $selectedline && $selectedline <= $endrow} {
5141 set targetrow $selectedline
5142 } elseif {[info exists targetid]} {
5143 set targetrow [expr {int(($row + $endrow) / 2)}]
5145 if {[info exists targetrow]} {
5146 if {$targetrow >= $numcommits} {
5147 set targetrow [expr {$numcommits - 1}]
5149 set targetid [commitonrow $targetrow]
5151 drawcommits $row $endrow
5154 proc clear_display {} {
5155 global iddrawn linesegs need_redisplay nrows_drawn
5156 global vhighlights fhighlights nhighlights rhighlights
5157 global linehtag linentag linedtag boldrows boldnamerows
5160 catch {unset iddrawn}
5161 catch {unset linesegs}
5162 catch {unset linehtag}
5163 catch {unset linentag}
5164 catch {unset linedtag}
5167 catch {unset vhighlights}
5168 catch {unset fhighlights}
5169 catch {unset nhighlights}
5170 catch {unset rhighlights}
5171 set need_redisplay 0
5175 proc findcrossings {id} {
5176 global rowidlist parentlist numcommits displayorder
5180 foreach {s e} [rowranges $id] {
5181 if {$e >= $numcommits} {
5182 set e [expr {$numcommits - 1}]
5184 if {$e <= $s} continue
5185 for {set row $e} {[incr row -1] >= $s} {} {
5186 set x [lsearch -exact [lindex $rowidlist $row] $id]
5188 set olds [lindex $parentlist $row]
5189 set kid [lindex $displayorder $row]
5190 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5191 if {$kidx < 0} continue
5192 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5194 set px [lsearch -exact $nextrow $p]
5195 if {$px < 0} continue
5196 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5197 if {[lsearch -exact $ccross $p] >= 0} continue
5198 if {$x == $px + ($kidx < $px? -1: 1)} {
5200 } elseif {[lsearch -exact $cross $p] < 0} {
5207 return [concat $ccross {{}} $cross]
5210 proc assigncolor {id} {
5211 global colormap colors nextcolor
5212 global parents children children curview
5214 if {[info exists colormap($id)]} return
5215 set ncolors [llength $colors]
5216 if {[info exists children($curview,$id)]} {
5217 set kids $children($curview,$id)
5221 if {[llength $kids] == 1} {
5222 set child [lindex $kids 0]
5223 if {[info exists colormap($child)]
5224 && [llength $parents($curview,$child)] == 1} {
5225 set colormap($id) $colormap($child)
5231 foreach x [findcrossings $id] {
5233 # delimiter between corner crossings and other crossings
5234 if {[llength $badcolors] >= $ncolors - 1} break
5235 set origbad $badcolors
5237 if {[info exists colormap($x)]
5238 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5239 lappend badcolors $colormap($x)
5242 if {[llength $badcolors] >= $ncolors} {
5243 set badcolors $origbad
5245 set origbad $badcolors
5246 if {[llength $badcolors] < $ncolors - 1} {
5247 foreach child $kids {
5248 if {[info exists colormap($child)]
5249 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5250 lappend badcolors $colormap($child)
5252 foreach p $parents($curview,$child) {
5253 if {[info exists colormap($p)]
5254 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5255 lappend badcolors $colormap($p)
5259 if {[llength $badcolors] >= $ncolors} {
5260 set badcolors $origbad
5263 for {set i 0} {$i <= $ncolors} {incr i} {
5264 set c [lindex $colors $nextcolor]
5265 if {[incr nextcolor] >= $ncolors} {
5268 if {[lsearch -exact $badcolors $c]} break
5270 set colormap($id) $c
5273 proc bindline {t id} {
5276 $canv bind $t <Enter> "lineenter %x %y $id"
5277 $canv bind $t <Motion> "linemotion %x %y $id"
5278 $canv bind $t <Leave> "lineleave $id"
5279 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5282 proc drawtags {id x xt y1} {
5283 global idtags idheads idotherrefs mainhead
5284 global linespc lthickness
5285 global canv rowtextx curview fgcolor bgcolor
5290 if {[info exists idtags($id)]} {
5291 set marks $idtags($id)
5292 set ntags [llength $marks]
5294 if {[info exists idheads($id)]} {
5295 set marks [concat $marks $idheads($id)]
5296 set nheads [llength $idheads($id)]
5298 if {[info exists idotherrefs($id)]} {
5299 set marks [concat $marks $idotherrefs($id)]
5305 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5306 set yt [expr {$y1 - 0.5 * $linespc}]
5307 set yb [expr {$yt + $linespc - 1}]
5311 foreach tag $marks {
5313 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5314 set wid [font measure mainfontbold $tag]
5316 set wid [font measure mainfont $tag]
5320 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5322 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5323 -width $lthickness -fill black -tags tag.$id]
5325 foreach tag $marks x $xvals wid $wvals {
5326 set xl [expr {$x + $delta}]
5327 set xr [expr {$x + $delta + $wid + $lthickness}]
5329 if {[incr ntags -1] >= 0} {
5331 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5332 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5333 -width 1 -outline black -fill yellow -tags tag.$id]
5334 $canv bind $t <1> [list showtag $tag 1]
5335 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5337 # draw a head or other ref
5338 if {[incr nheads -1] >= 0} {
5340 if {$tag eq $mainhead} {
5341 set font mainfontbold
5346 set xl [expr {$xl - $delta/2}]
5347 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5348 -width 1 -outline black -fill $col -tags tag.$id
5349 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5350 set rwid [font measure mainfont $remoteprefix]
5351 set xi [expr {$x + 1}]
5352 set yti [expr {$yt + 1}]
5353 set xri [expr {$x + $rwid}]
5354 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5355 -width 0 -fill "#ffddaa" -tags tag.$id
5358 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5359 -font $font -tags [list tag.$id text]]
5361 $canv bind $t <1> [list showtag $tag 1]
5362 } elseif {$nheads >= 0} {
5363 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5369 proc xcoord {i level ln} {
5370 global canvx0 xspc1 xspc2
5372 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5373 if {$i > 0 && $i == $level} {
5374 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5375 } elseif {$i > $level} {
5376 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5381 proc show_status {msg} {
5385 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5386 -tags text -fill $fgcolor
5389 # Don't change the text pane cursor if it is currently the hand cursor,
5390 # showing that we are over a sha1 ID link.
5391 proc settextcursor {c} {
5392 global ctext curtextcursor
5394 if {[$ctext cget -cursor] == $curtextcursor} {
5395 $ctext config -cursor $c
5397 set curtextcursor $c
5400 proc nowbusy {what {name {}}} {
5401 global isbusy busyname statusw
5403 if {[array names isbusy] eq {}} {
5404 . config -cursor watch
5408 set busyname($what) $name
5410 $statusw conf -text $name
5414 proc notbusy {what} {
5415 global isbusy maincursor textcursor busyname statusw
5419 if {$busyname($what) ne {} &&
5420 [$statusw cget -text] eq $busyname($what)} {
5421 $statusw conf -text {}
5424 if {[array names isbusy] eq {}} {
5425 . config -cursor $maincursor
5426 settextcursor $textcursor
5430 proc findmatches {f} {
5431 global findtype findstring
5432 if {$findtype == [mc "Regexp"]} {
5433 set matches [regexp -indices -all -inline $findstring $f]
5436 if {$findtype == [mc "IgnCase"]} {
5437 set f [string tolower $f]
5438 set fs [string tolower $fs]
5442 set l [string length $fs]
5443 while {[set j [string first $fs $f $i]] >= 0} {
5444 lappend matches [list $j [expr {$j+$l-1}]]
5445 set i [expr {$j + $l}]
5451 proc dofind {{dirn 1} {wrap 1}} {
5452 global findstring findstartline findcurline selectedline numcommits
5453 global gdttype filehighlight fh_serial find_dirn findallowwrap
5455 if {[info exists find_dirn]} {
5456 if {$find_dirn == $dirn} return
5460 if {$findstring eq {} || $numcommits == 0} return
5461 if {$selectedline eq {}} {
5462 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5464 set findstartline $selectedline
5466 set findcurline $findstartline
5467 nowbusy finding [mc "Searching"]
5468 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5469 after cancel do_file_hl $fh_serial
5470 do_file_hl $fh_serial
5473 set findallowwrap $wrap
5477 proc stopfinding {} {
5478 global find_dirn findcurline fprogcoord
5480 if {[info exists find_dirn]} {
5490 global commitdata commitinfo numcommits findpattern findloc
5491 global findstartline findcurline findallowwrap
5492 global find_dirn gdttype fhighlights fprogcoord
5493 global curview varcorder vrownum varccommits vrowmod
5495 if {![info exists find_dirn]} {
5498 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5501 if {$find_dirn > 0} {
5503 if {$l >= $numcommits} {
5506 if {$l <= $findstartline} {
5507 set lim [expr {$findstartline + 1}]
5510 set moretodo $findallowwrap
5517 if {$l >= $findstartline} {
5518 set lim [expr {$findstartline - 1}]
5521 set moretodo $findallowwrap
5524 set n [expr {($lim - $l) * $find_dirn}]
5529 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5530 update_arcrows $curview
5534 set ai [bsearch $vrownum($curview) $l]
5535 set a [lindex $varcorder($curview) $ai]
5536 set arow [lindex $vrownum($curview) $ai]
5537 set ids [lindex $varccommits($curview,$a)]
5538 set arowend [expr {$arow + [llength $ids]}]
5539 if {$gdttype eq [mc "containing:"]} {
5540 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5541 if {$l < $arow || $l >= $arowend} {
5543 set a [lindex $varcorder($curview) $ai]
5544 set arow [lindex $vrownum($curview) $ai]
5545 set ids [lindex $varccommits($curview,$a)]
5546 set arowend [expr {$arow + [llength $ids]}]
5548 set id [lindex $ids [expr {$l - $arow}]]
5549 # shouldn't happen unless git log doesn't give all the commits...
5550 if {![info exists commitdata($id)] ||
5551 ![doesmatch $commitdata($id)]} {
5554 if {![info exists commitinfo($id)]} {
5557 set info $commitinfo($id)
5558 foreach f $info ty $fldtypes {
5559 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5568 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5569 if {$l < $arow || $l >= $arowend} {
5571 set a [lindex $varcorder($curview) $ai]
5572 set arow [lindex $vrownum($curview) $ai]
5573 set ids [lindex $varccommits($curview,$a)]
5574 set arowend [expr {$arow + [llength $ids]}]
5576 set id [lindex $ids [expr {$l - $arow}]]
5577 if {![info exists fhighlights($id)]} {
5578 # this sets fhighlights($id) to -1
5579 askfilehighlight $l $id
5581 if {$fhighlights($id) > 0} {
5585 if {$fhighlights($id) < 0} {
5588 set findcurline [expr {$l - $find_dirn}]
5593 if {$found || ($domore && !$moretodo)} {
5609 set findcurline [expr {$l - $find_dirn}]
5611 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5615 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5620 proc findselectline {l} {
5621 global findloc commentend ctext findcurline markingmatches gdttype
5623 set markingmatches 1
5626 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5627 # highlight the matches in the comments
5628 set f [$ctext get 1.0 $commentend]
5629 set matches [findmatches $f]
5630 foreach match $matches {
5631 set start [lindex $match 0]
5632 set end [expr {[lindex $match 1] + 1}]
5633 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5639 # mark the bits of a headline or author that match a find string
5640 proc markmatches {canv l str tag matches font row} {
5643 set bbox [$canv bbox $tag]
5644 set x0 [lindex $bbox 0]
5645 set y0 [lindex $bbox 1]
5646 set y1 [lindex $bbox 3]
5647 foreach match $matches {
5648 set start [lindex $match 0]
5649 set end [lindex $match 1]
5650 if {$start > $end} continue
5651 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5652 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5653 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5654 [expr {$x0+$xlen+2}] $y1 \
5655 -outline {} -tags [list match$l matches] -fill yellow]
5657 if {$row == $selectedline} {
5658 $canv raise $t secsel
5663 proc unmarkmatches {} {
5664 global markingmatches
5666 allcanvs delete matches
5667 set markingmatches 0
5671 proc selcanvline {w x y} {
5672 global canv canvy0 ctext linespc
5674 set ymax [lindex [$canv cget -scrollregion] 3]
5675 if {$ymax == {}} return
5676 set yfrac [lindex [$canv yview] 0]
5677 set y [expr {$y + $yfrac * $ymax}]
5678 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5683 set xmax [lindex [$canv cget -scrollregion] 2]
5684 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5685 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5691 proc commit_descriptor {p} {
5693 if {![info exists commitinfo($p)]} {
5697 if {[llength $commitinfo($p)] > 1} {
5698 set l [lindex $commitinfo($p) 0]
5703 # append some text to the ctext widget, and make any SHA1 ID
5704 # that we know about be a clickable link.
5705 proc appendwithlinks {text tags} {
5706 global ctext linknum curview pendinglinks
5708 set start [$ctext index "end - 1c"]
5709 $ctext insert end $text $tags
5710 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5714 set linkid [string range $text $s $e]
5716 $ctext tag delete link$linknum
5717 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5718 setlink $linkid link$linknum
5723 proc setlink {id lk} {
5724 global curview ctext pendinglinks commitinterest
5726 if {[commitinview $id $curview]} {
5727 $ctext tag conf $lk -foreground blue -underline 1
5728 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5729 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5730 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5732 lappend pendinglinks($id) $lk
5733 lappend commitinterest($id) {makelink %I}
5737 proc makelink {id} {
5740 if {![info exists pendinglinks($id)]} return
5741 foreach lk $pendinglinks($id) {
5744 unset pendinglinks($id)
5747 proc linkcursor {w inc} {
5748 global linkentercount curtextcursor
5750 if {[incr linkentercount $inc] > 0} {
5751 $w configure -cursor hand2
5753 $w configure -cursor $curtextcursor
5754 if {$linkentercount < 0} {
5755 set linkentercount 0
5760 proc viewnextline {dir} {
5764 set ymax [lindex [$canv cget -scrollregion] 3]
5765 set wnow [$canv yview]
5766 set wtop [expr {[lindex $wnow 0] * $ymax}]
5767 set newtop [expr {$wtop + $dir * $linespc}]
5770 } elseif {$newtop > $ymax} {
5773 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5776 # add a list of tag or branch names at position pos
5777 # returns the number of names inserted
5778 proc appendrefs {pos ids var} {
5779 global ctext linknum curview $var maxrefs
5781 if {[catch {$ctext index $pos}]} {
5784 $ctext conf -state normal
5785 $ctext delete $pos "$pos lineend"
5788 foreach tag [set $var\($id\)] {
5789 lappend tags [list $tag $id]
5792 if {[llength $tags] > $maxrefs} {
5793 $ctext insert $pos "many ([llength $tags])"
5795 set tags [lsort -index 0 -decreasing $tags]
5798 set id [lindex $ti 1]
5801 $ctext tag delete $lk
5802 $ctext insert $pos $sep
5803 $ctext insert $pos [lindex $ti 0] $lk
5808 $ctext conf -state disabled
5809 return [llength $tags]
5812 # called when we have finished computing the nearby tags
5813 proc dispneartags {delay} {
5814 global selectedline currentid showneartags tagphase
5816 if {$selectedline eq {} || !$showneartags} return
5817 after cancel dispnexttag
5819 after 200 dispnexttag
5822 after idle dispnexttag
5827 proc dispnexttag {} {
5828 global selectedline currentid showneartags tagphase ctext
5830 if {$selectedline eq {} || !$showneartags} return
5831 switch -- $tagphase {
5833 set dtags [desctags $currentid]
5835 appendrefs precedes $dtags idtags
5839 set atags [anctags $currentid]
5841 appendrefs follows $atags idtags
5845 set dheads [descheads $currentid]
5846 if {$dheads ne {}} {
5847 if {[appendrefs branch $dheads idheads] > 1
5848 && [$ctext get "branch -3c"] eq "h"} {
5849 # turn "Branch" into "Branches"
5850 $ctext conf -state normal
5851 $ctext insert "branch -2c" "es"
5852 $ctext conf -state disabled
5857 if {[incr tagphase] <= 2} {
5858 after idle dispnexttag
5862 proc make_secsel {l} {
5863 global linehtag linentag linedtag canv canv2 canv3
5865 if {![info exists linehtag($l)]} return
5867 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5868 -tags secsel -fill [$canv cget -selectbackground]]
5870 $canv2 delete secsel
5871 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5872 -tags secsel -fill [$canv2 cget -selectbackground]]
5874 $canv3 delete secsel
5875 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5876 -tags secsel -fill [$canv3 cget -selectbackground]]
5880 proc selectline {l isnew} {
5881 global canv ctext commitinfo selectedline
5882 global canvy0 linespc parents children curview
5883 global currentid sha1entry
5884 global commentend idtags linknum
5885 global mergemax numcommits pending_select
5886 global cmitmode showneartags allcommits
5887 global targetrow targetid lastscrollrows
5890 catch {unset pending_select}
5895 if {$l < 0 || $l >= $numcommits} return
5896 set id [commitonrow $l]
5901 if {$lastscrollrows < $numcommits} {
5905 set y [expr {$canvy0 + $l * $linespc}]
5906 set ymax [lindex [$canv cget -scrollregion] 3]
5907 set ytop [expr {$y - $linespc - 1}]
5908 set ybot [expr {$y + $linespc + 1}]
5909 set wnow [$canv yview]
5910 set wtop [expr {[lindex $wnow 0] * $ymax}]
5911 set wbot [expr {[lindex $wnow 1] * $ymax}]
5912 set wh [expr {$wbot - $wtop}]
5914 if {$ytop < $wtop} {
5915 if {$ybot < $wtop} {
5916 set newtop [expr {$y - $wh / 2.0}]
5919 if {$newtop > $wtop - $linespc} {
5920 set newtop [expr {$wtop - $linespc}]
5923 } elseif {$ybot > $wbot} {
5924 if {$ytop > $wbot} {
5925 set newtop [expr {$y - $wh / 2.0}]
5927 set newtop [expr {$ybot - $wh}]
5928 if {$newtop < $wtop + $linespc} {
5929 set newtop [expr {$wtop + $linespc}]
5933 if {$newtop != $wtop} {
5937 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5944 addtohistory [list selbyid $id]
5947 $sha1entry delete 0 end
5948 $sha1entry insert 0 $id
5950 $sha1entry selection from 0
5951 $sha1entry selection to end
5955 $ctext conf -state normal
5958 if {![info exists commitinfo($id)]} {
5961 set info $commitinfo($id)
5962 set date [formatdate [lindex $info 2]]
5963 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5964 set date [formatdate [lindex $info 4]]
5965 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5966 if {[info exists idtags($id)]} {
5967 $ctext insert end [mc "Tags:"]
5968 foreach tag $idtags($id) {
5969 $ctext insert end " $tag"
5971 $ctext insert end "\n"
5975 set olds $parents($curview,$id)
5976 if {[llength $olds] > 1} {
5979 if {$np >= $mergemax} {
5984 $ctext insert end "[mc "Parent"]: " $tag
5985 appendwithlinks [commit_descriptor $p] {}
5990 append headers "[mc "Parent"]: [commit_descriptor $p]"
5994 foreach c $children($curview,$id) {
5995 append headers "[mc "Child"]: [commit_descriptor $c]"
5998 # make anything that looks like a SHA1 ID be a clickable link
5999 appendwithlinks $headers {}
6000 if {$showneartags} {
6001 if {![info exists allcommits]} {
6004 $ctext insert end "[mc "Branch"]: "
6005 $ctext mark set branch "end -1c"
6006 $ctext mark gravity branch left
6007 $ctext insert end "\n[mc "Follows"]: "
6008 $ctext mark set follows "end -1c"
6009 $ctext mark gravity follows left
6010 $ctext insert end "\n[mc "Precedes"]: "
6011 $ctext mark set precedes "end -1c"
6012 $ctext mark gravity precedes left
6013 $ctext insert end "\n"
6016 $ctext insert end "\n"
6017 set comment [lindex $info 5]
6018 if {[string first "\r" $comment] >= 0} {
6019 set comment [string map {"\r" "\n "} $comment]
6021 appendwithlinks $comment {comment}
6023 $ctext tag remove found 1.0 end
6024 $ctext conf -state disabled
6025 set commentend [$ctext index "end - 1c"]
6027 init_flist [mc "Comments"]
6028 if {$cmitmode eq "tree"} {
6030 } elseif {[llength $olds] <= 1} {
6037 proc selfirstline {} {
6042 proc sellastline {} {
6045 set l [expr {$numcommits - 1}]
6049 proc selnextline {dir} {
6052 if {$selectedline eq {}} return
6053 set l [expr {$selectedline + $dir}]
6058 proc selnextpage {dir} {
6059 global canv linespc selectedline numcommits
6061 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6065 allcanvs yview scroll [expr {$dir * $lpp}] units
6067 if {$selectedline eq {}} return
6068 set l [expr {$selectedline + $dir * $lpp}]
6071 } elseif {$l >= $numcommits} {
6072 set l [expr $numcommits - 1]
6078 proc unselectline {} {
6079 global selectedline currentid
6082 catch {unset currentid}
6083 allcanvs delete secsel
6087 proc reselectline {} {
6090 if {$selectedline ne {}} {
6091 selectline $selectedline 0
6095 proc addtohistory {cmd} {
6096 global history historyindex curview
6098 set elt [list $curview $cmd]
6099 if {$historyindex > 0
6100 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6104 if {$historyindex < [llength $history]} {
6105 set history [lreplace $history $historyindex end $elt]
6107 lappend history $elt
6110 if {$historyindex > 1} {
6111 .tf.bar.leftbut conf -state normal
6113 .tf.bar.leftbut conf -state disabled
6115 .tf.bar.rightbut conf -state disabled
6121 set view [lindex $elt 0]
6122 set cmd [lindex $elt 1]
6123 if {$curview != $view} {
6130 global history historyindex
6133 if {$historyindex > 1} {
6134 incr historyindex -1
6135 godo [lindex $history [expr {$historyindex - 1}]]
6136 .tf.bar.rightbut conf -state normal
6138 if {$historyindex <= 1} {
6139 .tf.bar.leftbut conf -state disabled
6144 global history historyindex
6147 if {$historyindex < [llength $history]} {
6148 set cmd [lindex $history $historyindex]
6151 .tf.bar.leftbut conf -state normal
6153 if {$historyindex >= [llength $history]} {
6154 .tf.bar.rightbut conf -state disabled
6159 global treefilelist treeidlist diffids diffmergeid treepending
6160 global nullid nullid2
6163 catch {unset diffmergeid}
6164 if {![info exists treefilelist($id)]} {
6165 if {![info exists treepending]} {
6166 if {$id eq $nullid} {
6167 set cmd [list | git ls-files]
6168 } elseif {$id eq $nullid2} {
6169 set cmd [list | git ls-files --stage -t]
6171 set cmd [list | git ls-tree -r $id]
6173 if {[catch {set gtf [open $cmd r]}]} {
6177 set treefilelist($id) {}
6178 set treeidlist($id) {}
6179 fconfigure $gtf -blocking 0
6180 filerun $gtf [list gettreeline $gtf $id]
6187 proc gettreeline {gtf id} {
6188 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6191 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6192 if {$diffids eq $nullid} {
6195 set i [string first "\t" $line]
6196 if {$i < 0} continue
6197 set fname [string range $line [expr {$i+1}] end]
6198 set line [string range $line 0 [expr {$i-1}]]
6199 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6200 set sha1 [lindex $line 2]
6201 if {[string index $fname 0] eq "\""} {
6202 set fname [lindex $fname 0]
6204 lappend treeidlist($id) $sha1
6206 lappend treefilelist($id) $fname
6209 return [expr {$nl >= 1000? 2: 1}]
6213 if {$cmitmode ne "tree"} {
6214 if {![info exists diffmergeid]} {
6215 gettreediffs $diffids
6217 } elseif {$id ne $diffids} {
6226 global treefilelist treeidlist diffids nullid nullid2
6227 global ctext commentend
6229 set i [lsearch -exact $treefilelist($diffids) $f]
6231 puts "oops, $f not in list for id $diffids"
6234 if {$diffids eq $nullid} {
6235 if {[catch {set bf [open $f r]} err]} {
6236 puts "oops, can't read $f: $err"
6240 set blob [lindex $treeidlist($diffids) $i]
6241 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6242 puts "oops, error reading blob $blob: $err"
6246 fconfigure $bf -blocking 0
6247 filerun $bf [list getblobline $bf $diffids]
6248 $ctext config -state normal
6249 clear_ctext $commentend
6250 $ctext insert end "\n"
6251 $ctext insert end "$f\n" filesep
6252 $ctext config -state disabled
6253 $ctext yview $commentend
6257 proc getblobline {bf id} {
6258 global diffids cmitmode ctext
6260 if {$id ne $diffids || $cmitmode ne "tree"} {
6264 $ctext config -state normal
6266 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6267 $ctext insert end "$line\n"
6270 # delete last newline
6271 $ctext delete "end - 2c" "end - 1c"
6275 $ctext config -state disabled
6276 return [expr {$nl >= 1000? 2: 1}]
6279 proc mergediff {id} {
6280 global diffmergeid mdifffd
6284 global limitdiffs vfilelimit curview
6288 # this doesn't seem to actually affect anything...
6289 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6290 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6291 set cmd [concat $cmd -- $vfilelimit($curview)]
6293 if {[catch {set mdf [open $cmd r]} err]} {
6294 error_popup "[mc "Error getting merge diffs:"] $err"
6297 fconfigure $mdf -blocking 0
6298 set mdifffd($id) $mdf
6299 set np [llength $parents($curview,$id)]
6301 filerun $mdf [list getmergediffline $mdf $id $np]
6304 proc getmergediffline {mdf id np} {
6305 global diffmergeid ctext cflist mergemax
6306 global difffilestart mdifffd
6308 $ctext conf -state normal
6310 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6311 if {![info exists diffmergeid] || $id != $diffmergeid
6312 || $mdf != $mdifffd($id)} {
6316 if {[regexp {^diff --cc (.*)} $line match fname]} {
6317 # start of a new file
6318 $ctext insert end "\n"
6319 set here [$ctext index "end - 1c"]
6320 lappend difffilestart $here
6321 add_flist [list $fname]
6322 set l [expr {(78 - [string length $fname]) / 2}]
6323 set pad [string range "----------------------------------------" 1 $l]
6324 $ctext insert end "$pad $fname $pad\n" filesep
6325 } elseif {[regexp {^@@} $line]} {
6326 $ctext insert end "$line\n" hunksep
6327 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6330 # parse the prefix - one ' ', '-' or '+' for each parent
6335 for {set j 0} {$j < $np} {incr j} {
6336 set c [string range $line $j $j]
6339 } elseif {$c == "-"} {
6341 } elseif {$c == "+"} {
6350 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6351 # line doesn't appear in result, parents in $minuses have the line
6352 set num [lindex $minuses 0]
6353 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6354 # line appears in result, parents in $pluses don't have the line
6355 lappend tags mresult
6356 set num [lindex $spaces 0]
6359 if {$num >= $mergemax} {
6364 $ctext insert end "$line\n" $tags
6367 $ctext conf -state disabled
6372 return [expr {$nr >= 1000? 2: 1}]
6375 proc startdiff {ids} {
6376 global treediffs diffids treepending diffmergeid nullid nullid2
6380 catch {unset diffmergeid}
6381 if {![info exists treediffs($ids)] ||
6382 [lsearch -exact $ids $nullid] >= 0 ||
6383 [lsearch -exact $ids $nullid2] >= 0} {
6384 if {![info exists treepending]} {
6392 proc path_filter {filter name} {
6394 set l [string length $p]
6395 if {[string index $p end] eq "/"} {
6396 if {[string compare -length $l $p $name] == 0} {
6400 if {[string compare -length $l $p $name] == 0 &&
6401 ([string length $name] == $l ||
6402 [string index $name $l] eq "/")} {
6410 proc addtocflist {ids} {
6413 add_flist $treediffs($ids)
6417 proc diffcmd {ids flags} {
6418 global nullid nullid2
6420 set i [lsearch -exact $ids $nullid]
6421 set j [lsearch -exact $ids $nullid2]
6423 if {[llength $ids] > 1 && $j < 0} {
6424 # comparing working directory with some specific revision
6425 set cmd [concat | git diff-index $flags]
6427 lappend cmd -R [lindex $ids 1]
6429 lappend cmd [lindex $ids 0]
6432 # comparing working directory with index
6433 set cmd [concat | git diff-files $flags]
6438 } elseif {$j >= 0} {
6439 set cmd [concat | git diff-index --cached $flags]
6440 if {[llength $ids] > 1} {
6441 # comparing index with specific revision
6443 lappend cmd -R [lindex $ids 1]
6445 lappend cmd [lindex $ids 0]
6448 # comparing index with HEAD
6452 set cmd [concat | git diff-tree -r $flags $ids]
6457 proc gettreediffs {ids} {
6458 global treediff treepending
6460 set treepending $ids
6462 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6463 fconfigure $gdtf -blocking 0
6464 filerun $gdtf [list gettreediffline $gdtf $ids]
6467 proc gettreediffline {gdtf ids} {
6468 global treediff treediffs treepending diffids diffmergeid
6469 global cmitmode vfilelimit curview limitdiffs
6472 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6473 set i [string first "\t" $line]
6475 set file [string range $line [expr {$i+1}] end]
6476 if {[string index $file 0] eq "\""} {
6477 set file [lindex $file 0]
6479 lappend treediff $file
6483 return [expr {$nr >= 1000? 2: 1}]
6486 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6488 foreach f $treediff {
6489 if {[path_filter $vfilelimit($curview) $f]} {
6493 set treediffs($ids) $flist
6495 set treediffs($ids) $treediff
6498 if {$cmitmode eq "tree"} {
6500 } elseif {$ids != $diffids} {
6501 if {![info exists diffmergeid]} {
6502 gettreediffs $diffids
6510 # empty string or positive integer
6511 proc diffcontextvalidate {v} {
6512 return [regexp {^(|[1-9][0-9]*)$} $v]
6515 proc diffcontextchange {n1 n2 op} {
6516 global diffcontextstring diffcontext
6518 if {[string is integer -strict $diffcontextstring]} {
6519 if {$diffcontextstring > 0} {
6520 set diffcontext $diffcontextstring
6526 proc changeignorespace {} {
6530 proc getblobdiffs {ids} {
6531 global blobdifffd diffids env
6532 global diffinhdr treediffs
6535 global limitdiffs vfilelimit curview
6537 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6541 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6542 set cmd [concat $cmd -- $vfilelimit($curview)]
6544 if {[catch {set bdf [open $cmd r]} err]} {
6545 puts "error getting diffs: $err"
6549 fconfigure $bdf -blocking 0
6550 set blobdifffd($ids) $bdf
6551 filerun $bdf [list getblobdiffline $bdf $diffids]
6554 proc setinlist {var i val} {
6557 while {[llength [set $var]] < $i} {
6560 if {[llength [set $var]] == $i} {
6567 proc makediffhdr {fname ids} {
6568 global ctext curdiffstart treediffs
6570 set i [lsearch -exact $treediffs($ids) $fname]
6572 setinlist difffilestart $i $curdiffstart
6574 set l [expr {(78 - [string length $fname]) / 2}]
6575 set pad [string range "----------------------------------------" 1 $l]
6576 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6579 proc getblobdiffline {bdf ids} {
6580 global diffids blobdifffd ctext curdiffstart
6581 global diffnexthead diffnextnote difffilestart
6582 global diffinhdr treediffs
6585 $ctext conf -state normal
6586 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6587 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6591 if {![string compare -length 11 "diff --git " $line]} {
6592 # trim off "diff --git "
6593 set line [string range $line 11 end]
6595 # start of a new file
6596 $ctext insert end "\n"
6597 set curdiffstart [$ctext index "end - 1c"]
6598 $ctext insert end "\n" filesep
6599 # If the name hasn't changed the length will be odd,
6600 # the middle char will be a space, and the two bits either
6601 # side will be a/name and b/name, or "a/name" and "b/name".
6602 # If the name has changed we'll get "rename from" and
6603 # "rename to" or "copy from" and "copy to" lines following this,
6604 # and we'll use them to get the filenames.
6605 # This complexity is necessary because spaces in the filename(s)
6606 # don't get escaped.
6607 set l [string length $line]
6608 set i [expr {$l / 2}]
6609 if {!(($l & 1) && [string index $line $i] eq " " &&
6610 [string range $line 2 [expr {$i - 1}]] eq \
6611 [string range $line [expr {$i + 3}] end])} {
6614 # unescape if quoted and chop off the a/ from the front
6615 if {[string index $line 0] eq "\""} {
6616 set fname [string range [lindex $line 0] 2 end]
6618 set fname [string range $line 2 [expr {$i - 1}]]
6620 makediffhdr $fname $ids
6622 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6623 $line match f1l f1c f2l f2c rest]} {
6624 $ctext insert end "$line\n" hunksep
6627 } elseif {$diffinhdr} {
6628 if {![string compare -length 12 "rename from " $line]} {
6629 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6630 if {[string index $fname 0] eq "\""} {
6631 set fname [lindex $fname 0]
6633 set i [lsearch -exact $treediffs($ids) $fname]
6635 setinlist difffilestart $i $curdiffstart
6637 } elseif {![string compare -length 10 $line "rename to "] ||
6638 ![string compare -length 8 $line "copy to "]} {
6639 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6640 if {[string index $fname 0] eq "\""} {
6641 set fname [lindex $fname 0]
6643 makediffhdr $fname $ids
6644 } elseif {[string compare -length 3 $line "---"] == 0} {
6647 } elseif {[string compare -length 3 $line "+++"] == 0} {
6651 $ctext insert end "$line\n" filesep
6654 set x [string range $line 0 0]
6655 if {$x == "-" || $x == "+"} {
6656 set tag [expr {$x == "+"}]
6657 $ctext insert end "$line\n" d$tag
6658 } elseif {$x == " "} {
6659 $ctext insert end "$line\n"
6661 # "\ No newline at end of file",
6662 # or something else we don't recognize
6663 $ctext insert end "$line\n" hunksep
6667 $ctext conf -state disabled
6672 return [expr {$nr >= 1000? 2: 1}]
6675 proc changediffdisp {} {
6676 global ctext diffelide
6678 $ctext tag conf d0 -elide [lindex $diffelide 0]
6679 $ctext tag conf d1 -elide [lindex $diffelide 1]
6682 proc highlightfile {loc cline} {
6683 global ctext cflist cflist_top
6686 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6687 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6688 $cflist see $cline.0
6689 set cflist_top $cline
6693 global difffilestart ctext cmitmode
6695 if {$cmitmode eq "tree"} return
6698 set here [$ctext index @0,0]
6699 foreach loc $difffilestart {
6700 if {[$ctext compare $loc >= $here]} {
6701 highlightfile $prev $prevline
6707 highlightfile $prev $prevline
6711 global difffilestart ctext cmitmode
6713 if {$cmitmode eq "tree"} return
6714 set here [$ctext index @0,0]
6716 foreach loc $difffilestart {
6718 if {[$ctext compare $loc > $here]} {
6719 highlightfile $loc $line
6725 proc clear_ctext {{first 1.0}} {
6726 global ctext smarktop smarkbot
6729 set l [lindex [split $first .] 0]
6730 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6733 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6736 $ctext delete $first end
6737 if {$first eq "1.0"} {
6738 catch {unset pendinglinks}
6742 proc settabs {{firstab {}}} {
6743 global firsttabstop tabstop ctext have_tk85
6745 if {$firstab ne {} && $have_tk85} {
6746 set firsttabstop $firstab
6748 set w [font measure textfont "0"]
6749 if {$firsttabstop != 0} {
6750 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6751 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6752 } elseif {$have_tk85 || $tabstop != 8} {
6753 $ctext conf -tabs [expr {$tabstop * $w}]
6755 $ctext conf -tabs {}
6759 proc incrsearch {name ix op} {
6760 global ctext searchstring searchdirn
6762 $ctext tag remove found 1.0 end
6763 if {[catch {$ctext index anchor}]} {
6764 # no anchor set, use start of selection, or of visible area
6765 set sel [$ctext tag ranges sel]
6767 $ctext mark set anchor [lindex $sel 0]
6768 } elseif {$searchdirn eq "-forwards"} {
6769 $ctext mark set anchor @0,0
6771 $ctext mark set anchor @0,[winfo height $ctext]
6774 if {$searchstring ne {}} {
6775 set here [$ctext search $searchdirn -- $searchstring anchor]
6784 global sstring ctext searchstring searchdirn
6787 $sstring icursor end
6788 set searchdirn -forwards
6789 if {$searchstring ne {}} {
6790 set sel [$ctext tag ranges sel]
6792 set start "[lindex $sel 0] + 1c"
6793 } elseif {[catch {set start [$ctext index anchor]}]} {
6796 set match [$ctext search -count mlen -- $searchstring $start]
6797 $ctext tag remove sel 1.0 end
6803 set mend "$match + $mlen c"
6804 $ctext tag add sel $match $mend
6805 $ctext mark unset anchor
6809 proc dosearchback {} {
6810 global sstring ctext searchstring searchdirn
6813 $sstring icursor end
6814 set searchdirn -backwards
6815 if {$searchstring ne {}} {
6816 set sel [$ctext tag ranges sel]
6818 set start [lindex $sel 0]
6819 } elseif {[catch {set start [$ctext index anchor]}]} {
6820 set start @0,[winfo height $ctext]
6822 set match [$ctext search -backwards -count ml -- $searchstring $start]
6823 $ctext tag remove sel 1.0 end
6829 set mend "$match + $ml c"
6830 $ctext tag add sel $match $mend
6831 $ctext mark unset anchor
6835 proc searchmark {first last} {
6836 global ctext searchstring
6840 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6841 if {$match eq {}} break
6842 set mend "$match + $mlen c"
6843 $ctext tag add found $match $mend
6847 proc searchmarkvisible {doall} {
6848 global ctext smarktop smarkbot
6850 set topline [lindex [split [$ctext index @0,0] .] 0]
6851 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6852 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6853 # no overlap with previous
6854 searchmark $topline $botline
6855 set smarktop $topline
6856 set smarkbot $botline
6858 if {$topline < $smarktop} {
6859 searchmark $topline [expr {$smarktop-1}]
6860 set smarktop $topline
6862 if {$botline > $smarkbot} {
6863 searchmark [expr {$smarkbot+1}] $botline
6864 set smarkbot $botline
6869 proc scrolltext {f0 f1} {
6872 .bleft.bottom.sb set $f0 $f1
6873 if {$searchstring ne {}} {
6879 global linespc charspc canvx0 canvy0
6880 global xspc1 xspc2 lthickness
6882 set linespc [font metrics mainfont -linespace]
6883 set charspc [font measure mainfont "m"]
6884 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6885 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6886 set lthickness [expr {int($linespc / 9) + 1}]
6887 set xspc1(0) $linespc
6895 set ymax [lindex [$canv cget -scrollregion] 3]
6896 if {$ymax eq {} || $ymax == 0} return
6897 set span [$canv yview]
6900 allcanvs yview moveto [lindex $span 0]
6902 if {$selectedline ne {}} {
6903 selectline $selectedline 0
6904 allcanvs yview moveto [lindex $span 0]
6908 proc parsefont {f n} {
6911 set fontattr($f,family) [lindex $n 0]
6913 if {$s eq {} || $s == 0} {
6916 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6918 set fontattr($f,size) $s
6919 set fontattr($f,weight) normal
6920 set fontattr($f,slant) roman
6921 foreach style [lrange $n 2 end] {
6924 "bold" {set fontattr($f,weight) $style}
6926 "italic" {set fontattr($f,slant) $style}
6931 proc fontflags {f {isbold 0}} {
6934 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6935 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6936 -slant $fontattr($f,slant)]
6942 set n [list $fontattr($f,family) $fontattr($f,size)]
6943 if {$fontattr($f,weight) eq "bold"} {
6946 if {$fontattr($f,slant) eq "italic"} {
6952 proc incrfont {inc} {
6953 global mainfont textfont ctext canv cflist showrefstop
6954 global stopped entries fontattr
6957 set s $fontattr(mainfont,size)
6962 set fontattr(mainfont,size) $s
6963 font config mainfont -size $s
6964 font config mainfontbold -size $s
6965 set mainfont [fontname mainfont]
6966 set s $fontattr(textfont,size)
6971 set fontattr(textfont,size) $s
6972 font config textfont -size $s
6973 font config textfontbold -size $s
6974 set textfont [fontname textfont]
6981 global sha1entry sha1string
6982 if {[string length $sha1string] == 40} {
6983 $sha1entry delete 0 end
6987 proc sha1change {n1 n2 op} {
6988 global sha1string currentid sha1but
6989 if {$sha1string == {}
6990 || ([info exists currentid] && $sha1string == $currentid)} {
6995 if {[$sha1but cget -state] == $state} return
6996 if {$state == "normal"} {
6997 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6999 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7003 proc gotocommit {} {
7004 global sha1string tagids headids curview varcid
7006 if {$sha1string == {}
7007 || ([info exists currentid] && $sha1string == $currentid)} return
7008 if {[info exists tagids($sha1string)]} {
7009 set id $tagids($sha1string)
7010 } elseif {[info exists headids($sha1string)]} {
7011 set id $headids($sha1string)
7013 set id [string tolower $sha1string]
7014 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7015 set matches [array names varcid "$curview,$id*"]
7016 if {$matches ne {}} {
7017 if {[llength $matches] > 1} {
7018 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7021 set id [lindex [split [lindex $matches 0] ","] 1]
7025 if {[commitinview $id $curview]} {
7026 selectline [rowofcommit $id] 1
7029 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7030 set msg [mc "SHA1 id %s is not known" $sha1string]
7032 set msg [mc "Tag/Head %s is not known" $sha1string]
7037 proc lineenter {x y id} {
7038 global hoverx hovery hoverid hovertimer
7039 global commitinfo canv
7041 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7045 if {[info exists hovertimer]} {
7046 after cancel $hovertimer
7048 set hovertimer [after 500 linehover]
7052 proc linemotion {x y id} {
7053 global hoverx hovery hoverid hovertimer
7055 if {[info exists hoverid] && $id == $hoverid} {
7058 if {[info exists hovertimer]} {
7059 after cancel $hovertimer
7061 set hovertimer [after 500 linehover]
7065 proc lineleave {id} {
7066 global hoverid hovertimer canv
7068 if {[info exists hoverid] && $id == $hoverid} {
7070 if {[info exists hovertimer]} {
7071 after cancel $hovertimer
7079 global hoverx hovery hoverid hovertimer
7080 global canv linespc lthickness
7083 set text [lindex $commitinfo($hoverid) 0]
7084 set ymax [lindex [$canv cget -scrollregion] 3]
7085 if {$ymax == {}} return
7086 set yfrac [lindex [$canv yview] 0]
7087 set x [expr {$hoverx + 2 * $linespc}]
7088 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7089 set x0 [expr {$x - 2 * $lthickness}]
7090 set y0 [expr {$y - 2 * $lthickness}]
7091 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7092 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7093 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7094 -fill \#ffff80 -outline black -width 1 -tags hover]
7096 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7101 proc clickisonarrow {id y} {
7104 set ranges [rowranges $id]
7105 set thresh [expr {2 * $lthickness + 6}]
7106 set n [expr {[llength $ranges] - 1}]
7107 for {set i 1} {$i < $n} {incr i} {
7108 set row [lindex $ranges $i]
7109 if {abs([yc $row] - $y) < $thresh} {
7116 proc arrowjump {id n y} {
7119 # 1 <-> 2, 3 <-> 4, etc...
7120 set n [expr {(($n - 1) ^ 1) + 1}]
7121 set row [lindex [rowranges $id] $n]
7123 set ymax [lindex [$canv cget -scrollregion] 3]
7124 if {$ymax eq {} || $ymax <= 0} return
7125 set view [$canv yview]
7126 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7127 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7131 allcanvs yview moveto $yfrac
7134 proc lineclick {x y id isnew} {
7135 global ctext commitinfo children canv thickerline curview
7137 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7142 # draw this line thicker than normal
7146 set ymax [lindex [$canv cget -scrollregion] 3]
7147 if {$ymax eq {}} return
7148 set yfrac [lindex [$canv yview] 0]
7149 set y [expr {$y + $yfrac * $ymax}]
7151 set dirn [clickisonarrow $id $y]
7153 arrowjump $id $dirn $y
7158 addtohistory [list lineclick $x $y $id 0]
7160 # fill the details pane with info about this line
7161 $ctext conf -state normal
7164 $ctext insert end "[mc "Parent"]:\t"
7165 $ctext insert end $id link0
7167 set info $commitinfo($id)
7168 $ctext insert end "\n\t[lindex $info 0]\n"
7169 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7170 set date [formatdate [lindex $info 2]]
7171 $ctext insert end "\t[mc "Date"]:\t$date\n"
7172 set kids $children($curview,$id)
7174 $ctext insert end "\n[mc "Children"]:"
7176 foreach child $kids {
7178 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7179 set info $commitinfo($child)
7180 $ctext insert end "\n\t"
7181 $ctext insert end $child link$i
7182 setlink $child link$i
7183 $ctext insert end "\n\t[lindex $info 0]"
7184 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7185 set date [formatdate [lindex $info 2]]
7186 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7189 $ctext conf -state disabled
7193 proc normalline {} {
7195 if {[info exists thickerline]} {
7204 if {[commitinview $id $curview]} {
7205 selectline [rowofcommit $id] 1
7211 if {![info exists startmstime]} {
7212 set startmstime [clock clicks -milliseconds]
7214 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7217 proc rowmenu {x y id} {
7218 global rowctxmenu selectedline rowmenuid curview
7219 global nullid nullid2 fakerowmenu mainhead
7223 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7228 if {$id ne $nullid && $id ne $nullid2} {
7229 set menu $rowctxmenu
7230 if {$mainhead ne {}} {
7231 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7233 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7236 set menu $fakerowmenu
7238 $menu entryconfigure [mc "Diff this -> selected"] -state $state
7239 $menu entryconfigure [mc "Diff selected -> this"] -state $state
7240 $menu entryconfigure [mc "Make patch"] -state $state
7241 tk_popup $menu $x $y
7244 proc diffvssel {dirn} {
7245 global rowmenuid selectedline
7247 if {$selectedline eq {}} return
7249 set oldid [commitonrow $selectedline]
7250 set newid $rowmenuid
7252 set oldid $rowmenuid
7253 set newid [commitonrow $selectedline]
7255 addtohistory [list doseldiff $oldid $newid]
7256 doseldiff $oldid $newid
7259 proc doseldiff {oldid newid} {
7263 $ctext conf -state normal
7265 init_flist [mc "Top"]
7266 $ctext insert end "[mc "From"] "
7267 $ctext insert end $oldid link0
7268 setlink $oldid link0
7269 $ctext insert end "\n "
7270 $ctext insert end [lindex $commitinfo($oldid) 0]
7271 $ctext insert end "\n\n[mc "To"] "
7272 $ctext insert end $newid link1
7273 setlink $newid link1
7274 $ctext insert end "\n "
7275 $ctext insert end [lindex $commitinfo($newid) 0]
7276 $ctext insert end "\n"
7277 $ctext conf -state disabled
7278 $ctext tag remove found 1.0 end
7279 startdiff [list $oldid $newid]
7283 global rowmenuid currentid commitinfo patchtop patchnum
7285 if {![info exists currentid]} return
7286 set oldid $currentid
7287 set oldhead [lindex $commitinfo($oldid) 0]
7288 set newid $rowmenuid
7289 set newhead [lindex $commitinfo($newid) 0]
7292 catch {destroy $top}
7294 label $top.title -text [mc "Generate patch"]
7295 grid $top.title - -pady 10
7296 label $top.from -text [mc "From:"]
7297 entry $top.fromsha1 -width 40 -relief flat
7298 $top.fromsha1 insert 0 $oldid
7299 $top.fromsha1 conf -state readonly
7300 grid $top.from $top.fromsha1 -sticky w
7301 entry $top.fromhead -width 60 -relief flat
7302 $top.fromhead insert 0 $oldhead
7303 $top.fromhead conf -state readonly
7304 grid x $top.fromhead -sticky w
7305 label $top.to -text [mc "To:"]
7306 entry $top.tosha1 -width 40 -relief flat
7307 $top.tosha1 insert 0 $newid
7308 $top.tosha1 conf -state readonly
7309 grid $top.to $top.tosha1 -sticky w
7310 entry $top.tohead -width 60 -relief flat
7311 $top.tohead insert 0 $newhead
7312 $top.tohead conf -state readonly
7313 grid x $top.tohead -sticky w
7314 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7315 grid $top.rev x -pady 10
7316 label $top.flab -text [mc "Output file:"]
7317 entry $top.fname -width 60
7318 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7320 grid $top.flab $top.fname -sticky w
7322 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7323 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7324 grid $top.buts.gen $top.buts.can
7325 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7326 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7327 grid $top.buts - -pady 10 -sticky ew
7331 proc mkpatchrev {} {
7334 set oldid [$patchtop.fromsha1 get]
7335 set oldhead [$patchtop.fromhead get]
7336 set newid [$patchtop.tosha1 get]
7337 set newhead [$patchtop.tohead get]
7338 foreach e [list fromsha1 fromhead tosha1 tohead] \
7339 v [list $newid $newhead $oldid $oldhead] {
7340 $patchtop.$e conf -state normal
7341 $patchtop.$e delete 0 end
7342 $patchtop.$e insert 0 $v
7343 $patchtop.$e conf -state readonly
7348 global patchtop nullid nullid2
7350 set oldid [$patchtop.fromsha1 get]
7351 set newid [$patchtop.tosha1 get]
7352 set fname [$patchtop.fname get]
7353 set cmd [diffcmd [list $oldid $newid] -p]
7354 # trim off the initial "|"
7355 set cmd [lrange $cmd 1 end]
7356 lappend cmd >$fname &
7357 if {[catch {eval exec $cmd} err]} {
7358 error_popup "[mc "Error creating patch:"] $err"
7360 catch {destroy $patchtop}
7364 proc mkpatchcan {} {
7367 catch {destroy $patchtop}
7372 global rowmenuid mktagtop commitinfo
7376 catch {destroy $top}
7378 label $top.title -text [mc "Create tag"]
7379 grid $top.title - -pady 10
7380 label $top.id -text [mc "ID:"]
7381 entry $top.sha1 -width 40 -relief flat
7382 $top.sha1 insert 0 $rowmenuid
7383 $top.sha1 conf -state readonly
7384 grid $top.id $top.sha1 -sticky w
7385 entry $top.head -width 60 -relief flat
7386 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7387 $top.head conf -state readonly
7388 grid x $top.head -sticky w
7389 label $top.tlab -text [mc "Tag name:"]
7390 entry $top.tag -width 60
7391 grid $top.tlab $top.tag -sticky w
7393 button $top.buts.gen -text [mc "Create"] -command mktaggo
7394 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7395 grid $top.buts.gen $top.buts.can
7396 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7397 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7398 grid $top.buts - -pady 10 -sticky ew
7403 global mktagtop env tagids idtags
7405 set id [$mktagtop.sha1 get]
7406 set tag [$mktagtop.tag get]
7408 error_popup [mc "No tag name specified"]
7411 if {[info exists tagids($tag)]} {
7412 error_popup [mc "Tag \"%s\" already exists" $tag]
7416 exec git tag $tag $id
7418 error_popup "[mc "Error creating tag:"] $err"
7422 set tagids($tag) $id
7423 lappend idtags($id) $tag
7430 proc redrawtags {id} {
7431 global canv linehtag idpos currentid curview cmitlisted
7432 global canvxmax iddrawn circleitem mainheadid circlecolors
7434 if {![commitinview $id $curview]} return
7435 if {![info exists iddrawn($id)]} return
7436 set row [rowofcommit $id]
7437 if {$id eq $mainheadid} {
7440 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7442 $canv itemconf $circleitem($row) -fill $ofill
7443 $canv delete tag.$id
7444 set xt [eval drawtags $id $idpos($id)]
7445 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7446 set text [$canv itemcget $linehtag($row) -text]
7447 set font [$canv itemcget $linehtag($row) -font]
7448 set xr [expr {$xt + [font measure $font $text]}]
7449 if {$xr > $canvxmax} {
7453 if {[info exists currentid] && $currentid == $id} {
7461 catch {destroy $mktagtop}
7470 proc writecommit {} {
7471 global rowmenuid wrcomtop commitinfo wrcomcmd
7473 set top .writecommit
7475 catch {destroy $top}
7477 label $top.title -text [mc "Write commit to file"]
7478 grid $top.title - -pady 10
7479 label $top.id -text [mc "ID:"]
7480 entry $top.sha1 -width 40 -relief flat
7481 $top.sha1 insert 0 $rowmenuid
7482 $top.sha1 conf -state readonly
7483 grid $top.id $top.sha1 -sticky w
7484 entry $top.head -width 60 -relief flat
7485 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7486 $top.head conf -state readonly
7487 grid x $top.head -sticky w
7488 label $top.clab -text [mc "Command:"]
7489 entry $top.cmd -width 60 -textvariable wrcomcmd
7490 grid $top.clab $top.cmd -sticky w -pady 10
7491 label $top.flab -text [mc "Output file:"]
7492 entry $top.fname -width 60
7493 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7494 grid $top.flab $top.fname -sticky w
7496 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7497 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7498 grid $top.buts.gen $top.buts.can
7499 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7500 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7501 grid $top.buts - -pady 10 -sticky ew
7508 set id [$wrcomtop.sha1 get]
7509 set cmd "echo $id | [$wrcomtop.cmd get]"
7510 set fname [$wrcomtop.fname get]
7511 if {[catch {exec sh -c $cmd >$fname &} err]} {
7512 error_popup "[mc "Error writing commit:"] $err"
7514 catch {destroy $wrcomtop}
7521 catch {destroy $wrcomtop}
7526 global rowmenuid mkbrtop
7529 catch {destroy $top}
7531 label $top.title -text [mc "Create new branch"]
7532 grid $top.title - -pady 10
7533 label $top.id -text [mc "ID:"]
7534 entry $top.sha1 -width 40 -relief flat
7535 $top.sha1 insert 0 $rowmenuid
7536 $top.sha1 conf -state readonly
7537 grid $top.id $top.sha1 -sticky w
7538 label $top.nlab -text [mc "Name:"]
7539 entry $top.name -width 40
7540 grid $top.nlab $top.name -sticky w
7542 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7543 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7544 grid $top.buts.go $top.buts.can
7545 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7546 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7547 grid $top.buts - -pady 10 -sticky ew
7552 global headids idheads
7554 set name [$top.name get]
7555 set id [$top.sha1 get]
7557 error_popup [mc "Please specify a name for the new branch"]
7560 catch {destroy $top}
7564 exec git branch $name $id
7569 set headids($name) $id
7570 lappend idheads($id) $name
7579 proc cherrypick {} {
7580 global rowmenuid curview
7581 global mainhead mainheadid
7583 set oldhead [exec git rev-parse HEAD]
7584 set dheads [descheads $rowmenuid]
7585 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7586 set ok [confirm_popup [mc "Commit %s is already\
7587 included in branch %s -- really re-apply it?" \
7588 [string range $rowmenuid 0 7] $mainhead]]
7591 nowbusy cherrypick [mc "Cherry-picking"]
7593 # Unfortunately git-cherry-pick writes stuff to stderr even when
7594 # no error occurs, and exec takes that as an indication of error...
7595 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7600 set newhead [exec git rev-parse HEAD]
7601 if {$newhead eq $oldhead} {
7603 error_popup [mc "No changes committed"]
7606 addnewchild $newhead $oldhead
7607 if {[commitinview $oldhead $curview]} {
7608 insertrow $newhead $oldhead $curview
7609 if {$mainhead ne {}} {
7610 movehead $newhead $mainhead
7611 movedhead $newhead $mainhead
7613 set mainheadid $newhead
7622 global mainhead rowmenuid confirm_ok resettype
7625 set w ".confirmreset"
7628 wm title $w [mc "Confirm reset"]
7629 message $w.m -text \
7630 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7631 -justify center -aspect 1000
7632 pack $w.m -side top -fill x -padx 20 -pady 20
7633 frame $w.f -relief sunken -border 2
7634 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7635 grid $w.f.rt -sticky w
7637 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7638 -text [mc "Soft: Leave working tree and index untouched"]
7639 grid $w.f.soft -sticky w
7640 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7641 -text [mc "Mixed: Leave working tree untouched, reset index"]
7642 grid $w.f.mixed -sticky w
7643 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7644 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7645 grid $w.f.hard -sticky w
7646 pack $w.f -side top -fill x
7647 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7648 pack $w.ok -side left -fill x -padx 20 -pady 20
7649 button $w.cancel -text [mc Cancel] -command "destroy $w"
7650 pack $w.cancel -side right -fill x -padx 20 -pady 20
7651 bind $w <Visibility> "grab $w; focus $w"
7653 if {!$confirm_ok} return
7654 if {[catch {set fd [open \
7655 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7659 filerun $fd [list readresetstat $fd]
7660 nowbusy reset [mc "Resetting"]
7665 proc readresetstat {fd} {
7666 global mainhead mainheadid showlocalchanges rprogcoord
7668 if {[gets $fd line] >= 0} {
7669 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7670 set rprogcoord [expr {1.0 * $m / $n}]
7678 if {[catch {close $fd} err]} {
7681 set oldhead $mainheadid
7682 set newhead [exec git rev-parse HEAD]
7683 if {$newhead ne $oldhead} {
7684 movehead $newhead $mainhead
7685 movedhead $newhead $mainhead
7686 set mainheadid $newhead
7690 if {$showlocalchanges} {
7696 # context menu for a head
7697 proc headmenu {x y id head} {
7698 global headmenuid headmenuhead headctxmenu mainhead
7702 set headmenuhead $head
7704 if {$head eq $mainhead} {
7707 $headctxmenu entryconfigure 0 -state $state
7708 $headctxmenu entryconfigure 1 -state $state
7709 tk_popup $headctxmenu $x $y
7713 global headmenuid headmenuhead headids
7714 global showlocalchanges mainheadid
7716 # check the tree is clean first??
7717 nowbusy checkout [mc "Checking out"]
7721 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7725 if {$showlocalchanges} {
7729 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7733 proc readcheckoutstat {fd newhead newheadid} {
7734 global mainhead mainheadid headids showlocalchanges progresscoords
7736 if {[gets $fd line] >= 0} {
7737 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7738 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7743 set progresscoords {0 0}
7746 if {[catch {close $fd} err]} {
7749 set oldmainid $mainheadid
7750 set mainhead $newhead
7751 set mainheadid $newheadid
7752 redrawtags $oldmainid
7753 redrawtags $newheadid
7755 if {$showlocalchanges} {
7761 global headmenuid headmenuhead mainhead
7764 set head $headmenuhead
7766 # this check shouldn't be needed any more...
7767 if {$head eq $mainhead} {
7768 error_popup [mc "Cannot delete the currently checked-out branch"]
7771 set dheads [descheads $id]
7772 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7773 # the stuff on this branch isn't on any other branch
7774 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7775 branch.\nReally delete branch %s?" $head $head]]} return
7779 if {[catch {exec git branch -D $head} err]} {
7784 removehead $id $head
7785 removedhead $id $head
7792 # Display a list of tags and heads
7794 global showrefstop bgcolor fgcolor selectbgcolor
7795 global bglist fglist reflistfilter reflist maincursor
7798 set showrefstop $top
7799 if {[winfo exists $top]} {
7805 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7806 text $top.list -background $bgcolor -foreground $fgcolor \
7807 -selectbackground $selectbgcolor -font mainfont \
7808 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7809 -width 30 -height 20 -cursor $maincursor \
7810 -spacing1 1 -spacing3 1 -state disabled
7811 $top.list tag configure highlight -background $selectbgcolor
7812 lappend bglist $top.list
7813 lappend fglist $top.list
7814 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7815 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7816 grid $top.list $top.ysb -sticky nsew
7817 grid $top.xsb x -sticky ew
7819 label $top.f.l -text "[mc "Filter"]: "
7820 entry $top.f.e -width 20 -textvariable reflistfilter
7821 set reflistfilter "*"
7822 trace add variable reflistfilter write reflistfilter_change
7823 pack $top.f.e -side right -fill x -expand 1
7824 pack $top.f.l -side left
7825 grid $top.f - -sticky ew -pady 2
7826 button $top.close -command [list destroy $top] -text [mc "Close"]
7828 grid columnconfigure $top 0 -weight 1
7829 grid rowconfigure $top 0 -weight 1
7830 bind $top.list <1> {break}
7831 bind $top.list <B1-Motion> {break}
7832 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7837 proc sel_reflist {w x y} {
7838 global showrefstop reflist headids tagids otherrefids
7840 if {![winfo exists $showrefstop]} return
7841 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7842 set ref [lindex $reflist [expr {$l-1}]]
7843 set n [lindex $ref 0]
7844 switch -- [lindex $ref 1] {
7845 "H" {selbyid $headids($n)}
7846 "T" {selbyid $tagids($n)}
7847 "o" {selbyid $otherrefids($n)}
7849 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7852 proc unsel_reflist {} {
7855 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7856 $showrefstop.list tag remove highlight 0.0 end
7859 proc reflistfilter_change {n1 n2 op} {
7860 global reflistfilter
7862 after cancel refill_reflist
7863 after 200 refill_reflist
7866 proc refill_reflist {} {
7867 global reflist reflistfilter showrefstop headids tagids otherrefids
7868 global curview commitinterest
7870 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7872 foreach n [array names headids] {
7873 if {[string match $reflistfilter $n]} {
7874 if {[commitinview $headids($n) $curview]} {
7875 lappend refs [list $n H]
7877 set commitinterest($headids($n)) {run refill_reflist}
7881 foreach n [array names tagids] {
7882 if {[string match $reflistfilter $n]} {
7883 if {[commitinview $tagids($n) $curview]} {
7884 lappend refs [list $n T]
7886 set commitinterest($tagids($n)) {run refill_reflist}
7890 foreach n [array names otherrefids] {
7891 if {[string match $reflistfilter $n]} {
7892 if {[commitinview $otherrefids($n) $curview]} {
7893 lappend refs [list $n o]
7895 set commitinterest($otherrefids($n)) {run refill_reflist}
7899 set refs [lsort -index 0 $refs]
7900 if {$refs eq $reflist} return
7902 # Update the contents of $showrefstop.list according to the
7903 # differences between $reflist (old) and $refs (new)
7904 $showrefstop.list conf -state normal
7905 $showrefstop.list insert end "\n"
7908 while {$i < [llength $reflist] || $j < [llength $refs]} {
7909 if {$i < [llength $reflist]} {
7910 if {$j < [llength $refs]} {
7911 set cmp [string compare [lindex $reflist $i 0] \
7912 [lindex $refs $j 0]]
7914 set cmp [string compare [lindex $reflist $i 1] \
7915 [lindex $refs $j 1]]
7925 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7933 set l [expr {$j + 1}]
7934 $showrefstop.list image create $l.0 -align baseline \
7935 -image reficon-[lindex $refs $j 1] -padx 2
7936 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7942 # delete last newline
7943 $showrefstop.list delete end-2c end-1c
7944 $showrefstop.list conf -state disabled
7947 # Stuff for finding nearby tags
7948 proc getallcommits {} {
7949 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7950 global idheads idtags idotherrefs allparents tagobjid
7952 if {![info exists allcommits]} {
7958 set allccache [file join [gitdir] "gitk.cache"]
7960 set f [open $allccache r]
7969 set cmd [list | git rev-list --parents]
7970 set allcupdate [expr {$seeds ne {}}]
7974 set refs [concat [array names idheads] [array names idtags] \
7975 [array names idotherrefs]]
7978 foreach name [array names tagobjid] {
7979 lappend tagobjs $tagobjid($name)
7981 foreach id [lsort -unique $refs] {
7982 if {![info exists allparents($id)] &&
7983 [lsearch -exact $tagobjs $id] < 0} {
7994 set fd [open [concat $cmd $ids] r]
7995 fconfigure $fd -blocking 0
7998 filerun $fd [list getallclines $fd]
8004 # Since most commits have 1 parent and 1 child, we group strings of
8005 # such commits into "arcs" joining branch/merge points (BMPs), which
8006 # are commits that either don't have 1 parent or don't have 1 child.
8008 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8009 # arcout(id) - outgoing arcs for BMP
8010 # arcids(a) - list of IDs on arc including end but not start
8011 # arcstart(a) - BMP ID at start of arc
8012 # arcend(a) - BMP ID at end of arc
8013 # growing(a) - arc a is still growing
8014 # arctags(a) - IDs out of arcids (excluding end) that have tags
8015 # archeads(a) - IDs out of arcids (excluding end) that have heads
8016 # The start of an arc is at the descendent end, so "incoming" means
8017 # coming from descendents, and "outgoing" means going towards ancestors.
8019 proc getallclines {fd} {
8020 global allparents allchildren idtags idheads nextarc
8021 global arcnos arcids arctags arcout arcend arcstart archeads growing
8022 global seeds allcommits cachedarcs allcupdate
8025 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8026 set id [lindex $line 0]
8027 if {[info exists allparents($id)]} {
8032 set olds [lrange $line 1 end]
8033 set allparents($id) $olds
8034 if {![info exists allchildren($id)]} {
8035 set allchildren($id) {}
8040 if {[llength $olds] == 1 && [llength $a] == 1} {
8041 lappend arcids($a) $id
8042 if {[info exists idtags($id)]} {
8043 lappend arctags($a) $id
8045 if {[info exists idheads($id)]} {
8046 lappend archeads($a) $id
8048 if {[info exists allparents($olds)]} {
8049 # seen parent already
8050 if {![info exists arcout($olds)]} {
8053 lappend arcids($a) $olds
8054 set arcend($a) $olds
8057 lappend allchildren($olds) $id
8058 lappend arcnos($olds) $a
8062 foreach a $arcnos($id) {
8063 lappend arcids($a) $id
8070 lappend allchildren($p) $id
8071 set a [incr nextarc]
8072 set arcstart($a) $id
8079 if {[info exists allparents($p)]} {
8080 # seen it already, may need to make a new branch
8081 if {![info exists arcout($p)]} {
8084 lappend arcids($a) $p
8088 lappend arcnos($p) $a
8093 global cached_dheads cached_dtags cached_atags
8094 catch {unset cached_dheads}
8095 catch {unset cached_dtags}
8096 catch {unset cached_atags}
8099 return [expr {$nid >= 1000? 2: 1}]
8103 fconfigure $fd -blocking 1
8106 # got an error reading the list of commits
8107 # if we were updating, try rereading the whole thing again
8113 error_popup "[mc "Error reading commit topology information;\
8114 branch and preceding/following tag information\
8115 will be incomplete."]\n($err)"
8118 if {[incr allcommits -1] == 0} {
8128 proc recalcarc {a} {
8129 global arctags archeads arcids idtags idheads
8133 foreach id [lrange $arcids($a) 0 end-1] {
8134 if {[info exists idtags($id)]} {
8137 if {[info exists idheads($id)]} {
8142 set archeads($a) $ah
8146 global arcnos arcids nextarc arctags archeads idtags idheads
8147 global arcstart arcend arcout allparents growing
8150 if {[llength $a] != 1} {
8151 puts "oops splitarc called but [llength $a] arcs already"
8155 set i [lsearch -exact $arcids($a) $p]
8157 puts "oops splitarc $p not in arc $a"
8160 set na [incr nextarc]
8161 if {[info exists arcend($a)]} {
8162 set arcend($na) $arcend($a)
8164 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8165 set j [lsearch -exact $arcnos($l) $a]
8166 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8168 set tail [lrange $arcids($a) [expr {$i+1}] end]
8169 set arcids($a) [lrange $arcids($a) 0 $i]
8171 set arcstart($na) $p
8173 set arcids($na) $tail
8174 if {[info exists growing($a)]} {
8180 if {[llength $arcnos($id)] == 1} {
8183 set j [lsearch -exact $arcnos($id) $a]
8184 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8188 # reconstruct tags and heads lists
8189 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8194 set archeads($na) {}
8198 # Update things for a new commit added that is a child of one
8199 # existing commit. Used when cherry-picking.
8200 proc addnewchild {id p} {
8201 global allparents allchildren idtags nextarc
8202 global arcnos arcids arctags arcout arcend arcstart archeads growing
8203 global seeds allcommits
8205 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8206 set allparents($id) [list $p]
8207 set allchildren($id) {}
8210 lappend allchildren($p) $id
8211 set a [incr nextarc]
8212 set arcstart($a) $id
8215 set arcids($a) [list $p]
8217 if {![info exists arcout($p)]} {
8220 lappend arcnos($p) $a
8221 set arcout($id) [list $a]
8224 # This implements a cache for the topology information.
8225 # The cache saves, for each arc, the start and end of the arc,
8226 # the ids on the arc, and the outgoing arcs from the end.
8227 proc readcache {f} {
8228 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8229 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8234 if {$lim - $a > 500} {
8235 set lim [expr {$a + 500}]
8239 # finish reading the cache and setting up arctags, etc.
8241 if {$line ne "1"} {error "bad final version"}
8243 foreach id [array names idtags] {
8244 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8245 [llength $allparents($id)] == 1} {
8246 set a [lindex $arcnos($id) 0]
8247 if {$arctags($a) eq {}} {
8252 foreach id [array names idheads] {
8253 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8254 [llength $allparents($id)] == 1} {
8255 set a [lindex $arcnos($id) 0]
8256 if {$archeads($a) eq {}} {
8261 foreach id [lsort -unique $possible_seeds] {
8262 if {$arcnos($id) eq {}} {
8268 while {[incr a] <= $lim} {
8270 if {[llength $line] != 3} {error "bad line"}
8271 set s [lindex $line 0]
8273 lappend arcout($s) $a
8274 if {![info exists arcnos($s)]} {
8275 lappend possible_seeds $s
8278 set e [lindex $line 1]
8283 if {![info exists arcout($e)]} {
8287 set arcids($a) [lindex $line 2]
8288 foreach id $arcids($a) {
8289 lappend allparents($s) $id
8291 lappend arcnos($id) $a
8293 if {![info exists allparents($s)]} {
8294 set allparents($s) {}
8299 set nextarc [expr {$a - 1}]
8312 global nextarc cachedarcs possible_seeds
8316 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8317 # make sure it's an integer
8318 set cachedarcs [expr {int([lindex $line 1])}]
8319 if {$cachedarcs < 0} {error "bad number of arcs"}
8321 set possible_seeds {}
8329 proc dropcache {err} {
8330 global allcwait nextarc cachedarcs seeds
8332 #puts "dropping cache ($err)"
8333 foreach v {arcnos arcout arcids arcstart arcend growing \
8334 arctags archeads allparents allchildren} {
8345 proc writecache {f} {
8346 global cachearc cachedarcs allccache
8347 global arcstart arcend arcnos arcids arcout
8351 if {$lim - $a > 1000} {
8352 set lim [expr {$a + 1000}]
8355 while {[incr a] <= $lim} {
8356 if {[info exists arcend($a)]} {
8357 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8359 puts $f [list $arcstart($a) {} $arcids($a)]
8364 catch {file delete $allccache}
8365 #puts "writing cache failed ($err)"
8368 set cachearc [expr {$a - 1}]
8369 if {$a > $cachedarcs} {
8378 global nextarc cachedarcs cachearc allccache
8380 if {$nextarc == $cachedarcs} return
8382 set cachedarcs $nextarc
8384 set f [open $allccache w]
8385 puts $f [list 1 $cachedarcs]
8390 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8391 # or 0 if neither is true.
8392 proc anc_or_desc {a b} {
8393 global arcout arcstart arcend arcnos cached_isanc
8395 if {$arcnos($a) eq $arcnos($b)} {
8396 # Both are on the same arc(s); either both are the same BMP,
8397 # or if one is not a BMP, the other is also not a BMP or is
8398 # the BMP at end of the arc (and it only has 1 incoming arc).
8399 # Or both can be BMPs with no incoming arcs.
8400 if {$a eq $b || $arcnos($a) eq {}} {
8403 # assert {[llength $arcnos($a)] == 1}
8404 set arc [lindex $arcnos($a) 0]
8405 set i [lsearch -exact $arcids($arc) $a]
8406 set j [lsearch -exact $arcids($arc) $b]
8407 if {$i < 0 || $i > $j} {
8414 if {![info exists arcout($a)]} {
8415 set arc [lindex $arcnos($a) 0]
8416 if {[info exists arcend($arc)]} {
8417 set aend $arcend($arc)
8421 set a $arcstart($arc)
8425 if {![info exists arcout($b)]} {
8426 set arc [lindex $arcnos($b) 0]
8427 if {[info exists arcend($arc)]} {
8428 set bend $arcend($arc)
8432 set b $arcstart($arc)
8442 if {[info exists cached_isanc($a,$bend)]} {
8443 if {$cached_isanc($a,$bend)} {
8447 if {[info exists cached_isanc($b,$aend)]} {
8448 if {$cached_isanc($b,$aend)} {
8451 if {[info exists cached_isanc($a,$bend)]} {
8456 set todo [list $a $b]
8459 for {set i 0} {$i < [llength $todo]} {incr i} {
8460 set x [lindex $todo $i]
8461 if {$anc($x) eq {}} {
8464 foreach arc $arcnos($x) {
8465 set xd $arcstart($arc)
8467 set cached_isanc($a,$bend) 1
8468 set cached_isanc($b,$aend) 0
8470 } elseif {$xd eq $aend} {
8471 set cached_isanc($b,$aend) 1
8472 set cached_isanc($a,$bend) 0
8475 if {![info exists anc($xd)]} {
8476 set anc($xd) $anc($x)
8478 } elseif {$anc($xd) ne $anc($x)} {
8483 set cached_isanc($a,$bend) 0
8484 set cached_isanc($b,$aend) 0
8488 # This identifies whether $desc has an ancestor that is
8489 # a growing tip of the graph and which is not an ancestor of $anc
8490 # and returns 0 if so and 1 if not.
8491 # If we subsequently discover a tag on such a growing tip, and that
8492 # turns out to be a descendent of $anc (which it could, since we
8493 # don't necessarily see children before parents), then $desc
8494 # isn't a good choice to display as a descendent tag of
8495 # $anc (since it is the descendent of another tag which is
8496 # a descendent of $anc). Similarly, $anc isn't a good choice to
8497 # display as a ancestor tag of $desc.
8499 proc is_certain {desc anc} {
8500 global arcnos arcout arcstart arcend growing problems
8503 if {[llength $arcnos($anc)] == 1} {
8504 # tags on the same arc are certain
8505 if {$arcnos($desc) eq $arcnos($anc)} {
8508 if {![info exists arcout($anc)]} {
8509 # if $anc is partway along an arc, use the start of the arc instead
8510 set a [lindex $arcnos($anc) 0]
8511 set anc $arcstart($a)
8514 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8517 set a [lindex $arcnos($desc) 0]
8523 set anclist [list $x]
8527 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8528 set x [lindex $anclist $i]
8533 foreach a $arcout($x) {
8534 if {[info exists growing($a)]} {
8535 if {![info exists growanc($x)] && $dl($x)} {
8541 if {[info exists dl($y)]} {
8545 if {![info exists done($y)]} {
8548 if {[info exists growanc($x)]} {
8552 for {set k 0} {$k < [llength $xl]} {incr k} {
8553 set z [lindex $xl $k]
8554 foreach c $arcout($z) {
8555 if {[info exists arcend($c)]} {
8557 if {[info exists dl($v)] && $dl($v)} {
8559 if {![info exists done($v)]} {
8562 if {[info exists growanc($v)]} {
8572 } elseif {$y eq $anc || !$dl($x)} {
8583 foreach x [array names growanc] {
8592 proc validate_arctags {a} {
8593 global arctags idtags
8597 foreach id $arctags($a) {
8599 if {![info exists idtags($id)]} {
8600 set na [lreplace $na $i $i]
8607 proc validate_archeads {a} {
8608 global archeads idheads
8611 set na $archeads($a)
8612 foreach id $archeads($a) {
8614 if {![info exists idheads($id)]} {
8615 set na [lreplace $na $i $i]
8619 set archeads($a) $na
8622 # Return the list of IDs that have tags that are descendents of id,
8623 # ignoring IDs that are descendents of IDs already reported.
8624 proc desctags {id} {
8625 global arcnos arcstart arcids arctags idtags allparents
8626 global growing cached_dtags
8628 if {![info exists allparents($id)]} {
8631 set t1 [clock clicks -milliseconds]
8633 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8634 # part-way along an arc; check that arc first
8635 set a [lindex $arcnos($id) 0]
8636 if {$arctags($a) ne {}} {
8638 set i [lsearch -exact $arcids($a) $id]
8640 foreach t $arctags($a) {
8641 set j [lsearch -exact $arcids($a) $t]
8649 set id $arcstart($a)
8650 if {[info exists idtags($id)]} {
8654 if {[info exists cached_dtags($id)]} {
8655 return $cached_dtags($id)
8662 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8663 set id [lindex $todo $i]
8665 set ta [info exists hastaggedancestor($id)]
8669 # ignore tags on starting node
8670 if {!$ta && $i > 0} {
8671 if {[info exists idtags($id)]} {
8674 } elseif {[info exists cached_dtags($id)]} {
8675 set tagloc($id) $cached_dtags($id)
8679 foreach a $arcnos($id) {
8681 if {!$ta && $arctags($a) ne {}} {
8683 if {$arctags($a) ne {}} {
8684 lappend tagloc($id) [lindex $arctags($a) end]
8687 if {$ta || $arctags($a) ne {}} {
8688 set tomark [list $d]
8689 for {set j 0} {$j < [llength $tomark]} {incr j} {
8690 set dd [lindex $tomark $j]
8691 if {![info exists hastaggedancestor($dd)]} {
8692 if {[info exists done($dd)]} {
8693 foreach b $arcnos($dd) {
8694 lappend tomark $arcstart($b)
8696 if {[info exists tagloc($dd)]} {
8699 } elseif {[info exists queued($dd)]} {
8702 set hastaggedancestor($dd) 1
8706 if {![info exists queued($d)]} {
8709 if {![info exists hastaggedancestor($d)]} {
8716 foreach id [array names tagloc] {
8717 if {![info exists hastaggedancestor($id)]} {
8718 foreach t $tagloc($id) {
8719 if {[lsearch -exact $tags $t] < 0} {
8725 set t2 [clock clicks -milliseconds]
8728 # remove tags that are descendents of other tags
8729 for {set i 0} {$i < [llength $tags]} {incr i} {
8730 set a [lindex $tags $i]
8731 for {set j 0} {$j < $i} {incr j} {
8732 set b [lindex $tags $j]
8733 set r [anc_or_desc $a $b]
8735 set tags [lreplace $tags $j $j]
8738 } elseif {$r == -1} {
8739 set tags [lreplace $tags $i $i]
8746 if {[array names growing] ne {}} {
8747 # graph isn't finished, need to check if any tag could get
8748 # eclipsed by another tag coming later. Simply ignore any
8749 # tags that could later get eclipsed.
8752 if {[is_certain $t $origid]} {
8756 if {$tags eq $ctags} {
8757 set cached_dtags($origid) $tags
8762 set cached_dtags($origid) $tags
8764 set t3 [clock clicks -milliseconds]
8765 if {0 && $t3 - $t1 >= 100} {
8766 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8767 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8773 global arcnos arcids arcout arcend arctags idtags allparents
8774 global growing cached_atags
8776 if {![info exists allparents($id)]} {
8779 set t1 [clock clicks -milliseconds]
8781 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8782 # part-way along an arc; check that arc first
8783 set a [lindex $arcnos($id) 0]
8784 if {$arctags($a) ne {}} {
8786 set i [lsearch -exact $arcids($a) $id]
8787 foreach t $arctags($a) {
8788 set j [lsearch -exact $arcids($a) $t]
8794 if {![info exists arcend($a)]} {
8798 if {[info exists idtags($id)]} {
8802 if {[info exists cached_atags($id)]} {
8803 return $cached_atags($id)
8811 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8812 set id [lindex $todo $i]
8814 set td [info exists hastaggeddescendent($id)]
8818 # ignore tags on starting node
8819 if {!$td && $i > 0} {
8820 if {[info exists idtags($id)]} {
8823 } elseif {[info exists cached_atags($id)]} {
8824 set tagloc($id) $cached_atags($id)
8828 foreach a $arcout($id) {
8829 if {!$td && $arctags($a) ne {}} {
8831 if {$arctags($a) ne {}} {
8832 lappend tagloc($id) [lindex $arctags($a) 0]
8835 if {![info exists arcend($a)]} continue
8837 if {$td || $arctags($a) ne {}} {
8838 set tomark [list $d]
8839 for {set j 0} {$j < [llength $tomark]} {incr j} {
8840 set dd [lindex $tomark $j]
8841 if {![info exists hastaggeddescendent($dd)]} {
8842 if {[info exists done($dd)]} {
8843 foreach b $arcout($dd) {
8844 if {[info exists arcend($b)]} {
8845 lappend tomark $arcend($b)
8848 if {[info exists tagloc($dd)]} {
8851 } elseif {[info exists queued($dd)]} {
8854 set hastaggeddescendent($dd) 1
8858 if {![info exists queued($d)]} {
8861 if {![info exists hastaggeddescendent($d)]} {
8867 set t2 [clock clicks -milliseconds]
8870 foreach id [array names tagloc] {
8871 if {![info exists hastaggeddescendent($id)]} {
8872 foreach t $tagloc($id) {
8873 if {[lsearch -exact $tags $t] < 0} {
8880 # remove tags that are ancestors of other tags
8881 for {set i 0} {$i < [llength $tags]} {incr i} {
8882 set a [lindex $tags $i]
8883 for {set j 0} {$j < $i} {incr j} {
8884 set b [lindex $tags $j]
8885 set r [anc_or_desc $a $b]
8887 set tags [lreplace $tags $j $j]
8890 } elseif {$r == 1} {
8891 set tags [lreplace $tags $i $i]
8898 if {[array names growing] ne {}} {
8899 # graph isn't finished, need to check if any tag could get
8900 # eclipsed by another tag coming later. Simply ignore any
8901 # tags that could later get eclipsed.
8904 if {[is_certain $origid $t]} {
8908 if {$tags eq $ctags} {
8909 set cached_atags($origid) $tags
8914 set cached_atags($origid) $tags
8916 set t3 [clock clicks -milliseconds]
8917 if {0 && $t3 - $t1 >= 100} {
8918 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8919 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8924 # Return the list of IDs that have heads that are descendents of id,
8925 # including id itself if it has a head.
8926 proc descheads {id} {
8927 global arcnos arcstart arcids archeads idheads cached_dheads
8930 if {![info exists allparents($id)]} {
8934 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8935 # part-way along an arc; check it first
8936 set a [lindex $arcnos($id) 0]
8937 if {$archeads($a) ne {}} {
8938 validate_archeads $a
8939 set i [lsearch -exact $arcids($a) $id]
8940 foreach t $archeads($a) {
8941 set j [lsearch -exact $arcids($a) $t]
8946 set id $arcstart($a)
8952 for {set i 0} {$i < [llength $todo]} {incr i} {
8953 set id [lindex $todo $i]
8954 if {[info exists cached_dheads($id)]} {
8955 set ret [concat $ret $cached_dheads($id)]
8957 if {[info exists idheads($id)]} {
8960 foreach a $arcnos($id) {
8961 if {$archeads($a) ne {}} {
8962 validate_archeads $a
8963 if {$archeads($a) ne {}} {
8964 set ret [concat $ret $archeads($a)]
8968 if {![info exists seen($d)]} {
8975 set ret [lsort -unique $ret]
8976 set cached_dheads($origid) $ret
8977 return [concat $ret $aret]
8980 proc addedtag {id} {
8981 global arcnos arcout cached_dtags cached_atags
8983 if {![info exists arcnos($id)]} return
8984 if {![info exists arcout($id)]} {
8985 recalcarc [lindex $arcnos($id) 0]
8987 catch {unset cached_dtags}
8988 catch {unset cached_atags}
8991 proc addedhead {hid head} {
8992 global arcnos arcout cached_dheads
8994 if {![info exists arcnos($hid)]} return
8995 if {![info exists arcout($hid)]} {
8996 recalcarc [lindex $arcnos($hid) 0]
8998 catch {unset cached_dheads}
9001 proc removedhead {hid head} {
9002 global cached_dheads
9004 catch {unset cached_dheads}
9007 proc movedhead {hid head} {
9008 global arcnos arcout cached_dheads
9010 if {![info exists arcnos($hid)]} return
9011 if {![info exists arcout($hid)]} {
9012 recalcarc [lindex $arcnos($hid) 0]
9014 catch {unset cached_dheads}
9017 proc changedrefs {} {
9018 global cached_dheads cached_dtags cached_atags
9019 global arctags archeads arcnos arcout idheads idtags
9021 foreach id [concat [array names idheads] [array names idtags]] {
9022 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9023 set a [lindex $arcnos($id) 0]
9024 if {![info exists donearc($a)]} {
9030 catch {unset cached_dtags}
9031 catch {unset cached_atags}
9032 catch {unset cached_dheads}
9035 proc rereadrefs {} {
9036 global idtags idheads idotherrefs mainheadid
9038 set refids [concat [array names idtags] \
9039 [array names idheads] [array names idotherrefs]]
9040 foreach id $refids {
9041 if {![info exists ref($id)]} {
9042 set ref($id) [listrefs $id]
9045 set oldmainhead $mainheadid
9048 set refids [lsort -unique [concat $refids [array names idtags] \
9049 [array names idheads] [array names idotherrefs]]]
9050 foreach id $refids {
9051 set v [listrefs $id]
9052 if {![info exists ref($id)] || $ref($id) != $v} {
9056 if {$oldmainhead ne $mainheadid} {
9057 redrawtags $oldmainhead
9058 redrawtags $mainheadid
9063 proc listrefs {id} {
9064 global idtags idheads idotherrefs
9067 if {[info exists idtags($id)]} {
9071 if {[info exists idheads($id)]} {
9075 if {[info exists idotherrefs($id)]} {
9076 set z $idotherrefs($id)
9078 return [list $x $y $z]
9081 proc showtag {tag isnew} {
9082 global ctext tagcontents tagids linknum tagobjid
9085 addtohistory [list showtag $tag 0]
9087 $ctext conf -state normal
9091 if {![info exists tagcontents($tag)]} {
9093 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9096 if {[info exists tagcontents($tag)]} {
9097 set text $tagcontents($tag)
9099 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9101 appendwithlinks $text {}
9102 $ctext conf -state disabled
9114 if {[info exists gitktmpdir]} {
9115 catch {file delete -force $gitktmpdir}
9119 proc mkfontdisp {font top which} {
9120 global fontattr fontpref $font
9122 set fontpref($font) [set $font]
9123 button $top.${font}but -text $which -font optionfont \
9124 -command [list choosefont $font $which]
9125 label $top.$font -relief flat -font $font \
9126 -text $fontattr($font,family) -justify left
9127 grid x $top.${font}but $top.$font -sticky w
9130 proc choosefont {font which} {
9131 global fontparam fontlist fonttop fontattr
9133 set fontparam(which) $which
9134 set fontparam(font) $font
9135 set fontparam(family) [font actual $font -family]
9136 set fontparam(size) $fontattr($font,size)
9137 set fontparam(weight) $fontattr($font,weight)
9138 set fontparam(slant) $fontattr($font,slant)
9141 if {![winfo exists $top]} {
9143 eval font config sample [font actual $font]
9145 wm title $top [mc "Gitk font chooser"]
9146 label $top.l -textvariable fontparam(which)
9147 pack $top.l -side top
9148 set fontlist [lsort [font families]]
9150 listbox $top.f.fam -listvariable fontlist \
9151 -yscrollcommand [list $top.f.sb set]
9152 bind $top.f.fam <<ListboxSelect>> selfontfam
9153 scrollbar $top.f.sb -command [list $top.f.fam yview]
9154 pack $top.f.sb -side right -fill y
9155 pack $top.f.fam -side left -fill both -expand 1
9156 pack $top.f -side top -fill both -expand 1
9158 spinbox $top.g.size -from 4 -to 40 -width 4 \
9159 -textvariable fontparam(size) \
9160 -validatecommand {string is integer -strict %s}
9161 checkbutton $top.g.bold -padx 5 \
9162 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9163 -variable fontparam(weight) -onvalue bold -offvalue normal
9164 checkbutton $top.g.ital -padx 5 \
9165 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9166 -variable fontparam(slant) -onvalue italic -offvalue roman
9167 pack $top.g.size $top.g.bold $top.g.ital -side left
9168 pack $top.g -side top
9169 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9171 $top.c create text 100 25 -anchor center -text $which -font sample \
9172 -fill black -tags text
9173 bind $top.c <Configure> [list centertext $top.c]
9174 pack $top.c -side top -fill x
9176 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9177 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9178 grid $top.buts.ok $top.buts.can
9179 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9180 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9181 pack $top.buts -side bottom -fill x
9182 trace add variable fontparam write chg_fontparam
9185 $top.c itemconf text -text $which
9187 set i [lsearch -exact $fontlist $fontparam(family)]
9189 $top.f.fam selection set $i
9194 proc centertext {w} {
9195 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9199 global fontparam fontpref prefstop
9201 set f $fontparam(font)
9202 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9203 if {$fontparam(weight) eq "bold"} {
9204 lappend fontpref($f) "bold"
9206 if {$fontparam(slant) eq "italic"} {
9207 lappend fontpref($f) "italic"
9210 $w conf -text $fontparam(family) -font $fontpref($f)
9216 global fonttop fontparam
9218 if {[info exists fonttop]} {
9219 catch {destroy $fonttop}
9220 catch {font delete sample}
9226 proc selfontfam {} {
9227 global fonttop fontparam
9229 set i [$fonttop.f.fam curselection]
9231 set fontparam(family) [$fonttop.f.fam get $i]
9235 proc chg_fontparam {v sub op} {
9238 font config sample -$sub $fontparam($sub)
9242 global maxwidth maxgraphpct
9243 global oldprefs prefstop showneartags showlocalchanges
9244 global bgcolor fgcolor ctext diffcolors selectbgcolor
9245 global tabstop limitdiffs autoselect extdifftool
9249 if {[winfo exists $top]} {
9253 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9254 limitdiffs tabstop} {
9255 set oldprefs($v) [set $v]
9258 wm title $top [mc "Gitk preferences"]
9259 label $top.ldisp -text [mc "Commit list display options"]
9260 grid $top.ldisp - -sticky w -pady 10
9261 label $top.spacer -text " "
9262 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9264 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9265 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9266 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9268 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9269 grid x $top.maxpctl $top.maxpct -sticky w
9270 frame $top.showlocal
9271 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9272 checkbutton $top.showlocal.b -variable showlocalchanges
9273 pack $top.showlocal.b $top.showlocal.l -side left
9274 grid x $top.showlocal -sticky w
9275 frame $top.autoselect
9276 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9277 checkbutton $top.autoselect.b -variable autoselect
9278 pack $top.autoselect.b $top.autoselect.l -side left
9279 grid x $top.autoselect -sticky w
9281 label $top.ddisp -text [mc "Diff display options"]
9282 grid $top.ddisp - -sticky w -pady 10
9283 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9284 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9285 grid x $top.tabstopl $top.tabstop -sticky w
9287 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9288 checkbutton $top.ntag.b -variable showneartags
9289 pack $top.ntag.b $top.ntag.l -side left
9290 grid x $top.ntag -sticky w
9292 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9293 checkbutton $top.ldiff.b -variable limitdiffs
9294 pack $top.ldiff.b $top.ldiff.l -side left
9295 grid x $top.ldiff -sticky w
9297 entry $top.extdifft -textvariable extdifftool
9299 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9301 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9302 -command choose_extdiff
9303 pack $top.extdifff.l $top.extdifff.b -side left
9304 grid x $top.extdifff $top.extdifft -sticky w
9306 label $top.cdisp -text [mc "Colors: press to choose"]
9307 grid $top.cdisp - -sticky w -pady 10
9308 label $top.bg -padx 40 -relief sunk -background $bgcolor
9309 button $top.bgbut -text [mc "Background"] -font optionfont \
9310 -command [list choosecolor bgcolor {} $top.bg background setbg]
9311 grid x $top.bgbut $top.bg -sticky w
9312 label $top.fg -padx 40 -relief sunk -background $fgcolor
9313 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9314 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9315 grid x $top.fgbut $top.fg -sticky w
9316 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9317 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9318 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9319 [list $ctext tag conf d0 -foreground]]
9320 grid x $top.diffoldbut $top.diffold -sticky w
9321 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9322 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9323 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9324 [list $ctext tag conf d1 -foreground]]
9325 grid x $top.diffnewbut $top.diffnew -sticky w
9326 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9327 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9328 -command [list choosecolor diffcolors 2 $top.hunksep \
9329 "diff hunk header" \
9330 [list $ctext tag conf hunksep -foreground]]
9331 grid x $top.hunksepbut $top.hunksep -sticky w
9332 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9333 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9334 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9335 grid x $top.selbgbut $top.selbgsep -sticky w
9337 label $top.cfont -text [mc "Fonts: press to choose"]
9338 grid $top.cfont - -sticky w -pady 10
9339 mkfontdisp mainfont $top [mc "Main font"]
9340 mkfontdisp textfont $top [mc "Diff display font"]
9341 mkfontdisp uifont $top [mc "User interface font"]
9344 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9345 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9346 grid $top.buts.ok $top.buts.can
9347 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9348 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9349 grid $top.buts - - -pady 10 -sticky ew
9350 bind $top <Visibility> "focus $top.buts.ok"
9353 proc choose_extdiff {} {
9356 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9358 set extdifftool $prog
9362 proc choosecolor {v vi w x cmd} {
9365 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9366 -title [mc "Gitk: choose color for %s" $x]]
9367 if {$c eq {}} return
9368 $w conf -background $c
9374 global bglist cflist
9376 $w configure -selectbackground $c
9378 $cflist tag configure highlight \
9379 -background [$cflist cget -selectbackground]
9380 allcanvs itemconf secsel -fill $c
9387 $w conf -background $c
9395 $w conf -foreground $c
9397 allcanvs itemconf text -fill $c
9398 $canv itemconf circle -outline $c
9402 global oldprefs prefstop
9404 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9405 limitdiffs tabstop} {
9407 set $v $oldprefs($v)
9409 catch {destroy $prefstop}
9415 global maxwidth maxgraphpct
9416 global oldprefs prefstop showneartags showlocalchanges
9417 global fontpref mainfont textfont uifont
9418 global limitdiffs treediffs
9420 catch {destroy $prefstop}
9424 if {$mainfont ne $fontpref(mainfont)} {
9425 set mainfont $fontpref(mainfont)
9426 parsefont mainfont $mainfont
9427 eval font configure mainfont [fontflags mainfont]
9428 eval font configure mainfontbold [fontflags mainfont 1]
9432 if {$textfont ne $fontpref(textfont)} {
9433 set textfont $fontpref(textfont)
9434 parsefont textfont $textfont
9435 eval font configure textfont [fontflags textfont]
9436 eval font configure textfontbold [fontflags textfont 1]
9438 if {$uifont ne $fontpref(uifont)} {
9439 set uifont $fontpref(uifont)
9440 parsefont uifont $uifont
9441 eval font configure uifont [fontflags uifont]
9444 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9445 if {$showlocalchanges} {
9451 if {$limitdiffs != $oldprefs(limitdiffs)} {
9452 # treediffs elements are limited by path
9453 catch {unset treediffs}
9455 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9456 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9458 } elseif {$showneartags != $oldprefs(showneartags) ||
9459 $limitdiffs != $oldprefs(limitdiffs)} {
9464 proc formatdate {d} {
9465 global datetimeformat
9467 set d [clock format $d -format $datetimeformat]
9472 # This list of encoding names and aliases is distilled from
9473 # http://www.iana.org/assignments/character-sets.
9474 # Not all of them are supported by Tcl.
9475 set encoding_aliases {
9476 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9477 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9478 { ISO-10646-UTF-1 csISO10646UTF1 }
9479 { ISO_646.basic:1983 ref csISO646basic1983 }
9480 { INVARIANT csINVARIANT }
9481 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9482 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9483 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9484 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9485 { NATS-DANO iso-ir-9-1 csNATSDANO }
9486 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9487 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9488 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9489 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9490 { ISO-2022-KR csISO2022KR }
9492 { ISO-2022-JP csISO2022JP }
9493 { ISO-2022-JP-2 csISO2022JP2 }
9494 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9496 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9497 { IT iso-ir-15 ISO646-IT csISO15Italian }
9498 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9499 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9500 { greek7-old iso-ir-18 csISO18Greek7Old }
9501 { latin-greek iso-ir-19 csISO19LatinGreek }
9502 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9503 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9504 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9505 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9506 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9507 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9508 { INIS iso-ir-49 csISO49INIS }
9509 { INIS-8 iso-ir-50 csISO50INIS8 }
9510 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9511 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9512 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9513 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9514 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9515 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9517 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9518 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9519 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9520 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9521 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9522 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9523 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9524 { greek7 iso-ir-88 csISO88Greek7 }
9525 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9526 { iso-ir-90 csISO90 }
9527 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9528 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9529 csISO92JISC62991984b }
9530 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9531 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9532 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9533 csISO95JIS62291984handadd }
9534 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9535 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9536 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9537 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9539 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9540 { T.61-7bit iso-ir-102 csISO102T617bit }
9541 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9542 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9543 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9544 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9545 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9546 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9547 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9548 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9549 arabic csISOLatinArabic }
9550 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9551 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9552 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9553 greek greek8 csISOLatinGreek }
9554 { T.101-G2 iso-ir-128 csISO128T101G2 }
9555 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9557 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9558 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9559 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9560 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9561 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9562 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9563 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9564 csISOLatinCyrillic }
9565 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9566 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9567 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9568 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9569 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9570 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9571 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9572 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9573 { ISO_10367-box iso-ir-155 csISO10367Box }
9574 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9575 { latin-lap lap iso-ir-158 csISO158Lap }
9576 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9577 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9580 { JIS_X0201 X0201 csHalfWidthKatakana }
9581 { KSC5636 ISO646-KR csKSC5636 }
9582 { ISO-10646-UCS-2 csUnicode }
9583 { ISO-10646-UCS-4 csUCS4 }
9584 { DEC-MCS dec csDECMCS }
9585 { hp-roman8 roman8 r8 csHPRoman8 }
9586 { macintosh mac csMacintosh }
9587 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9589 { IBM038 EBCDIC-INT cp038 csIBM038 }
9590 { IBM273 CP273 csIBM273 }
9591 { IBM274 EBCDIC-BE CP274 csIBM274 }
9592 { IBM275 EBCDIC-BR cp275 csIBM275 }
9593 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9594 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9595 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9596 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9597 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9598 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9599 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9600 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9601 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9602 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9603 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9604 { IBM437 cp437 437 csPC8CodePage437 }
9605 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9606 { IBM775 cp775 csPC775Baltic }
9607 { IBM850 cp850 850 csPC850Multilingual }
9608 { IBM851 cp851 851 csIBM851 }
9609 { IBM852 cp852 852 csPCp852 }
9610 { IBM855 cp855 855 csIBM855 }
9611 { IBM857 cp857 857 csIBM857 }
9612 { IBM860 cp860 860 csIBM860 }
9613 { IBM861 cp861 861 cp-is csIBM861 }
9614 { IBM862 cp862 862 csPC862LatinHebrew }
9615 { IBM863 cp863 863 csIBM863 }
9616 { IBM864 cp864 csIBM864 }
9617 { IBM865 cp865 865 csIBM865 }
9618 { IBM866 cp866 866 csIBM866 }
9619 { IBM868 CP868 cp-ar csIBM868 }
9620 { IBM869 cp869 869 cp-gr csIBM869 }
9621 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9622 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9623 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9624 { IBM891 cp891 csIBM891 }
9625 { IBM903 cp903 csIBM903 }
9626 { IBM904 cp904 904 csIBBM904 }
9627 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9628 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9629 { IBM1026 CP1026 csIBM1026 }
9630 { EBCDIC-AT-DE csIBMEBCDICATDE }
9631 { EBCDIC-AT-DE-A csEBCDICATDEA }
9632 { EBCDIC-CA-FR csEBCDICCAFR }
9633 { EBCDIC-DK-NO csEBCDICDKNO }
9634 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9635 { EBCDIC-FI-SE csEBCDICFISE }
9636 { EBCDIC-FI-SE-A csEBCDICFISEA }
9637 { EBCDIC-FR csEBCDICFR }
9638 { EBCDIC-IT csEBCDICIT }
9639 { EBCDIC-PT csEBCDICPT }
9640 { EBCDIC-ES csEBCDICES }
9641 { EBCDIC-ES-A csEBCDICESA }
9642 { EBCDIC-ES-S csEBCDICESS }
9643 { EBCDIC-UK csEBCDICUK }
9644 { EBCDIC-US csEBCDICUS }
9645 { UNKNOWN-8BIT csUnknown8BiT }
9646 { MNEMONIC csMnemonic }
9651 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9652 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9653 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9654 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9655 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9656 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9657 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9658 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9659 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9660 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9661 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9662 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9663 { IBM1047 IBM-1047 }
9664 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9665 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9666 { UNICODE-1-1 csUnicode11 }
9669 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9670 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9672 { ISO-8859-15 ISO_8859-15 Latin-9 }
9673 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9674 { GBK CP936 MS936 windows-936 }
9675 { JIS_Encoding csJISEncoding }
9676 { Shift_JIS MS_Kanji csShiftJIS }
9677 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9679 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9680 { ISO-10646-UCS-Basic csUnicodeASCII }
9681 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9682 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9683 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9684 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9685 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9686 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9687 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9688 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9689 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9690 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9691 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9692 { Ventura-US csVenturaUS }
9693 { Ventura-International csVenturaInternational }
9694 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9695 { PC8-Turkish csPC8Turkish }
9696 { IBM-Symbols csIBMSymbols }
9697 { IBM-Thai csIBMThai }
9698 { HP-Legal csHPLegal }
9699 { HP-Pi-font csHPPiFont }
9700 { HP-Math8 csHPMath8 }
9701 { Adobe-Symbol-Encoding csHPPSMath }
9702 { HP-DeskTop csHPDesktop }
9703 { Ventura-Math csVenturaMath }
9704 { Microsoft-Publishing csMicrosoftPublishing }
9705 { Windows-31J csWindows31J }
9710 proc tcl_encoding {enc} {
9711 global encoding_aliases
9712 set names [encoding names]
9713 set lcnames [string tolower $names]
9714 set enc [string tolower $enc]
9715 set i [lsearch -exact $lcnames $enc]
9717 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9718 if {[regsub {^iso[-_]} $enc iso encx]} {
9719 set i [lsearch -exact $lcnames $encx]
9723 foreach l $encoding_aliases {
9724 set ll [string tolower $l]
9725 if {[lsearch -exact $ll $enc] < 0} continue
9726 # look through the aliases for one that tcl knows about
9728 set i [lsearch -exact $lcnames $e]
9730 if {[regsub {^iso[-_]} $e iso ex]} {
9731 set i [lsearch -exact $lcnames $ex]
9740 return [lindex $names $i]
9745 # First check that Tcl/Tk is recent enough
9746 if {[catch {package require Tk 8.4} err]} {
9747 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9748 Gitk requires at least Tcl/Tk 8.4."]
9753 set wrcomcmd "git diff-tree --stdin -p --pretty"
9757 set gitencoding [exec git config --get i18n.commitencoding]
9759 if {$gitencoding == ""} {
9760 set gitencoding "utf-8"
9762 set tclencoding [tcl_encoding $gitencoding]
9763 if {$tclencoding == {}} {
9764 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9767 set mainfont {Helvetica 9}
9768 set textfont {Courier 9}
9769 set uifont {Helvetica 9 bold}
9771 set findmergefiles 0
9779 set cmitmode "patch"
9780 set wrapcomment "none"
9784 set showlocalchanges 1
9786 set datetimeformat "%Y-%m-%d %H:%M:%S"
9789 set extdifftool "meld"
9791 set colors {green red blue magenta darkgrey brown orange}
9794 set diffcolors {red "#00a000" blue}
9797 set selectbgcolor gray85
9799 set circlecolors {white blue gray blue blue}
9801 ## For msgcat loading, first locate the installation location.
9802 if { [info exists ::env(GITK_MSGSDIR)] } {
9803 ## Msgsdir was manually set in the environment.
9804 set gitk_msgsdir $::env(GITK_MSGSDIR)
9806 ## Let's guess the prefix from argv0.
9807 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9808 set gitk_libdir [file join $gitk_prefix share gitk lib]
9809 set gitk_msgsdir [file join $gitk_libdir msgs]
9813 ## Internationalization (i18n) through msgcat and gettext. See
9814 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9815 package require msgcat
9816 namespace import ::msgcat::mc
9817 ## And eventually load the actual message catalog
9818 ::msgcat::mcload $gitk_msgsdir
9820 catch {source ~/.gitk}
9822 font create optionfont -family sans-serif -size -12
9824 parsefont mainfont $mainfont
9825 eval font create mainfont [fontflags mainfont]
9826 eval font create mainfontbold [fontflags mainfont 1]
9828 parsefont textfont $textfont
9829 eval font create textfont [fontflags textfont]
9830 eval font create textfontbold [fontflags textfont 1]
9832 parsefont uifont $uifont
9833 eval font create uifont [fontflags uifont]
9837 # check that we can find a .git directory somewhere...
9838 if {[catch {set gitdir [gitdir]}]} {
9839 show_error {} . [mc "Cannot find a git repository here."]
9842 if {![file isdirectory $gitdir]} {
9843 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9848 set cmdline_files {}
9850 set revtreeargscmd {}
9852 switch -glob -- $arg {
9855 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9859 set revtreeargscmd [string range $arg 10 end]
9862 lappend revtreeargs $arg
9868 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9869 # no -- on command line, but some arguments (other than --argscmd)
9871 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9872 set cmdline_files [split $f "\n"]
9873 set n [llength $cmdline_files]
9874 set revtreeargs [lrange $revtreeargs 0 end-$n]
9875 # Unfortunately git rev-parse doesn't produce an error when
9876 # something is both a revision and a filename. To be consistent
9877 # with git log and git rev-list, check revtreeargs for filenames.
9878 foreach arg $revtreeargs {
9879 if {[file exists $arg]} {
9880 show_error {} . [mc "Ambiguous argument '%s': both revision\
9886 # unfortunately we get both stdout and stderr in $err,
9887 # so look for "fatal:".
9888 set i [string first "fatal:" $err]
9890 set err [string range $err [expr {$i + 6}] end]
9892 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9897 set nullid "0000000000000000000000000000000000000000"
9898 set nullid2 "0000000000000000000000000000000000000001"
9899 set nullfile "/dev/null"
9901 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9908 set highlight_paths {}
9910 set searchdirn -forwards
9914 set markingmatches 0
9915 set linkentercount 0
9916 set need_redisplay 0
9923 set selectedhlview [mc "None"]
9924 set highlight_related [mc "None"]
9925 set highlight_files {}
9929 set viewargscmd(0) {}
9939 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9942 # wait for the window to become visible
9944 wm title . "[file tail $argv0]: [file tail [pwd]]"
9947 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9948 # create a view for the files/dirs specified on the command line
9952 set viewname(1) [mc "Command line"]
9953 set viewfiles(1) $cmdline_files
9954 set viewargs(1) $revtreeargs
9955 set viewargscmd(1) $revtreeargscmd
9959 .bar.view entryconf [mc "Edit view..."] -state normal
9960 .bar.view entryconf [mc "Delete view"] -state normal
9963 if {[info exists permviews]} {
9964 foreach v $permviews {
9967 set viewname($n) [lindex $v 0]
9968 set viewfiles($n) [lindex $v 1]
9969 set viewargs($n) [lindex $v 2]
9970 set viewargscmd($n) [lindex $v 3]