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 unmerged_files
{files
} {
96 # find the list of unmerged files
100 set fd
[open
"| git ls-files -u" r
]
102 show_error
{} .
"[mc "Couldn
't get list of unmerged files:"] $err"
105 while {[gets $fd line] >= 0} {
106 set i [string first "\t" $line]
108 set fname [string range $line [expr {$i+1}] end]
109 if {[lsearch -exact $mlist $fname] >= 0} continue
111 if {$files eq {} || [path_filter $files $fname]} {
119 proc parseviewargs {n arglist} {
120 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
128 set origargs $arglist
132 foreach arg $arglist {
139 switch -glob -- $arg {
143 # remove from origargs in case we hit an unknown option
144 set origargs [lreplace $origargs $i $i]
147 # These request or affect diff output, which we don't want.
148 # Some could be used to set our defaults for diff display.
150 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
151 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
152 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
153 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
154 "--ignore-space-change" - "-U*" - "--unified=*" {
155 lappend diffargs
$arg
157 # These cause our parsing of git log's output to fail, or else
158 # they're options we want to set ourselves, so ignore them.
159 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
160 "--name-only" - "--name-status" - "--color" - "--color-words" -
161 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
162 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
163 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
164 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
165 "--objects" - "--objects-edge" - "--reverse" {
167 # These are harmless, and some are even useful
168 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
169 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
170 "--full-history" - "--dense" - "--sparse" -
171 "--follow" - "--left-right" - "--encoding=*" {
174 # These mean that we get a subset of the commits
175 "--diff-filter=*" - "--no-merges" - "--unpacked" -
176 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
177 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
178 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
179 "--remove-empty" - "--first-parent" - "--cherry-pick" -
180 "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
184 # This appears to be the only one that has a value as a
185 # separate word following it
192 set notflag
[expr {!$notflag}]
200 # git rev-parse doesn't understand --merge
201 lappend revargs
--gitk-symmetric-diff-marker MERGE_HEAD...HEAD
203 # Other flag arguments including -<n>
205 if {[string is digit
-strict [string range
$arg 1 end
]]} {
208 # a flag argument that we don't recognize;
209 # that means we can't optimize
214 # Non-flag arguments specify commits or ranges of commits
216 if {[string match
"*...*" $arg]} {
217 lappend revargs
--gitk-symmetric-diff-marker
223 set vdflags
($n) $diffargs
224 set vflags
($n) $glflags
225 set vrevs
($n) $revargs
226 set vfiltered
($n) $filtered
227 set vorigargs
($n) $origargs
231 proc parseviewrevs
{view revs
} {
232 global vposids vnegids
237 if {[catch
{set ids
[eval exec git rev-parse
$revs]} err
]} {
238 # we get stdout followed by stderr in $err
239 # for an unknown rev, git rev-parse echoes it and then errors out
240 set errlines
[split $err "\n"]
242 for {set l
0} {$l < [llength
$errlines]} {incr l
} {
243 set line
[lindex
$errlines $l]
244 if {!([string length
$line] == 40 && [string is xdigit
$line])} {
245 if {[string match
"fatal:*" $line]} {
246 if {[string match
"fatal: ambiguous argument*" $line]
248 if {[llength
$badrev] == 1} {
249 set err
"unknown revision $badrev"
251 set err
"unknown revisions: [join $badrev ", "]"
254 set err
[join [lrange
$errlines $l end
] "\n"]
261 error_popup
"Error parsing revisions: $err"
268 foreach id
[split $ids "\n"] {
269 if {$id eq
"--gitk-symmetric-diff-marker"} {
271 } elseif
{[string match
"^*" $id]} {
278 lappend neg
[string range
$id 1 end
]
283 lset ret end
[lindex
$ret end
]...
$id
289 set vposids
($view) $pos
290 set vnegids
($view) $neg
294 # Start off a git log process and arrange to read its output
295 proc start_rev_list
{view
} {
296 global startmsecs commitidx viewcomplete curview
297 global commfd leftover tclencoding
298 global viewargs viewargscmd viewfiles vfilelimit
299 global showlocalchanges commitinterest mainheadid
300 global viewactive loginstance viewinstances vmergeonly
301 global pending_select mainheadid
302 global vcanopt vflags vrevs vorigargs
304 set startmsecs
[clock clicks
-milliseconds]
305 set commitidx
($view) 0
306 # these are set this way for the error exits
307 set viewcomplete
($view) 1
308 set viewactive
($view) 0
311 set args
$viewargs($view)
312 if {$viewargscmd($view) ne
{}} {
314 set str
[exec sh
-c $viewargscmd($view)]
316 error_popup
"Error executing --argscmd command: $err"
319 set args
[concat
$args [split $str "\n"]]
321 set vcanopt
($view) [parseviewargs
$view $args]
323 set files
$viewfiles($view)
324 if {$vmergeonly($view)} {
325 set files
[unmerged_files
$files]
328 if {$nr_unmerged == 0} {
329 error_popup
[mc
"No files selected: --merge specified but\
330 no files are unmerged."]
332 error_popup
[mc
"No files selected: --merge specified but\
333 no unmerged files are within file limit."]
338 set vfilelimit
($view) $files
340 if {$vcanopt($view)} {
341 set revs
[parseviewrevs
$view $vrevs($view)]
345 set args
[concat
$vflags($view) $revs]
347 set args
$vorigargs($view)
351 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
352 --boundary $args "--" $files] r
]
354 error_popup
"[mc "Error executing git log
:"] $err"
357 set i
[incr loginstance
]
358 set viewinstances
($view) [list
$i]
361 if {$showlocalchanges} {
362 lappend commitinterest
($mainheadid) {dodiffindex
}
364 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
365 if {$tclencoding != {}} {
366 fconfigure
$fd -encoding $tclencoding
368 filerun
$fd [list getcommitlines
$fd $i $view 0]
369 nowbusy
$view [mc
"Reading"]
370 if {$view == $curview} {
371 set pending_select
$mainheadid
373 set viewcomplete
($view) 0
374 set viewactive
($view) 1
378 proc stop_rev_list
{view
} {
379 global commfd viewinstances leftover
381 foreach inst
$viewinstances($view) {
382 set fd
$commfd($inst)
390 unset leftover
($inst)
392 set viewinstances
($view) {}
396 global canv curview need_redisplay viewactive
399 if {[start_rev_list
$curview]} {
400 show_status
[mc
"Reading commits..."]
403 show_status
[mc
"No commits selected"]
407 proc updatecommits
{} {
408 global curview vcanopt vorigargs vfilelimit viewinstances
409 global viewactive viewcomplete loginstance tclencoding mainheadid
410 global startmsecs commfd showneartags showlocalchanges leftover
411 global mainheadid pending_select
413 global varcid vposids vnegids vflags vrevs
415 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
416 set oldmainid
$mainheadid
418 if {$showlocalchanges} {
419 if {$mainheadid ne
$oldmainid} {
422 if {[commitinview
$mainheadid $curview]} {
427 if {$vcanopt($view)} {
428 set oldpos
$vposids($view)
429 set oldneg
$vnegids($view)
430 set revs
[parseviewrevs
$view $vrevs($view)]
434 # note: getting the delta when negative refs change is hard,
435 # and could require multiple git log invocations, so in that
436 # case we ask git log for all the commits (not just the delta)
437 if {$oldneg eq
$vnegids($view)} {
440 # take out positive refs that we asked for before or
441 # that we have already seen
443 if {[string length
$rev] == 40} {
444 if {[lsearch
-exact $oldpos $rev] < 0
445 && ![info exists varcid
($view,$rev)]} {
450 lappend
$newrevs $rev
453 if {$npos == 0} return
455 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
457 set args
[concat
$vflags($view) $revs --not $oldpos]
459 set args
$vorigargs($view)
462 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
463 --boundary $args "--" $vfilelimit($view)] r
]
465 error_popup
"Error executing git log: $err"
468 if {$viewactive($view) == 0} {
469 set startmsecs
[clock clicks
-milliseconds]
471 set i
[incr loginstance
]
472 lappend viewinstances
($view) $i
475 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
476 if {$tclencoding != {}} {
477 fconfigure
$fd -encoding $tclencoding
479 filerun
$fd [list getcommitlines
$fd $i $view 1]
480 incr viewactive
($view)
481 set viewcomplete
($view) 0
482 set pending_select
$mainheadid
483 nowbusy
$view "Reading"
489 proc reloadcommits
{} {
490 global curview viewcomplete selectedline currentid thickerline
491 global showneartags treediffs commitinterest cached_commitrow
494 if {!$viewcomplete($curview)} {
495 stop_rev_list
$curview
498 catch
{unset selectedline
}
499 catch
{unset currentid
}
500 catch
{unset thickerline
}
501 catch
{unset treediffs
}
508 catch
{unset commitinterest
}
509 catch
{unset cached_commitrow
}
510 catch
{unset targetid
}
516 # This makes a string representation of a positive integer which
517 # sorts as a string in numerical order
520 return [format
"%x" $n]
521 } elseif
{$n < 256} {
522 return [format
"x%.2x" $n]
523 } elseif
{$n < 65536} {
524 return [format
"y%.4x" $n]
526 return [format
"z%.8x" $n]
529 # Procedures used in reordering commits from git log (without
530 # --topo-order) into the order for display.
532 proc varcinit
{view
} {
533 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
534 global vtokmod varcmod vrowmod varcix vlastins
536 set varcstart
($view) {{}}
537 set vupptr
($view) {0}
538 set vdownptr
($view) {0}
539 set vleftptr
($view) {0}
540 set vbackptr
($view) {0}
541 set varctok
($view) {{}}
542 set varcrow
($view) {{}}
543 set vtokmod
($view) {}
546 set varcix
($view) {{}}
547 set vlastins
($view) {0}
550 proc resetvarcs
{view
} {
551 global varcid varccommits parents children vseedcount ordertok
553 foreach vid
[array names varcid
$view,*] {
558 # some commits might have children but haven't been seen yet
559 foreach vid
[array names children
$view,*] {
562 foreach va
[array names varccommits
$view,*] {
563 unset varccommits
($va)
565 foreach vd
[array names vseedcount
$view,*] {
566 unset vseedcount
($vd)
568 catch
{unset ordertok
}
571 # returns a list of the commits with no children
573 global vdownptr vleftptr varcstart
576 set a
[lindex
$vdownptr($v) 0]
578 lappend ret
[lindex
$varcstart($v) $a]
579 set a
[lindex
$vleftptr($v) $a]
584 proc newvarc
{view id
} {
585 global varcid varctok parents children vdatemode
586 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
587 global commitdata commitinfo vseedcount varccommits vlastins
589 set a
[llength
$varctok($view)]
591 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
592 if {![info exists commitinfo
($id)]} {
593 parsecommit
$id $commitdata($id) 1
595 set cdate
[lindex
$commitinfo($id) 4]
596 if {![string is integer
-strict $cdate]} {
599 if {![info exists vseedcount
($view,$cdate)]} {
600 set vseedcount
($view,$cdate) -1
602 set c
[incr vseedcount
($view,$cdate)]
603 set cdate
[expr {$cdate ^
0xffffffff}]
604 set tok
"s[strrep $cdate][strrep $c]"
609 if {[llength
$children($vid)] > 0} {
610 set kid
[lindex
$children($vid) end
]
611 set k
$varcid($view,$kid)
612 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
615 set tok
[lindex
$varctok($view) $k]
619 set i
[lsearch
-exact $parents($view,$ki) $id]
620 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
621 append tok
[strrep
$j]
623 set c
[lindex
$vlastins($view) $ka]
624 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
626 set b
[lindex
$vdownptr($view) $ka]
628 set b
[lindex
$vleftptr($view) $c]
630 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
632 set b
[lindex
$vleftptr($view) $c]
635 lset vdownptr
($view) $ka $a
636 lappend vbackptr
($view) 0
638 lset vleftptr
($view) $c $a
639 lappend vbackptr
($view) $c
641 lset vlastins
($view) $ka $a
642 lappend vupptr
($view) $ka
643 lappend vleftptr
($view) $b
645 lset vbackptr
($view) $b $a
647 lappend varctok
($view) $tok
648 lappend varcstart
($view) $id
649 lappend vdownptr
($view) 0
650 lappend varcrow
($view) {}
651 lappend varcix
($view) {}
652 set varccommits
($view,$a) {}
653 lappend vlastins
($view) 0
657 proc splitvarc
{p v
} {
658 global varcid varcstart varccommits varctok
659 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
661 set oa
$varcid($v,$p)
662 set ac
$varccommits($v,$oa)
663 set i
[lsearch
-exact $varccommits($v,$oa) $p]
665 set na
[llength
$varctok($v)]
666 # "%" sorts before "0"...
667 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
668 lappend varctok
($v) $tok
669 lappend varcrow
($v) {}
670 lappend varcix
($v) {}
671 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
672 set varccommits
($v,$na) [lrange
$ac $i end
]
673 lappend varcstart
($v) $p
674 foreach id
$varccommits($v,$na) {
675 set varcid
($v,$id) $na
677 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
678 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
679 lset vdownptr
($v) $oa $na
680 lset vlastins
($v) $oa 0
681 lappend vupptr
($v) $oa
682 lappend vleftptr
($v) 0
683 lappend vbackptr
($v) 0
684 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
685 lset vupptr
($v) $b $na
689 proc renumbervarc
{a v
} {
690 global parents children varctok varcstart varccommits
691 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
693 set t1
[clock clicks
-milliseconds]
699 if {[info exists isrelated
($a)]} {
701 set id
[lindex
$varccommits($v,$a) end
]
702 foreach p
$parents($v,$id) {
703 if {[info exists varcid
($v,$p)]} {
704 set isrelated
($varcid($v,$p)) 1
709 set b
[lindex
$vdownptr($v) $a]
712 set b
[lindex
$vleftptr($v) $a]
714 set a
[lindex
$vupptr($v) $a]
720 if {![info exists kidchanged
($a)]} continue
721 set id
[lindex
$varcstart($v) $a]
722 if {[llength
$children($v,$id)] > 1} {
723 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
726 set oldtok
[lindex
$varctok($v) $a]
727 if {!$vdatemode($v)} {
733 set kid
[last_real_child
$v,$id]
735 set k
$varcid($v,$kid)
736 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
739 set tok
[lindex
$varctok($v) $k]
743 set i
[lsearch
-exact $parents($v,$ki) $id]
744 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
745 append tok
[strrep
$j]
747 if {$tok eq
$oldtok} {
750 set id
[lindex
$varccommits($v,$a) end
]
751 foreach p
$parents($v,$id) {
752 if {[info exists varcid
($v,$p)]} {
753 set kidchanged
($varcid($v,$p)) 1
758 lset varctok
($v) $a $tok
759 set b
[lindex
$vupptr($v) $a]
761 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
764 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
767 set c
[lindex
$vbackptr($v) $a]
768 set d
[lindex
$vleftptr($v) $a]
770 lset vdownptr
($v) $b $d
772 lset vleftptr
($v) $c $d
775 lset vbackptr
($v) $d $c
777 if {[lindex
$vlastins($v) $b] == $a} {
778 lset vlastins
($v) $b $c
780 lset vupptr
($v) $a $ka
781 set c
[lindex
$vlastins($v) $ka]
783 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
785 set b
[lindex
$vdownptr($v) $ka]
787 set b
[lindex
$vleftptr($v) $c]
790 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
792 set b
[lindex
$vleftptr($v) $c]
795 lset vdownptr
($v) $ka $a
796 lset vbackptr
($v) $a 0
798 lset vleftptr
($v) $c $a
799 lset vbackptr
($v) $a $c
801 lset vleftptr
($v) $a $b
803 lset vbackptr
($v) $b $a
805 lset vlastins
($v) $ka $a
808 foreach id
[array names sortkids
] {
809 if {[llength
$children($v,$id)] > 1} {
810 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
814 set t2
[clock clicks
-milliseconds]
815 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
818 # Fix up the graph after we have found out that in view $v,
819 # $p (a commit that we have already seen) is actually the parent
820 # of the last commit in arc $a.
821 proc fix_reversal
{p a v
} {
822 global varcid varcstart varctok vupptr
824 set pa
$varcid($v,$p)
825 if {$p ne
[lindex
$varcstart($v) $pa]} {
827 set pa
$varcid($v,$p)
829 # seeds always need to be renumbered
830 if {[lindex
$vupptr($v) $pa] == 0 ||
831 [string compare
[lindex
$varctok($v) $a] \
832 [lindex
$varctok($v) $pa]] > 0} {
837 proc insertrow
{id p v
} {
838 global cmitlisted children parents varcid varctok vtokmod
839 global varccommits ordertok commitidx numcommits curview
840 global targetid targetrow
844 set cmitlisted
($vid) 1
845 set children
($vid) {}
846 set parents
($vid) [list
$p]
847 set a
[newvarc
$v $id]
849 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
852 lappend varccommits
($v,$a) $id
854 if {[llength
[lappend children
($vp) $id]] > 1} {
855 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
856 catch
{unset ordertok
}
858 fix_reversal
$p $a $v
860 if {$v == $curview} {
861 set numcommits
$commitidx($v)
863 if {[info exists targetid
]} {
864 if {![comes_before
$targetid $p]} {
871 proc insertfakerow
{id p
} {
872 global varcid varccommits parents children cmitlisted
873 global commitidx varctok vtokmod targetid targetrow curview numcommits
877 set i
[lsearch
-exact $varccommits($v,$a) $p]
879 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
882 set children
($v,$id) {}
883 set parents
($v,$id) [list
$p]
884 set varcid
($v,$id) $a
885 lappend children
($v,$p) $id
886 set cmitlisted
($v,$id) 1
887 set numcommits
[incr commitidx
($v)]
888 # note we deliberately don't update varcstart($v) even if $i == 0
889 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
891 if {[info exists targetid
]} {
892 if {![comes_before
$targetid $p]} {
900 proc removefakerow
{id
} {
901 global varcid varccommits parents children commitidx
902 global varctok vtokmod cmitlisted currentid selectedline
903 global targetid curview numcommits
906 if {[llength
$parents($v,$id)] != 1} {
907 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
910 set p
[lindex
$parents($v,$id) 0]
911 set a
$varcid($v,$id)
912 set i
[lsearch
-exact $varccommits($v,$a) $id]
914 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
918 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
919 unset parents
($v,$id)
920 unset children
($v,$id)
921 unset cmitlisted
($v,$id)
922 set numcommits
[incr commitidx
($v) -1]
923 set j
[lsearch
-exact $children($v,$p) $id]
925 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
928 if {[info exist currentid
] && $id eq
$currentid} {
932 if {[info exists targetid
] && $targetid eq
$id} {
939 proc first_real_child
{vp
} {
940 global children nullid nullid2
942 foreach id
$children($vp) {
943 if {$id ne
$nullid && $id ne
$nullid2} {
950 proc last_real_child
{vp
} {
951 global children nullid nullid2
953 set kids
$children($vp)
954 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
955 set id
[lindex
$kids $i]
956 if {$id ne
$nullid && $id ne
$nullid2} {
963 proc vtokcmp
{v a b
} {
964 global varctok varcid
966 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
967 [lindex
$varctok($v) $varcid($v,$b)]]
970 # This assumes that if lim is not given, the caller has checked that
971 # arc a's token is less than $vtokmod($v)
972 proc modify_arc
{v a
{lim
{}}} {
973 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
976 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
979 set r
[lindex
$varcrow($v) $a]
980 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
983 set vtokmod
($v) [lindex
$varctok($v) $a]
985 if {$v == $curview} {
986 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
987 set a
[lindex
$vupptr($v) $a]
993 set lim
[llength
$varccommits($v,$a)]
995 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1002 proc update_arcrows
{v
} {
1003 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1004 global varcid vrownum varcorder varcix varccommits
1005 global vupptr vdownptr vleftptr varctok
1006 global displayorder parentlist curview cached_commitrow
1008 if {$vrowmod($v) == $commitidx($v)} return
1009 if {$v == $curview} {
1010 if {[llength
$displayorder] > $vrowmod($v)} {
1011 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1012 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1014 catch
{unset cached_commitrow
}
1016 set narctot
[expr {[llength
$varctok($v)] - 1}]
1018 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1019 # go up the tree until we find something that has a row number,
1020 # or we get to a seed
1021 set a
[lindex
$vupptr($v) $a]
1024 set a
[lindex
$vdownptr($v) 0]
1027 set varcorder
($v) [list
$a]
1028 lset varcix
($v) $a 0
1029 lset varcrow
($v) $a 0
1033 set arcn
[lindex
$varcix($v) $a]
1034 if {[llength
$vrownum($v)] > $arcn + 1} {
1035 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1036 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1038 set row
[lindex
$varcrow($v) $a]
1042 incr row
[llength
$varccommits($v,$a)]
1043 # go down if possible
1044 set b
[lindex
$vdownptr($v) $a]
1046 # if not, go left, or go up until we can go left
1048 set b
[lindex
$vleftptr($v) $a]
1050 set a
[lindex
$vupptr($v) $a]
1056 lappend vrownum
($v) $row
1057 lappend varcorder
($v) $a
1058 lset varcix
($v) $a $arcn
1059 lset varcrow
($v) $a $row
1061 set vtokmod
($v) [lindex
$varctok($v) $p]
1063 set vrowmod
($v) $row
1064 if {[info exists currentid
]} {
1065 set selectedline
[rowofcommit
$currentid]
1069 # Test whether view $v contains commit $id
1070 proc commitinview
{id v
} {
1073 return [info exists varcid
($v,$id)]
1076 # Return the row number for commit $id in the current view
1077 proc rowofcommit
{id
} {
1078 global varcid varccommits varcrow curview cached_commitrow
1079 global varctok vtokmod
1082 if {![info exists varcid
($v,$id)]} {
1083 puts
"oops rowofcommit no arc for [shortids $id]"
1086 set a
$varcid($v,$id)
1087 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1090 if {[info exists cached_commitrow
($id)]} {
1091 return $cached_commitrow($id)
1093 set i
[lsearch
-exact $varccommits($v,$a) $id]
1095 puts
"oops didn't find commit [shortids $id] in arc $a"
1098 incr i
[lindex
$varcrow($v) $a]
1099 set cached_commitrow
($id) $i
1103 # Returns 1 if a is on an earlier row than b, otherwise 0
1104 proc comes_before
{a b
} {
1105 global varcid varctok curview
1108 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1109 ![info exists varcid
($v,$b)]} {
1112 if {$varcid($v,$a) != $varcid($v,$b)} {
1113 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1114 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1116 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1119 proc bsearch
{l elt
} {
1120 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1125 while {$hi - $lo > 1} {
1126 set mid
[expr {int
(($lo + $hi) / 2)}]
1127 set t
[lindex
$l $mid]
1130 } elseif
{$elt > $t} {
1139 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1140 proc make_disporder
{start end
} {
1141 global vrownum curview commitidx displayorder parentlist
1142 global varccommits varcorder parents vrowmod varcrow
1143 global d_valid_start d_valid_end
1145 if {$end > $vrowmod($curview)} {
1146 update_arcrows
$curview
1148 set ai
[bsearch
$vrownum($curview) $start]
1149 set start
[lindex
$vrownum($curview) $ai]
1150 set narc
[llength
$vrownum($curview)]
1151 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1152 set a
[lindex
$varcorder($curview) $ai]
1153 set l
[llength
$displayorder]
1154 set al
[llength
$varccommits($curview,$a)]
1155 if {$l < $r + $al} {
1157 set pad
[ntimes
[expr {$r - $l}] {}]
1158 set displayorder
[concat
$displayorder $pad]
1159 set parentlist
[concat
$parentlist $pad]
1160 } elseif
{$l > $r} {
1161 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1162 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1164 foreach id
$varccommits($curview,$a) {
1165 lappend displayorder
$id
1166 lappend parentlist
$parents($curview,$id)
1168 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1170 foreach id
$varccommits($curview,$a) {
1171 lset displayorder
$i $id
1172 lset parentlist
$i $parents($curview,$id)
1180 proc commitonrow
{row
} {
1183 set id
[lindex
$displayorder $row]
1185 make_disporder
$row [expr {$row + 1}]
1186 set id
[lindex
$displayorder $row]
1191 proc closevarcs
{v
} {
1192 global varctok varccommits varcid parents children
1193 global cmitlisted commitidx commitinterest vtokmod
1195 set missing_parents
0
1197 set narcs
[llength
$varctok($v)]
1198 for {set a
1} {$a < $narcs} {incr a
} {
1199 set id
[lindex
$varccommits($v,$a) end
]
1200 foreach p
$parents($v,$id) {
1201 if {[info exists varcid
($v,$p)]} continue
1202 # add p as a new commit
1203 incr missing_parents
1204 set cmitlisted
($v,$p) 0
1205 set parents
($v,$p) {}
1206 if {[llength
$children($v,$p)] == 1 &&
1207 [llength
$parents($v,$id)] == 1} {
1210 set b
[newvarc
$v $p]
1212 set varcid
($v,$p) $b
1213 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1216 lappend varccommits
($v,$b) $p
1218 if {[info exists commitinterest
($p)]} {
1219 foreach
script $commitinterest($p) {
1220 lappend scripts
[string map
[list
"%I" $p] $script]
1222 unset commitinterest
($id)
1226 if {$missing_parents > 0} {
1227 foreach s
$scripts {
1233 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1234 # Assumes we already have an arc for $rwid.
1235 proc rewrite_commit
{v id rwid
} {
1236 global children parents varcid varctok vtokmod varccommits
1238 foreach ch
$children($v,$id) {
1239 # make $rwid be $ch's parent in place of $id
1240 set i
[lsearch
-exact $parents($v,$ch) $id]
1242 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1244 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1245 # add $ch to $rwid's children and sort the list if necessary
1246 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1247 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1248 $children($v,$rwid)]
1250 # fix the graph after joining $id to $rwid
1251 set a
$varcid($v,$ch)
1252 fix_reversal
$rwid $a $v
1253 # parentlist is wrong for the last element of arc $a
1254 # even if displayorder is right, hence the 3rd arg here
1255 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1259 proc getcommitlines
{fd inst view updating
} {
1260 global cmitlisted commitinterest leftover
1261 global commitidx commitdata vdatemode
1262 global parents children curview hlview
1263 global idpending ordertok
1264 global varccommits varcid varctok vtokmod vfilelimit
1266 set stuff
[read $fd 500000]
1267 # git log doesn't terminate the last commit with a null...
1268 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1275 global commfd viewcomplete viewactive viewname
1276 global viewinstances
1278 set i
[lsearch
-exact $viewinstances($view) $inst]
1280 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1282 # set it blocking so we wait for the process to terminate
1283 fconfigure
$fd -blocking 1
1284 if {[catch
{close
$fd} err
]} {
1286 if {$view != $curview} {
1287 set fv
" for the \"$viewname($view)\" view"
1289 if {[string range
$err 0 4] == "usage"} {
1290 set err
"Gitk: error reading commits$fv:\
1291 bad arguments to git log."
1292 if {$viewname($view) eq
"Command line"} {
1294 " (Note: arguments to gitk are passed to git log\
1295 to allow selection of commits to be displayed.)"
1298 set err
"Error reading commits$fv: $err"
1302 if {[incr viewactive
($view) -1] <= 0} {
1303 set viewcomplete
($view) 1
1304 # Check if we have seen any ids listed as parents that haven't
1305 # appeared in the list
1309 if {$view == $curview} {
1318 set i
[string first
"\0" $stuff $start]
1320 append leftover
($inst) [string range
$stuff $start end
]
1324 set cmit
$leftover($inst)
1325 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1326 set leftover
($inst) {}
1328 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1330 set start
[expr {$i + 1}]
1331 set j
[string first
"\n" $cmit]
1334 if {$j >= 0 && [string match
"commit *" $cmit]} {
1335 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1336 if {[string match
{[-^
<>]*} $ids]} {
1337 switch
-- [string index
$ids 0] {
1343 set ids
[string range
$ids 1 end
]
1347 if {[string length
$id] != 40} {
1355 if {[string length
$shortcmit] > 80} {
1356 set shortcmit
"[string range $shortcmit 0 80]..."
1358 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1361 set id [lindex $ids 0]
1364 if {!$listed && $updating && ![info exists varcid($vid)] &&
1365 $vfilelimit($view) ne {}} {
1366 # git log doesn't rewrite parents
for unlisted commits
1367 # when doing path limiting, so work around that here
1368 # by working out the rewritten parent with git rev-list
1369 # and if we already know about it, using the rewritten
1370 # parent as a substitute parent for $id's children.
1372 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1373 $id -- $vfilelimit($view)]
1375 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1376 # use $rwid in place of $id
1377 rewrite_commit
$view $id $rwid
1384 if {[info exists varcid
($vid)]} {
1385 if {$cmitlisted($vid) ||
!$listed} continue
1389 set olds
[lrange
$ids 1 end
]
1393 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1394 set cmitlisted
($vid) $listed
1395 set parents
($vid) $olds
1396 if {![info exists children
($vid)]} {
1397 set children
($vid) {}
1398 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1399 set k
[lindex
$children($vid) 0]
1400 if {[llength
$parents($view,$k)] == 1 &&
1401 (!$vdatemode($view) ||
1402 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1403 set a
$varcid($view,$k)
1408 set a
[newvarc
$view $id]
1410 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1413 if {![info exists varcid
($vid)]} {
1415 lappend varccommits
($view,$a) $id
1416 incr commitidx
($view)
1421 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1423 if {[llength
[lappend children
($vp) $id]] > 1 &&
1424 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1425 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1427 catch
{unset ordertok
}
1429 if {[info exists varcid
($view,$p)]} {
1430 fix_reversal
$p $a $view
1436 if {[info exists commitinterest
($id)]} {
1437 foreach
script $commitinterest($id) {
1438 lappend scripts
[string map
[list
"%I" $id] $script]
1440 unset commitinterest
($id)
1445 global numcommits hlview
1447 if {$view == $curview} {
1448 set numcommits
$commitidx($view)
1451 if {[info exists hlview
] && $view == $hlview} {
1452 # we never actually get here...
1455 foreach s
$scripts {
1462 proc chewcommits
{} {
1463 global curview hlview viewcomplete
1464 global pending_select
1467 if {$viewcomplete($curview)} {
1468 global commitidx varctok
1469 global numcommits startmsecs
1470 global mainheadid nullid
1472 if {[info exists pending_select
]} {
1473 set row
[first_real_row
]
1476 if {$commitidx($curview) > 0} {
1477 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1478 #puts "overall $ms ms for $numcommits commits"
1479 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1481 show_status
[mc
"No commits selected"]
1488 proc readcommit
{id
} {
1489 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1490 parsecommit
$id $contents 0
1493 proc parsecommit
{id contents listed
} {
1494 global commitinfo cdate
1503 set hdrend
[string first
"\n\n" $contents]
1505 # should never happen...
1506 set hdrend
[string length
$contents]
1508 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1509 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1510 foreach line
[split $header "\n"] {
1511 set tag
[lindex
$line 0]
1512 if {$tag == "author"} {
1513 set audate
[lindex
$line end-1
]
1514 set auname
[lrange
$line 1 end-2
]
1515 } elseif
{$tag == "committer"} {
1516 set comdate
[lindex
$line end-1
]
1517 set comname
[lrange
$line 1 end-2
]
1521 # take the first non-blank line of the comment as the headline
1522 set headline
[string trimleft
$comment]
1523 set i
[string first
"\n" $headline]
1525 set headline
[string range
$headline 0 $i]
1527 set headline
[string trimright
$headline]
1528 set i
[string first
"\r" $headline]
1530 set headline
[string trimright
[string range
$headline 0 $i]]
1533 # git log indents the comment by 4 spaces;
1534 # if we got this via git cat-file, add the indentation
1536 foreach line
[split $comment "\n"] {
1537 append newcomment
" "
1538 append newcomment
$line
1539 append newcomment
"\n"
1541 set comment
$newcomment
1543 if {$comdate != {}} {
1544 set cdate
($id) $comdate
1546 set commitinfo
($id) [list
$headline $auname $audate \
1547 $comname $comdate $comment]
1550 proc getcommit
{id
} {
1551 global commitdata commitinfo
1553 if {[info exists commitdata
($id)]} {
1554 parsecommit
$id $commitdata($id) 1
1557 if {![info exists commitinfo
($id)]} {
1558 set commitinfo
($id) [list
[mc
"No commit information available"]]
1565 global tagids idtags headids idheads tagobjid
1566 global otherrefids idotherrefs mainhead mainheadid
1568 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1571 set refd
[open
[list | git show-ref
-d] r
]
1572 while {[gets
$refd line
] >= 0} {
1573 if {[string index
$line 40] ne
" "} continue
1574 set id
[string range
$line 0 39]
1575 set ref
[string range
$line 41 end
]
1576 if {![string match
"refs/*" $ref]} continue
1577 set name
[string range
$ref 5 end
]
1578 if {[string match
"remotes/*" $name]} {
1579 if {![string match
"*/HEAD" $name]} {
1580 set headids
($name) $id
1581 lappend idheads
($id) $name
1583 } elseif
{[string match
"heads/*" $name]} {
1584 set name
[string range
$name 6 end
]
1585 set headids
($name) $id
1586 lappend idheads
($id) $name
1587 } elseif
{[string match
"tags/*" $name]} {
1588 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1589 # which is what we want since the former is the commit ID
1590 set name
[string range
$name 5 end
]
1591 if {[string match
"*^{}" $name]} {
1592 set name
[string range
$name 0 end-3
]
1594 set tagobjid
($name) $id
1596 set tagids
($name) $id
1597 lappend idtags
($id) $name
1599 set otherrefids
($name) $id
1600 lappend idotherrefs
($id) $name
1607 set thehead
[exec git symbolic-ref HEAD
]
1608 if {[string match
"refs/heads/*" $thehead]} {
1609 set mainhead
[string range
$thehead 11 end
]
1610 if {[info exists headids
($mainhead)]} {
1611 set mainheadid
$headids($mainhead)
1617 # skip over fake commits
1618 proc first_real_row
{} {
1619 global nullid nullid2 numcommits
1621 for {set row
0} {$row < $numcommits} {incr row
} {
1622 set id
[commitonrow
$row]
1623 if {$id ne
$nullid && $id ne
$nullid2} {
1630 # update things for a head moved to a child of its previous location
1631 proc movehead
{id name
} {
1632 global headids idheads
1634 removehead
$headids($name) $name
1635 set headids
($name) $id
1636 lappend idheads
($id) $name
1639 # update things when a head has been removed
1640 proc removehead
{id name
} {
1641 global headids idheads
1643 if {$idheads($id) eq
$name} {
1646 set i
[lsearch
-exact $idheads($id) $name]
1648 set idheads
($id) [lreplace
$idheads($id) $i $i]
1651 unset headids
($name)
1654 proc show_error
{w top msg
} {
1655 message
$w.m
-text $msg -justify center
-aspect 400
1656 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1657 button
$w.ok
-text [mc OK
] -command "destroy $top"
1658 pack
$w.ok
-side bottom
-fill x
1659 bind $top <Visibility
> "grab $top; focus $top"
1660 bind $top <Key-Return
> "destroy $top"
1664 proc error_popup msg
{
1668 show_error
$w $w $msg
1671 proc confirm_popup msg
{
1677 message
$w.m
-text $msg -justify center
-aspect 400
1678 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1679 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1680 pack
$w.ok
-side left
-fill x
1681 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1682 pack
$w.cancel
-side right
-fill x
1683 bind $w <Visibility
> "grab $w; focus $w"
1688 proc setoptions
{} {
1689 option add
*Panedwindow.showHandle
1 startupFile
1690 option add
*Panedwindow.sashRelief raised startupFile
1691 option add
*Button.font uifont startupFile
1692 option add
*Checkbutton.font uifont startupFile
1693 option add
*Radiobutton.font uifont startupFile
1694 option add
*Menu.font uifont startupFile
1695 option add
*Menubutton.font uifont startupFile
1696 option add
*Label.font uifont startupFile
1697 option add
*Message.font uifont startupFile
1698 option add
*Entry.font uifont startupFile
1701 proc makewindow
{} {
1702 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1704 global findtype findtypemenu findloc findstring fstring geometry
1705 global entries sha1entry sha1string sha1but
1706 global diffcontextstring diffcontext
1708 global maincursor textcursor curtextcursor
1709 global rowctxmenu fakerowmenu mergemax wrapcomment
1710 global highlight_files gdttype
1711 global searchstring sstring
1712 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1713 global headctxmenu progresscanv progressitem progresscoords statusw
1714 global fprogitem fprogcoord lastprogupdate progupdatepending
1715 global rprogitem rprogcoord rownumsel numcommits
1719 .bar add cascade
-label [mc
"File"] -menu .bar.
file
1721 .bar.
file add
command -label [mc
"Update"] -command updatecommits
1722 .bar.
file add
command -label [mc
"Reload"] -command reloadcommits
1723 .bar.
file add
command -label [mc
"Reread references"] -command rereadrefs
1724 .bar.
file add
command -label [mc
"List references"] -command showrefs
1725 .bar.
file add
command -label [mc
"Quit"] -command doquit
1727 .bar add cascade
-label [mc
"Edit"] -menu .bar.edit
1728 .bar.edit add
command -label [mc
"Preferences"] -command doprefs
1731 .bar add cascade
-label [mc
"View"] -menu .bar.view
1732 .bar.view add
command -label [mc
"New view..."] -command {newview
0}
1733 .bar.view add
command -label [mc
"Edit view..."] -command editview \
1735 .bar.view add
command -label [mc
"Delete view"] -command delview
-state disabled
1736 .bar.view add separator
1737 .bar.view add radiobutton
-label [mc
"All files"] -command {showview
0} \
1738 -variable selectedview
-value 0
1741 .bar add cascade
-label [mc
"Help"] -menu .bar.
help
1742 .bar.
help add
command -label [mc
"About gitk"] -command about
1743 .bar.
help add
command -label [mc
"Key bindings"] -command keys
1745 . configure
-menu .bar
1747 # the gui has upper and lower half, parts of a paned window.
1748 panedwindow .ctop
-orient vertical
1750 # possibly use assumed geometry
1751 if {![info exists geometry
(pwsash0
)]} {
1752 set geometry
(topheight
) [expr {15 * $linespc}]
1753 set geometry
(topwidth
) [expr {80 * $charspc}]
1754 set geometry
(botheight
) [expr {15 * $linespc}]
1755 set geometry
(botwidth
) [expr {50 * $charspc}]
1756 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1757 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1760 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1761 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1763 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1765 # create three canvases
1766 set cscroll .tf.histframe.csb
1767 set canv .tf.histframe.pwclist.canv
1769 -selectbackground $selectbgcolor \
1770 -background $bgcolor -bd 0 \
1771 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1772 .tf.histframe.pwclist add
$canv
1773 set canv2 .tf.histframe.pwclist.canv2
1775 -selectbackground $selectbgcolor \
1776 -background $bgcolor -bd 0 -yscrollincr $linespc
1777 .tf.histframe.pwclist add
$canv2
1778 set canv3 .tf.histframe.pwclist.canv3
1780 -selectbackground $selectbgcolor \
1781 -background $bgcolor -bd 0 -yscrollincr $linespc
1782 .tf.histframe.pwclist add
$canv3
1783 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1784 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1786 # a scroll bar to rule them
1787 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1788 pack
$cscroll -side right
-fill y
1789 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1790 lappend bglist
$canv $canv2 $canv3
1791 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1793 # we have two button bars at bottom of top frame. Bar 1
1795 frame .tf.lbar
-height 15
1797 set sha1entry .tf.bar.sha1
1798 set entries
$sha1entry
1799 set sha1but .tf.bar.sha1label
1800 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
1801 -command gotocommit
-width 8
1802 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1803 pack .tf.bar.sha1label
-side left
1804 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1805 trace add variable sha1string
write sha1change
1806 pack
$sha1entry -side left
-pady 2
1808 image create bitmap bm-left
-data {
1809 #define left_width 16
1810 #define left_height 16
1811 static unsigned char left_bits
[] = {
1812 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1813 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1814 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1816 image create bitmap bm-right
-data {
1817 #define right_width 16
1818 #define right_height 16
1819 static unsigned char right_bits
[] = {
1820 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1821 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1822 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1824 button .tf.bar.leftbut
-image bm-left
-command goback \
1825 -state disabled
-width 26
1826 pack .tf.bar.leftbut
-side left
-fill y
1827 button .tf.bar.rightbut
-image bm-right
-command goforw \
1828 -state disabled
-width 26
1829 pack .tf.bar.rightbut
-side left
-fill y
1831 label .tf.bar.rowlabel
-text [mc
"Row"]
1833 label .tf.bar.rownum
-width 7 -font textfont
-textvariable rownumsel \
1834 -relief sunken
-anchor e
1835 label .tf.bar.rowlabel2
-text "/"
1836 label .tf.bar.numcommits
-width 7 -font textfont
-textvariable numcommits \
1837 -relief sunken
-anchor e
1838 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1841 trace add variable selectedline
{write unset} selectedline_change
1843 # Status label and progress bar
1844 set statusw .tf.bar.status
1845 label
$statusw -width 15 -relief sunken
1846 pack
$statusw -side left
-padx 5
1847 set h
[expr {[font metrics uifont
-linespace] + 2}]
1848 set progresscanv .tf.bar.progress
1849 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1850 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1851 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1852 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1853 pack
$progresscanv -side right
-expand 1 -fill x
1854 set progresscoords
{0 0}
1857 bind $progresscanv <Configure
> adjustprogress
1858 set lastprogupdate
[clock clicks
-milliseconds]
1859 set progupdatepending
0
1861 # build up the bottom bar of upper window
1862 label .tf.lbar.flabel
-text "[mc "Find
"] "
1863 button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
1864 button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
1865 label .tf.lbar.flab2
-text " [mc "commit
"] "
1866 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1868 set gdttype
[mc
"containing:"]
1869 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1870 [mc
"containing:"] \
1871 [mc
"touching paths:"] \
1872 [mc
"adding/removing string:"]]
1873 trace add variable gdttype
write gdttype_change
1874 pack .tf.lbar.gdttype
-side left
-fill y
1877 set fstring .tf.lbar.findstring
1878 lappend entries
$fstring
1879 entry
$fstring -width 30 -font textfont
-textvariable findstring
1880 trace add variable findstring
write find_change
1881 set findtype
[mc
"Exact"]
1882 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1883 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
1884 trace add variable findtype
write findcom_change
1885 set findloc
[mc
"All fields"]
1886 tk_optionMenu .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
1887 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
1888 trace add variable findloc
write find_change
1889 pack .tf.lbar.findloc
-side right
1890 pack .tf.lbar.findtype
-side right
1891 pack
$fstring -side left
-expand 1 -fill x
1893 # Finish putting the upper half of the viewer together
1894 pack .tf.lbar
-in .tf
-side bottom
-fill x
1895 pack .tf.bar
-in .tf
-side bottom
-fill x
1896 pack .tf.histframe
-fill both
-side top
-expand 1
1898 .ctop paneconfigure .tf
-height $geometry(topheight
)
1899 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1901 # now build up the bottom
1902 panedwindow .pwbottom
-orient horizontal
1904 # lower left, a text box over search bar, scroll bar to the right
1905 # if we know window height, then that will set the lower text height, otherwise
1906 # we set lower text height which will drive window height
1907 if {[info exists geometry
(main
)]} {
1908 frame .bleft
-width $geometry(botwidth
)
1910 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
1916 button .bleft.top.search
-text [mc
"Search"] -command dosearch
1917 pack .bleft.top.search
-side left
-padx 5
1918 set sstring .bleft.top.sstring
1919 entry
$sstring -width 20 -font textfont
-textvariable searchstring
1920 lappend entries
$sstring
1921 trace add variable searchstring
write incrsearch
1922 pack
$sstring -side left
-expand 1 -fill x
1923 radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
1924 -command changediffdisp
-variable diffelide
-value {0 0}
1925 radiobutton .bleft.mid.old
-text [mc
"Old version"] \
1926 -command changediffdisp
-variable diffelide
-value {0 1}
1927 radiobutton .bleft.mid.new
-text [mc
"New version"] \
1928 -command changediffdisp
-variable diffelide
-value {1 0}
1929 label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
1930 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
1931 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
1932 -from 1 -increment 1 -to 10000000 \
1933 -validate all
-validatecommand "diffcontextvalidate %P" \
1934 -textvariable diffcontextstring
1935 .bleft.mid.diffcontext
set $diffcontext
1936 trace add variable diffcontextstring
write diffcontextchange
1937 lappend entries .bleft.mid.diffcontext
1938 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
1939 checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
1940 -command changeignorespace
-variable ignorespace
1941 pack .bleft.mid.ignspace
-side left
-padx 5
1942 set ctext .bleft.bottom.ctext
1943 text
$ctext -background $bgcolor -foreground $fgcolor \
1944 -state disabled
-font textfont \
1945 -yscrollcommand scrolltext
-wrap none \
1946 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1948 $ctext conf
-tabstyle wordprocessor
1950 scrollbar .bleft.bottom.sb
-command "$ctext yview"
1951 scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h \
1953 pack .bleft.top
-side top
-fill x
1954 pack .bleft.mid
-side top
-fill x
1955 grid
$ctext .bleft.bottom.sb
-sticky nsew
1956 grid .bleft.bottom.sbhorizontal
-sticky ew
1957 grid columnconfigure .bleft.bottom
0 -weight 1
1958 grid rowconfigure .bleft.bottom
0 -weight 1
1959 grid rowconfigure .bleft.bottom
1 -weight 0
1960 pack .bleft.bottom
-side top
-fill both
-expand 1
1961 lappend bglist
$ctext
1962 lappend fglist
$ctext
1964 $ctext tag conf comment
-wrap $wrapcomment
1965 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
1966 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
1967 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
1968 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
1969 $ctext tag conf m0
-fore red
1970 $ctext tag conf m1
-fore blue
1971 $ctext tag conf m2
-fore green
1972 $ctext tag conf m3
-fore purple
1973 $ctext tag conf
m4 -fore brown
1974 $ctext tag conf m5
-fore "#009090"
1975 $ctext tag conf m6
-fore magenta
1976 $ctext tag conf m7
-fore "#808000"
1977 $ctext tag conf m8
-fore "#009000"
1978 $ctext tag conf m9
-fore "#ff0080"
1979 $ctext tag conf m10
-fore cyan
1980 $ctext tag conf m11
-fore "#b07070"
1981 $ctext tag conf m12
-fore "#70b0f0"
1982 $ctext tag conf m13
-fore "#70f0b0"
1983 $ctext tag conf m14
-fore "#f0b070"
1984 $ctext tag conf m15
-fore "#ff70b0"
1985 $ctext tag conf mmax
-fore darkgrey
1987 $ctext tag conf mresult
-font textfontbold
1988 $ctext tag conf msep
-font textfontbold
1989 $ctext tag conf found
-back yellow
1991 .pwbottom add .bleft
1992 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
1997 radiobutton .bright.mode.
patch -text [mc
"Patch"] \
1998 -command reselectline
-variable cmitmode
-value "patch"
1999 radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2000 -command reselectline
-variable cmitmode
-value "tree"
2001 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2002 pack .bright.mode
-side top
-fill x
2003 set cflist .bright.cfiles
2004 set indent
[font measure mainfont
"nn"]
2006 -selectbackground $selectbgcolor \
2007 -background $bgcolor -foreground $fgcolor \
2009 -tabs [list
$indent [expr {2 * $indent}]] \
2010 -yscrollcommand ".bright.sb set" \
2011 -cursor [. cget
-cursor] \
2012 -spacing1 1 -spacing3 1
2013 lappend bglist
$cflist
2014 lappend fglist
$cflist
2015 scrollbar .bright.sb
-command "$cflist yview"
2016 pack .bright.sb
-side right
-fill y
2017 pack
$cflist -side left
-fill both
-expand 1
2018 $cflist tag configure highlight \
2019 -background [$cflist cget
-selectbackground]
2020 $cflist tag configure bold
-font mainfontbold
2022 .pwbottom add .bright
2025 # restore window width & height if known
2026 if {[info exists geometry
(main
)]} {
2027 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2028 if {$w > [winfo screenwidth .
]} {
2029 set w
[winfo screenwidth .
]
2031 if {$h > [winfo screenheight .
]} {
2032 set h
[winfo screenheight .
]
2034 wm geometry .
"${w}x$h"
2038 if {[tk windowingsystem
] eq
{aqua
}} {
2044 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2045 pack .ctop
-fill both
-expand 1
2046 bindall
<1> {selcanvline
%W
%x
%y
}
2047 #bindall <B1-Motion> {selcanvline %W %x %y}
2048 if {[tk windowingsystem
] == "win32"} {
2049 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2050 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2052 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2053 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2054 if {[tk windowingsystem
] eq
"aqua"} {
2055 bindall
<MouseWheel
> {
2056 set delta
[expr {- (%D
)}]
2057 allcanvs yview scroll
$delta units
2061 bindall
<2> "canvscan mark %W %x %y"
2062 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
2063 bindkey
<Home
> selfirstline
2064 bindkey
<End
> sellastline
2065 bind .
<Key-Up
> "selnextline -1"
2066 bind .
<Key-Down
> "selnextline 1"
2067 bind .
<Shift-Key-Up
> "dofind -1 0"
2068 bind .
<Shift-Key-Down
> "dofind 1 0"
2069 bindkey
<Key-Right
> "goforw"
2070 bindkey
<Key-Left
> "goback"
2071 bind .
<Key-Prior
> "selnextpage -1"
2072 bind .
<Key-Next
> "selnextpage 1"
2073 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2074 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2075 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2076 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2077 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2078 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2079 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2080 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2081 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2082 bindkey p
"selnextline -1"
2083 bindkey n
"selnextline 1"
2086 bindkey i
"selnextline -1"
2087 bindkey k
"selnextline 1"
2091 bindkey d
"$ctext yview scroll 18 units"
2092 bindkey u
"$ctext yview scroll -18 units"
2093 bindkey
/ {dofind
1 1}
2094 bindkey
<Key-Return
> {dofind
1 1}
2095 bindkey ?
{dofind
-1 1}
2097 bindkey
<F5
> updatecommits
2098 bind .
<$M1B-q> doquit
2099 bind .
<$M1B-f> {dofind
1 1}
2100 bind .
<$M1B-g> {dofind
1 0}
2101 bind .
<$M1B-r> dosearchback
2102 bind .
<$M1B-s> dosearch
2103 bind .
<$M1B-equal> {incrfont
1}
2104 bind .
<$M1B-plus> {incrfont
1}
2105 bind .
<$M1B-KP_Add> {incrfont
1}
2106 bind .
<$M1B-minus> {incrfont
-1}
2107 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2108 wm protocol . WM_DELETE_WINDOW doquit
2109 bind .
<Button-1
> "click %W"
2110 bind $fstring <Key-Return
> {dofind
1 1}
2111 bind $sha1entry <Key-Return
> gotocommit
2112 bind $sha1entry <<PasteSelection>> clearsha1
2113 bind $cflist <1> {sel_flist %W %x %y; break}
2114 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2115 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2116 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
2118 set maincursor [. cget -cursor]
2119 set textcursor [$ctext cget -cursor]
2120 set curtextcursor $textcursor
2122 set rowctxmenu .rowctxmenu
2123 menu $rowctxmenu -tearoff 0
2124 $rowctxmenu add command -label [mc "Diff this -> selected"] \
2125 -command {diffvssel 0}
2126 $rowctxmenu add command -label [mc "Diff selected -> this"] \
2127 -command {diffvssel 1}
2128 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2129 $rowctxmenu add command -label [mc "Create tag"] -command mktag
2130 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2131 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2132 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2134 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2137 set fakerowmenu .fakerowmenu
2138 menu $fakerowmenu -tearoff 0
2139 $fakerowmenu add command -label [mc "Diff this -> selected"] \
2140 -command {diffvssel 0}
2141 $fakerowmenu add command -label [mc "Diff selected -> this"] \
2142 -command {diffvssel 1}
2143 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2144 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2145 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2146 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2148 set headctxmenu .headctxmenu
2149 menu $headctxmenu -tearoff 0
2150 $headctxmenu add command -label [mc "Check out this branch"] \
2152 $headctxmenu add command -label [mc "Remove this branch"] \
2156 set flist_menu .flistctxmenu
2157 menu $flist_menu -tearoff 0
2158 $flist_menu add command -label [mc "Highlight this too"] \
2159 -command {flist_hl 0}
2160 $flist_menu add command -label [mc "Highlight this only"] \
2161 -command {flist_hl 1}
2162 $flist_menu add command -label [mc "External diff"] \
2163 -command {external_diff}
2166 # Windows sends all mouse wheel events to the current focused window, not
2167 # the one where the mouse hovers, so bind those events here and redirect
2168 # to the correct window
2169 proc windows_mousewheel_redirector {W X Y D} {
2170 global canv canv2 canv3
2171 set w [winfo containing -displayof $W $X $Y]
2173 set u [expr {$D < 0 ? 5 : -5}]
2174 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2175 allcanvs yview scroll $u units
2178 $w yview scroll $u units
2184 # Update row number label when selectedline changes
2185 proc selectedline_change {n1 n2 op} {
2186 global selectedline rownumsel
2188 if {$op eq "unset"} {
2191 set rownumsel [expr {$selectedline + 1}]
2195 # mouse-2 makes all windows scan vertically, but only the one
2196 # the cursor is in scans horizontally
2197 proc canvscan {op w x y} {
2198 global canv canv2 canv3
2199 foreach c [list $canv $canv2 $canv3] {
2208 proc scrollcanv {cscroll f0 f1} {
2209 $cscroll set $f0 $f1
2214 # when we make a key binding for the toplevel, make sure
2215 # it doesn't get triggered when that key is pressed in the
2216 # find string entry widget.
2217 proc bindkey {ev script} {
2220 set escript [bind Entry $ev]
2221 if {$escript == {}} {
2222 set escript [bind Entry <Key>]
2224 foreach e $entries {
2225 bind $e $ev "$escript; break"
2229 # set the focus back to the toplevel for any click outside
2232 global ctext entries
2233 foreach e [concat $entries $ctext] {
2234 if {$w == $e} return
2239 # Adjust the progress bar for a change in requested extent or canvas size
2240 proc adjustprogress {} {
2241 global progresscanv progressitem progresscoords
2242 global fprogitem fprogcoord lastprogupdate progupdatepending
2243 global rprogitem rprogcoord
2245 set w [expr {[winfo width $progresscanv] - 4}]
2246 set x0 [expr {$w * [lindex $progresscoords 0]}]
2247 set x1 [expr {$w * [lindex $progresscoords 1]}]
2248 set h [winfo height $progresscanv]
2249 $progresscanv coords $progressitem $x0 0 $x1 $h
2250 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2251 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2252 set now [clock clicks -milliseconds]
2253 if {$now >= $lastprogupdate + 100} {
2254 set progupdatepending 0
2256 } elseif {!$progupdatepending} {
2257 set progupdatepending 1
2258 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2262 proc doprogupdate {} {
2263 global lastprogupdate progupdatepending
2265 if {$progupdatepending} {
2266 set progupdatepending 0
2267 set lastprogupdate [clock clicks -milliseconds]
2272 proc savestuff {w} {
2273 global canv canv2 canv3 mainfont textfont uifont tabstop
2274 global stuffsaved findmergefiles maxgraphpct
2275 global maxwidth showneartags showlocalchanges
2276 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2277 global cmitmode wrapcomment datetimeformat limitdiffs
2278 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2279 global autoselect extdifftool
2281 if {$stuffsaved} return
2282 if {![winfo viewable .]} return
2284 set f [open "~/.gitk-new" w]
2285 puts $f [list set mainfont $mainfont]
2286 puts $f [list set textfont $textfont]
2287 puts $f [list set uifont $uifont]
2288 puts $f [list set tabstop $tabstop]
2289 puts $f [list set findmergefiles $findmergefiles]
2290 puts $f [list set maxgraphpct $maxgraphpct]
2291 puts $f [list set maxwidth $maxwidth]
2292 puts $f [list set cmitmode $cmitmode]
2293 puts $f [list set wrapcomment $wrapcomment]
2294 puts $f [list set autoselect $autoselect]
2295 puts $f [list set showneartags $showneartags]
2296 puts $f [list set showlocalchanges $showlocalchanges]
2297 puts $f [list set datetimeformat $datetimeformat]
2298 puts $f [list set limitdiffs $limitdiffs]
2299 puts $f [list set bgcolor $bgcolor]
2300 puts $f [list set fgcolor $fgcolor]
2301 puts $f [list set colors $colors]
2302 puts $f [list set diffcolors $diffcolors]
2303 puts $f [list set diffcontext $diffcontext]
2304 puts $f [list set selectbgcolor $selectbgcolor]
2305 puts $f [list set extdifftool $extdifftool]
2307 puts $f "set geometry(main) [wm geometry .]"
2308 puts $f "set geometry(topwidth) [winfo width .tf]"
2309 puts $f "set geometry(topheight) [winfo height .tf]"
2310 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2311 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2312 puts $f "set geometry(botwidth) [winfo width .bleft]"
2313 puts $f "set geometry(botheight) [winfo height .bleft]"
2315 puts -nonewline $f "set permviews {"
2316 for {set v 0} {$v < $nextviewnum} {incr v} {
2317 if {$viewperm($v)} {
2318 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2323 file rename -force "~/.gitk-new" "~/.gitk"
2328 proc resizeclistpanes {win w} {
2330 if {[info exists oldwidth($win)]} {
2331 set s0 [$win sash coord 0]
2332 set s1 [$win sash coord 1]
2334 set sash0 [expr {int($w/2 - 2)}]
2335 set sash1 [expr {int($w*5/6 - 2)}]
2337 set factor [expr {1.0 * $w / $oldwidth($win)}]
2338 set sash0 [expr {int($factor * [lindex $s0 0])}]
2339 set sash1 [expr {int($factor * [lindex $s1 0])}]
2343 if {$sash1 < $sash0 + 20} {
2344 set sash1 [expr {$sash0 + 20}]
2346 if {$sash1 > $w - 10} {
2347 set sash1 [expr {$w - 10}]
2348 if {$sash0 > $sash1 - 20} {
2349 set sash0 [expr {$sash1 - 20}]
2353 $win sash place 0 $sash0 [lindex $s0 1]
2354 $win sash place 1 $sash1 [lindex $s1 1]
2356 set oldwidth($win) $w
2359 proc resizecdetpanes {win w} {
2361 if {[info exists oldwidth($win)]} {
2362 set s0 [$win sash coord 0]
2364 set sash0 [expr {int($w*3/4 - 2)}]
2366 set factor [expr {1.0 * $w / $oldwidth($win)}]
2367 set sash0 [expr {int($factor * [lindex $s0 0])}]
2371 if {$sash0 > $w - 15} {
2372 set sash0 [expr {$w - 15}]
2375 $win sash place 0 $sash0 [lindex $s0 1]
2377 set oldwidth($win) $w
2380 proc allcanvs args {
2381 global canv canv2 canv3
2387 proc bindall {event action} {
2388 global canv canv2 canv3
2389 bind $canv $event $action
2390 bind $canv2 $event $action
2391 bind $canv3 $event $action
2397 if {[winfo exists $w]} {
2402 wm title $w [mc "About gitk"]
2403 message $w.m -text [mc "
2404 Gitk - a commit viewer for git
2406 Copyright © 2005-2008 Paul Mackerras
2408 Use and redistribute under the terms of the GNU General Public License"] \
2409 -justify center -aspect 400 -border 2 -bg white -relief groove
2410 pack $w.m -side top -fill x -padx 2 -pady 2
2411 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2412 pack $w.ok -side bottom
2413 bind $w <Visibility> "focus $w.ok"
2414 bind $w <Key-Escape> "destroy $w"
2415 bind $w <Key-Return> "destroy $w"
2420 if {[winfo exists $w]} {
2424 if {[tk windowingsystem] eq {aqua}} {
2430 wm title $w [mc "Gitk key bindings"]
2431 message $w.m -text "
2432 [mc "Gitk key bindings:"]
2434 [mc "<%s-Q> Quit" $M1T]
2435 [mc "<Home> Move to first commit"]
2436 [mc "<End> Move to last commit"]
2437 [mc "<Up>, p, i Move up one commit"]
2438 [mc "<Down>, n, k Move down one commit"]
2439 [mc "<Left>, z, j Go back in history list"]
2440 [mc "<Right>, x, l Go forward in history list"]
2441 [mc "<PageUp> Move up one page in commit list"]
2442 [mc "<PageDown> Move down one page in commit list"]
2443 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2444 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2445 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2446 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2447 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2448 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2449 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2450 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2451 [mc "<Delete>, b Scroll diff view up one page"]
2452 [mc "<Backspace> Scroll diff view up one page"]
2453 [mc "<Space> Scroll diff view down one page"]
2454 [mc "u Scroll diff view up 18 lines"]
2455 [mc "d Scroll diff view down 18 lines"]
2456 [mc "<%s-F> Find" $M1T]
2457 [mc "<%s-G> Move to next find hit" $M1T]
2458 [mc "<Return> Move to next find hit"]
2459 [mc "/ Move to next find hit, or redo find"]
2460 [mc "? Move to previous find hit"]
2461 [mc "f Scroll diff view to next file"]
2462 [mc "<%s-S> Search for next hit in diff view" $M1T]
2463 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2464 [mc "<%s-KP+> Increase font size" $M1T]
2465 [mc "<%s-plus> Increase font size" $M1T]
2466 [mc "<%s-KP-> Decrease font size" $M1T]
2467 [mc "<%s-minus> Decrease font size" $M1T]
2470 -justify left -bg white -border 2 -relief groove
2471 pack $w.m -side top -fill both -padx 2 -pady 2
2472 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2473 pack $w.ok -side bottom
2474 bind $w <Visibility> "focus $w.ok"
2475 bind $w <Key-Escape> "destroy $w"
2476 bind $w <Key-Return> "destroy $w"
2479 # Procedures for manipulating the file list window at the
2480 # bottom right of the overall window.
2482 proc treeview {w l openlevs} {
2483 global treecontents treediropen treeheight treeparent treeindex
2493 set treecontents() {}
2494 $w conf -state normal
2496 while {[string range $f 0 $prefixend] ne $prefix} {
2497 if {$lev <= $openlevs} {
2498 $w mark set e:$treeindex($prefix) "end -1c"
2499 $w mark gravity e:$treeindex($prefix) left
2501 set treeheight($prefix) $ht
2502 incr ht [lindex $htstack end]
2503 set htstack [lreplace $htstack end end]
2504 set prefixend [lindex $prefendstack end]
2505 set prefendstack [lreplace $prefendstack end end]
2506 set prefix [string range $prefix 0 $prefixend]
2509 set tail [string range $f [expr {$prefixend+1}] end]
2510 while {[set slash [string first "/" $tail]] >= 0} {
2513 lappend prefendstack $prefixend
2514 incr prefixend [expr {$slash + 1}]
2515 set d [string range $tail 0 $slash]
2516 lappend treecontents($prefix) $d
2517 set oldprefix $prefix
2519 set treecontents($prefix) {}
2520 set treeindex($prefix) [incr ix]
2521 set treeparent($prefix) $oldprefix
2522 set tail [string range $tail [expr {$slash+1}] end]
2523 if {$lev <= $openlevs} {
2525 set treediropen($prefix) [expr {$lev < $openlevs}]
2526 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2527 $w mark set d:$ix "end -1c"
2528 $w mark gravity d:$ix left
2530 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2532 $w image create end -align center -image $bm -padx 1 \
2534 $w insert end $d [highlight_tag $prefix]
2535 $w mark set s:$ix "end -1c"
2536 $w mark gravity s:$ix left
2541 if {$lev <= $openlevs} {
2544 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2546 $w insert end $tail [highlight_tag $f]
2548 lappend treecontents($prefix) $tail
2551 while {$htstack ne {}} {
2552 set treeheight($prefix) $ht
2553 incr ht [lindex $htstack end]
2554 set htstack [lreplace $htstack end end]
2555 set prefixend [lindex $prefendstack end]
2556 set prefendstack [lreplace $prefendstack end end]
2557 set prefix [string range $prefix 0 $prefixend]
2559 $w conf -state disabled
2562 proc linetoelt {l} {
2563 global treeheight treecontents
2568 foreach e $treecontents($prefix) {
2573 if {[string index $e end] eq "/"} {
2574 set n $treeheight($prefix$e)
2586 proc highlight_tree {y prefix} {
2587 global treeheight treecontents cflist
2589 foreach e $treecontents($prefix) {
2591 if {[highlight_tag $path] ne {}} {
2592 $cflist tag add bold $y.0 "$y.0 lineend"
2595 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2596 set y [highlight_tree $y $path]
2602 proc treeclosedir {w dir} {
2603 global treediropen treeheight treeparent treeindex
2605 set ix $treeindex($dir)
2606 $w conf -state normal
2607 $w delete s:$ix e:$ix
2608 set treediropen($dir) 0
2609 $w image configure a:$ix -image tri-rt
2610 $w conf -state disabled
2611 set n [expr {1 - $treeheight($dir)}]
2612 while {$dir ne {}} {
2613 incr treeheight($dir) $n
2614 set dir $treeparent($dir)
2618 proc treeopendir {w dir} {
2619 global treediropen treeheight treeparent treecontents treeindex
2621 set ix $treeindex($dir)
2622 $w conf -state normal
2623 $w image configure a:$ix -image tri-dn
2624 $w mark set e:$ix s:$ix
2625 $w mark gravity e:$ix right
2628 set n [llength $treecontents($dir)]
2629 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2632 incr treeheight($x) $n
2634 foreach e $treecontents($dir) {
2636 if {[string index $e end] eq "/"} {
2637 set iy $treeindex($de)
2638 $w mark set d:$iy e:$ix
2639 $w mark gravity d:$iy left
2640 $w insert e:$ix $str
2641 set treediropen($de) 0
2642 $w image create e:$ix -align center -image tri-rt -padx 1 \
2644 $w insert e:$ix $e [highlight_tag $de]
2645 $w mark set s:$iy e:$ix
2646 $w mark gravity s:$iy left
2647 set treeheight($de) 1
2649 $w insert e:$ix $str
2650 $w insert e:$ix $e [highlight_tag $de]
2653 $w mark gravity e:$ix left
2654 $w conf -state disabled
2655 set treediropen($dir) 1
2656 set top [lindex [split [$w index @0,0] .] 0]
2657 set ht [$w cget -height]
2658 set l [lindex [split [$w index s:$ix] .] 0]
2661 } elseif {$l + $n + 1 > $top + $ht} {
2662 set top [expr {$l + $n + 2 - $ht}]
2670 proc treeclick {w x y} {
2671 global treediropen cmitmode ctext cflist cflist_top
2673 if {$cmitmode ne "tree"} return
2674 if {![info exists cflist_top]} return
2675 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2676 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2677 $cflist tag add highlight $l.0 "$l.0 lineend"
2683 set e [linetoelt $l]
2684 if {[string index $e end] ne "/"} {
2686 } elseif {$treediropen($e)} {
2693 proc setfilelist {id} {
2694 global treefilelist cflist
2696 treeview $cflist $treefilelist($id) 0
2699 image create bitmap tri-rt -background black -foreground blue -data {
2700 #define tri-rt_width 13
2701 #define tri-rt_height 13
2702 static unsigned char tri-rt_bits[] = {
2703 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2704 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2707 #define tri-rt-mask_width 13
2708 #define tri-rt-mask_height 13
2709 static unsigned char tri-rt-mask_bits[] = {
2710 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2711 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2714 image create bitmap tri-dn -background black -foreground blue -data {
2715 #define tri-dn_width 13
2716 #define tri-dn_height 13
2717 static unsigned char tri-dn_bits[] = {
2718 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2719 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2722 #define tri-dn-mask_width 13
2723 #define tri-dn-mask_height 13
2724 static unsigned char tri-dn-mask_bits[] = {
2725 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2726 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2730 image create bitmap reficon-T -background black -foreground yellow -data {
2731 #define tagicon_width 13
2732 #define tagicon_height 9
2733 static unsigned char tagicon_bits[] = {
2734 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2735 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2737 #define tagicon-mask_width 13
2738 #define tagicon-mask_height 9
2739 static unsigned char tagicon-mask_bits[] = {
2740 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2741 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2744 #define headicon_width 13
2745 #define headicon_height 9
2746 static unsigned char headicon_bits[] = {
2747 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2748 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2751 #define headicon-mask_width 13
2752 #define headicon-mask_height 9
2753 static unsigned char headicon-mask_bits[] = {
2754 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2755 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2757 image create bitmap reficon-H -background black -foreground green \
2758 -data $rectdata -maskdata $rectmask
2759 image create bitmap reficon-o -background black -foreground "#ddddff" \
2760 -data $rectdata -maskdata $rectmask
2762 proc init_flist {first} {
2763 global cflist cflist_top difffilestart
2765 $cflist conf -state normal
2766 $cflist delete 0.0 end
2768 $cflist insert end $first
2770 $cflist tag add highlight 1.0 "1.0 lineend"
2772 catch {unset cflist_top}
2774 $cflist conf -state disabled
2775 set difffilestart {}
2778 proc highlight_tag {f} {
2779 global highlight_paths
2781 foreach p $highlight_paths {
2782 if {[string match $p $f]} {
2789 proc highlight_filelist {} {
2790 global cmitmode cflist
2792 $cflist conf -state normal
2793 if {$cmitmode ne "tree"} {
2794 set end [lindex [split [$cflist index end] .] 0]
2795 for {set l 2} {$l < $end} {incr l} {
2796 set line [$cflist get $l.0 "$l.0 lineend"]
2797 if {[highlight_tag $line] ne {}} {
2798 $cflist tag add bold $l.0 "$l.0 lineend"
2804 $cflist conf -state disabled
2807 proc unhighlight_filelist {} {
2810 $cflist conf -state normal
2811 $cflist tag remove bold 1.0 end
2812 $cflist conf -state disabled
2815 proc add_flist {fl} {
2818 $cflist conf -state normal
2820 $cflist insert end "\n"
2821 $cflist insert end $f [highlight_tag $f]
2823 $cflist conf -state disabled
2826 proc sel_flist {w x y} {
2827 global ctext difffilestart cflist cflist_top cmitmode
2829 if {$cmitmode eq "tree"} return
2830 if {![info exists cflist_top]} return
2831 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2832 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2833 $cflist tag add highlight $l.0 "$l.0 lineend"
2838 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2842 proc pop_flist_menu {w X Y x y} {
2843 global ctext cflist cmitmode flist_menu flist_menu_file
2844 global treediffs diffids
2847 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2849 if {$cmitmode eq "tree"} {
2850 set e [linetoelt $l]
2851 if {[string index $e end] eq "/"} return
2853 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2855 set flist_menu_file $e
2856 set xdiffstate "normal"
2857 if {$cmitmode eq "tree"} {
2858 set xdiffstate "disabled"
2860 # Disable "External diff" item in tree mode
2861 $flist_menu entryconf 2 -state $xdiffstate
2862 tk_popup $flist_menu $X $Y
2865 proc flist_hl {only} {
2866 global flist_menu_file findstring gdttype
2868 set x [shellquote $flist_menu_file]
2869 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2872 append findstring " " $x
2874 set gdttype [mc "touching paths:"]
2877 proc save_file_from_commit {filename output what} {
2880 if {[catch {exec git show $filename -- > $output} err]} {
2881 if {[string match "fatal: bad revision *" $err]} {
2884 error_popup "Error getting \"$filename\" from $what: $err"
2890 proc external_diff_get_one_file {diffid filename diffdir} {
2891 global nullid nullid2 nullfile
2894 if {$diffid == $nullid} {
2895 set difffile [file join [file dirname $gitdir] $filename]
2896 if {[file exists $difffile]} {
2901 if {$diffid == $nullid2} {
2902 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2903 return [save_file_from_commit :$filename $difffile index]
2905 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2906 return [save_file_from_commit $diffid:$filename $difffile \
2910 proc external_diff {} {
2911 global gitktmpdir nullid nullid2
2912 global flist_menu_file
2915 global gitdir extdifftool
2917 if {[llength $diffids] == 1} {
2918 # no reference commit given
2919 set diffidto [lindex $diffids 0]
2920 if {$diffidto eq $nullid} {
2921 # diffing working copy with index
2922 set diffidfrom $nullid2
2923 } elseif {$diffidto eq $nullid2} {
2924 # diffing index with HEAD
2925 set diffidfrom "HEAD"
2927 # use first parent commit
2928 global parentlist selectedline
2929 set diffidfrom [lindex $parentlist $selectedline 0]
2932 set diffidfrom [lindex $diffids 0]
2933 set diffidto [lindex $diffids 1]
2936 # make sure that several diffs wont collide
2937 if {![info exists gitktmpdir]} {
2938 set gitktmpdir [file join [file dirname $gitdir] \
2939 [format ".gitk-tmp.%s" [pid]]]
2940 if {[catch {file mkdir $gitktmpdir} err]} {
2941 error_popup "Error creating temporary directory $gitktmpdir: $err"
2948 set diffdir [file join $gitktmpdir $diffnum]
2949 if {[catch {file mkdir $diffdir} err]} {
2950 error_popup "Error creating temporary directory $diffdir: $err"
2954 # gather files to diff
2955 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
2956 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
2958 if {$difffromfile ne {} && $difftofile ne {}} {
2959 set cmd [concat | [shellsplit $extdifftool] \
2960 [list $difffromfile $difftofile]]
2961 if {[catch {set fl [open $cmd r]} err]} {
2962 file delete -force $diffdir
2963 error_popup [mc "$extdifftool: command failed: $err"]
2965 fconfigure $fl -blocking 0
2966 filerun $fl [list delete_at_eof $fl $diffdir]
2971 # delete $dir when we see eof on $f (presumably because the child has exited)
2972 proc delete_at_eof {f dir} {
2973 while {[gets $f line] >= 0} {}
2975 if {[catch {close $f} err]} {
2976 error_popup "External diff viewer failed: $err"
2978 file delete -force $dir
2984 # Functions for adding and removing shell-type quoting
2986 proc shellquote {str} {
2987 if {![string match "*\['\"\\ \t]*" $str]} {
2990 if {![string match "*\['\"\\]*" $str]} {
2993 if {![string match "*'*" $str]} {
2996 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2999 proc shellarglist {l} {
3005 append str [shellquote $a]
3010 proc shelldequote {str} {
3015 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3016 append ret [string range $str $used end]
3017 set used [string length $str]
3020 set first [lindex $first 0]
3021 set ch [string index $str $first]
3022 if {$first > $used} {
3023 append ret [string range $str $used [expr {$first - 1}]]
3026 if {$ch eq " " || $ch eq "\t"} break
3029 set first [string first "'" $str $used]
3031 error "unmatched single-quote"
3033 append ret [string range $str $used [expr {$first - 1}]]
3038 if {$used >= [string length $str]} {
3039 error "trailing backslash"
3041 append ret [string index $str $used]
3046 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3047 error "unmatched double-quote"
3049 set first [lindex $first 0]
3050 set ch [string index $str $first]
3051 if {$first > $used} {
3052 append ret [string range $str $used [expr {$first - 1}]]
3055 if {$ch eq "\""} break
3057 append ret [string index $str $used]
3061 return [list $used $ret]
3064 proc shellsplit {str} {
3067 set str [string trimleft $str]
3068 if {$str eq {}} break
3069 set dq [shelldequote $str]
3070 set n [lindex $dq 0]
3071 set word [lindex $dq 1]
3072 set str [string range $str $n end]
3078 # Code to implement multiple views
3080 proc newview {ishighlight} {
3081 global nextviewnum newviewname newviewperm newishighlight
3082 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3084 set newishighlight $ishighlight
3086 if {[winfo exists $top]} {
3090 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3091 set newviewperm($nextviewnum) 0
3092 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3093 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3094 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3099 global viewname viewperm newviewname newviewperm
3100 global viewargs newviewargs viewargscmd newviewargscmd
3102 set top .gitkvedit-$curview
3103 if {[winfo exists $top]} {
3107 set newviewname($curview) $viewname($curview)
3108 set newviewperm($curview) $viewperm($curview)
3109 set newviewargs($curview) [shellarglist $viewargs($curview)]
3110 set newviewargscmd($curview) $viewargscmd($curview)
3111 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3114 proc vieweditor {top n title} {
3115 global newviewname newviewperm viewfiles bgcolor
3118 wm title $top $title
3119 label $top.nl -text [mc "Name"]
3120 entry $top.name -width 20 -textvariable newviewname($n)
3121 grid $top.nl $top.name -sticky w -pady 5
3122 checkbutton $top.perm -text [mc "Remember this view"] \
3123 -variable newviewperm($n)
3124 grid $top.perm - -pady 5 -sticky w
3125 message $top.al -aspect 1000 \
3126 -text [mc "Commits to include (arguments to git log):"]
3127 grid $top.al - -sticky w -pady 5
3128 entry $top.args -width 50 -textvariable newviewargs($n) \
3129 -background $bgcolor
3130 grid $top.args - -sticky ew -padx 5
3132 message $top.ac -aspect 1000 \
3133 -text [mc "Command to generate more commits to include:"]
3134 grid $top.ac - -sticky w -pady 5
3135 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3137 grid $top.argscmd - -sticky ew -padx 5
3139 message $top.l -aspect 1000 \
3140 -text [mc "Enter files and directories to include, one per line:"]
3141 grid $top.l - -sticky w
3142 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3143 if {[info exists viewfiles($n)]} {
3144 foreach f $viewfiles($n) {
3145 $top.t insert end $f
3146 $top.t insert end "\n"
3148 $top.t delete {end - 1c} end
3149 $top.t mark set insert 0.0
3151 grid $top.t - -sticky ew -padx 5
3153 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3154 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3155 grid $top.buts.ok $top.buts.can
3156 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3157 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3158 grid $top.buts - -pady 10 -sticky ew
3162 proc doviewmenu {m first cmd op argv} {
3163 set nmenu [$m index end]
3164 for {set i $first} {$i <= $nmenu} {incr i} {
3165 if {[$m entrycget $i -command] eq $cmd} {
3166 eval $m $op $i $argv
3172 proc allviewmenus {n op args} {
3175 doviewmenu .bar.view 5 [list showview $n] $op $args
3176 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3179 proc newviewok {top n} {
3180 global nextviewnum newviewperm newviewname newishighlight
3181 global viewname viewfiles viewperm selectedview curview
3182 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3185 set newargs [shellsplit $newviewargs($n)]
3187 error_popup "[mc "Error in commit selection arguments:"] $err"
3193 foreach f [split [$top.t get 0.0 end] "\n"] {
3194 set ft [string trim $f]
3199 if {![info exists viewfiles($n)]} {
3200 # creating a new view
3202 set viewname($n) $newviewname($n)
3203 set viewperm($n) $newviewperm($n)
3204 set viewfiles($n) $files
3205 set viewargs($n) $newargs
3206 set viewargscmd($n) $newviewargscmd($n)
3208 if {!$newishighlight} {
3211 run addvhighlight $n
3214 # editing an existing view
3215 set viewperm($n) $newviewperm($n)
3216 if {$newviewname($n) ne $viewname($n)} {
3217 set viewname($n) $newviewname($n)
3218 doviewmenu .bar.view 5 [list showview $n] \
3219 entryconf [list -label $viewname($n)]
3220 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3221 # entryconf [list -label $viewname($n) -value $viewname($n)]
3223 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3224 $newviewargscmd($n) ne $viewargscmd($n)} {
3225 set viewfiles($n) $files
3226 set viewargs($n) $newargs
3227 set viewargscmd($n) $newviewargscmd($n)
3228 if {$curview == $n} {
3233 catch {destroy $top}
3237 global curview viewperm hlview selectedhlview
3239 if {$curview == 0} return
3240 if {[info exists hlview] && $hlview == $curview} {
3241 set selectedhlview [mc "None"]
3244 allviewmenus $curview delete
3245 set viewperm($curview) 0
3249 proc addviewmenu {n} {
3250 global viewname viewhlmenu
3252 .bar.view add radiobutton -label $viewname($n) \
3253 -command [list showview $n] -variable selectedview -value $n
3254 #$viewhlmenu add radiobutton -label $viewname($n) \
3255 # -command [list addvhighlight $n] -variable selectedhlview
3259 global curview cached_commitrow ordertok
3260 global displayorder parentlist rowidlist rowisopt rowfinal
3261 global colormap rowtextx nextcolor canvxmax
3262 global numcommits viewcomplete
3263 global selectedline currentid canv canvy0
3265 global pending_select mainheadid
3268 global hlview selectedhlview commitinterest
3270 if {$n == $curview} return
3272 set ymax [lindex [$canv cget -scrollregion] 3]
3273 set span [$canv yview]
3274 set ytop [expr {[lindex $span 0] * $ymax}]
3275 set ybot [expr {[lindex $span 1] * $ymax}]
3276 set yscreen [expr {($ybot - $ytop) / 2}]
3277 if {[info exists selectedline]} {
3278 set selid $currentid
3279 set y [yc $selectedline]
3280 if {$ytop < $y && $y < $ybot} {
3281 set yscreen [expr {$y - $ytop}]
3283 } elseif {[info exists pending_select]} {
3284 set selid $pending_select
3285 unset pending_select
3289 catch {unset treediffs}
3291 if {[info exists hlview] && $hlview == $n} {
3293 set selectedhlview [mc "None"]
3295 catch {unset commitinterest}
3296 catch {unset cached_commitrow}
3297 catch {unset ordertok}
3301 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3302 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3305 if {![info exists viewcomplete($n)]} {
3307 set pending_select $selid
3318 set numcommits $commitidx($n)
3320 catch {unset colormap}
3321 catch {unset rowtextx}
3323 set canvxmax [$canv cget -width]
3329 if {$selid ne {} && [commitinview $selid $n]} {
3330 set row [rowofcommit $selid]
3331 # try to get the selected row in the same position on the screen
3332 set ymax [lindex [$canv cget -scrollregion] 3]
3333 set ytop [expr {[yc $row] - $yscreen}]
3337 set yf [expr {$ytop * 1.0 / $ymax}]
3339 allcanvs yview moveto $yf
3343 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
3344 selectline [rowofcommit $mainheadid] 1
3345 } elseif {!$viewcomplete($n)} {
3347 set pending_select $selid
3349 set pending_select $mainheadid
3352 set row [first_real_row]
3353 if {$row < $numcommits} {
3357 if {!$viewcomplete($n)} {
3358 if {$numcommits == 0} {
3359 show_status [mc "Reading commits..."]
3361 } elseif {$numcommits == 0} {
3362 show_status [mc "No commits selected"]
3366 # Stuff relating to the highlighting facility
3368 proc ishighlighted {id} {
3369 global vhighlights fhighlights nhighlights rhighlights
3371 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3372 return $nhighlights($id)
3374 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3375 return $vhighlights($id)
3377 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3378 return $fhighlights($id)
3380 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3381 return $rhighlights($id)
3386 proc bolden {row font} {
3387 global canv linehtag selectedline boldrows
3389 lappend boldrows $row
3390 $canv itemconf $linehtag($row) -font $font
3391 if {[info exists selectedline] && $row == $selectedline} {
3393 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3394 -outline {{}} -tags secsel \
3395 -fill [$canv cget -selectbackground]]
3400 proc bolden_name {row font} {
3401 global canv2 linentag selectedline boldnamerows
3403 lappend boldnamerows $row
3404 $canv2 itemconf $linentag($row) -font $font
3405 if {[info exists selectedline] && $row == $selectedline} {
3406 $canv2 delete secsel
3407 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3408 -outline {{}} -tags secsel \
3409 -fill [$canv2 cget -selectbackground]]
3418 foreach row $boldrows {
3419 if {![ishighlighted [commitonrow $row]]} {
3420 bolden $row mainfont
3422 lappend stillbold $row
3425 set boldrows $stillbold
3428 proc addvhighlight {n} {
3429 global hlview viewcomplete curview vhl_done commitidx
3431 if {[info exists hlview]} {
3435 if {$n != $curview && ![info exists viewcomplete($n)]} {
3438 set vhl_done $commitidx($hlview)
3439 if {$vhl_done > 0} {
3444 proc delvhighlight {} {
3445 global hlview vhighlights
3447 if {![info exists hlview]} return
3449 catch {unset vhighlights}
3453 proc vhighlightmore {} {
3454 global hlview vhl_done commitidx vhighlights curview
3456 set max $commitidx($hlview)
3457 set vr [visiblerows]
3458 set r0 [lindex $vr 0]
3459 set r1 [lindex $vr 1]
3460 for {set i $vhl_done} {$i < $max} {incr i} {
3461 set id [commitonrow $i $hlview]
3462 if {[commitinview $id $curview]} {
3463 set row [rowofcommit $id]
3464 if {$r0 <= $row && $row <= $r1} {
3465 if {![highlighted $row]} {
3466 bolden $row mainfontbold
3468 set vhighlights($id) 1
3476 proc askvhighlight {row id} {
3477 global hlview vhighlights iddrawn
3479 if {[commitinview $id $hlview]} {
3480 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3481 bolden $row mainfontbold
3483 set vhighlights($id) 1
3485 set vhighlights($id) 0
3489 proc hfiles_change {} {
3490 global highlight_files filehighlight fhighlights fh_serial
3491 global highlight_paths gdttype
3493 if {[info exists filehighlight]} {
3494 # delete previous highlights
3495 catch {close $filehighlight}
3497 catch {unset fhighlights}
3499 unhighlight_filelist
3501 set highlight_paths {}
3502 after cancel do_file_hl $fh_serial
3504 if {$highlight_files ne {}} {
3505 after 300 do_file_hl $fh_serial
3509 proc gdttype_change {name ix op} {
3510 global gdttype highlight_files findstring findpattern
3513 if {$findstring ne {}} {
3514 if {$gdttype eq [mc "containing:"]} {
3515 if {$highlight_files ne {}} {
3516 set highlight_files {}
3521 if {$findpattern ne {}} {
3525 set highlight_files $findstring
3530 # enable/disable findtype/findloc menus too
3533 proc find_change {name ix op} {
3534 global gdttype findstring highlight_files
3537 if {$gdttype eq [mc "containing:"]} {
3540 if {$highlight_files ne $findstring} {
3541 set highlight_files $findstring
3548 proc findcom_change args {
3549 global nhighlights boldnamerows
3550 global findpattern findtype findstring gdttype
3553 # delete previous highlights, if any
3554 foreach row $boldnamerows {
3555 bolden_name $row mainfont
3558 catch {unset nhighlights}
3561 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3563 } elseif {$findtype eq [mc "Regexp"]} {
3564 set findpattern $findstring
3566 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3568 set findpattern "*$e*"
3572 proc makepatterns {l} {
3575 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3576 if {[string index $ee end] eq "/"} {
3586 proc do_file_hl {serial} {
3587 global highlight_files filehighlight highlight_paths gdttype fhl_list
3589 if {$gdttype eq [mc "touching paths:"]} {
3590 if {[catch {set paths [shellsplit $highlight_files]}]} return
3591 set highlight_paths [makepatterns $paths]
3593 set gdtargs [concat -- $paths]
3594 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3595 set gdtargs [list "-S$highlight_files"]
3597 # must be "containing:", i.e. we're searching commit info
3600 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3601 set filehighlight [open $cmd r+]
3602 fconfigure $filehighlight -blocking 0
3603 filerun $filehighlight readfhighlight
3609 proc flushhighlights {} {
3610 global filehighlight fhl_list
3612 if {[info exists filehighlight]} {
3614 puts $filehighlight ""
3615 flush $filehighlight
3619 proc askfilehighlight {row id} {
3620 global filehighlight fhighlights fhl_list
3622 lappend fhl_list $id
3623 set fhighlights($id) -1
3624 puts $filehighlight $id
3627 proc readfhighlight {} {
3628 global filehighlight fhighlights curview iddrawn
3629 global fhl_list find_dirn
3631 if {![info exists filehighlight]} {
3635 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3636 set line [string trim $line]
3637 set i [lsearch -exact $fhl_list $line]
3638 if {$i < 0} continue
3639 for {set j 0} {$j < $i} {incr j} {
3640 set id [lindex $fhl_list $j]
3641 set fhighlights($id) 0
3643 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3644 if {$line eq {}} continue
3645 if {![commitinview $line $curview]} continue
3646 set row [rowofcommit $line]
3647 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3648 bolden $row mainfontbold
3650 set fhighlights($line) 1
3652 if {[eof $filehighlight]} {
3654 puts "oops, git diff-tree died"
3655 catch {close $filehighlight}
3659 if {[info exists find_dirn]} {
3665 proc doesmatch {f} {
3666 global findtype findpattern
3668 if {$findtype eq [mc "Regexp"]} {
3669 return [regexp $findpattern $f]
3670 } elseif {$findtype eq [mc "IgnCase"]} {
3671 return [string match -nocase $findpattern $f]
3673 return [string match $findpattern $f]
3677 proc askfindhighlight {row id} {
3678 global nhighlights commitinfo iddrawn
3680 global markingmatches
3682 if {![info exists commitinfo($id)]} {
3685 set info $commitinfo($id)
3687 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3688 foreach f $info ty $fldtypes {
3689 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3691 if {$ty eq [mc "Author"]} {
3698 if {$isbold && [info exists iddrawn($id)]} {
3699 if {![ishighlighted $id]} {
3700 bolden $row mainfontbold
3702 bolden_name $row mainfontbold
3705 if {$markingmatches} {
3706 markrowmatches $row $id
3709 set nhighlights($id) $isbold
3712 proc markrowmatches {row id} {
3713 global canv canv2 linehtag linentag commitinfo findloc
3715 set headline [lindex $commitinfo($id) 0]
3716 set author [lindex $commitinfo($id) 1]
3717 $canv delete match$row
3718 $canv2 delete match$row
3719 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3720 set m [findmatches $headline]
3722 markmatches $canv $row $headline $linehtag($row) $m \
3723 [$canv itemcget $linehtag($row) -font] $row
3726 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3727 set m [findmatches $author]
3729 markmatches $canv2 $row $author $linentag($row) $m \
3730 [$canv2 itemcget $linentag($row) -font] $row
3735 proc vrel_change {name ix op} {
3736 global highlight_related
3739 if {$highlight_related ne [mc "None"]} {
3744 # prepare for testing whether commits are descendents or ancestors of a
3745 proc rhighlight_sel {a} {
3746 global descendent desc_todo ancestor anc_todo
3747 global highlight_related
3749 catch {unset descendent}
3750 set desc_todo [list $a]
3751 catch {unset ancestor}
3752 set anc_todo [list $a]
3753 if {$highlight_related ne [mc "None"]} {
3759 proc rhighlight_none {} {
3762 catch {unset rhighlights}
3766 proc is_descendent {a} {
3767 global curview children descendent desc_todo
3770 set la [rowofcommit $a]
3774 for {set i 0} {$i < [llength $todo]} {incr i} {
3775 set do [lindex $todo $i]
3776 if {[rowofcommit $do] < $la} {
3777 lappend leftover $do
3780 foreach nk $children($v,$do) {
3781 if {![info exists descendent($nk)]} {
3782 set descendent($nk) 1
3790 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3794 set descendent($a) 0
3795 set desc_todo $leftover
3798 proc is_ancestor {a} {
3799 global curview parents ancestor anc_todo
3802 set la [rowofcommit $a]
3806 for {set i 0} {$i < [llength $todo]} {incr i} {
3807 set do [lindex $todo $i]
3808 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3809 lappend leftover $do
3812 foreach np $parents($v,$do) {
3813 if {![info exists ancestor($np)]} {
3822 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3827 set anc_todo $leftover
3830 proc askrelhighlight {row id} {
3831 global descendent highlight_related iddrawn rhighlights
3832 global selectedline ancestor
3834 if {![info exists selectedline]} return
3836 if {$highlight_related eq [mc "Descendant"] ||
3837 $highlight_related eq [mc "Not descendant"]} {
3838 if {![info exists descendent($id)]} {
3841 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3844 } elseif {$highlight_related eq [mc "Ancestor"] ||
3845 $highlight_related eq [mc "Not ancestor"]} {
3846 if {![info exists ancestor($id)]} {
3849 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3853 if {[info exists iddrawn($id)]} {
3854 if {$isbold && ![ishighlighted $id]} {
3855 bolden $row mainfontbold
3858 set rhighlights($id) $isbold
3861 # Graph layout functions
3863 proc shortids {ids} {
3866 if {[llength $id] > 1} {
3867 lappend res [shortids $id]
3868 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3869 lappend res [string range $id 0 7]
3880 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3881 if {($n & $mask) != 0} {
3882 set ret [concat $ret $o]
3884 set o [concat $o $o]
3889 proc ordertoken {id} {
3890 global ordertok curview varcid varcstart varctok curview parents children
3891 global nullid nullid2
3893 if {[info exists ordertok($id)]} {
3894 return $ordertok($id)
3899 if {[info exists varcid($curview,$id)]} {
3900 set a $varcid($curview,$id)
3901 set p [lindex $varcstart($curview) $a]
3903 set p [lindex $children($curview,$id) 0]
3905 if {[info exists ordertok($p)]} {
3906 set tok $ordertok($p)
3909 set id [first_real_child $curview,$p]
3912 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3915 if {[llength $parents($curview,$id)] == 1} {
3916 lappend todo [list $p {}]
3918 set j [lsearch -exact $parents($curview,$id) $p]
3920 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3922 lappend todo [list $p [strrep $j]]
3925 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3926 set p [lindex $todo $i 0]
3927 append tok [lindex $todo $i 1]
3928 set ordertok($p) $tok
3930 set ordertok($origid) $tok
3934 # Work out where id should go in idlist so that order-token
3935 # values increase from left to right
3936 proc idcol {idlist id {i 0}} {
3937 set t [ordertoken $id]
3941 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3942 if {$i > [llength $idlist]} {
3943 set i [llength $idlist]
3945 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3948 if {$t > [ordertoken [lindex $idlist $i]]} {
3949 while {[incr i] < [llength $idlist] &&
3950 $t >= [ordertoken [lindex $idlist $i]]} {}
3956 proc initlayout {} {
3957 global rowidlist rowisopt rowfinal displayorder parentlist
3958 global numcommits canvxmax canv
3960 global colormap rowtextx
3969 set canvxmax [$canv cget -width]
3970 catch {unset colormap}
3971 catch {unset rowtextx}
3975 proc setcanvscroll {} {
3976 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3977 global lastscrollset lastscrollrows
3979 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3980 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3981 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3982 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3983 set lastscrollset [clock clicks -milliseconds]
3984 set lastscrollrows $numcommits
3987 proc visiblerows {} {
3988 global canv numcommits linespc
3990 set ymax [lindex [$canv cget -scrollregion] 3]
3991 if {$ymax eq {} || $ymax == 0} return
3993 set y0 [expr {int([lindex $f 0] * $ymax)}]
3994 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3998 set y1 [expr {int([lindex $f 1] * $ymax)}]
3999 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4000 if {$r1 >= $numcommits} {
4001 set r1 [expr {$numcommits - 1}]
4003 return [list $r0 $r1]
4006 proc layoutmore {} {
4007 global commitidx viewcomplete curview
4008 global numcommits pending_select selectedline curview
4009 global lastscrollset lastscrollrows commitinterest
4011 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4012 [clock clicks -milliseconds] - $lastscrollset > 500} {
4015 if {[info exists pending_select] &&
4016 [commitinview $pending_select $curview]} {
4017 selectline [rowofcommit $pending_select] 1
4022 proc doshowlocalchanges {} {
4023 global curview mainheadid
4025 if {[commitinview $mainheadid $curview]} {
4028 lappend commitinterest($mainheadid) {dodiffindex}
4032 proc dohidelocalchanges {} {
4033 global nullid nullid2 lserial curview
4035 if {[commitinview $nullid $curview]} {
4036 removefakerow $nullid
4038 if {[commitinview $nullid2 $curview]} {
4039 removefakerow $nullid2
4044 # spawn off a process to do git diff-index --cached HEAD
4045 proc dodiffindex {} {
4046 global lserial showlocalchanges
4049 if {!$showlocalchanges || !$isworktree} return
4051 set fd [open "|git diff-index --cached HEAD" r]
4052 fconfigure $fd -blocking 0
4053 filerun $fd [list readdiffindex $fd $lserial]
4056 proc readdiffindex {fd serial} {
4057 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4060 if {[gets $fd line] < 0} {
4066 # we only need to see one line and we don't really care what it says...
4069 if {$serial != $lserial} {
4073 # now see if there are any local changes not checked in to the index
4074 set fd [open "|git diff-files" r]
4075 fconfigure $fd -blocking 0
4076 filerun $fd [list readdifffiles $fd $serial]
4078 if {$isdiff && ![commitinview $nullid2 $curview]} {
4079 # add the line for the changes in the index to the graph
4080 set hl [mc "Local changes checked in to index but not committed"]
4081 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4082 set commitdata($nullid2) "\n $hl\n"
4083 if {[commitinview $nullid $curview]} {
4084 removefakerow $nullid
4086 insertfakerow $nullid2 $mainheadid
4087 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4088 removefakerow $nullid2
4093 proc readdifffiles {fd serial} {
4094 global mainheadid nullid nullid2 curview
4095 global commitinfo commitdata lserial
4098 if {[gets $fd line] < 0} {
4104 # we only need to see one line and we don't really care what it says...
4107 if {$serial != $lserial} {
4111 if {$isdiff && ![commitinview $nullid $curview]} {
4112 # add the line for the local diff to the graph
4113 set hl [mc "Local uncommitted changes, not checked in to index"]
4114 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4115 set commitdata($nullid) "\n $hl\n"
4116 if {[commitinview $nullid2 $curview]} {
4121 insertfakerow $nullid $p
4122 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4123 removefakerow $nullid
4128 proc nextuse {id row} {
4129 global curview children
4131 if {[info exists children($curview,$id)]} {
4132 foreach kid $children($curview,$id) {
4133 if {![commitinview $kid $curview]} {
4136 if {[rowofcommit $kid] > $row} {
4137 return [rowofcommit $kid]
4141 if {[commitinview $id $curview]} {
4142 return [rowofcommit $id]
4147 proc prevuse {id row} {
4148 global curview children
4151 if {[info exists children($curview,$id)]} {
4152 foreach kid $children($curview,$id) {
4153 if {![commitinview $kid $curview]} break
4154 if {[rowofcommit $kid] < $row} {
4155 set ret [rowofcommit $kid]
4162 proc make_idlist {row} {
4163 global displayorder parentlist uparrowlen downarrowlen mingaplen
4164 global commitidx curview children
4166 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4170 set ra [expr {$row - $downarrowlen}]
4174 set rb [expr {$row + $uparrowlen}]
4175 if {$rb > $commitidx($curview)} {
4176 set rb $commitidx($curview)
4178 make_disporder $r [expr {$rb + 1}]
4180 for {} {$r < $ra} {incr r} {
4181 set nextid [lindex $displayorder [expr {$r + 1}]]
4182 foreach p [lindex $parentlist $r] {
4183 if {$p eq $nextid} continue
4184 set rn [nextuse $p $r]
4186 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4187 lappend ids [list [ordertoken $p] $p]
4191 for {} {$r < $row} {incr r} {
4192 set nextid [lindex $displayorder [expr {$r + 1}]]
4193 foreach p [lindex $parentlist $r] {
4194 if {$p eq $nextid} continue
4195 set rn [nextuse $p $r]
4196 if {$rn < 0 || $rn >= $row} {
4197 lappend ids [list [ordertoken $p] $p]
4201 set id [lindex $displayorder $row]
4202 lappend ids [list [ordertoken $id] $id]
4204 foreach p [lindex $parentlist $r] {
4205 set firstkid [lindex $children($curview,$p) 0]
4206 if {[rowofcommit $firstkid] < $row} {
4207 lappend ids [list [ordertoken $p] $p]
4211 set id [lindex $displayorder $r]
4213 set firstkid [lindex $children($curview,$id) 0]
4214 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4215 lappend ids [list [ordertoken $id] $id]
4220 foreach idx [lsort -unique $ids] {
4221 lappend idlist [lindex $idx 1]
4226 proc rowsequal {a b} {
4227 while {[set i [lsearch -exact $a {}]] >= 0} {
4228 set a [lreplace $a $i $i]
4230 while {[set i [lsearch -exact $b {}]] >= 0} {
4231 set b [lreplace $b $i $i]
4233 return [expr {$a eq $b}]
4236 proc makeupline {id row rend col} {
4237 global rowidlist uparrowlen downarrowlen mingaplen
4239 for {set r $rend} {1} {set r $rstart} {
4240 set rstart [prevuse $id $r]
4241 if {$rstart < 0} return
4242 if {$rstart < $row} break
4244 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4245 set rstart [expr {$rend - $uparrowlen - 1}]
4247 for {set r $rstart} {[incr r] <= $row} {} {
4248 set idlist [lindex $rowidlist $r]
4249 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4250 set col [idcol $idlist $id $col]
4251 lset rowidlist $r [linsert $idlist $col $id]
4257 proc layoutrows {row endrow} {
4258 global rowidlist rowisopt rowfinal displayorder
4259 global uparrowlen downarrowlen maxwidth mingaplen
4260 global children parentlist
4261 global commitidx viewcomplete curview
4263 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4266 set rm1 [expr {$row - 1}]
4267 foreach id [lindex $rowidlist $rm1] {
4272 set final [lindex $rowfinal $rm1]
4274 for {} {$row < $endrow} {incr row} {
4275 set rm1 [expr {$row - 1}]
4276 if {$rm1 < 0 || $idlist eq {}} {
4277 set idlist [make_idlist $row]
4280 set id [lindex $displayorder $rm1]
4281 set col [lsearch -exact $idlist $id]
4282 set idlist [lreplace $idlist $col $col]
4283 foreach p [lindex $parentlist $rm1] {
4284 if {[lsearch -exact $idlist $p] < 0} {
4285 set col [idcol $idlist $p $col]
4286 set idlist [linsert $idlist $col $p]
4287 # if not the first child, we have to insert a line going up
4288 if {$id ne [lindex $children($curview,$p) 0]} {
4289 makeupline $p $rm1 $row $col
4293 set id [lindex $displayorder $row]
4294 if {$row > $downarrowlen} {
4295 set termrow [expr {$row - $downarrowlen - 1}]
4296 foreach p [lindex $parentlist $termrow] {
4297 set i [lsearch -exact $idlist $p]
4298 if {$i < 0} continue
4299 set nr [nextuse $p $termrow]
4300 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4301 set idlist [lreplace $idlist $i $i]
4305 set col [lsearch -exact $idlist $id]
4307 set col [idcol $idlist $id]
4308 set idlist [linsert $idlist $col $id]
4309 if {$children($curview,$id) ne {}} {
4310 makeupline $id $rm1 $row $col
4313 set r [expr {$row + $uparrowlen - 1}]
4314 if {$r < $commitidx($curview)} {
4316 foreach p [lindex $parentlist $r] {
4317 if {[lsearch -exact $idlist $p] >= 0} continue
4318 set fk [lindex $children($curview,$p) 0]
4319 if {[rowofcommit $fk] < $row} {
4320 set x [idcol $idlist $p $x]
4321 set idlist [linsert $idlist $x $p]
4324 if {[incr r] < $commitidx($curview)} {
4325 set p [lindex $displayorder $r]
4326 if {[lsearch -exact $idlist $p] < 0} {
4327 set fk [lindex $children($curview,$p) 0]
4328 if {$fk ne {} && [rowofcommit $fk] < $row} {
4329 set x [idcol $idlist $p $x]
4330 set idlist [linsert $idlist $x $p]
4336 if {$final && !$viewcomplete($curview) &&
4337 $row + $uparrowlen + $mingaplen + $downarrowlen
4338 >= $commitidx($curview)} {
4341 set l [llength $rowidlist]
4343 lappend rowidlist $idlist
4345 lappend rowfinal $final
4346 } elseif {$row < $l} {
4347 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4348 lset rowidlist $row $idlist
4351 lset rowfinal $row $final
4353 set pad [ntimes [expr {$row - $l}] {}]
4354 set rowidlist [concat $rowidlist $pad]
4355 lappend rowidlist $idlist
4356 set rowfinal [concat $rowfinal $pad]
4357 lappend rowfinal $final
4358 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4364 proc changedrow {row} {
4365 global displayorder iddrawn rowisopt need_redisplay
4367 set l [llength $rowisopt]
4369 lset rowisopt $row 0
4370 if {$row + 1 < $l} {
4371 lset rowisopt [expr {$row + 1}] 0
4372 if {$row + 2 < $l} {
4373 lset rowisopt [expr {$row + 2}] 0
4377 set id [lindex $displayorder $row]
4378 if {[info exists iddrawn($id)]} {
4379 set need_redisplay 1
4383 proc insert_pad {row col npad} {
4386 set pad [ntimes $npad {}]
4387 set idlist [lindex $rowidlist $row]
4388 set bef [lrange $idlist 0 [expr {$col - 1}]]
4389 set aft [lrange $idlist $col end]
4390 set i [lsearch -exact $aft {}]
4392 set aft [lreplace $aft $i $i]
4394 lset rowidlist $row [concat $bef $pad $aft]
4398 proc optimize_rows {row col endrow} {
4399 global rowidlist rowisopt displayorder curview children
4404 for {} {$row < $endrow} {incr row; set col 0} {
4405 if {[lindex $rowisopt $row]} continue
4407 set y0 [expr {$row - 1}]
4408 set ym [expr {$row - 2}]
4409 set idlist [lindex $rowidlist $row]
4410 set previdlist [lindex $rowidlist $y0]
4411 if {$idlist eq {} || $previdlist eq {}} continue
4413 set pprevidlist [lindex $rowidlist $ym]
4414 if {$pprevidlist eq {}} continue
4420 for {} {$col < [llength $idlist]} {incr col} {
4421 set id [lindex $idlist $col]
4422 if {[lindex $previdlist $col] eq $id} continue
4427 set x0 [lsearch -exact $previdlist $id]
4428 if {$x0 < 0} continue
4429 set z [expr {$x0 - $col}]
4433 set xm [lsearch -exact $pprevidlist $id]
4435 set z0 [expr {$xm - $x0}]
4439 # if row y0 is the first child of $id then it's not an arrow
4440 if {[lindex $children($curview,$id) 0] ne
4441 [lindex $displayorder $y0]} {
4445 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4446 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4449 # Looking at lines from this row to the previous row,
4450 # make them go straight up if they end in an arrow on
4451 # the previous row; otherwise make them go straight up
4453 if {$z < -1 || ($z < 0 && $isarrow)} {
4454 # Line currently goes left too much;
4455 # insert pads in the previous row, then optimize it
4456 set npad [expr {-1 - $z + $isarrow}]
4457 insert_pad $y0 $x0 $npad
4459 optimize_rows $y0 $x0 $row
4461 set previdlist [lindex $rowidlist $y0]
4462 set x0 [lsearch -exact $previdlist $id]
4463 set z [expr {$x0 - $col}]
4465 set pprevidlist [lindex $rowidlist $ym]
4466 set xm [lsearch -exact $pprevidlist $id]
4467 set z0 [expr {$xm - $x0}]
4469 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4470 # Line currently goes right too much;
4471 # insert pads in this line
4472 set npad [expr {$z - 1 + $isarrow}]
4473 insert_pad $row $col $npad
4474 set idlist [lindex $rowidlist $row]
4476 set z [expr {$x0 - $col}]
4479 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4480 # this line links to its first child on row $row-2
4481 set id [lindex $displayorder $ym]
4482 set xc [lsearch -exact $pprevidlist $id]
4484 set z0 [expr {$xc - $x0}]
4487 # avoid lines jigging left then immediately right
4488 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4489 insert_pad $y0 $x0 1
4491 optimize_rows $y0 $x0 $row
4492 set previdlist [lindex $rowidlist $y0]
4496 # Find the first column that doesn't have a line going right
4497 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4498 set id [lindex $idlist $col]
4499 if {$id eq {}} break
4500 set x0 [lsearch -exact $previdlist $id]
4502 # check if this is the link to the first child
4503 set kid [lindex $displayorder $y0]
4504 if {[lindex $children($curview,$id) 0] eq $kid} {
4505 # it is, work out offset to child
4506 set x0 [lsearch -exact $previdlist $kid]
4509 if {$x0 <= $col} break
4511 # Insert a pad at that column as long as it has a line and
4512 # isn't the last column
4513 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4514 set idlist [linsert $idlist $col {}]
4515 lset rowidlist $row $idlist
4523 global canvx0 linespc
4524 return [expr {$canvx0 + $col * $linespc}]
4528 global canvy0 linespc
4529 return [expr {$canvy0 + $row * $linespc}]
4532 proc linewidth {id} {
4533 global thickerline lthickness
4536 if {[info exists thickerline] && $id eq $thickerline} {
4537 set wid [expr {2 * $lthickness}]
4542 proc rowranges {id} {
4543 global curview children uparrowlen downarrowlen
4546 set kids $children($curview,$id)
4552 foreach child $kids {
4553 if {![commitinview $child $curview]} break
4554 set row [rowofcommit $child]
4555 if {![info exists prev]} {
4556 lappend ret [expr {$row + 1}]
4558 if {$row <= $prevrow} {
4559 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4561 # see if the line extends the whole way from prevrow to row
4562 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4563 [lsearch -exact [lindex $rowidlist \
4564 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4565 # it doesn't, see where it ends
4566 set r [expr {$prevrow + $downarrowlen}]
4567 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4568 while {[incr r -1] > $prevrow &&
4569 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4571 while {[incr r] <= $row &&
4572 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4576 # see where it starts up again
4577 set r [expr {$row - $uparrowlen}]
4578 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4579 while {[incr r] < $row &&
4580 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4582 while {[incr r -1] >= $prevrow &&
4583 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4589 if {$child eq $id} {
4598 proc drawlineseg {id row endrow arrowlow} {
4599 global rowidlist displayorder iddrawn linesegs
4600 global canv colormap linespc curview maxlinelen parentlist
4602 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4603 set le [expr {$row + 1}]
4606 set c [lsearch -exact [lindex $rowidlist $le] $id]
4612 set x [lindex $displayorder $le]
4617 if {[info exists iddrawn($x)] || $le == $endrow} {
4618 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4634 if {[info exists linesegs($id)]} {
4635 set lines $linesegs($id)
4637 set r0 [lindex $li 0]
4639 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4649 set li [lindex $lines [expr {$i-1}]]
4650 set r1 [lindex $li 1]
4651 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4656 set x [lindex $cols [expr {$le - $row}]]
4657 set xp [lindex $cols [expr {$le - 1 - $row}]]
4658 set dir [expr {$xp - $x}]
4660 set ith [lindex $lines $i 2]
4661 set coords [$canv coords $ith]
4662 set ah [$canv itemcget $ith -arrow]
4663 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4664 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4665 if {$x2 ne {} && $x - $x2 == $dir} {
4666 set coords [lrange $coords 0 end-2]
4669 set coords [list [xc $le $x] [yc $le]]
4672 set itl [lindex $lines [expr {$i-1}] 2]
4673 set al [$canv itemcget $itl -arrow]
4674 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4675 } elseif {$arrowlow} {
4676 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4677 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4681 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4682 for {set y $le} {[incr y -1] > $row} {} {
4684 set xp [lindex $cols [expr {$y - 1 - $row}]]
4685 set ndir [expr {$xp - $x}]
4686 if {$dir != $ndir || $xp < 0} {
4687 lappend coords [xc $y $x] [yc $y]
4693 # join parent line to first child
4694 set ch [lindex $displayorder $row]
4695 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4697 puts "oops: drawlineseg: child $ch not on row $row"
4698 } elseif {$xc != $x} {
4699 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4700 set d [expr {int(0.5 * $linespc)}]
4703 set x2 [expr {$x1 - $d}]
4705 set x2 [expr {$x1 + $d}]
4708 set y1 [expr {$y2 + $d}]
4709 lappend coords $x1 $y1 $x2 $y2
4710 } elseif {$xc < $x - 1} {
4711 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4712 } elseif {$xc > $x + 1} {
4713 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4717 lappend coords [xc $row $x] [yc $row]
4719 set xn [xc $row $xp]
4721 lappend coords $xn $yn
4725 set t [$canv create line $coords -width [linewidth $id] \
4726 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4729 set lines [linsert $lines $i [list $row $le $t]]
4731 $canv coords $ith $coords
4732 if {$arrow ne $ah} {
4733 $canv itemconf $ith -arrow $arrow
4735 lset lines $i 0 $row
4738 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4739 set ndir [expr {$xo - $xp}]
4740 set clow [$canv coords $itl]
4741 if {$dir == $ndir} {
4742 set clow [lrange $clow 2 end]
4744 set coords [concat $coords $clow]
4746 lset lines [expr {$i-1}] 1 $le
4748 # coalesce two pieces
4750 set b [lindex $lines [expr {$i-1}] 0]
4751 set e [lindex $lines $i 1]
4752 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4754 $canv coords $itl $coords
4755 if {$arrow ne $al} {
4756 $canv itemconf $itl -arrow $arrow
4760 set linesegs($id) $lines
4764 proc drawparentlinks {id row} {
4765 global rowidlist canv colormap curview parentlist
4766 global idpos linespc
4768 set rowids [lindex $rowidlist $row]
4769 set col [lsearch -exact $rowids $id]
4770 if {$col < 0} return
4771 set olds [lindex $parentlist $row]
4772 set row2 [expr {$row + 1}]
4773 set x [xc $row $col]
4776 set d [expr {int(0.5 * $linespc)}]
4777 set ymid [expr {$y + $d}]
4778 set ids [lindex $rowidlist $row2]
4779 # rmx = right-most X coord used
4782 set i [lsearch -exact $ids $p]
4784 puts "oops, parent $p of $id not in list"
4787 set x2 [xc $row2 $i]
4791 set j [lsearch -exact $rowids $p]
4793 # drawlineseg will do this one for us
4797 # should handle duplicated parents here...
4798 set coords [list $x $y]
4800 # if attaching to a vertical segment, draw a smaller
4801 # slant for visual distinctness
4804 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4806 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4808 } elseif {$i < $col && $i < $j} {
4809 # segment slants towards us already
4810 lappend coords [xc $row $j] $y
4812 if {$i < $col - 1} {
4813 lappend coords [expr {$x2 + $linespc}] $y
4814 } elseif {$i > $col + 1} {
4815 lappend coords [expr {$x2 - $linespc}] $y
4817 lappend coords $x2 $y2
4820 lappend coords $x2 $y2
4822 set t [$canv create line $coords -width [linewidth $p] \
4823 -fill $colormap($p) -tags lines.$p]
4827 if {$rmx > [lindex $idpos($id) 1]} {
4828 lset idpos($id) 1 $rmx
4833 proc drawlines {id} {
4836 $canv itemconf lines.$id -width [linewidth $id]
4839 proc drawcmittext {id row col} {
4840 global linespc canv canv2 canv3 fgcolor curview
4841 global cmitlisted commitinfo rowidlist parentlist
4842 global rowtextx idpos idtags idheads idotherrefs
4843 global linehtag linentag linedtag selectedline
4844 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4846 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4847 set listed $cmitlisted($curview,$id)
4848 if {$id eq $nullid} {
4850 } elseif {$id eq $nullid2} {
4853 set ofill [expr {$listed != 0 ? $listed == 2 ? "gray" : "blue" : "white"}]
4855 set x [xc $row $col]
4857 set orad [expr {$linespc / 3}]
4859 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4860 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4861 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4862 } elseif {$listed == 3} {
4863 # triangle pointing left for left-side commits
4864 set t [$canv create polygon \
4865 [expr {$x - $orad}] $y \
4866 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4867 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4868 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4870 # triangle pointing right for right-side commits
4871 set t [$canv create polygon \
4872 [expr {$x + $orad - 1}] $y \
4873 [expr {$x - $orad}] [expr {$y - $orad}] \
4874 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4875 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4878 $canv bind $t <1> {selcanvline {} %x %y}
4879 set rmx [llength [lindex $rowidlist $row]]
4880 set olds [lindex $parentlist $row]
4882 set nextids [lindex $rowidlist [expr {$row + 1}]]
4884 set i [lsearch -exact $nextids $p]
4890 set xt [xc $row $rmx]
4891 set rowtextx($row) $xt
4892 set idpos($id) [list $x $xt $y]
4893 if {[info exists idtags($id)] || [info exists idheads($id)]
4894 || [info exists idotherrefs($id)]} {
4895 set xt [drawtags $id $x $xt $y]
4897 set headline [lindex $commitinfo($id) 0]
4898 set name [lindex $commitinfo($id) 1]
4899 set date [lindex $commitinfo($id) 2]
4900 set date [formatdate $date]
4903 set isbold [ishighlighted $id]
4905 lappend boldrows $row
4906 set font mainfontbold
4908 lappend boldnamerows $row
4909 set nfont mainfontbold
4912 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4913 -text $headline -font $font -tags text]
4914 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4915 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4916 -text $name -font $nfont -tags text]
4917 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4918 -text $date -font mainfont -tags text]
4919 if {[info exists selectedline] && $selectedline == $row} {
4922 set xr [expr {$xt + [font measure $font $headline]}]
4923 if {$xr > $canvxmax} {
4929 proc drawcmitrow {row} {
4930 global displayorder rowidlist nrows_drawn
4931 global iddrawn markingmatches
4932 global commitinfo numcommits
4933 global filehighlight fhighlights findpattern nhighlights
4934 global hlview vhighlights
4935 global highlight_related rhighlights
4937 if {$row >= $numcommits} return
4939 set id [lindex $displayorder $row]
4940 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4941 askvhighlight $row $id
4943 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4944 askfilehighlight $row $id
4946 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4947 askfindhighlight $row $id
4949 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4950 askrelhighlight $row $id
4952 if {![info exists iddrawn($id)]} {
4953 set col [lsearch -exact [lindex $rowidlist $row] $id]
4955 puts "oops, row $row id $id not in list"
4958 if {![info exists commitinfo($id)]} {
4962 drawcmittext $id $row $col
4966 if {$markingmatches} {
4967 markrowmatches $row $id
4971 proc drawcommits {row {endrow {}}} {
4972 global numcommits iddrawn displayorder curview need_redisplay
4973 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4978 if {$endrow eq {}} {
4981 if {$endrow >= $numcommits} {
4982 set endrow [expr {$numcommits - 1}]
4985 set rl1 [expr {$row - $downarrowlen - 3}]
4989 set ro1 [expr {$row - 3}]
4993 set r2 [expr {$endrow + $uparrowlen + 3}]
4994 if {$r2 > $numcommits} {
4997 for {set r $rl1} {$r < $r2} {incr r} {
4998 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5002 set rl1 [expr {$r + 1}]
5008 optimize_rows $ro1 0 $r2
5009 if {$need_redisplay || $nrows_drawn > 2000} {
5014 # make the lines join to already-drawn rows either side
5015 set r [expr {$row - 1}]
5016 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5019 set er [expr {$endrow + 1}]
5020 if {$er >= $numcommits ||
5021 ![info exists iddrawn([lindex $displayorder $er])]} {
5024 for {} {$r <= $er} {incr r} {
5025 set id [lindex $displayorder $r]
5026 set wasdrawn [info exists iddrawn($id)]
5028 if {$r == $er} break
5029 set nextid [lindex $displayorder [expr {$r + 1}]]
5030 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5031 drawparentlinks $id $r
5033 set rowids [lindex $rowidlist $r]
5034 foreach lid $rowids {
5035 if {$lid eq {}} continue
5036 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5038 # see if this is the first child of any of its parents
5039 foreach p [lindex $parentlist $r] {
5040 if {[lsearch -exact $rowids $p] < 0} {
5041 # make this line extend up to the child
5042 set lineend($p) [drawlineseg $p $r $er 0]
5046 set lineend($lid) [drawlineseg $lid $r $er 1]
5052 proc undolayout {row} {
5053 global uparrowlen mingaplen downarrowlen
5054 global rowidlist rowisopt rowfinal need_redisplay
5056 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5060 if {[llength $rowidlist] > $r} {
5062 set rowidlist [lrange $rowidlist 0 $r]
5063 set rowfinal [lrange $rowfinal 0 $r]
5064 set rowisopt [lrange $rowisopt 0 $r]
5065 set need_redisplay 1
5070 proc drawvisible {} {
5071 global canv linespc curview vrowmod selectedline targetrow targetid
5072 global need_redisplay cscroll numcommits
5074 set fs [$canv yview]
5075 set ymax [lindex [$canv cget -scrollregion] 3]
5076 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5077 set f0 [lindex $fs 0]
5078 set f1 [lindex $fs 1]
5079 set y0 [expr {int($f0 * $ymax)}]
5080 set y1 [expr {int($f1 * $ymax)}]
5082 if {[info exists targetid]} {
5083 if {[commitinview $targetid $curview]} {
5084 set r [rowofcommit $targetid]
5085 if {$r != $targetrow} {
5086 # Fix up the scrollregion and change the scrolling position
5087 # now that our target row has moved.
5088 set diff [expr {($r - $targetrow) * $linespc}]
5091 set ymax [lindex [$canv cget -scrollregion] 3]
5094 set f0 [expr {$y0 / $ymax}]
5095 set f1 [expr {$y1 / $ymax}]
5096 allcanvs yview moveto $f0
5097 $cscroll set $f0 $f1
5098 set need_redisplay 1
5105 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5106 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5107 if {$endrow >= $vrowmod($curview)} {
5108 update_arcrows $curview
5110 if {[info exists selectedline] &&
5111 $row <= $selectedline && $selectedline <= $endrow} {
5112 set targetrow $selectedline
5113 } elseif {[info exists targetid]} {
5114 set targetrow [expr {int(($row + $endrow) / 2)}]
5116 if {[info exists targetrow]} {
5117 if {$targetrow >= $numcommits} {
5118 set targetrow [expr {$numcommits - 1}]
5120 set targetid [commitonrow $targetrow]
5122 drawcommits $row $endrow
5125 proc clear_display {} {
5126 global iddrawn linesegs need_redisplay nrows_drawn
5127 global vhighlights fhighlights nhighlights rhighlights
5130 catch {unset iddrawn}
5131 catch {unset linesegs}
5132 catch {unset vhighlights}
5133 catch {unset fhighlights}
5134 catch {unset nhighlights}
5135 catch {unset rhighlights}
5136 set need_redisplay 0
5140 proc findcrossings {id} {
5141 global rowidlist parentlist numcommits displayorder
5145 foreach {s e} [rowranges $id] {
5146 if {$e >= $numcommits} {
5147 set e [expr {$numcommits - 1}]
5149 if {$e <= $s} continue
5150 for {set row $e} {[incr row -1] >= $s} {} {
5151 set x [lsearch -exact [lindex $rowidlist $row] $id]
5153 set olds [lindex $parentlist $row]
5154 set kid [lindex $displayorder $row]
5155 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5156 if {$kidx < 0} continue
5157 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5159 set px [lsearch -exact $nextrow $p]
5160 if {$px < 0} continue
5161 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5162 if {[lsearch -exact $ccross $p] >= 0} continue
5163 if {$x == $px + ($kidx < $px? -1: 1)} {
5165 } elseif {[lsearch -exact $cross $p] < 0} {
5172 return [concat $ccross {{}} $cross]
5175 proc assigncolor {id} {
5176 global colormap colors nextcolor
5177 global parents children children curview
5179 if {[info exists colormap($id)]} return
5180 set ncolors [llength $colors]
5181 if {[info exists children($curview,$id)]} {
5182 set kids $children($curview,$id)
5186 if {[llength $kids] == 1} {
5187 set child [lindex $kids 0]
5188 if {[info exists colormap($child)]
5189 && [llength $parents($curview,$child)] == 1} {
5190 set colormap($id) $colormap($child)
5196 foreach x [findcrossings $id] {
5198 # delimiter between corner crossings and other crossings
5199 if {[llength $badcolors] >= $ncolors - 1} break
5200 set origbad $badcolors
5202 if {[info exists colormap($x)]
5203 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5204 lappend badcolors $colormap($x)
5207 if {[llength $badcolors] >= $ncolors} {
5208 set badcolors $origbad
5210 set origbad $badcolors
5211 if {[llength $badcolors] < $ncolors - 1} {
5212 foreach child $kids {
5213 if {[info exists colormap($child)]
5214 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5215 lappend badcolors $colormap($child)
5217 foreach p $parents($curview,$child) {
5218 if {[info exists colormap($p)]
5219 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5220 lappend badcolors $colormap($p)
5224 if {[llength $badcolors] >= $ncolors} {
5225 set badcolors $origbad
5228 for {set i 0} {$i <= $ncolors} {incr i} {
5229 set c [lindex $colors $nextcolor]
5230 if {[incr nextcolor] >= $ncolors} {
5233 if {[lsearch -exact $badcolors $c]} break
5235 set colormap($id) $c
5238 proc bindline {t id} {
5241 $canv bind $t <Enter> "lineenter %x %y $id"
5242 $canv bind $t <Motion> "linemotion %x %y $id"
5243 $canv bind $t <Leave> "lineleave $id"
5244 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5247 proc drawtags {id x xt y1} {
5248 global idtags idheads idotherrefs mainhead
5249 global linespc lthickness
5250 global canv rowtextx curview fgcolor bgcolor
5255 if {[info exists idtags($id)]} {
5256 set marks $idtags($id)
5257 set ntags [llength $marks]
5259 if {[info exists idheads($id)]} {
5260 set marks [concat $marks $idheads($id)]
5261 set nheads [llength $idheads($id)]
5263 if {[info exists idotherrefs($id)]} {
5264 set marks [concat $marks $idotherrefs($id)]
5270 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5271 set yt [expr {$y1 - 0.5 * $linespc}]
5272 set yb [expr {$yt + $linespc - 1}]
5276 foreach tag $marks {
5278 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5279 set wid [font measure mainfontbold $tag]
5281 set wid [font measure mainfont $tag]
5285 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5287 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5288 -width $lthickness -fill black -tags tag.$id]
5290 foreach tag $marks x $xvals wid $wvals {
5291 set xl [expr {$x + $delta}]
5292 set xr [expr {$x + $delta + $wid + $lthickness}]
5294 if {[incr ntags -1] >= 0} {
5296 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5297 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5298 -width 1 -outline black -fill yellow -tags tag.$id]
5299 $canv bind $t <1> [list showtag $tag 1]
5300 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5302 # draw a head or other ref
5303 if {[incr nheads -1] >= 0} {
5305 if {$tag eq $mainhead} {
5306 set font mainfontbold
5311 set xl [expr {$xl - $delta/2}]
5312 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5313 -width 1 -outline black -fill $col -tags tag.$id
5314 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5315 set rwid [font measure mainfont $remoteprefix]
5316 set xi [expr {$x + 1}]
5317 set yti [expr {$yt + 1}]
5318 set xri [expr {$x + $rwid}]
5319 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5320 -width 0 -fill "#ffddaa" -tags tag.$id
5323 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5324 -font $font -tags [list tag.$id text]]
5326 $canv bind $t <1> [list showtag $tag 1]
5327 } elseif {$nheads >= 0} {
5328 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5334 proc xcoord {i level ln} {
5335 global canvx0 xspc1 xspc2
5337 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5338 if {$i > 0 && $i == $level} {
5339 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5340 } elseif {$i > $level} {
5341 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5346 proc show_status {msg} {
5350 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5351 -tags text -fill $fgcolor
5354 # Don't change the text pane cursor if it is currently the hand cursor,
5355 # showing that we are over a sha1 ID link.
5356 proc settextcursor {c} {
5357 global ctext curtextcursor
5359 if {[$ctext cget -cursor] == $curtextcursor} {
5360 $ctext config -cursor $c
5362 set curtextcursor $c
5365 proc nowbusy {what {name {}}} {
5366 global isbusy busyname statusw
5368 if {[array names isbusy] eq {}} {
5369 . config -cursor watch
5373 set busyname($what) $name
5375 $statusw conf -text $name
5379 proc notbusy {what} {
5380 global isbusy maincursor textcursor busyname statusw
5384 if {$busyname($what) ne {} &&
5385 [$statusw cget -text] eq $busyname($what)} {
5386 $statusw conf -text {}
5389 if {[array names isbusy] eq {}} {
5390 . config -cursor $maincursor
5391 settextcursor $textcursor
5395 proc findmatches {f} {
5396 global findtype findstring
5397 if {$findtype == [mc "Regexp"]} {
5398 set matches [regexp -indices -all -inline $findstring $f]
5401 if {$findtype == [mc "IgnCase"]} {
5402 set f [string tolower $f]
5403 set fs [string tolower $fs]
5407 set l [string length $fs]
5408 while {[set j [string first $fs $f $i]] >= 0} {
5409 lappend matches [list $j [expr {$j+$l-1}]]
5410 set i [expr {$j + $l}]
5416 proc dofind {{dirn 1} {wrap 1}} {
5417 global findstring findstartline findcurline selectedline numcommits
5418 global gdttype filehighlight fh_serial find_dirn findallowwrap
5420 if {[info exists find_dirn]} {
5421 if {$find_dirn == $dirn} return
5425 if {$findstring eq {} || $numcommits == 0} return
5426 if {![info exists selectedline]} {
5427 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5429 set findstartline $selectedline
5431 set findcurline $findstartline
5432 nowbusy finding [mc "Searching"]
5433 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5434 after cancel do_file_hl $fh_serial
5435 do_file_hl $fh_serial
5438 set findallowwrap $wrap
5442 proc stopfinding {} {
5443 global find_dirn findcurline fprogcoord
5445 if {[info exists find_dirn]} {
5455 global commitdata commitinfo numcommits findpattern findloc
5456 global findstartline findcurline findallowwrap
5457 global find_dirn gdttype fhighlights fprogcoord
5458 global curview varcorder vrownum varccommits vrowmod
5460 if {![info exists find_dirn]} {
5463 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5466 if {$find_dirn > 0} {
5468 if {$l >= $numcommits} {
5471 if {$l <= $findstartline} {
5472 set lim [expr {$findstartline + 1}]
5475 set moretodo $findallowwrap
5482 if {$l >= $findstartline} {
5483 set lim [expr {$findstartline - 1}]
5486 set moretodo $findallowwrap
5489 set n [expr {($lim - $l) * $find_dirn}]
5494 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5495 update_arcrows $curview
5499 set ai [bsearch $vrownum($curview) $l]
5500 set a [lindex $varcorder($curview) $ai]
5501 set arow [lindex $vrownum($curview) $ai]
5502 set ids [lindex $varccommits($curview,$a)]
5503 set arowend [expr {$arow + [llength $ids]}]
5504 if {$gdttype eq [mc "containing:"]} {
5505 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5506 if {$l < $arow || $l >= $arowend} {
5508 set a [lindex $varcorder($curview) $ai]
5509 set arow [lindex $vrownum($curview) $ai]
5510 set ids [lindex $varccommits($curview,$a)]
5511 set arowend [expr {$arow + [llength $ids]}]
5513 set id [lindex $ids [expr {$l - $arow}]]
5514 # shouldn't happen unless git log doesn't give all the commits...
5515 if {![info exists commitdata($id)] ||
5516 ![doesmatch $commitdata($id)]} {
5519 if {![info exists commitinfo($id)]} {
5522 set info $commitinfo($id)
5523 foreach f $info ty $fldtypes {
5524 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5533 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5534 if {$l < $arow || $l >= $arowend} {
5536 set a [lindex $varcorder($curview) $ai]
5537 set arow [lindex $vrownum($curview) $ai]
5538 set ids [lindex $varccommits($curview,$a)]
5539 set arowend [expr {$arow + [llength $ids]}]
5541 set id [lindex $ids [expr {$l - $arow}]]
5542 if {![info exists fhighlights($id)]} {
5543 # this sets fhighlights($id) to -1
5544 askfilehighlight $l $id
5546 if {$fhighlights($id) > 0} {
5550 if {$fhighlights($id) < 0} {
5553 set findcurline [expr {$l - $find_dirn}]
5558 if {$found || ($domore && !$moretodo)} {
5574 set findcurline [expr {$l - $find_dirn}]
5576 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5580 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5585 proc findselectline {l} {
5586 global findloc commentend ctext findcurline markingmatches gdttype
5588 set markingmatches 1
5591 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5592 # highlight the matches in the comments
5593 set f [$ctext get 1.0 $commentend]
5594 set matches [findmatches $f]
5595 foreach match $matches {
5596 set start [lindex $match 0]
5597 set end [expr {[lindex $match 1] + 1}]
5598 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5604 # mark the bits of a headline or author that match a find string
5605 proc markmatches {canv l str tag matches font row} {
5608 set bbox [$canv bbox $tag]
5609 set x0 [lindex $bbox 0]
5610 set y0 [lindex $bbox 1]
5611 set y1 [lindex $bbox 3]
5612 foreach match $matches {
5613 set start [lindex $match 0]
5614 set end [lindex $match 1]
5615 if {$start > $end} continue
5616 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5617 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5618 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5619 [expr {$x0+$xlen+2}] $y1 \
5620 -outline {} -tags [list match$l matches] -fill yellow]
5622 if {[info exists selectedline] && $row == $selectedline} {
5623 $canv raise $t secsel
5628 proc unmarkmatches {} {
5629 global markingmatches
5631 allcanvs delete matches
5632 set markingmatches 0
5636 proc selcanvline {w x y} {
5637 global canv canvy0 ctext linespc
5639 set ymax [lindex [$canv cget -scrollregion] 3]
5640 if {$ymax == {}} return
5641 set yfrac [lindex [$canv yview] 0]
5642 set y [expr {$y + $yfrac * $ymax}]
5643 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5648 set xmax [lindex [$canv cget -scrollregion] 2]
5649 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5650 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5656 proc commit_descriptor {p} {
5658 if {![info exists commitinfo($p)]} {
5662 if {[llength $commitinfo($p)] > 1} {
5663 set l [lindex $commitinfo($p) 0]
5668 # append some text to the ctext widget, and make any SHA1 ID
5669 # that we know about be a clickable link.
5670 proc appendwithlinks {text tags} {
5671 global ctext linknum curview pendinglinks
5673 set start [$ctext index "end - 1c"]
5674 $ctext insert end $text $tags
5675 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5679 set linkid [string range $text $s $e]
5681 $ctext tag delete link$linknum
5682 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5683 setlink $linkid link$linknum
5688 proc setlink {id lk} {
5689 global curview ctext pendinglinks commitinterest
5691 if {[commitinview $id $curview]} {
5692 $ctext tag conf $lk -foreground blue -underline 1
5693 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5694 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5695 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5697 lappend pendinglinks($id) $lk
5698 lappend commitinterest($id) {makelink %I}
5702 proc makelink {id} {
5705 if {![info exists pendinglinks($id)]} return
5706 foreach lk $pendinglinks($id) {
5709 unset pendinglinks($id)
5712 proc linkcursor {w inc} {
5713 global linkentercount curtextcursor
5715 if {[incr linkentercount $inc] > 0} {
5716 $w configure -cursor hand2
5718 $w configure -cursor $curtextcursor
5719 if {$linkentercount < 0} {
5720 set linkentercount 0
5725 proc viewnextline {dir} {
5729 set ymax [lindex [$canv cget -scrollregion] 3]
5730 set wnow [$canv yview]
5731 set wtop [expr {[lindex $wnow 0] * $ymax}]
5732 set newtop [expr {$wtop + $dir * $linespc}]
5735 } elseif {$newtop > $ymax} {
5738 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5741 # add a list of tag or branch names at position pos
5742 # returns the number of names inserted
5743 proc appendrefs {pos ids var} {
5744 global ctext linknum curview $var maxrefs
5746 if {[catch {$ctext index $pos}]} {
5749 $ctext conf -state normal
5750 $ctext delete $pos "$pos lineend"
5753 foreach tag [set $var\($id\)] {
5754 lappend tags [list $tag $id]
5757 if {[llength $tags] > $maxrefs} {
5758 $ctext insert $pos "many ([llength $tags])"
5760 set tags [lsort -index 0 -decreasing $tags]
5763 set id [lindex $ti 1]
5766 $ctext tag delete $lk
5767 $ctext insert $pos $sep
5768 $ctext insert $pos [lindex $ti 0] $lk
5773 $ctext conf -state disabled
5774 return [llength $tags]
5777 # called when we have finished computing the nearby tags
5778 proc dispneartags {delay} {
5779 global selectedline currentid showneartags tagphase
5781 if {![info exists selectedline] || !$showneartags} return
5782 after cancel dispnexttag
5784 after 200 dispnexttag
5787 after idle dispnexttag
5792 proc dispnexttag {} {
5793 global selectedline currentid showneartags tagphase ctext
5795 if {![info exists selectedline] || !$showneartags} return
5796 switch -- $tagphase {
5798 set dtags [desctags $currentid]
5800 appendrefs precedes $dtags idtags
5804 set atags [anctags $currentid]
5806 appendrefs follows $atags idtags
5810 set dheads [descheads $currentid]
5811 if {$dheads ne {}} {
5812 if {[appendrefs branch $dheads idheads] > 1
5813 && [$ctext get "branch -3c"] eq "h"} {
5814 # turn "Branch" into "Branches"
5815 $ctext conf -state normal
5816 $ctext insert "branch -2c" "es"
5817 $ctext conf -state disabled
5822 if {[incr tagphase] <= 2} {
5823 after idle dispnexttag
5827 proc make_secsel {l} {
5828 global linehtag linentag linedtag canv canv2 canv3
5830 if {![info exists linehtag($l)]} return
5832 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5833 -tags secsel -fill [$canv cget -selectbackground]]
5835 $canv2 delete secsel
5836 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5837 -tags secsel -fill [$canv2 cget -selectbackground]]
5839 $canv3 delete secsel
5840 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5841 -tags secsel -fill [$canv3 cget -selectbackground]]
5845 proc selectline {l isnew} {
5846 global canv ctext commitinfo selectedline
5847 global canvy0 linespc parents children curview
5848 global currentid sha1entry
5849 global commentend idtags linknum
5850 global mergemax numcommits pending_select
5851 global cmitmode showneartags allcommits
5852 global targetrow targetid lastscrollrows
5855 catch {unset pending_select}
5860 if {$l < 0 || $l >= $numcommits} return
5861 set id [commitonrow $l]
5866 if {$lastscrollrows < $numcommits} {
5870 set y [expr {$canvy0 + $l * $linespc}]
5871 set ymax [lindex [$canv cget -scrollregion] 3]
5872 set ytop [expr {$y - $linespc - 1}]
5873 set ybot [expr {$y + $linespc + 1}]
5874 set wnow [$canv yview]
5875 set wtop [expr {[lindex $wnow 0] * $ymax}]
5876 set wbot [expr {[lindex $wnow 1] * $ymax}]
5877 set wh [expr {$wbot - $wtop}]
5879 if {$ytop < $wtop} {
5880 if {$ybot < $wtop} {
5881 set newtop [expr {$y - $wh / 2.0}]
5884 if {$newtop > $wtop - $linespc} {
5885 set newtop [expr {$wtop - $linespc}]
5888 } elseif {$ybot > $wbot} {
5889 if {$ytop > $wbot} {
5890 set newtop [expr {$y - $wh / 2.0}]
5892 set newtop [expr {$ybot - $wh}]
5893 if {$newtop < $wtop + $linespc} {
5894 set newtop [expr {$wtop + $linespc}]
5898 if {$newtop != $wtop} {
5902 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5909 addtohistory [list selbyid $id]
5912 $sha1entry delete 0 end
5913 $sha1entry insert 0 $id
5915 $sha1entry selection from 0
5916 $sha1entry selection to end
5920 $ctext conf -state normal
5923 if {![info exists commitinfo($id)]} {
5926 set info $commitinfo($id)
5927 set date [formatdate [lindex $info 2]]
5928 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5929 set date [formatdate [lindex $info 4]]
5930 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5931 if {[info exists idtags($id)]} {
5932 $ctext insert end [mc "Tags:"]
5933 foreach tag $idtags($id) {
5934 $ctext insert end " $tag"
5936 $ctext insert end "\n"
5940 set olds $parents($curview,$id)
5941 if {[llength $olds] > 1} {
5944 if {$np >= $mergemax} {
5949 $ctext insert end "[mc "Parent"]: " $tag
5950 appendwithlinks [commit_descriptor $p] {}
5955 append headers "[mc "Parent"]: [commit_descriptor $p]"
5959 foreach c $children($curview,$id) {
5960 append headers "[mc "Child"]: [commit_descriptor $c]"
5963 # make anything that looks like a SHA1 ID be a clickable link
5964 appendwithlinks $headers {}
5965 if {$showneartags} {
5966 if {![info exists allcommits]} {
5969 $ctext insert end "[mc "Branch"]: "
5970 $ctext mark set branch "end -1c"
5971 $ctext mark gravity branch left
5972 $ctext insert end "\n[mc "Follows"]: "
5973 $ctext mark set follows "end -1c"
5974 $ctext mark gravity follows left
5975 $ctext insert end "\n[mc "Precedes"]: "
5976 $ctext mark set precedes "end -1c"
5977 $ctext mark gravity precedes left
5978 $ctext insert end "\n"
5981 $ctext insert end "\n"
5982 set comment [lindex $info 5]
5983 if {[string first "\r" $comment] >= 0} {
5984 set comment [string map {"\r" "\n "} $comment]
5986 appendwithlinks $comment {comment}
5988 $ctext tag remove found 1.0 end
5989 $ctext conf -state disabled
5990 set commentend [$ctext index "end - 1c"]
5992 init_flist [mc "Comments"]
5993 if {$cmitmode eq "tree"} {
5995 } elseif {[llength $olds] <= 1} {
6002 proc selfirstline {} {
6007 proc sellastline {} {
6010 set l [expr {$numcommits - 1}]
6014 proc selnextline {dir} {
6017 if {![info exists selectedline]} return
6018 set l [expr {$selectedline + $dir}]
6023 proc selnextpage {dir} {
6024 global canv linespc selectedline numcommits
6026 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6030 allcanvs yview scroll [expr {$dir * $lpp}] units
6032 if {![info exists selectedline]} return
6033 set l [expr {$selectedline + $dir * $lpp}]
6036 } elseif {$l >= $numcommits} {
6037 set l [expr $numcommits - 1]
6043 proc unselectline {} {
6044 global selectedline currentid
6046 catch {unset selectedline}
6047 catch {unset currentid}
6048 allcanvs delete secsel
6052 proc reselectline {} {
6055 if {[info exists selectedline]} {
6056 selectline $selectedline 0
6060 proc addtohistory {cmd} {
6061 global history historyindex curview
6063 set elt [list $curview $cmd]
6064 if {$historyindex > 0
6065 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6069 if {$historyindex < [llength $history]} {
6070 set history [lreplace $history $historyindex end $elt]
6072 lappend history $elt
6075 if {$historyindex > 1} {
6076 .tf.bar.leftbut conf -state normal
6078 .tf.bar.leftbut conf -state disabled
6080 .tf.bar.rightbut conf -state disabled
6086 set view [lindex $elt 0]
6087 set cmd [lindex $elt 1]
6088 if {$curview != $view} {
6095 global history historyindex
6098 if {$historyindex > 1} {
6099 incr historyindex -1
6100 godo [lindex $history [expr {$historyindex - 1}]]
6101 .tf.bar.rightbut conf -state normal
6103 if {$historyindex <= 1} {
6104 .tf.bar.leftbut conf -state disabled
6109 global history historyindex
6112 if {$historyindex < [llength $history]} {
6113 set cmd [lindex $history $historyindex]
6116 .tf.bar.leftbut conf -state normal
6118 if {$historyindex >= [llength $history]} {
6119 .tf.bar.rightbut conf -state disabled
6124 global treefilelist treeidlist diffids diffmergeid treepending
6125 global nullid nullid2
6128 catch {unset diffmergeid}
6129 if {![info exists treefilelist($id)]} {
6130 if {![info exists treepending]} {
6131 if {$id eq $nullid} {
6132 set cmd [list | git ls-files]
6133 } elseif {$id eq $nullid2} {
6134 set cmd [list | git ls-files --stage -t]
6136 set cmd [list | git ls-tree -r $id]
6138 if {[catch {set gtf [open $cmd r]}]} {
6142 set treefilelist($id) {}
6143 set treeidlist($id) {}
6144 fconfigure $gtf -blocking 0
6145 filerun $gtf [list gettreeline $gtf $id]
6152 proc gettreeline {gtf id} {
6153 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6156 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6157 if {$diffids eq $nullid} {
6160 set i [string first "\t" $line]
6161 if {$i < 0} continue
6162 set fname [string range $line [expr {$i+1}] end]
6163 set line [string range $line 0 [expr {$i-1}]]
6164 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6165 set sha1 [lindex $line 2]
6166 if {[string index $fname 0] eq "\""} {
6167 set fname [lindex $fname 0]
6169 lappend treeidlist($id) $sha1
6171 lappend treefilelist($id) $fname
6174 return [expr {$nl >= 1000? 2: 1}]
6178 if {$cmitmode ne "tree"} {
6179 if {![info exists diffmergeid]} {
6180 gettreediffs $diffids
6182 } elseif {$id ne $diffids} {
6191 global treefilelist treeidlist diffids nullid nullid2
6192 global ctext commentend
6194 set i [lsearch -exact $treefilelist($diffids) $f]
6196 puts "oops, $f not in list for id $diffids"
6199 if {$diffids eq $nullid} {
6200 if {[catch {set bf [open $f r]} err]} {
6201 puts "oops, can't read $f: $err"
6205 set blob [lindex $treeidlist($diffids) $i]
6206 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6207 puts "oops, error reading blob $blob: $err"
6211 fconfigure $bf -blocking 0
6212 filerun $bf [list getblobline $bf $diffids]
6213 $ctext config -state normal
6214 clear_ctext $commentend
6215 $ctext insert end "\n"
6216 $ctext insert end "$f\n" filesep
6217 $ctext config -state disabled
6218 $ctext yview $commentend
6222 proc getblobline {bf id} {
6223 global diffids cmitmode ctext
6225 if {$id ne $diffids || $cmitmode ne "tree"} {
6229 $ctext config -state normal
6231 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6232 $ctext insert end "$line\n"
6235 # delete last newline
6236 $ctext delete "end - 2c" "end - 1c"
6240 $ctext config -state disabled
6241 return [expr {$nl >= 1000? 2: 1}]
6244 proc mergediff {id} {
6245 global diffmergeid mdifffd
6249 global limitdiffs vfilelimit curview
6253 # this doesn't seem to actually affect anything...
6254 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6255 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6256 set cmd [concat $cmd -- $vfilelimit($curview)]
6258 if {[catch {set mdf [open $cmd r]} err]} {
6259 error_popup "[mc "Error getting merge diffs:"] $err"
6262 fconfigure $mdf -blocking 0
6263 set mdifffd($id) $mdf
6264 set np [llength $parents($curview,$id)]
6266 filerun $mdf [list getmergediffline $mdf $id $np]
6269 proc getmergediffline {mdf id np} {
6270 global diffmergeid ctext cflist mergemax
6271 global difffilestart mdifffd
6273 $ctext conf -state normal
6275 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6276 if {![info exists diffmergeid] || $id != $diffmergeid
6277 || $mdf != $mdifffd($id)} {
6281 if {[regexp {^diff --cc (.*)} $line match fname]} {
6282 # start of a new file
6283 $ctext insert end "\n"
6284 set here [$ctext index "end - 1c"]
6285 lappend difffilestart $here
6286 add_flist [list $fname]
6287 set l [expr {(78 - [string length $fname]) / 2}]
6288 set pad [string range "----------------------------------------" 1 $l]
6289 $ctext insert end "$pad $fname $pad\n" filesep
6290 } elseif {[regexp {^@@} $line]} {
6291 $ctext insert end "$line\n" hunksep
6292 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6295 # parse the prefix - one ' ', '-' or '+' for each parent
6300 for {set j 0} {$j < $np} {incr j} {
6301 set c [string range $line $j $j]
6304 } elseif {$c == "-"} {
6306 } elseif {$c == "+"} {
6315 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6316 # line doesn't appear in result, parents in $minuses have the line
6317 set num [lindex $minuses 0]
6318 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6319 # line appears in result, parents in $pluses don't have the line
6320 lappend tags mresult
6321 set num [lindex $spaces 0]
6324 if {$num >= $mergemax} {
6329 $ctext insert end "$line\n" $tags
6332 $ctext conf -state disabled
6337 return [expr {$nr >= 1000? 2: 1}]
6340 proc startdiff {ids} {
6341 global treediffs diffids treepending diffmergeid nullid nullid2
6345 catch {unset diffmergeid}
6346 if {![info exists treediffs($ids)] ||
6347 [lsearch -exact $ids $nullid] >= 0 ||
6348 [lsearch -exact $ids $nullid2] >= 0} {
6349 if {![info exists treepending]} {
6357 proc path_filter {filter name} {
6359 set l [string length $p]
6360 if {[string index $p end] eq "/"} {
6361 if {[string compare -length $l $p $name] == 0} {
6365 if {[string compare -length $l $p $name] == 0 &&
6366 ([string length $name] == $l ||
6367 [string index $name $l] eq "/")} {
6375 proc addtocflist {ids} {
6378 add_flist $treediffs($ids)
6382 proc diffcmd {ids flags} {
6383 global nullid nullid2
6385 set i [lsearch -exact $ids $nullid]
6386 set j [lsearch -exact $ids $nullid2]
6388 if {[llength $ids] > 1 && $j < 0} {
6389 # comparing working directory with some specific revision
6390 set cmd [concat | git diff-index $flags]
6392 lappend cmd -R [lindex $ids 1]
6394 lappend cmd [lindex $ids 0]
6397 # comparing working directory with index
6398 set cmd [concat | git diff-files $flags]
6403 } elseif {$j >= 0} {
6404 set cmd [concat | git diff-index --cached $flags]
6405 if {[llength $ids] > 1} {
6406 # comparing index with specific revision
6408 lappend cmd -R [lindex $ids 1]
6410 lappend cmd [lindex $ids 0]
6413 # comparing index with HEAD
6417 set cmd [concat | git diff-tree -r $flags $ids]
6422 proc gettreediffs {ids} {
6423 global treediff treepending
6425 set treepending $ids
6427 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6428 fconfigure $gdtf -blocking 0
6429 filerun $gdtf [list gettreediffline $gdtf $ids]
6432 proc gettreediffline {gdtf ids} {
6433 global treediff treediffs treepending diffids diffmergeid
6434 global cmitmode vfilelimit curview limitdiffs
6437 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6438 set i [string first "\t" $line]
6440 set file [string range $line [expr {$i+1}] end]
6441 if {[string index $file 0] eq "\""} {
6442 set file [lindex $file 0]
6444 lappend treediff $file
6448 return [expr {$nr >= 1000? 2: 1}]
6451 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6453 foreach f $treediff {
6454 if {[path_filter $vfilelimit($curview) $f]} {
6458 set treediffs($ids) $flist
6460 set treediffs($ids) $treediff
6463 if {$cmitmode eq "tree"} {
6465 } elseif {$ids != $diffids} {
6466 if {![info exists diffmergeid]} {
6467 gettreediffs $diffids
6475 # empty string or positive integer
6476 proc diffcontextvalidate {v} {
6477 return [regexp {^(|[1-9][0-9]*)$} $v]
6480 proc diffcontextchange {n1 n2 op} {
6481 global diffcontextstring diffcontext
6483 if {[string is integer -strict $diffcontextstring]} {
6484 if {$diffcontextstring > 0} {
6485 set diffcontext $diffcontextstring
6491 proc changeignorespace {} {
6495 proc getblobdiffs {ids} {
6496 global blobdifffd diffids env
6497 global diffinhdr treediffs
6500 global limitdiffs vfilelimit curview
6502 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6506 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6507 set cmd [concat $cmd -- $vfilelimit($curview)]
6509 if {[catch {set bdf [open $cmd r]} err]} {
6510 puts "error getting diffs: $err"
6514 fconfigure $bdf -blocking 0
6515 set blobdifffd($ids) $bdf
6516 filerun $bdf [list getblobdiffline $bdf $diffids]
6519 proc setinlist {var i val} {
6522 while {[llength [set $var]] < $i} {
6525 if {[llength [set $var]] == $i} {
6532 proc makediffhdr {fname ids} {
6533 global ctext curdiffstart treediffs
6535 set i [lsearch -exact $treediffs($ids) $fname]
6537 setinlist difffilestart $i $curdiffstart
6539 set l [expr {(78 - [string length $fname]) / 2}]
6540 set pad [string range "----------------------------------------" 1 $l]
6541 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6544 proc getblobdiffline {bdf ids} {
6545 global diffids blobdifffd ctext curdiffstart
6546 global diffnexthead diffnextnote difffilestart
6547 global diffinhdr treediffs
6550 $ctext conf -state normal
6551 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6552 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6556 if {![string compare -length 11 "diff --git " $line]} {
6557 # trim off "diff --git "
6558 set line [string range $line 11 end]
6560 # start of a new file
6561 $ctext insert end "\n"
6562 set curdiffstart [$ctext index "end - 1c"]
6563 $ctext insert end "\n" filesep
6564 # If the name hasn't changed the length will be odd,
6565 # the middle char will be a space, and the two bits either
6566 # side will be a/name and b/name, or "a/name" and "b/name".
6567 # If the name has changed we'll get "rename from" and
6568 # "rename to" or "copy from" and "copy to" lines following this,
6569 # and we'll use them to get the filenames.
6570 # This complexity is necessary because spaces in the filename(s)
6571 # don't get escaped.
6572 set l [string length $line]
6573 set i [expr {$l / 2}]
6574 if {!(($l & 1) && [string index $line $i] eq " " &&
6575 [string range $line 2 [expr {$i - 1}]] eq \
6576 [string range $line [expr {$i + 3}] end])} {
6579 # unescape if quoted and chop off the a/ from the front
6580 if {[string index $line 0] eq "\""} {
6581 set fname [string range [lindex $line 0] 2 end]
6583 set fname [string range $line 2 [expr {$i - 1}]]
6585 makediffhdr $fname $ids
6587 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6588 $line match f1l f1c f2l f2c rest]} {
6589 $ctext insert end "$line\n" hunksep
6592 } elseif {$diffinhdr} {
6593 if {![string compare -length 12 "rename from " $line]} {
6594 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6595 if {[string index $fname 0] eq "\""} {
6596 set fname [lindex $fname 0]
6598 set i [lsearch -exact $treediffs($ids) $fname]
6600 setinlist difffilestart $i $curdiffstart
6602 } elseif {![string compare -length 10 $line "rename to "] ||
6603 ![string compare -length 8 $line "copy to "]} {
6604 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6605 if {[string index $fname 0] eq "\""} {
6606 set fname [lindex $fname 0]
6608 makediffhdr $fname $ids
6609 } elseif {[string compare -length 3 $line "---"] == 0} {
6612 } elseif {[string compare -length 3 $line "+++"] == 0} {
6616 $ctext insert end "$line\n" filesep
6619 set x [string range $line 0 0]
6620 if {$x == "-" || $x == "+"} {
6621 set tag [expr {$x == "+"}]
6622 $ctext insert end "$line\n" d$tag
6623 } elseif {$x == " "} {
6624 $ctext insert end "$line\n"
6626 # "\ No newline at end of file",
6627 # or something else we don't recognize
6628 $ctext insert end "$line\n" hunksep
6632 $ctext conf -state disabled
6637 return [expr {$nr >= 1000? 2: 1}]
6640 proc changediffdisp {} {
6641 global ctext diffelide
6643 $ctext tag conf d0 -elide [lindex $diffelide 0]
6644 $ctext tag conf d1 -elide [lindex $diffelide 1]
6647 proc highlightfile {loc cline} {
6648 global ctext cflist cflist_top
6651 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6652 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6653 $cflist see $cline.0
6654 set cflist_top $cline
6658 global difffilestart ctext cmitmode
6660 if {$cmitmode eq "tree"} return
6663 set here [$ctext index @0,0]
6664 foreach loc $difffilestart {
6665 if {[$ctext compare $loc >= $here]} {
6666 highlightfile $prev $prevline
6672 highlightfile $prev $prevline
6676 global difffilestart ctext cmitmode
6678 if {$cmitmode eq "tree"} return
6679 set here [$ctext index @0,0]
6681 foreach loc $difffilestart {
6683 if {[$ctext compare $loc > $here]} {
6684 highlightfile $loc $line
6690 proc clear_ctext {{first 1.0}} {
6691 global ctext smarktop smarkbot
6694 set l [lindex [split $first .] 0]
6695 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6698 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6701 $ctext delete $first end
6702 if {$first eq "1.0"} {
6703 catch {unset pendinglinks}
6707 proc settabs {{firstab {}}} {
6708 global firsttabstop tabstop ctext have_tk85
6710 if {$firstab ne {} && $have_tk85} {
6711 set firsttabstop $firstab
6713 set w [font measure textfont "0"]
6714 if {$firsttabstop != 0} {
6715 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6716 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6717 } elseif {$have_tk85 || $tabstop != 8} {
6718 $ctext conf -tabs [expr {$tabstop * $w}]
6720 $ctext conf -tabs {}
6724 proc incrsearch {name ix op} {
6725 global ctext searchstring searchdirn
6727 $ctext tag remove found 1.0 end
6728 if {[catch {$ctext index anchor}]} {
6729 # no anchor set, use start of selection, or of visible area
6730 set sel [$ctext tag ranges sel]
6732 $ctext mark set anchor [lindex $sel 0]
6733 } elseif {$searchdirn eq "-forwards"} {
6734 $ctext mark set anchor @0,0
6736 $ctext mark set anchor @0,[winfo height $ctext]
6739 if {$searchstring ne {}} {
6740 set here [$ctext search $searchdirn -- $searchstring anchor]
6749 global sstring ctext searchstring searchdirn
6752 $sstring icursor end
6753 set searchdirn -forwards
6754 if {$searchstring ne {}} {
6755 set sel [$ctext tag ranges sel]
6757 set start "[lindex $sel 0] + 1c"
6758 } elseif {[catch {set start [$ctext index anchor]}]} {
6761 set match [$ctext search -count mlen -- $searchstring $start]
6762 $ctext tag remove sel 1.0 end
6768 set mend "$match + $mlen c"
6769 $ctext tag add sel $match $mend
6770 $ctext mark unset anchor
6774 proc dosearchback {} {
6775 global sstring ctext searchstring searchdirn
6778 $sstring icursor end
6779 set searchdirn -backwards
6780 if {$searchstring ne {}} {
6781 set sel [$ctext tag ranges sel]
6783 set start [lindex $sel 0]
6784 } elseif {[catch {set start [$ctext index anchor]}]} {
6785 set start @0,[winfo height $ctext]
6787 set match [$ctext search -backwards -count ml -- $searchstring $start]
6788 $ctext tag remove sel 1.0 end
6794 set mend "$match + $ml c"
6795 $ctext tag add sel $match $mend
6796 $ctext mark unset anchor
6800 proc searchmark {first last} {
6801 global ctext searchstring
6805 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6806 if {$match eq {}} break
6807 set mend "$match + $mlen c"
6808 $ctext tag add found $match $mend
6812 proc searchmarkvisible {doall} {
6813 global ctext smarktop smarkbot
6815 set topline [lindex [split [$ctext index @0,0] .] 0]
6816 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6817 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6818 # no overlap with previous
6819 searchmark $topline $botline
6820 set smarktop $topline
6821 set smarkbot $botline
6823 if {$topline < $smarktop} {
6824 searchmark $topline [expr {$smarktop-1}]
6825 set smarktop $topline
6827 if {$botline > $smarkbot} {
6828 searchmark [expr {$smarkbot+1}] $botline
6829 set smarkbot $botline
6834 proc scrolltext {f0 f1} {
6837 .bleft.bottom.sb set $f0 $f1
6838 if {$searchstring ne {}} {
6844 global linespc charspc canvx0 canvy0
6845 global xspc1 xspc2 lthickness
6847 set linespc [font metrics mainfont -linespace]
6848 set charspc [font measure mainfont "m"]
6849 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6850 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6851 set lthickness [expr {int($linespc / 9) + 1}]
6852 set xspc1(0) $linespc
6860 set ymax [lindex [$canv cget -scrollregion] 3]
6861 if {$ymax eq {} || $ymax == 0} return
6862 set span [$canv yview]
6865 allcanvs yview moveto [lindex $span 0]
6867 if {[info exists selectedline]} {
6868 selectline $selectedline 0
6869 allcanvs yview moveto [lindex $span 0]
6873 proc parsefont {f n} {
6876 set fontattr($f,family) [lindex $n 0]
6878 if {$s eq {} || $s == 0} {
6881 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6883 set fontattr($f,size) $s
6884 set fontattr($f,weight) normal
6885 set fontattr($f,slant) roman
6886 foreach style [lrange $n 2 end] {
6889 "bold" {set fontattr($f,weight) $style}
6891 "italic" {set fontattr($f,slant) $style}
6896 proc fontflags {f {isbold 0}} {
6899 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6900 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6901 -slant $fontattr($f,slant)]
6907 set n [list $fontattr($f,family) $fontattr($f,size)]
6908 if {$fontattr($f,weight) eq "bold"} {
6911 if {$fontattr($f,slant) eq "italic"} {
6917 proc incrfont {inc} {
6918 global mainfont textfont ctext canv cflist showrefstop
6919 global stopped entries fontattr
6922 set s $fontattr(mainfont,size)
6927 set fontattr(mainfont,size) $s
6928 font config mainfont -size $s
6929 font config mainfontbold -size $s
6930 set mainfont [fontname mainfont]
6931 set s $fontattr(textfont,size)
6936 set fontattr(textfont,size) $s
6937 font config textfont -size $s
6938 font config textfontbold -size $s
6939 set textfont [fontname textfont]
6946 global sha1entry sha1string
6947 if {[string length $sha1string] == 40} {
6948 $sha1entry delete 0 end
6952 proc sha1change {n1 n2 op} {
6953 global sha1string currentid sha1but
6954 if {$sha1string == {}
6955 || ([info exists currentid] && $sha1string == $currentid)} {
6960 if {[$sha1but cget -state] == $state} return
6961 if {$state == "normal"} {
6962 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6964 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6968 proc gotocommit {} {
6969 global sha1string tagids headids curview varcid
6971 if {$sha1string == {}
6972 || ([info exists currentid] && $sha1string == $currentid)} return
6973 if {[info exists tagids($sha1string)]} {
6974 set id $tagids($sha1string)
6975 } elseif {[info exists headids($sha1string)]} {
6976 set id $headids($sha1string)
6978 set id [string tolower $sha1string]
6979 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6980 set matches [array names varcid "$curview,$id*"]
6981 if {$matches ne {}} {
6982 if {[llength $matches] > 1} {
6983 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6986 set id [lindex [split [lindex $matches 0] ","] 1]
6990 if {[commitinview $id $curview]} {
6991 selectline [rowofcommit $id] 1
6994 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6995 set msg [mc "SHA1 id %s is not known" $sha1string]
6997 set msg [mc "Tag/Head %s is not known" $sha1string]
7002 proc lineenter {x y id} {
7003 global hoverx hovery hoverid hovertimer
7004 global commitinfo canv
7006 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7010 if {[info exists hovertimer]} {
7011 after cancel $hovertimer
7013 set hovertimer [after 500 linehover]
7017 proc linemotion {x y id} {
7018 global hoverx hovery hoverid hovertimer
7020 if {[info exists hoverid] && $id == $hoverid} {
7023 if {[info exists hovertimer]} {
7024 after cancel $hovertimer
7026 set hovertimer [after 500 linehover]
7030 proc lineleave {id} {
7031 global hoverid hovertimer canv
7033 if {[info exists hoverid] && $id == $hoverid} {
7035 if {[info exists hovertimer]} {
7036 after cancel $hovertimer
7044 global hoverx hovery hoverid hovertimer
7045 global canv linespc lthickness
7048 set text [lindex $commitinfo($hoverid) 0]
7049 set ymax [lindex [$canv cget -scrollregion] 3]
7050 if {$ymax == {}} return
7051 set yfrac [lindex [$canv yview] 0]
7052 set x [expr {$hoverx + 2 * $linespc}]
7053 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7054 set x0 [expr {$x - 2 * $lthickness}]
7055 set y0 [expr {$y - 2 * $lthickness}]
7056 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7057 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7058 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7059 -fill \#ffff80 -outline black -width 1 -tags hover]
7061 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7066 proc clickisonarrow {id y} {
7069 set ranges [rowranges $id]
7070 set thresh [expr {2 * $lthickness + 6}]
7071 set n [expr {[llength $ranges] - 1}]
7072 for {set i 1} {$i < $n} {incr i} {
7073 set row [lindex $ranges $i]
7074 if {abs([yc $row] - $y) < $thresh} {
7081 proc arrowjump {id n y} {
7084 # 1 <-> 2, 3 <-> 4, etc...
7085 set n [expr {(($n - 1) ^ 1) + 1}]
7086 set row [lindex [rowranges $id] $n]
7088 set ymax [lindex [$canv cget -scrollregion] 3]
7089 if {$ymax eq {} || $ymax <= 0} return
7090 set view [$canv yview]
7091 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7092 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7096 allcanvs yview moveto $yfrac
7099 proc lineclick {x y id isnew} {
7100 global ctext commitinfo children canv thickerline curview
7102 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7107 # draw this line thicker than normal
7111 set ymax [lindex [$canv cget -scrollregion] 3]
7112 if {$ymax eq {}} return
7113 set yfrac [lindex [$canv yview] 0]
7114 set y [expr {$y + $yfrac * $ymax}]
7116 set dirn [clickisonarrow $id $y]
7118 arrowjump $id $dirn $y
7123 addtohistory [list lineclick $x $y $id 0]
7125 # fill the details pane with info about this line
7126 $ctext conf -state normal
7129 $ctext insert end "[mc "Parent"]:\t"
7130 $ctext insert end $id link0
7132 set info $commitinfo($id)
7133 $ctext insert end "\n\t[lindex $info 0]\n"
7134 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7135 set date [formatdate [lindex $info 2]]
7136 $ctext insert end "\t[mc "Date"]:\t$date\n"
7137 set kids $children($curview,$id)
7139 $ctext insert end "\n[mc "Children"]:"
7141 foreach child $kids {
7143 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7144 set info $commitinfo($child)
7145 $ctext insert end "\n\t"
7146 $ctext insert end $child link$i
7147 setlink $child link$i
7148 $ctext insert end "\n\t[lindex $info 0]"
7149 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7150 set date [formatdate [lindex $info 2]]
7151 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7154 $ctext conf -state disabled
7158 proc normalline {} {
7160 if {[info exists thickerline]} {
7169 if {[commitinview $id $curview]} {
7170 selectline [rowofcommit $id] 1
7176 if {![info exists startmstime]} {
7177 set startmstime [clock clicks -milliseconds]
7179 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7182 proc rowmenu {x y id} {
7183 global rowctxmenu selectedline rowmenuid curview
7184 global nullid nullid2 fakerowmenu mainhead
7188 if {![info exists selectedline]
7189 || [rowofcommit $id] eq $selectedline} {
7194 if {$id ne $nullid && $id ne $nullid2} {
7195 set menu $rowctxmenu
7196 if {$mainhead ne {}} {
7197 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7199 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7202 set menu $fakerowmenu
7204 $menu entryconfigure [mc "Diff this -> selected"] -state $state
7205 $menu entryconfigure [mc "Diff selected -> this"] -state $state
7206 $menu entryconfigure [mc "Make patch"] -state $state
7207 tk_popup $menu $x $y
7210 proc diffvssel {dirn} {
7211 global rowmenuid selectedline
7213 if {![info exists selectedline]} return
7215 set oldid [commitonrow $selectedline]
7216 set newid $rowmenuid
7218 set oldid $rowmenuid
7219 set newid [commitonrow $selectedline]
7221 addtohistory [list doseldiff $oldid $newid]
7222 doseldiff $oldid $newid
7225 proc doseldiff {oldid newid} {
7229 $ctext conf -state normal
7231 init_flist [mc "Top"]
7232 $ctext insert end "[mc "From"] "
7233 $ctext insert end $oldid link0
7234 setlink $oldid link0
7235 $ctext insert end "\n "
7236 $ctext insert end [lindex $commitinfo($oldid) 0]
7237 $ctext insert end "\n\n[mc "To"] "
7238 $ctext insert end $newid link1
7239 setlink $newid link1
7240 $ctext insert end "\n "
7241 $ctext insert end [lindex $commitinfo($newid) 0]
7242 $ctext insert end "\n"
7243 $ctext conf -state disabled
7244 $ctext tag remove found 1.0 end
7245 startdiff [list $oldid $newid]
7249 global rowmenuid currentid commitinfo patchtop patchnum
7251 if {![info exists currentid]} return
7252 set oldid $currentid
7253 set oldhead [lindex $commitinfo($oldid) 0]
7254 set newid $rowmenuid
7255 set newhead [lindex $commitinfo($newid) 0]
7258 catch {destroy $top}
7260 label $top.title -text [mc "Generate patch"]
7261 grid $top.title - -pady 10
7262 label $top.from -text [mc "From:"]
7263 entry $top.fromsha1 -width 40 -relief flat
7264 $top.fromsha1 insert 0 $oldid
7265 $top.fromsha1 conf -state readonly
7266 grid $top.from $top.fromsha1 -sticky w
7267 entry $top.fromhead -width 60 -relief flat
7268 $top.fromhead insert 0 $oldhead
7269 $top.fromhead conf -state readonly
7270 grid x $top.fromhead -sticky w
7271 label $top.to -text [mc "To:"]
7272 entry $top.tosha1 -width 40 -relief flat
7273 $top.tosha1 insert 0 $newid
7274 $top.tosha1 conf -state readonly
7275 grid $top.to $top.tosha1 -sticky w
7276 entry $top.tohead -width 60 -relief flat
7277 $top.tohead insert 0 $newhead
7278 $top.tohead conf -state readonly
7279 grid x $top.tohead -sticky w
7280 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7281 grid $top.rev x -pady 10
7282 label $top.flab -text [mc "Output file:"]
7283 entry $top.fname -width 60
7284 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7286 grid $top.flab $top.fname -sticky w
7288 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7289 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7290 grid $top.buts.gen $top.buts.can
7291 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7292 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7293 grid $top.buts - -pady 10 -sticky ew
7297 proc mkpatchrev {} {
7300 set oldid [$patchtop.fromsha1 get]
7301 set oldhead [$patchtop.fromhead get]
7302 set newid [$patchtop.tosha1 get]
7303 set newhead [$patchtop.tohead get]
7304 foreach e [list fromsha1 fromhead tosha1 tohead] \
7305 v [list $newid $newhead $oldid $oldhead] {
7306 $patchtop.$e conf -state normal
7307 $patchtop.$e delete 0 end
7308 $patchtop.$e insert 0 $v
7309 $patchtop.$e conf -state readonly
7314 global patchtop nullid nullid2
7316 set oldid [$patchtop.fromsha1 get]
7317 set newid [$patchtop.tosha1 get]
7318 set fname [$patchtop.fname get]
7319 set cmd [diffcmd [list $oldid $newid] -p]
7320 # trim off the initial "|"
7321 set cmd [lrange $cmd 1 end]
7322 lappend cmd >$fname &
7323 if {[catch {eval exec $cmd} err]} {
7324 error_popup "[mc "Error creating patch:"] $err"
7326 catch {destroy $patchtop}
7330 proc mkpatchcan {} {
7333 catch {destroy $patchtop}
7338 global rowmenuid mktagtop commitinfo
7342 catch {destroy $top}
7344 label $top.title -text [mc "Create tag"]
7345 grid $top.title - -pady 10
7346 label $top.id -text [mc "ID:"]
7347 entry $top.sha1 -width 40 -relief flat
7348 $top.sha1 insert 0 $rowmenuid
7349 $top.sha1 conf -state readonly
7350 grid $top.id $top.sha1 -sticky w
7351 entry $top.head -width 60 -relief flat
7352 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7353 $top.head conf -state readonly
7354 grid x $top.head -sticky w
7355 label $top.tlab -text [mc "Tag name:"]
7356 entry $top.tag -width 60
7357 grid $top.tlab $top.tag -sticky w
7359 button $top.buts.gen -text [mc "Create"] -command mktaggo
7360 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7361 grid $top.buts.gen $top.buts.can
7362 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7363 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7364 grid $top.buts - -pady 10 -sticky ew
7369 global mktagtop env tagids idtags
7371 set id [$mktagtop.sha1 get]
7372 set tag [$mktagtop.tag get]
7374 error_popup [mc "No tag name specified"]
7377 if {[info exists tagids($tag)]} {
7378 error_popup [mc "Tag \"%s\" already exists" $tag]
7382 exec git tag $tag $id
7384 error_popup "[mc "Error creating tag:"] $err"
7388 set tagids($tag) $id
7389 lappend idtags($id) $tag
7396 proc redrawtags {id} {
7397 global canv linehtag idpos currentid curview
7398 global canvxmax iddrawn
7400 if {![commitinview $id $curview]} return
7401 if {![info exists iddrawn($id)]} return
7402 set row [rowofcommit $id]
7403 $canv delete tag.$id
7404 set xt [eval drawtags $id $idpos($id)]
7405 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7406 set text [$canv itemcget $linehtag($row) -text]
7407 set font [$canv itemcget $linehtag($row) -font]
7408 set xr [expr {$xt + [font measure $font $text]}]
7409 if {$xr > $canvxmax} {
7413 if {[info exists currentid] && $currentid == $id} {
7421 catch {destroy $mktagtop}
7430 proc writecommit {} {
7431 global rowmenuid wrcomtop commitinfo wrcomcmd
7433 set top .writecommit
7435 catch {destroy $top}
7437 label $top.title -text [mc "Write commit to file"]
7438 grid $top.title - -pady 10
7439 label $top.id -text [mc "ID:"]
7440 entry $top.sha1 -width 40 -relief flat
7441 $top.sha1 insert 0 $rowmenuid
7442 $top.sha1 conf -state readonly
7443 grid $top.id $top.sha1 -sticky w
7444 entry $top.head -width 60 -relief flat
7445 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7446 $top.head conf -state readonly
7447 grid x $top.head -sticky w
7448 label $top.clab -text [mc "Command:"]
7449 entry $top.cmd -width 60 -textvariable wrcomcmd
7450 grid $top.clab $top.cmd -sticky w -pady 10
7451 label $top.flab -text [mc "Output file:"]
7452 entry $top.fname -width 60
7453 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7454 grid $top.flab $top.fname -sticky w
7456 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7457 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7458 grid $top.buts.gen $top.buts.can
7459 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7460 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7461 grid $top.buts - -pady 10 -sticky ew
7468 set id [$wrcomtop.sha1 get]
7469 set cmd "echo $id | [$wrcomtop.cmd get]"
7470 set fname [$wrcomtop.fname get]
7471 if {[catch {exec sh -c $cmd >$fname &} err]} {
7472 error_popup "[mc "Error writing commit:"] $err"
7474 catch {destroy $wrcomtop}
7481 catch {destroy $wrcomtop}
7486 global rowmenuid mkbrtop
7489 catch {destroy $top}
7491 label $top.title -text [mc "Create new branch"]
7492 grid $top.title - -pady 10
7493 label $top.id -text [mc "ID:"]
7494 entry $top.sha1 -width 40 -relief flat
7495 $top.sha1 insert 0 $rowmenuid
7496 $top.sha1 conf -state readonly
7497 grid $top.id $top.sha1 -sticky w
7498 label $top.nlab -text [mc "Name:"]
7499 entry $top.name -width 40
7500 grid $top.nlab $top.name -sticky w
7502 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7503 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7504 grid $top.buts.go $top.buts.can
7505 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7506 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7507 grid $top.buts - -pady 10 -sticky ew
7512 global headids idheads
7514 set name [$top.name get]
7515 set id [$top.sha1 get]
7517 error_popup [mc "Please specify a name for the new branch"]
7520 catch {destroy $top}
7524 exec git branch $name $id
7529 set headids($name) $id
7530 lappend idheads($id) $name
7539 proc cherrypick {} {
7540 global rowmenuid curview
7541 global mainhead mainheadid
7543 set oldhead [exec git rev-parse HEAD]
7544 set dheads [descheads $rowmenuid]
7545 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7546 set ok [confirm_popup [mc "Commit %s is already\
7547 included in branch %s -- really re-apply it?" \
7548 [string range $rowmenuid 0 7] $mainhead]]
7551 nowbusy cherrypick [mc "Cherry-picking"]
7553 # Unfortunately git-cherry-pick writes stuff to stderr even when
7554 # no error occurs, and exec takes that as an indication of error...
7555 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7560 set newhead [exec git rev-parse HEAD]
7561 if {$newhead eq $oldhead} {
7563 error_popup [mc "No changes committed"]
7566 addnewchild $newhead $oldhead
7567 if {[commitinview $oldhead $curview]} {
7568 insertrow $newhead $oldhead $curview
7569 if {$mainhead ne {}} {
7570 movehead $newhead $mainhead
7571 movedhead $newhead $mainhead
7572 set mainheadid $newhead
7582 global mainhead rowmenuid confirm_ok resettype
7585 set w ".confirmreset"
7588 wm title $w [mc "Confirm reset"]
7589 message $w.m -text \
7590 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7591 -justify center -aspect 1000
7592 pack $w.m -side top -fill x -padx 20 -pady 20
7593 frame $w.f -relief sunken -border 2
7594 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7595 grid $w.f.rt -sticky w
7597 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7598 -text [mc "Soft: Leave working tree and index untouched"]
7599 grid $w.f.soft -sticky w
7600 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7601 -text [mc "Mixed: Leave working tree untouched, reset index"]
7602 grid $w.f.mixed -sticky w
7603 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7604 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7605 grid $w.f.hard -sticky w
7606 pack $w.f -side top -fill x
7607 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7608 pack $w.ok -side left -fill x -padx 20 -pady 20
7609 button $w.cancel -text [mc Cancel] -command "destroy $w"
7610 pack $w.cancel -side right -fill x -padx 20 -pady 20
7611 bind $w <Visibility> "grab $w; focus $w"
7613 if {!$confirm_ok} return
7614 if {[catch {set fd [open \
7615 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7619 filerun $fd [list readresetstat $fd]
7620 nowbusy reset [mc "Resetting"]
7625 proc readresetstat {fd} {
7626 global mainhead mainheadid showlocalchanges rprogcoord
7628 if {[gets $fd line] >= 0} {
7629 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7630 set rprogcoord [expr {1.0 * $m / $n}]
7638 if {[catch {close $fd} err]} {
7641 set oldhead $mainheadid
7642 set newhead [exec git rev-parse HEAD]
7643 if {$newhead ne $oldhead} {
7644 movehead $newhead $mainhead
7645 movedhead $newhead $mainhead
7646 set mainheadid $newhead
7650 if {$showlocalchanges} {
7656 # context menu for a head
7657 proc headmenu {x y id head} {
7658 global headmenuid headmenuhead headctxmenu mainhead
7662 set headmenuhead $head
7664 if {$head eq $mainhead} {
7667 $headctxmenu entryconfigure 0 -state $state
7668 $headctxmenu entryconfigure 1 -state $state
7669 tk_popup $headctxmenu $x $y
7673 global headmenuid headmenuhead mainhead headids
7674 global showlocalchanges mainheadid
7676 # check the tree is clean first??
7677 nowbusy checkout [mc "Checking out"]
7681 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7685 if {$showlocalchanges} {
7689 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7693 proc readcheckoutstat {fd newhead newheadid} {
7694 global mainhead mainheadid headids showlocalchanges progresscoords
7696 if {[gets $fd line] >= 0} {
7697 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7698 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7703 set progresscoords {0 0}
7706 if {[catch {close $fd} err]} {
7709 set oldmainhead $mainhead
7710 set mainhead $newhead
7711 set mainheadid $newheadid
7712 if {[info exists headids($oldmainhead)]} {
7713 redrawtags $headids($oldmainhead)
7715 redrawtags $newheadid
7717 if {$showlocalchanges} {
7723 global headmenuid headmenuhead mainhead
7726 set head $headmenuhead
7728 # this check shouldn't be needed any more...
7729 if {$head eq $mainhead} {
7730 error_popup [mc "Cannot delete the currently checked-out branch"]
7733 set dheads [descheads $id]
7734 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7735 # the stuff on this branch isn't on any other branch
7736 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7737 branch.\nReally delete branch %s?" $head $head]]} return
7741 if {[catch {exec git branch -D $head} err]} {
7746 removehead $id $head
7747 removedhead $id $head
7754 # Display a list of tags and heads
7756 global showrefstop bgcolor fgcolor selectbgcolor
7757 global bglist fglist reflistfilter reflist maincursor
7760 set showrefstop $top
7761 if {[winfo exists $top]} {
7767 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7768 text $top.list -background $bgcolor -foreground $fgcolor \
7769 -selectbackground $selectbgcolor -font mainfont \
7770 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7771 -width 30 -height 20 -cursor $maincursor \
7772 -spacing1 1 -spacing3 1 -state disabled
7773 $top.list tag configure highlight -background $selectbgcolor
7774 lappend bglist $top.list
7775 lappend fglist $top.list
7776 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7777 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7778 grid $top.list $top.ysb -sticky nsew
7779 grid $top.xsb x -sticky ew
7781 label $top.f.l -text "[mc "Filter"]: "
7782 entry $top.f.e -width 20 -textvariable reflistfilter
7783 set reflistfilter "*"
7784 trace add variable reflistfilter write reflistfilter_change
7785 pack $top.f.e -side right -fill x -expand 1
7786 pack $top.f.l -side left
7787 grid $top.f - -sticky ew -pady 2
7788 button $top.close -command [list destroy $top] -text [mc "Close"]
7790 grid columnconfigure $top 0 -weight 1
7791 grid rowconfigure $top 0 -weight 1
7792 bind $top.list <1> {break}
7793 bind $top.list <B1-Motion> {break}
7794 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7799 proc sel_reflist {w x y} {
7800 global showrefstop reflist headids tagids otherrefids
7802 if {![winfo exists $showrefstop]} return
7803 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7804 set ref [lindex $reflist [expr {$l-1}]]
7805 set n [lindex $ref 0]
7806 switch -- [lindex $ref 1] {
7807 "H" {selbyid $headids($n)}
7808 "T" {selbyid $tagids($n)}
7809 "o" {selbyid $otherrefids($n)}
7811 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7814 proc unsel_reflist {} {
7817 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7818 $showrefstop.list tag remove highlight 0.0 end
7821 proc reflistfilter_change {n1 n2 op} {
7822 global reflistfilter
7824 after cancel refill_reflist
7825 after 200 refill_reflist
7828 proc refill_reflist {} {
7829 global reflist reflistfilter showrefstop headids tagids otherrefids
7830 global curview commitinterest
7832 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7834 foreach n [array names headids] {
7835 if {[string match $reflistfilter $n]} {
7836 if {[commitinview $headids($n) $curview]} {
7837 lappend refs [list $n H]
7839 set commitinterest($headids($n)) {run refill_reflist}
7843 foreach n [array names tagids] {
7844 if {[string match $reflistfilter $n]} {
7845 if {[commitinview $tagids($n) $curview]} {
7846 lappend refs [list $n T]
7848 set commitinterest($tagids($n)) {run refill_reflist}
7852 foreach n [array names otherrefids] {
7853 if {[string match $reflistfilter $n]} {
7854 if {[commitinview $otherrefids($n) $curview]} {
7855 lappend refs [list $n o]
7857 set commitinterest($otherrefids($n)) {run refill_reflist}
7861 set refs [lsort -index 0 $refs]
7862 if {$refs eq $reflist} return
7864 # Update the contents of $showrefstop.list according to the
7865 # differences between $reflist (old) and $refs (new)
7866 $showrefstop.list conf -state normal
7867 $showrefstop.list insert end "\n"
7870 while {$i < [llength $reflist] || $j < [llength $refs]} {
7871 if {$i < [llength $reflist]} {
7872 if {$j < [llength $refs]} {
7873 set cmp [string compare [lindex $reflist $i 0] \
7874 [lindex $refs $j 0]]
7876 set cmp [string compare [lindex $reflist $i 1] \
7877 [lindex $refs $j 1]]
7887 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7895 set l [expr {$j + 1}]
7896 $showrefstop.list image create $l.0 -align baseline \
7897 -image reficon-[lindex $refs $j 1] -padx 2
7898 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7904 # delete last newline
7905 $showrefstop.list delete end-2c end-1c
7906 $showrefstop.list conf -state disabled
7909 # Stuff for finding nearby tags
7910 proc getallcommits {} {
7911 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7912 global idheads idtags idotherrefs allparents tagobjid
7914 if {![info exists allcommits]} {
7920 set allccache [file join [gitdir] "gitk.cache"]
7922 set f [open $allccache r]
7931 set cmd [list | git rev-list --parents]
7932 set allcupdate [expr {$seeds ne {}}]
7936 set refs [concat [array names idheads] [array names idtags] \
7937 [array names idotherrefs]]
7940 foreach name [array names tagobjid] {
7941 lappend tagobjs $tagobjid($name)
7943 foreach id [lsort -unique $refs] {
7944 if {![info exists allparents($id)] &&
7945 [lsearch -exact $tagobjs $id] < 0} {
7956 set fd [open [concat $cmd $ids] r]
7957 fconfigure $fd -blocking 0
7960 filerun $fd [list getallclines $fd]
7966 # Since most commits have 1 parent and 1 child, we group strings of
7967 # such commits into "arcs" joining branch/merge points (BMPs), which
7968 # are commits that either don't have 1 parent or don't have 1 child.
7970 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7971 # arcout(id) - outgoing arcs for BMP
7972 # arcids(a) - list of IDs on arc including end but not start
7973 # arcstart(a) - BMP ID at start of arc
7974 # arcend(a) - BMP ID at end of arc
7975 # growing(a) - arc a is still growing
7976 # arctags(a) - IDs out of arcids (excluding end) that have tags
7977 # archeads(a) - IDs out of arcids (excluding end) that have heads
7978 # The start of an arc is at the descendent end, so "incoming" means
7979 # coming from descendents, and "outgoing" means going towards ancestors.
7981 proc getallclines {fd} {
7982 global allparents allchildren idtags idheads nextarc
7983 global arcnos arcids arctags arcout arcend arcstart archeads growing
7984 global seeds allcommits cachedarcs allcupdate
7987 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7988 set id [lindex $line 0]
7989 if {[info exists allparents($id)]} {
7994 set olds [lrange $line 1 end]
7995 set allparents($id) $olds
7996 if {![info exists allchildren($id)]} {
7997 set allchildren($id) {}
8002 if {[llength $olds] == 1 && [llength $a] == 1} {
8003 lappend arcids($a) $id
8004 if {[info exists idtags($id)]} {
8005 lappend arctags($a) $id
8007 if {[info exists idheads($id)]} {
8008 lappend archeads($a) $id
8010 if {[info exists allparents($olds)]} {
8011 # seen parent already
8012 if {![info exists arcout($olds)]} {
8015 lappend arcids($a) $olds
8016 set arcend($a) $olds
8019 lappend allchildren($olds) $id
8020 lappend arcnos($olds) $a
8024 foreach a $arcnos($id) {
8025 lappend arcids($a) $id
8032 lappend allchildren($p) $id
8033 set a [incr nextarc]
8034 set arcstart($a) $id
8041 if {[info exists allparents($p)]} {
8042 # seen it already, may need to make a new branch
8043 if {![info exists arcout($p)]} {
8046 lappend arcids($a) $p
8050 lappend arcnos($p) $a
8055 global cached_dheads cached_dtags cached_atags
8056 catch {unset cached_dheads}
8057 catch {unset cached_dtags}
8058 catch {unset cached_atags}
8061 return [expr {$nid >= 1000? 2: 1}]
8065 fconfigure $fd -blocking 1
8068 # got an error reading the list of commits
8069 # if we were updating, try rereading the whole thing again
8075 error_popup "[mc "Error reading commit topology information;\
8076 branch and preceding/following tag information\
8077 will be incomplete."]\n($err)"
8080 if {[incr allcommits -1] == 0} {
8090 proc recalcarc {a} {
8091 global arctags archeads arcids idtags idheads
8095 foreach id [lrange $arcids($a) 0 end-1] {
8096 if {[info exists idtags($id)]} {
8099 if {[info exists idheads($id)]} {
8104 set archeads($a) $ah
8108 global arcnos arcids nextarc arctags archeads idtags idheads
8109 global arcstart arcend arcout allparents growing
8112 if {[llength $a] != 1} {
8113 puts "oops splitarc called but [llength $a] arcs already"
8117 set i [lsearch -exact $arcids($a) $p]
8119 puts "oops splitarc $p not in arc $a"
8122 set na [incr nextarc]
8123 if {[info exists arcend($a)]} {
8124 set arcend($na) $arcend($a)
8126 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8127 set j [lsearch -exact $arcnos($l) $a]
8128 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8130 set tail [lrange $arcids($a) [expr {$i+1}] end]
8131 set arcids($a) [lrange $arcids($a) 0 $i]
8133 set arcstart($na) $p
8135 set arcids($na) $tail
8136 if {[info exists growing($a)]} {
8142 if {[llength $arcnos($id)] == 1} {
8145 set j [lsearch -exact $arcnos($id) $a]
8146 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8150 # reconstruct tags and heads lists
8151 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8156 set archeads($na) {}
8160 # Update things for a new commit added that is a child of one
8161 # existing commit. Used when cherry-picking.
8162 proc addnewchild {id p} {
8163 global allparents allchildren idtags nextarc
8164 global arcnos arcids arctags arcout arcend arcstart archeads growing
8165 global seeds allcommits
8167 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8168 set allparents($id) [list $p]
8169 set allchildren($id) {}
8172 lappend allchildren($p) $id
8173 set a [incr nextarc]
8174 set arcstart($a) $id
8177 set arcids($a) [list $p]
8179 if {![info exists arcout($p)]} {
8182 lappend arcnos($p) $a
8183 set arcout($id) [list $a]
8186 # This implements a cache for the topology information.
8187 # The cache saves, for each arc, the start and end of the arc,
8188 # the ids on the arc, and the outgoing arcs from the end.
8189 proc readcache {f} {
8190 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8191 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8196 if {$lim - $a > 500} {
8197 set lim [expr {$a + 500}]
8201 # finish reading the cache and setting up arctags, etc.
8203 if {$line ne "1"} {error "bad final version"}
8205 foreach id [array names idtags] {
8206 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8207 [llength $allparents($id)] == 1} {
8208 set a [lindex $arcnos($id) 0]
8209 if {$arctags($a) eq {}} {
8214 foreach id [array names idheads] {
8215 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8216 [llength $allparents($id)] == 1} {
8217 set a [lindex $arcnos($id) 0]
8218 if {$archeads($a) eq {}} {
8223 foreach id [lsort -unique $possible_seeds] {
8224 if {$arcnos($id) eq {}} {
8230 while {[incr a] <= $lim} {
8232 if {[llength $line] != 3} {error "bad line"}
8233 set s [lindex $line 0]
8235 lappend arcout($s) $a
8236 if {![info exists arcnos($s)]} {
8237 lappend possible_seeds $s
8240 set e [lindex $line 1]
8245 if {![info exists arcout($e)]} {
8249 set arcids($a) [lindex $line 2]
8250 foreach id $arcids($a) {
8251 lappend allparents($s) $id
8253 lappend arcnos($id) $a
8255 if {![info exists allparents($s)]} {
8256 set allparents($s) {}
8261 set nextarc [expr {$a - 1}]
8274 global nextarc cachedarcs possible_seeds
8278 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8279 # make sure it's an integer
8280 set cachedarcs [expr {int([lindex $line 1])}]
8281 if {$cachedarcs < 0} {error "bad number of arcs"}
8283 set possible_seeds {}
8291 proc dropcache {err} {
8292 global allcwait nextarc cachedarcs seeds
8294 #puts "dropping cache ($err)"
8295 foreach v {arcnos arcout arcids arcstart arcend growing \
8296 arctags archeads allparents allchildren} {
8307 proc writecache {f} {
8308 global cachearc cachedarcs allccache
8309 global arcstart arcend arcnos arcids arcout
8313 if {$lim - $a > 1000} {
8314 set lim [expr {$a + 1000}]
8317 while {[incr a] <= $lim} {
8318 if {[info exists arcend($a)]} {
8319 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8321 puts $f [list $arcstart($a) {} $arcids($a)]
8326 catch {file delete $allccache}
8327 #puts "writing cache failed ($err)"
8330 set cachearc [expr {$a - 1}]
8331 if {$a > $cachedarcs} {
8340 global nextarc cachedarcs cachearc allccache
8342 if {$nextarc == $cachedarcs} return
8344 set cachedarcs $nextarc
8346 set f [open $allccache w]
8347 puts $f [list 1 $cachedarcs]
8352 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8353 # or 0 if neither is true.
8354 proc anc_or_desc {a b} {
8355 global arcout arcstart arcend arcnos cached_isanc
8357 if {$arcnos($a) eq $arcnos($b)} {
8358 # Both are on the same arc(s); either both are the same BMP,
8359 # or if one is not a BMP, the other is also not a BMP or is
8360 # the BMP at end of the arc (and it only has 1 incoming arc).
8361 # Or both can be BMPs with no incoming arcs.
8362 if {$a eq $b || $arcnos($a) eq {}} {
8365 # assert {[llength $arcnos($a)] == 1}
8366 set arc [lindex $arcnos($a) 0]
8367 set i [lsearch -exact $arcids($arc) $a]
8368 set j [lsearch -exact $arcids($arc) $b]
8369 if {$i < 0 || $i > $j} {
8376 if {![info exists arcout($a)]} {
8377 set arc [lindex $arcnos($a) 0]
8378 if {[info exists arcend($arc)]} {
8379 set aend $arcend($arc)
8383 set a $arcstart($arc)
8387 if {![info exists arcout($b)]} {
8388 set arc [lindex $arcnos($b) 0]
8389 if {[info exists arcend($arc)]} {
8390 set bend $arcend($arc)
8394 set b $arcstart($arc)
8404 if {[info exists cached_isanc($a,$bend)]} {
8405 if {$cached_isanc($a,$bend)} {
8409 if {[info exists cached_isanc($b,$aend)]} {
8410 if {$cached_isanc($b,$aend)} {
8413 if {[info exists cached_isanc($a,$bend)]} {
8418 set todo [list $a $b]
8421 for {set i 0} {$i < [llength $todo]} {incr i} {
8422 set x [lindex $todo $i]
8423 if {$anc($x) eq {}} {
8426 foreach arc $arcnos($x) {
8427 set xd $arcstart($arc)
8429 set cached_isanc($a,$bend) 1
8430 set cached_isanc($b,$aend) 0
8432 } elseif {$xd eq $aend} {
8433 set cached_isanc($b,$aend) 1
8434 set cached_isanc($a,$bend) 0
8437 if {![info exists anc($xd)]} {
8438 set anc($xd) $anc($x)
8440 } elseif {$anc($xd) ne $anc($x)} {
8445 set cached_isanc($a,$bend) 0
8446 set cached_isanc($b,$aend) 0
8450 # This identifies whether $desc has an ancestor that is
8451 # a growing tip of the graph and which is not an ancestor of $anc
8452 # and returns 0 if so and 1 if not.
8453 # If we subsequently discover a tag on such a growing tip, and that
8454 # turns out to be a descendent of $anc (which it could, since we
8455 # don't necessarily see children before parents), then $desc
8456 # isn't a good choice to display as a descendent tag of
8457 # $anc (since it is the descendent of another tag which is
8458 # a descendent of $anc). Similarly, $anc isn't a good choice to
8459 # display as a ancestor tag of $desc.
8461 proc is_certain {desc anc} {
8462 global arcnos arcout arcstart arcend growing problems
8465 if {[llength $arcnos($anc)] == 1} {
8466 # tags on the same arc are certain
8467 if {$arcnos($desc) eq $arcnos($anc)} {
8470 if {![info exists arcout($anc)]} {
8471 # if $anc is partway along an arc, use the start of the arc instead
8472 set a [lindex $arcnos($anc) 0]
8473 set anc $arcstart($a)
8476 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8479 set a [lindex $arcnos($desc) 0]
8485 set anclist [list $x]
8489 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8490 set x [lindex $anclist $i]
8495 foreach a $arcout($x) {
8496 if {[info exists growing($a)]} {
8497 if {![info exists growanc($x)] && $dl($x)} {
8503 if {[info exists dl($y)]} {
8507 if {![info exists done($y)]} {
8510 if {[info exists growanc($x)]} {
8514 for {set k 0} {$k < [llength $xl]} {incr k} {
8515 set z [lindex $xl $k]
8516 foreach c $arcout($z) {
8517 if {[info exists arcend($c)]} {
8519 if {[info exists dl($v)] && $dl($v)} {
8521 if {![info exists done($v)]} {
8524 if {[info exists growanc($v)]} {
8534 } elseif {$y eq $anc || !$dl($x)} {
8545 foreach x [array names growanc] {
8554 proc validate_arctags {a} {
8555 global arctags idtags
8559 foreach id $arctags($a) {
8561 if {![info exists idtags($id)]} {
8562 set na [lreplace $na $i $i]
8569 proc validate_archeads {a} {
8570 global archeads idheads
8573 set na $archeads($a)
8574 foreach id $archeads($a) {
8576 if {![info exists idheads($id)]} {
8577 set na [lreplace $na $i $i]
8581 set archeads($a) $na
8584 # Return the list of IDs that have tags that are descendents of id,
8585 # ignoring IDs that are descendents of IDs already reported.
8586 proc desctags {id} {
8587 global arcnos arcstart arcids arctags idtags allparents
8588 global growing cached_dtags
8590 if {![info exists allparents($id)]} {
8593 set t1 [clock clicks -milliseconds]
8595 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8596 # part-way along an arc; check that arc first
8597 set a [lindex $arcnos($id) 0]
8598 if {$arctags($a) ne {}} {
8600 set i [lsearch -exact $arcids($a) $id]
8602 foreach t $arctags($a) {
8603 set j [lsearch -exact $arcids($a) $t]
8611 set id $arcstart($a)
8612 if {[info exists idtags($id)]} {
8616 if {[info exists cached_dtags($id)]} {
8617 return $cached_dtags($id)
8624 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8625 set id [lindex $todo $i]
8627 set ta [info exists hastaggedancestor($id)]
8631 # ignore tags on starting node
8632 if {!$ta && $i > 0} {
8633 if {[info exists idtags($id)]} {
8636 } elseif {[info exists cached_dtags($id)]} {
8637 set tagloc($id) $cached_dtags($id)
8641 foreach a $arcnos($id) {
8643 if {!$ta && $arctags($a) ne {}} {
8645 if {$arctags($a) ne {}} {
8646 lappend tagloc($id) [lindex $arctags($a) end]
8649 if {$ta || $arctags($a) ne {}} {
8650 set tomark [list $d]
8651 for {set j 0} {$j < [llength $tomark]} {incr j} {
8652 set dd [lindex $tomark $j]
8653 if {![info exists hastaggedancestor($dd)]} {
8654 if {[info exists done($dd)]} {
8655 foreach b $arcnos($dd) {
8656 lappend tomark $arcstart($b)
8658 if {[info exists tagloc($dd)]} {
8661 } elseif {[info exists queued($dd)]} {
8664 set hastaggedancestor($dd) 1
8668 if {![info exists queued($d)]} {
8671 if {![info exists hastaggedancestor($d)]} {
8678 foreach id [array names tagloc] {
8679 if {![info exists hastaggedancestor($id)]} {
8680 foreach t $tagloc($id) {
8681 if {[lsearch -exact $tags $t] < 0} {
8687 set t2 [clock clicks -milliseconds]
8690 # remove tags that are descendents of other tags
8691 for {set i 0} {$i < [llength $tags]} {incr i} {
8692 set a [lindex $tags $i]
8693 for {set j 0} {$j < $i} {incr j} {
8694 set b [lindex $tags $j]
8695 set r [anc_or_desc $a $b]
8697 set tags [lreplace $tags $j $j]
8700 } elseif {$r == -1} {
8701 set tags [lreplace $tags $i $i]
8708 if {[array names growing] ne {}} {
8709 # graph isn't finished, need to check if any tag could get
8710 # eclipsed by another tag coming later. Simply ignore any
8711 # tags that could later get eclipsed.
8714 if {[is_certain $t $origid]} {
8718 if {$tags eq $ctags} {
8719 set cached_dtags($origid) $tags
8724 set cached_dtags($origid) $tags
8726 set t3 [clock clicks -milliseconds]
8727 if {0 && $t3 - $t1 >= 100} {
8728 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8729 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8735 global arcnos arcids arcout arcend arctags idtags allparents
8736 global growing cached_atags
8738 if {![info exists allparents($id)]} {
8741 set t1 [clock clicks -milliseconds]
8743 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8744 # part-way along an arc; check that arc first
8745 set a [lindex $arcnos($id) 0]
8746 if {$arctags($a) ne {}} {
8748 set i [lsearch -exact $arcids($a) $id]
8749 foreach t $arctags($a) {
8750 set j [lsearch -exact $arcids($a) $t]
8756 if {![info exists arcend($a)]} {
8760 if {[info exists idtags($id)]} {
8764 if {[info exists cached_atags($id)]} {
8765 return $cached_atags($id)
8773 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8774 set id [lindex $todo $i]
8776 set td [info exists hastaggeddescendent($id)]
8780 # ignore tags on starting node
8781 if {!$td && $i > 0} {
8782 if {[info exists idtags($id)]} {
8785 } elseif {[info exists cached_atags($id)]} {
8786 set tagloc($id) $cached_atags($id)
8790 foreach a $arcout($id) {
8791 if {!$td && $arctags($a) ne {}} {
8793 if {$arctags($a) ne {}} {
8794 lappend tagloc($id) [lindex $arctags($a) 0]
8797 if {![info exists arcend($a)]} continue
8799 if {$td || $arctags($a) ne {}} {
8800 set tomark [list $d]
8801 for {set j 0} {$j < [llength $tomark]} {incr j} {
8802 set dd [lindex $tomark $j]
8803 if {![info exists hastaggeddescendent($dd)]} {
8804 if {[info exists done($dd)]} {
8805 foreach b $arcout($dd) {
8806 if {[info exists arcend($b)]} {
8807 lappend tomark $arcend($b)
8810 if {[info exists tagloc($dd)]} {
8813 } elseif {[info exists queued($dd)]} {
8816 set hastaggeddescendent($dd) 1
8820 if {![info exists queued($d)]} {
8823 if {![info exists hastaggeddescendent($d)]} {
8829 set t2 [clock clicks -milliseconds]
8832 foreach id [array names tagloc] {
8833 if {![info exists hastaggeddescendent($id)]} {
8834 foreach t $tagloc($id) {
8835 if {[lsearch -exact $tags $t] < 0} {
8842 # remove tags that are ancestors of other tags
8843 for {set i 0} {$i < [llength $tags]} {incr i} {
8844 set a [lindex $tags $i]
8845 for {set j 0} {$j < $i} {incr j} {
8846 set b [lindex $tags $j]
8847 set r [anc_or_desc $a $b]
8849 set tags [lreplace $tags $j $j]
8852 } elseif {$r == 1} {
8853 set tags [lreplace $tags $i $i]
8860 if {[array names growing] ne {}} {
8861 # graph isn't finished, need to check if any tag could get
8862 # eclipsed by another tag coming later. Simply ignore any
8863 # tags that could later get eclipsed.
8866 if {[is_certain $origid $t]} {
8870 if {$tags eq $ctags} {
8871 set cached_atags($origid) $tags
8876 set cached_atags($origid) $tags
8878 set t3 [clock clicks -milliseconds]
8879 if {0 && $t3 - $t1 >= 100} {
8880 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8881 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8886 # Return the list of IDs that have heads that are descendents of id,
8887 # including id itself if it has a head.
8888 proc descheads {id} {
8889 global arcnos arcstart arcids archeads idheads cached_dheads
8892 if {![info exists allparents($id)]} {
8896 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8897 # part-way along an arc; check it first
8898 set a [lindex $arcnos($id) 0]
8899 if {$archeads($a) ne {}} {
8900 validate_archeads $a
8901 set i [lsearch -exact $arcids($a) $id]
8902 foreach t $archeads($a) {
8903 set j [lsearch -exact $arcids($a) $t]
8908 set id $arcstart($a)
8914 for {set i 0} {$i < [llength $todo]} {incr i} {
8915 set id [lindex $todo $i]
8916 if {[info exists cached_dheads($id)]} {
8917 set ret [concat $ret $cached_dheads($id)]
8919 if {[info exists idheads($id)]} {
8922 foreach a $arcnos($id) {
8923 if {$archeads($a) ne {}} {
8924 validate_archeads $a
8925 if {$archeads($a) ne {}} {
8926 set ret [concat $ret $archeads($a)]
8930 if {![info exists seen($d)]} {
8937 set ret [lsort -unique $ret]
8938 set cached_dheads($origid) $ret
8939 return [concat $ret $aret]
8942 proc addedtag {id} {
8943 global arcnos arcout cached_dtags cached_atags
8945 if {![info exists arcnos($id)]} return
8946 if {![info exists arcout($id)]} {
8947 recalcarc [lindex $arcnos($id) 0]
8949 catch {unset cached_dtags}
8950 catch {unset cached_atags}
8953 proc addedhead {hid head} {
8954 global arcnos arcout cached_dheads
8956 if {![info exists arcnos($hid)]} return
8957 if {![info exists arcout($hid)]} {
8958 recalcarc [lindex $arcnos($hid) 0]
8960 catch {unset cached_dheads}
8963 proc removedhead {hid head} {
8964 global cached_dheads
8966 catch {unset cached_dheads}
8969 proc movedhead {hid head} {
8970 global arcnos arcout cached_dheads
8972 if {![info exists arcnos($hid)]} return
8973 if {![info exists arcout($hid)]} {
8974 recalcarc [lindex $arcnos($hid) 0]
8976 catch {unset cached_dheads}
8979 proc changedrefs {} {
8980 global cached_dheads cached_dtags cached_atags
8981 global arctags archeads arcnos arcout idheads idtags
8983 foreach id [concat [array names idheads] [array names idtags]] {
8984 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8985 set a [lindex $arcnos($id) 0]
8986 if {![info exists donearc($a)]} {
8992 catch {unset cached_dtags}
8993 catch {unset cached_atags}
8994 catch {unset cached_dheads}
8997 proc rereadrefs {} {
8998 global idtags idheads idotherrefs mainheadid
9000 set refids [concat [array names idtags] \
9001 [array names idheads] [array names idotherrefs]]
9002 foreach id $refids {
9003 if {![info exists ref($id)]} {
9004 set ref($id) [listrefs $id]
9007 set oldmainhead $mainheadid
9010 set refids [lsort -unique [concat $refids [array names idtags] \
9011 [array names idheads] [array names idotherrefs]]]
9012 foreach id $refids {
9013 set v [listrefs $id]
9014 if {![info exists ref($id)] || $ref($id) != $v ||
9015 ($id eq $oldmainhead && $id ne $mainheadid) ||
9016 ($id eq $mainheadid && $id ne $oldmainhead)} {
9023 proc listrefs {id} {
9024 global idtags idheads idotherrefs
9027 if {[info exists idtags($id)]} {
9031 if {[info exists idheads($id)]} {
9035 if {[info exists idotherrefs($id)]} {
9036 set z $idotherrefs($id)
9038 return [list $x $y $z]
9041 proc showtag {tag isnew} {
9042 global ctext tagcontents tagids linknum tagobjid
9045 addtohistory [list showtag $tag 0]
9047 $ctext conf -state normal
9051 if {![info exists tagcontents($tag)]} {
9053 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9056 if {[info exists tagcontents($tag)]} {
9057 set text $tagcontents($tag)
9059 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9061 appendwithlinks $text {}
9062 $ctext conf -state disabled
9074 if {[info exists gitktmpdir]} {
9075 catch {file delete -force $gitktmpdir}
9079 proc mkfontdisp {font top which} {
9080 global fontattr fontpref $font
9082 set fontpref($font) [set $font]
9083 button $top.${font}but -text $which -font optionfont \
9084 -command [list choosefont $font $which]
9085 label $top.$font -relief flat -font $font \
9086 -text $fontattr($font,family) -justify left
9087 grid x $top.${font}but $top.$font -sticky w
9090 proc choosefont {font which} {
9091 global fontparam fontlist fonttop fontattr
9093 set fontparam(which) $which
9094 set fontparam(font) $font
9095 set fontparam(family) [font actual $font -family]
9096 set fontparam(size) $fontattr($font,size)
9097 set fontparam(weight) $fontattr($font,weight)
9098 set fontparam(slant) $fontattr($font,slant)
9101 if {![winfo exists $top]} {
9103 eval font config sample [font actual $font]
9105 wm title $top [mc "Gitk font chooser"]
9106 label $top.l -textvariable fontparam(which)
9107 pack $top.l -side top
9108 set fontlist [lsort [font families]]
9110 listbox $top.f.fam -listvariable fontlist \
9111 -yscrollcommand [list $top.f.sb set]
9112 bind $top.f.fam <<ListboxSelect>> selfontfam
9113 scrollbar $top.f.sb -command [list $top.f.fam yview]
9114 pack $top.f.sb -side right -fill y
9115 pack $top.f.fam -side left -fill both -expand 1
9116 pack $top.f -side top -fill both -expand 1
9118 spinbox $top.g.size -from 4 -to 40 -width 4 \
9119 -textvariable fontparam(size) \
9120 -validatecommand {string is integer -strict %s}
9121 checkbutton $top.g.bold -padx 5 \
9122 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9123 -variable fontparam(weight) -onvalue bold -offvalue normal
9124 checkbutton $top.g.ital -padx 5 \
9125 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9126 -variable fontparam(slant) -onvalue italic -offvalue roman
9127 pack $top.g.size $top.g.bold $top.g.ital -side left
9128 pack $top.g -side top
9129 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9131 $top.c create text 100 25 -anchor center -text $which -font sample \
9132 -fill black -tags text
9133 bind $top.c <Configure> [list centertext $top.c]
9134 pack $top.c -side top -fill x
9136 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9137 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9138 grid $top.buts.ok $top.buts.can
9139 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9140 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9141 pack $top.buts -side bottom -fill x
9142 trace add variable fontparam write chg_fontparam
9145 $top.c itemconf text -text $which
9147 set i [lsearch -exact $fontlist $fontparam(family)]
9149 $top.f.fam selection set $i
9154 proc centertext {w} {
9155 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9159 global fontparam fontpref prefstop
9161 set f $fontparam(font)
9162 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9163 if {$fontparam(weight) eq "bold"} {
9164 lappend fontpref($f) "bold"
9166 if {$fontparam(slant) eq "italic"} {
9167 lappend fontpref($f) "italic"
9170 $w conf -text $fontparam(family) -font $fontpref($f)
9176 global fonttop fontparam
9178 if {[info exists fonttop]} {
9179 catch {destroy $fonttop}
9180 catch {font delete sample}
9186 proc selfontfam {} {
9187 global fonttop fontparam
9189 set i [$fonttop.f.fam curselection]
9191 set fontparam(family) [$fonttop.f.fam get $i]
9195 proc chg_fontparam {v sub op} {
9198 font config sample -$sub $fontparam($sub)
9202 global maxwidth maxgraphpct
9203 global oldprefs prefstop showneartags showlocalchanges
9204 global bgcolor fgcolor ctext diffcolors selectbgcolor
9205 global tabstop limitdiffs autoselect extdifftool
9209 if {[winfo exists $top]} {
9213 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9214 limitdiffs tabstop} {
9215 set oldprefs($v) [set $v]
9218 wm title $top [mc "Gitk preferences"]
9219 label $top.ldisp -text [mc "Commit list display options"]
9220 grid $top.ldisp - -sticky w -pady 10
9221 label $top.spacer -text " "
9222 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9224 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9225 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9226 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9228 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9229 grid x $top.maxpctl $top.maxpct -sticky w
9230 frame $top.showlocal
9231 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9232 checkbutton $top.showlocal.b -variable showlocalchanges
9233 pack $top.showlocal.b $top.showlocal.l -side left
9234 grid x $top.showlocal -sticky w
9235 frame $top.autoselect
9236 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9237 checkbutton $top.autoselect.b -variable autoselect
9238 pack $top.autoselect.b $top.autoselect.l -side left
9239 grid x $top.autoselect -sticky w
9241 label $top.ddisp -text [mc "Diff display options"]
9242 grid $top.ddisp - -sticky w -pady 10
9243 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9244 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9245 grid x $top.tabstopl $top.tabstop -sticky w
9247 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9248 checkbutton $top.ntag.b -variable showneartags
9249 pack $top.ntag.b $top.ntag.l -side left
9250 grid x $top.ntag -sticky w
9252 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9253 checkbutton $top.ldiff.b -variable limitdiffs
9254 pack $top.ldiff.b $top.ldiff.l -side left
9255 grid x $top.ldiff -sticky w
9257 entry $top.extdifft -textvariable extdifftool
9259 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9261 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9262 -command choose_extdiff
9263 pack $top.extdifff.l $top.extdifff.b -side left
9264 grid x $top.extdifff $top.extdifft -sticky w
9266 label $top.cdisp -text [mc "Colors: press to choose"]
9267 grid $top.cdisp - -sticky w -pady 10
9268 label $top.bg -padx 40 -relief sunk -background $bgcolor
9269 button $top.bgbut -text [mc "Background"] -font optionfont \
9270 -command [list choosecolor bgcolor {} $top.bg background setbg]
9271 grid x $top.bgbut $top.bg -sticky w
9272 label $top.fg -padx 40 -relief sunk -background $fgcolor
9273 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9274 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9275 grid x $top.fgbut $top.fg -sticky w
9276 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9277 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9278 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9279 [list $ctext tag conf d0 -foreground]]
9280 grid x $top.diffoldbut $top.diffold -sticky w
9281 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9282 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9283 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9284 [list $ctext tag conf d1 -foreground]]
9285 grid x $top.diffnewbut $top.diffnew -sticky w
9286 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9287 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9288 -command [list choosecolor diffcolors 2 $top.hunksep \
9289 "diff hunk header" \
9290 [list $ctext tag conf hunksep -foreground]]
9291 grid x $top.hunksepbut $top.hunksep -sticky w
9292 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9293 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9294 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9295 grid x $top.selbgbut $top.selbgsep -sticky w
9297 label $top.cfont -text [mc "Fonts: press to choose"]
9298 grid $top.cfont - -sticky w -pady 10
9299 mkfontdisp mainfont $top [mc "Main font"]
9300 mkfontdisp textfont $top [mc "Diff display font"]
9301 mkfontdisp uifont $top [mc "User interface font"]
9304 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9305 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9306 grid $top.buts.ok $top.buts.can
9307 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9308 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9309 grid $top.buts - - -pady 10 -sticky ew
9310 bind $top <Visibility> "focus $top.buts.ok"
9313 proc choose_extdiff {} {
9316 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9318 set extdifftool $prog
9322 proc choosecolor {v vi w x cmd} {
9325 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9326 -title [mc "Gitk: choose color for %s" $x]]
9327 if {$c eq {}} return
9328 $w conf -background $c
9334 global bglist cflist
9336 $w configure -selectbackground $c
9338 $cflist tag configure highlight \
9339 -background [$cflist cget -selectbackground]
9340 allcanvs itemconf secsel -fill $c
9347 $w conf -background $c
9355 $w conf -foreground $c
9357 allcanvs itemconf text -fill $c
9358 $canv itemconf circle -outline $c
9362 global oldprefs prefstop
9364 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9365 limitdiffs tabstop} {
9367 set $v $oldprefs($v)
9369 catch {destroy $prefstop}
9375 global maxwidth maxgraphpct
9376 global oldprefs prefstop showneartags showlocalchanges
9377 global fontpref mainfont textfont uifont
9378 global limitdiffs treediffs
9380 catch {destroy $prefstop}
9384 if {$mainfont ne $fontpref(mainfont)} {
9385 set mainfont $fontpref(mainfont)
9386 parsefont mainfont $mainfont
9387 eval font configure mainfont [fontflags mainfont]
9388 eval font configure mainfontbold [fontflags mainfont 1]
9392 if {$textfont ne $fontpref(textfont)} {
9393 set textfont $fontpref(textfont)
9394 parsefont textfont $textfont
9395 eval font configure textfont [fontflags textfont]
9396 eval font configure textfontbold [fontflags textfont 1]
9398 if {$uifont ne $fontpref(uifont)} {
9399 set uifont $fontpref(uifont)
9400 parsefont uifont $uifont
9401 eval font configure uifont [fontflags uifont]
9404 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9405 if {$showlocalchanges} {
9411 if {$limitdiffs != $oldprefs(limitdiffs)} {
9412 # treediffs elements are limited by path
9413 catch {unset treediffs}
9415 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9416 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9418 } elseif {$showneartags != $oldprefs(showneartags) ||
9419 $limitdiffs != $oldprefs(limitdiffs)} {
9424 proc formatdate {d} {
9425 global datetimeformat
9427 set d [clock format $d -format $datetimeformat]
9432 # This list of encoding names and aliases is distilled from
9433 # http://www.iana.org/assignments/character-sets.
9434 # Not all of them are supported by Tcl.
9435 set encoding_aliases {
9436 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9437 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9438 { ISO-10646-UTF-1 csISO10646UTF1 }
9439 { ISO_646.basic:1983 ref csISO646basic1983 }
9440 { INVARIANT csINVARIANT }
9441 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9442 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9443 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9444 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9445 { NATS-DANO iso-ir-9-1 csNATSDANO }
9446 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9447 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9448 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9449 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9450 { ISO-2022-KR csISO2022KR }
9452 { ISO-2022-JP csISO2022JP }
9453 { ISO-2022-JP-2 csISO2022JP2 }
9454 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9456 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9457 { IT iso-ir-15 ISO646-IT csISO15Italian }
9458 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9459 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9460 { greek7-old iso-ir-18 csISO18Greek7Old }
9461 { latin-greek iso-ir-19 csISO19LatinGreek }
9462 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9463 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9464 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9465 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9466 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9467 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9468 { INIS iso-ir-49 csISO49INIS }
9469 { INIS-8 iso-ir-50 csISO50INIS8 }
9470 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9471 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9472 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9473 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9474 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9475 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9477 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9478 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9479 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9480 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9481 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9482 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9483 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9484 { greek7 iso-ir-88 csISO88Greek7 }
9485 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9486 { iso-ir-90 csISO90 }
9487 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9488 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9489 csISO92JISC62991984b }
9490 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9491 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9492 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9493 csISO95JIS62291984handadd }
9494 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9495 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9496 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9497 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9499 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9500 { T.61-7bit iso-ir-102 csISO102T617bit }
9501 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9502 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9503 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9504 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9505 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9506 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9507 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9508 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9509 arabic csISOLatinArabic }
9510 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9511 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9512 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9513 greek greek8 csISOLatinGreek }
9514 { T.101-G2 iso-ir-128 csISO128T101G2 }
9515 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9517 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9518 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9519 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9520 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9521 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9522 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9523 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9524 csISOLatinCyrillic }
9525 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9526 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9527 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9528 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9529 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9530 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9531 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9532 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9533 { ISO_10367-box iso-ir-155 csISO10367Box }
9534 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9535 { latin-lap lap iso-ir-158 csISO158Lap }
9536 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9537 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9540 { JIS_X0201 X0201 csHalfWidthKatakana }
9541 { KSC5636 ISO646-KR csKSC5636 }
9542 { ISO-10646-UCS-2 csUnicode }
9543 { ISO-10646-UCS-4 csUCS4 }
9544 { DEC-MCS dec csDECMCS }
9545 { hp-roman8 roman8 r8 csHPRoman8 }
9546 { macintosh mac csMacintosh }
9547 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9549 { IBM038 EBCDIC-INT cp038 csIBM038 }
9550 { IBM273 CP273 csIBM273 }
9551 { IBM274 EBCDIC-BE CP274 csIBM274 }
9552 { IBM275 EBCDIC-BR cp275 csIBM275 }
9553 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9554 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9555 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9556 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9557 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9558 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9559 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9560 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9561 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9562 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9563 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9564 { IBM437 cp437 437 csPC8CodePage437 }
9565 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9566 { IBM775 cp775 csPC775Baltic }
9567 { IBM850 cp850 850 csPC850Multilingual }
9568 { IBM851 cp851 851 csIBM851 }
9569 { IBM852 cp852 852 csPCp852 }
9570 { IBM855 cp855 855 csIBM855 }
9571 { IBM857 cp857 857 csIBM857 }
9572 { IBM860 cp860 860 csIBM860 }
9573 { IBM861 cp861 861 cp-is csIBM861 }
9574 { IBM862 cp862 862 csPC862LatinHebrew }
9575 { IBM863 cp863 863 csIBM863 }
9576 { IBM864 cp864 csIBM864 }
9577 { IBM865 cp865 865 csIBM865 }
9578 { IBM866 cp866 866 csIBM866 }
9579 { IBM868 CP868 cp-ar csIBM868 }
9580 { IBM869 cp869 869 cp-gr csIBM869 }
9581 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9582 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9583 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9584 { IBM891 cp891 csIBM891 }
9585 { IBM903 cp903 csIBM903 }
9586 { IBM904 cp904 904 csIBBM904 }
9587 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9588 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9589 { IBM1026 CP1026 csIBM1026 }
9590 { EBCDIC-AT-DE csIBMEBCDICATDE }
9591 { EBCDIC-AT-DE-A csEBCDICATDEA }
9592 { EBCDIC-CA-FR csEBCDICCAFR }
9593 { EBCDIC-DK-NO csEBCDICDKNO }
9594 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9595 { EBCDIC-FI-SE csEBCDICFISE }
9596 { EBCDIC-FI-SE-A csEBCDICFISEA }
9597 { EBCDIC-FR csEBCDICFR }
9598 { EBCDIC-IT csEBCDICIT }
9599 { EBCDIC-PT csEBCDICPT }
9600 { EBCDIC-ES csEBCDICES }
9601 { EBCDIC-ES-A csEBCDICESA }
9602 { EBCDIC-ES-S csEBCDICESS }
9603 { EBCDIC-UK csEBCDICUK }
9604 { EBCDIC-US csEBCDICUS }
9605 { UNKNOWN-8BIT csUnknown8BiT }
9606 { MNEMONIC csMnemonic }
9611 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9612 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9613 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9614 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9615 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9616 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9617 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9618 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9619 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9620 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9621 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9622 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9623 { IBM1047 IBM-1047 }
9624 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9625 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9626 { UNICODE-1-1 csUnicode11 }
9629 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9630 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9632 { ISO-8859-15 ISO_8859-15 Latin-9 }
9633 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9634 { GBK CP936 MS936 windows-936 }
9635 { JIS_Encoding csJISEncoding }
9636 { Shift_JIS MS_Kanji csShiftJIS }
9637 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9639 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9640 { ISO-10646-UCS-Basic csUnicodeASCII }
9641 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9642 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9643 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9644 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9645 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9646 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9647 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9648 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9649 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9650 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9651 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9652 { Ventura-US csVenturaUS }
9653 { Ventura-International csVenturaInternational }
9654 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9655 { PC8-Turkish csPC8Turkish }
9656 { IBM-Symbols csIBMSymbols }
9657 { IBM-Thai csIBMThai }
9658 { HP-Legal csHPLegal }
9659 { HP-Pi-font csHPPiFont }
9660 { HP-Math8 csHPMath8 }
9661 { Adobe-Symbol-Encoding csHPPSMath }
9662 { HP-DeskTop csHPDesktop }
9663 { Ventura-Math csVenturaMath }
9664 { Microsoft-Publishing csMicrosoftPublishing }
9665 { Windows-31J csWindows31J }
9670 proc tcl_encoding {enc} {
9671 global encoding_aliases
9672 set names [encoding names]
9673 set lcnames [string tolower $names]
9674 set enc [string tolower $enc]
9675 set i [lsearch -exact $lcnames $enc]
9677 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9678 if {[regsub {^iso[-_]} $enc iso encx]} {
9679 set i [lsearch -exact $lcnames $encx]
9683 foreach l $encoding_aliases {
9684 set ll [string tolower $l]
9685 if {[lsearch -exact $ll $enc] < 0} continue
9686 # look through the aliases for one that tcl knows about
9688 set i [lsearch -exact $lcnames $e]
9690 if {[regsub {^iso[-_]} $e iso ex]} {
9691 set i [lsearch -exact $lcnames $ex]
9700 return [lindex $names $i]
9705 # First check that Tcl/Tk is recent enough
9706 if {[catch {package require Tk 8.4} err]} {
9707 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9708 Gitk requires at least Tcl/Tk 8.4."]
9713 set wrcomcmd "git diff-tree --stdin -p --pretty"
9717 set gitencoding [exec git config --get i18n.commitencoding]
9719 if {$gitencoding == ""} {
9720 set gitencoding "utf-8"
9722 set tclencoding [tcl_encoding $gitencoding]
9723 if {$tclencoding == {}} {
9724 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9727 set mainfont {Helvetica 9}
9728 set textfont {Courier 9}
9729 set uifont {Helvetica 9 bold}
9731 set findmergefiles 0
9739 set cmitmode "patch"
9740 set wrapcomment "none"
9744 set showlocalchanges 1
9746 set datetimeformat "%Y-%m-%d %H:%M:%S"
9749 set extdifftool "meld"
9751 set colors {green red blue magenta darkgrey brown orange}
9754 set diffcolors {red "#00a000" blue}
9757 set selectbgcolor gray85
9759 ## For msgcat loading, first locate the installation location.
9760 if { [info exists ::env(GITK_MSGSDIR)] } {
9761 ## Msgsdir was manually set in the environment.
9762 set gitk_msgsdir $::env(GITK_MSGSDIR)
9764 ## Let's guess the prefix from argv0.
9765 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9766 set gitk_libdir [file join $gitk_prefix share gitk lib]
9767 set gitk_msgsdir [file join $gitk_libdir msgs]
9771 ## Internationalization (i18n) through msgcat and gettext. See
9772 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9773 package require msgcat
9774 namespace import ::msgcat::mc
9775 ## And eventually load the actual message catalog
9776 ::msgcat::mcload $gitk_msgsdir
9778 catch {source ~/.gitk}
9780 font create optionfont -family sans-serif -size -12
9782 parsefont mainfont $mainfont
9783 eval font create mainfont [fontflags mainfont]
9784 eval font create mainfontbold [fontflags mainfont 1]
9786 parsefont textfont $textfont
9787 eval font create textfont [fontflags textfont]
9788 eval font create textfontbold [fontflags textfont 1]
9790 parsefont uifont $uifont
9791 eval font create uifont [fontflags uifont]
9795 # check that we can find a .git directory somewhere...
9796 if {[catch {set gitdir [gitdir]}]} {
9797 show_error {} . [mc "Cannot find a git repository here."]
9800 if {![file isdirectory $gitdir]} {
9801 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9806 set cmdline_files {}
9808 set revtreeargscmd {}
9810 switch -glob -- $arg {
9813 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9817 set revtreeargscmd [string range $arg 10 end]
9820 lappend revtreeargs $arg
9826 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9827 # no -- on command line, but some arguments (other than --argscmd)
9829 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9830 set cmdline_files [split $f "\n"]
9831 set n [llength $cmdline_files]
9832 set revtreeargs [lrange $revtreeargs 0 end-$n]
9833 # Unfortunately git rev-parse doesn't produce an error when
9834 # something is both a revision and a filename. To be consistent
9835 # with git log and git rev-list, check revtreeargs for filenames.
9836 foreach arg $revtreeargs {
9837 if {[file exists $arg]} {
9838 show_error {} . [mc "Ambiguous argument '%s': both revision\
9844 # unfortunately we get both stdout and stderr in $err,
9845 # so look for "fatal:".
9846 set i [string first "fatal:" $err]
9848 set err [string range $err [expr {$i + 6}] end]
9850 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9855 set nullid "0000000000000000000000000000000000000000"
9856 set nullid2 "0000000000000000000000000000000000000001"
9857 set nullfile "/dev/null"
9859 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9866 set highlight_paths {}
9868 set searchdirn -forwards
9872 set markingmatches 0
9873 set linkentercount 0
9874 set need_redisplay 0
9881 set selectedhlview [mc "None"]
9882 set highlight_related [mc "None"]
9883 set highlight_files {}
9887 set viewargscmd(0) {}
9896 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9899 # wait for the window to become visible
9901 wm title . "[file tail $argv0]: [file tail [pwd]]"
9904 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9905 # create a view for the files/dirs specified on the command line
9909 set viewname(1) [mc "Command line"]
9910 set viewfiles(1) $cmdline_files
9911 set viewargs(1) $revtreeargs
9912 set viewargscmd(1) $revtreeargscmd
9916 .bar.view entryconf [mc "Edit view..."] -state normal
9917 .bar.view entryconf [mc "Delete view"] -state normal
9920 if {[info exists permviews]} {
9921 foreach v $permviews {
9924 set viewname($n) [lindex $v 0]
9925 set viewfiles($n) [lindex $v 1]
9926 set viewargs($n) [lindex $v 2]
9927 set viewargscmd($n) [lindex $v 3]