t5510: test "git fetch" following tags minimally
[git/jnareb-git.git] / gitk-git / gitk
blob2eaa2ae7d6f692f6063ebbd211eaab30212c2eae
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
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.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
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.
24 proc run args {
25 global isonrunq runq currunq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {} && ![info exists currunq]} {
30 after idle dorunq
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} {
41 global runq currunq
43 fileevent $fd readable {}
44 if {$runq eq {} && ![info exists currunq]} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq currunq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set currunq [lindex $runq 0]
71 set runq [lrange $runq 1 end]
72 set repeat [eval $script]
73 unset currunq
74 set t1 [clock clicks -milliseconds]
75 set t [expr {$t1 - $t0}]
76 if {$repeat ne {} && $repeat} {
77 if {$fd eq {} || $repeat == 2} {
78 # script returns 1 if it wants to be readded
79 # file readers return 2 if they could do more straight away
80 lappend runq [list $fd $script]
81 } else {
82 fileevent $fd readable [list filereadable $fd $script]
84 } elseif {$fd eq {}} {
85 unset isonrunq($script)
87 set t0 $t1
88 if {$t1 - $tstart >= 80} break
90 if {$runq ne {}} {
91 after idle dorunq
95 proc reg_instance {fd} {
96 global commfd leftover loginstance
98 set i [incr loginstance]
99 set commfd($i) $fd
100 set leftover($i) {}
101 return $i
104 proc unmerged_files {files} {
105 global nr_unmerged
107 # find the list of unmerged files
108 set mlist {}
109 set nr_unmerged 0
110 if {[catch {
111 set fd [open "| git ls-files -u" r]
112 } err]} {
113 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
114 exit 1
116 while {[gets $fd line] >= 0} {
117 set i [string first "\t" $line]
118 if {$i < 0} continue
119 set fname [string range $line [expr {$i+1}] end]
120 if {[lsearch -exact $mlist $fname] >= 0} continue
121 incr nr_unmerged
122 if {$files eq {} || [path_filter $files $fname]} {
123 lappend mlist $fname
126 catch {close $fd}
127 return $mlist
130 proc parseviewargs {n arglist} {
131 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
133 set vdatemode($n) 0
134 set vmergeonly($n) 0
135 set glflags {}
136 set diffargs {}
137 set nextisval 0
138 set revargs {}
139 set origargs $arglist
140 set allknown 1
141 set filtered 0
142 set i -1
143 foreach arg $arglist {
144 incr i
145 if {$nextisval} {
146 lappend glflags $arg
147 set nextisval 0
148 continue
150 switch -glob -- $arg {
151 "-d" -
152 "--date-order" {
153 set vdatemode($n) 1
154 # remove from origargs in case we hit an unknown option
155 set origargs [lreplace $origargs $i $i]
156 incr i -1
158 # These request or affect diff output, which we don't want.
159 # Some could be used to set our defaults for diff display.
160 "-[puabwcrRBMC]" -
161 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165 "--ignore-space-change" - "-U*" - "--unified=*" {
166 lappend diffargs $arg
168 # These cause our parsing of git log's output to fail, or else
169 # they're options we want to set ourselves, so ignore them.
170 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171 "--name-only" - "--name-status" - "--color" - "--color-words" -
172 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176 "--objects" - "--objects-edge" - "--reverse" {
178 # These are harmless, and some are even useful
179 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
180 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
181 "--full-history" - "--dense" - "--sparse" -
182 "--follow" - "--left-right" - "--encoding=*" {
183 lappend glflags $arg
185 # These mean that we get a subset of the commits
186 "--diff-filter=*" - "--no-merges" - "--unpacked" -
187 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
188 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
189 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
190 "--remove-empty" - "--first-parent" - "--cherry-pick" -
191 "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
192 set filtered 1
193 lappend glflags $arg
195 # This appears to be the only one that has a value as a
196 # separate word following it
197 "-n" {
198 set filtered 1
199 set nextisval 1
200 lappend glflags $arg
202 "--not" {
203 set notflag [expr {!$notflag}]
204 lappend revargs $arg
206 "--all" {
207 lappend revargs $arg
209 "--merge" {
210 set vmergeonly($n) 1
211 # git rev-parse doesn't understand --merge
212 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
214 # Other flag arguments including -<n>
215 "-*" {
216 if {[string is digit -strict [string range $arg 1 end]]} {
217 set filtered 1
218 } else {
219 # a flag argument that we don't recognize;
220 # that means we can't optimize
221 set allknown 0
223 lappend glflags $arg
225 # Non-flag arguments specify commits or ranges of commits
226 default {
227 if {[string match "*...*" $arg]} {
228 lappend revargs --gitk-symmetric-diff-marker
230 lappend revargs $arg
234 set vdflags($n) $diffargs
235 set vflags($n) $glflags
236 set vrevs($n) $revargs
237 set vfiltered($n) $filtered
238 set vorigargs($n) $origargs
239 return $allknown
242 proc parseviewrevs {view revs} {
243 global vposids vnegids
245 if {$revs eq {}} {
246 set revs HEAD
248 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
249 # we get stdout followed by stderr in $err
250 # for an unknown rev, git rev-parse echoes it and then errors out
251 set errlines [split $err "\n"]
252 set badrev {}
253 for {set l 0} {$l < [llength $errlines]} {incr l} {
254 set line [lindex $errlines $l]
255 if {!([string length $line] == 40 && [string is xdigit $line])} {
256 if {[string match "fatal:*" $line]} {
257 if {[string match "fatal: ambiguous argument*" $line]
258 && $badrev ne {}} {
259 if {[llength $badrev] == 1} {
260 set err "unknown revision $badrev"
261 } else {
262 set err "unknown revisions: [join $badrev ", "]"
264 } else {
265 set err [join [lrange $errlines $l end] "\n"]
267 break
269 lappend badrev $line
272 error_popup "Error parsing revisions: $err"
273 return {}
275 set ret {}
276 set pos {}
277 set neg {}
278 set sdm 0
279 foreach id [split $ids "\n"] {
280 if {$id eq "--gitk-symmetric-diff-marker"} {
281 set sdm 4
282 } elseif {[string match "^*" $id]} {
283 if {$sdm != 1} {
284 lappend ret $id
285 if {$sdm == 3} {
286 set sdm 0
289 lappend neg [string range $id 1 end]
290 } else {
291 if {$sdm != 2} {
292 lappend ret $id
293 } else {
294 lset ret end [lindex $ret end]...$id
296 lappend pos $id
298 incr sdm -1
300 set vposids($view) $pos
301 set vnegids($view) $neg
302 return $ret
305 # Start off a git log process and arrange to read its output
306 proc start_rev_list {view} {
307 global startmsecs commitidx viewcomplete curview
308 global tclencoding
309 global viewargs viewargscmd viewfiles vfilelimit
310 global showlocalchanges commitinterest
311 global viewactive viewinstances vmergeonly
312 global mainheadid
313 global vcanopt vflags vrevs vorigargs
315 set startmsecs [clock clicks -milliseconds]
316 set commitidx($view) 0
317 # these are set this way for the error exits
318 set viewcomplete($view) 1
319 set viewactive($view) 0
320 varcinit $view
322 set args $viewargs($view)
323 if {$viewargscmd($view) ne {}} {
324 if {[catch {
325 set str [exec sh -c $viewargscmd($view)]
326 } err]} {
327 error_popup "Error executing --argscmd command: $err"
328 return 0
330 set args [concat $args [split $str "\n"]]
332 set vcanopt($view) [parseviewargs $view $args]
334 set files $viewfiles($view)
335 if {$vmergeonly($view)} {
336 set files [unmerged_files $files]
337 if {$files eq {}} {
338 global nr_unmerged
339 if {$nr_unmerged == 0} {
340 error_popup [mc "No files selected: --merge specified but\
341 no files are unmerged."]
342 } else {
343 error_popup [mc "No files selected: --merge specified but\
344 no unmerged files are within file limit."]
346 return 0
349 set vfilelimit($view) $files
351 if {$vcanopt($view)} {
352 set revs [parseviewrevs $view $vrevs($view)]
353 if {$revs eq {}} {
354 return 0
356 set args [concat $vflags($view) $revs]
357 } else {
358 set args $vorigargs($view)
361 if {[catch {
362 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
363 --boundary $args "--" $files] r]
364 } err]} {
365 error_popup "[mc "Error executing git log:"] $err"
366 return 0
368 set i [reg_instance $fd]
369 set viewinstances($view) [list $i]
370 if {$showlocalchanges && $mainheadid ne {}} {
371 lappend commitinterest($mainheadid) {dodiffindex}
373 fconfigure $fd -blocking 0 -translation lf -eofchar {}
374 if {$tclencoding != {}} {
375 fconfigure $fd -encoding $tclencoding
377 filerun $fd [list getcommitlines $fd $i $view 0]
378 nowbusy $view [mc "Reading"]
379 set viewcomplete($view) 0
380 set viewactive($view) 1
381 return 1
384 proc stop_instance {inst} {
385 global commfd leftover
387 set fd $commfd($inst)
388 catch {
389 set pid [pid $fd]
391 if {$::tcl_platform(platform) eq {windows}} {
392 exec kill -f $pid
393 } else {
394 exec kill $pid
397 catch {close $fd}
398 nukefile $fd
399 unset commfd($inst)
400 unset leftover($inst)
403 proc stop_backends {} {
404 global commfd
406 foreach inst [array names commfd] {
407 stop_instance $inst
411 proc stop_rev_list {view} {
412 global viewinstances
414 foreach inst $viewinstances($view) {
415 stop_instance $inst
417 set viewinstances($view) {}
420 proc reset_pending_select {selid} {
421 global pending_select mainheadid selectheadid
423 if {$selid ne {}} {
424 set pending_select $selid
425 } elseif {$selectheadid ne {}} {
426 set pending_select $selectheadid
427 } else {
428 set pending_select $mainheadid
432 proc getcommits {selid} {
433 global canv curview need_redisplay viewactive
435 initlayout
436 if {[start_rev_list $curview]} {
437 reset_pending_select $selid
438 show_status [mc "Reading commits..."]
439 set need_redisplay 1
440 } else {
441 show_status [mc "No commits selected"]
445 proc updatecommits {} {
446 global curview vcanopt vorigargs vfilelimit viewinstances
447 global viewactive viewcomplete tclencoding
448 global startmsecs showneartags showlocalchanges
449 global mainheadid pending_select
450 global isworktree
451 global varcid vposids vnegids vflags vrevs
453 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
454 set oldmainid $mainheadid
455 rereadrefs
456 if {$showlocalchanges} {
457 if {$mainheadid ne $oldmainid} {
458 dohidelocalchanges
460 if {[commitinview $mainheadid $curview]} {
461 dodiffindex
464 set view $curview
465 if {$vcanopt($view)} {
466 set oldpos $vposids($view)
467 set oldneg $vnegids($view)
468 set revs [parseviewrevs $view $vrevs($view)]
469 if {$revs eq {}} {
470 return
472 # note: getting the delta when negative refs change is hard,
473 # and could require multiple git log invocations, so in that
474 # case we ask git log for all the commits (not just the delta)
475 if {$oldneg eq $vnegids($view)} {
476 set newrevs {}
477 set npos 0
478 # take out positive refs that we asked for before or
479 # that we have already seen
480 foreach rev $revs {
481 if {[string length $rev] == 40} {
482 if {[lsearch -exact $oldpos $rev] < 0
483 && ![info exists varcid($view,$rev)]} {
484 lappend newrevs $rev
485 incr npos
487 } else {
488 lappend $newrevs $rev
491 if {$npos == 0} return
492 set revs $newrevs
493 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
495 set args [concat $vflags($view) $revs --not $oldpos]
496 } else {
497 set args $vorigargs($view)
499 if {[catch {
500 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
501 --boundary $args "--" $vfilelimit($view)] r]
502 } err]} {
503 error_popup "Error executing git log: $err"
504 return
506 if {$viewactive($view) == 0} {
507 set startmsecs [clock clicks -milliseconds]
509 set i [reg_instance $fd]
510 lappend viewinstances($view) $i
511 fconfigure $fd -blocking 0 -translation lf -eofchar {}
512 if {$tclencoding != {}} {
513 fconfigure $fd -encoding $tclencoding
515 filerun $fd [list getcommitlines $fd $i $view 1]
516 incr viewactive($view)
517 set viewcomplete($view) 0
518 reset_pending_select {}
519 nowbusy $view "Reading"
520 if {$showneartags} {
521 getallcommits
525 proc reloadcommits {} {
526 global curview viewcomplete selectedline currentid thickerline
527 global showneartags treediffs commitinterest cached_commitrow
528 global targetid
530 set selid {}
531 if {$selectedline ne {}} {
532 set selid $currentid
535 if {!$viewcomplete($curview)} {
536 stop_rev_list $curview
538 resetvarcs $curview
539 set selectedline {}
540 catch {unset currentid}
541 catch {unset thickerline}
542 catch {unset treediffs}
543 readrefs
544 changedrefs
545 if {$showneartags} {
546 getallcommits
548 clear_display
549 catch {unset commitinterest}
550 catch {unset cached_commitrow}
551 catch {unset targetid}
552 setcanvscroll
553 getcommits $selid
554 return 0
557 # This makes a string representation of a positive integer which
558 # sorts as a string in numerical order
559 proc strrep {n} {
560 if {$n < 16} {
561 return [format "%x" $n]
562 } elseif {$n < 256} {
563 return [format "x%.2x" $n]
564 } elseif {$n < 65536} {
565 return [format "y%.4x" $n]
567 return [format "z%.8x" $n]
570 # Procedures used in reordering commits from git log (without
571 # --topo-order) into the order for display.
573 proc varcinit {view} {
574 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
575 global vtokmod varcmod vrowmod varcix vlastins
577 set varcstart($view) {{}}
578 set vupptr($view) {0}
579 set vdownptr($view) {0}
580 set vleftptr($view) {0}
581 set vbackptr($view) {0}
582 set varctok($view) {{}}
583 set varcrow($view) {{}}
584 set vtokmod($view) {}
585 set varcmod($view) 0
586 set vrowmod($view) 0
587 set varcix($view) {{}}
588 set vlastins($view) {0}
591 proc resetvarcs {view} {
592 global varcid varccommits parents children vseedcount ordertok
594 foreach vid [array names varcid $view,*] {
595 unset varcid($vid)
596 unset children($vid)
597 unset parents($vid)
599 # some commits might have children but haven't been seen yet
600 foreach vid [array names children $view,*] {
601 unset children($vid)
603 foreach va [array names varccommits $view,*] {
604 unset varccommits($va)
606 foreach vd [array names vseedcount $view,*] {
607 unset vseedcount($vd)
609 catch {unset ordertok}
612 # returns a list of the commits with no children
613 proc seeds {v} {
614 global vdownptr vleftptr varcstart
616 set ret {}
617 set a [lindex $vdownptr($v) 0]
618 while {$a != 0} {
619 lappend ret [lindex $varcstart($v) $a]
620 set a [lindex $vleftptr($v) $a]
622 return $ret
625 proc newvarc {view id} {
626 global varcid varctok parents children vdatemode
627 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
628 global commitdata commitinfo vseedcount varccommits vlastins
630 set a [llength $varctok($view)]
631 set vid $view,$id
632 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
633 if {![info exists commitinfo($id)]} {
634 parsecommit $id $commitdata($id) 1
636 set cdate [lindex $commitinfo($id) 4]
637 if {![string is integer -strict $cdate]} {
638 set cdate 0
640 if {![info exists vseedcount($view,$cdate)]} {
641 set vseedcount($view,$cdate) -1
643 set c [incr vseedcount($view,$cdate)]
644 set cdate [expr {$cdate ^ 0xffffffff}]
645 set tok "s[strrep $cdate][strrep $c]"
646 } else {
647 set tok {}
649 set ka 0
650 if {[llength $children($vid)] > 0} {
651 set kid [lindex $children($vid) end]
652 set k $varcid($view,$kid)
653 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
654 set ki $kid
655 set ka $k
656 set tok [lindex $varctok($view) $k]
659 if {$ka != 0} {
660 set i [lsearch -exact $parents($view,$ki) $id]
661 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
662 append tok [strrep $j]
664 set c [lindex $vlastins($view) $ka]
665 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
666 set c $ka
667 set b [lindex $vdownptr($view) $ka]
668 } else {
669 set b [lindex $vleftptr($view) $c]
671 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
672 set c $b
673 set b [lindex $vleftptr($view) $c]
675 if {$c == $ka} {
676 lset vdownptr($view) $ka $a
677 lappend vbackptr($view) 0
678 } else {
679 lset vleftptr($view) $c $a
680 lappend vbackptr($view) $c
682 lset vlastins($view) $ka $a
683 lappend vupptr($view) $ka
684 lappend vleftptr($view) $b
685 if {$b != 0} {
686 lset vbackptr($view) $b $a
688 lappend varctok($view) $tok
689 lappend varcstart($view) $id
690 lappend vdownptr($view) 0
691 lappend varcrow($view) {}
692 lappend varcix($view) {}
693 set varccommits($view,$a) {}
694 lappend vlastins($view) 0
695 return $a
698 proc splitvarc {p v} {
699 global varcid varcstart varccommits varctok
700 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
702 set oa $varcid($v,$p)
703 set ac $varccommits($v,$oa)
704 set i [lsearch -exact $varccommits($v,$oa) $p]
705 if {$i <= 0} return
706 set na [llength $varctok($v)]
707 # "%" sorts before "0"...
708 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
709 lappend varctok($v) $tok
710 lappend varcrow($v) {}
711 lappend varcix($v) {}
712 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
713 set varccommits($v,$na) [lrange $ac $i end]
714 lappend varcstart($v) $p
715 foreach id $varccommits($v,$na) {
716 set varcid($v,$id) $na
718 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
719 lappend vlastins($v) [lindex $vlastins($v) $oa]
720 lset vdownptr($v) $oa $na
721 lset vlastins($v) $oa 0
722 lappend vupptr($v) $oa
723 lappend vleftptr($v) 0
724 lappend vbackptr($v) 0
725 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
726 lset vupptr($v) $b $na
730 proc renumbervarc {a v} {
731 global parents children varctok varcstart varccommits
732 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
734 set t1 [clock clicks -milliseconds]
735 set todo {}
736 set isrelated($a) 1
737 set kidchanged($a) 1
738 set ntot 0
739 while {$a != 0} {
740 if {[info exists isrelated($a)]} {
741 lappend todo $a
742 set id [lindex $varccommits($v,$a) end]
743 foreach p $parents($v,$id) {
744 if {[info exists varcid($v,$p)]} {
745 set isrelated($varcid($v,$p)) 1
749 incr ntot
750 set b [lindex $vdownptr($v) $a]
751 if {$b == 0} {
752 while {$a != 0} {
753 set b [lindex $vleftptr($v) $a]
754 if {$b != 0} break
755 set a [lindex $vupptr($v) $a]
758 set a $b
760 foreach a $todo {
761 if {![info exists kidchanged($a)]} continue
762 set id [lindex $varcstart($v) $a]
763 if {[llength $children($v,$id)] > 1} {
764 set children($v,$id) [lsort -command [list vtokcmp $v] \
765 $children($v,$id)]
767 set oldtok [lindex $varctok($v) $a]
768 if {!$vdatemode($v)} {
769 set tok {}
770 } else {
771 set tok $oldtok
773 set ka 0
774 set kid [last_real_child $v,$id]
775 if {$kid ne {}} {
776 set k $varcid($v,$kid)
777 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
778 set ki $kid
779 set ka $k
780 set tok [lindex $varctok($v) $k]
783 if {$ka != 0} {
784 set i [lsearch -exact $parents($v,$ki) $id]
785 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
786 append tok [strrep $j]
788 if {$tok eq $oldtok} {
789 continue
791 set id [lindex $varccommits($v,$a) end]
792 foreach p $parents($v,$id) {
793 if {[info exists varcid($v,$p)]} {
794 set kidchanged($varcid($v,$p)) 1
795 } else {
796 set sortkids($p) 1
799 lset varctok($v) $a $tok
800 set b [lindex $vupptr($v) $a]
801 if {$b != $ka} {
802 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
803 modify_arc $v $ka
805 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
806 modify_arc $v $b
808 set c [lindex $vbackptr($v) $a]
809 set d [lindex $vleftptr($v) $a]
810 if {$c == 0} {
811 lset vdownptr($v) $b $d
812 } else {
813 lset vleftptr($v) $c $d
815 if {$d != 0} {
816 lset vbackptr($v) $d $c
818 if {[lindex $vlastins($v) $b] == $a} {
819 lset vlastins($v) $b $c
821 lset vupptr($v) $a $ka
822 set c [lindex $vlastins($v) $ka]
823 if {$c == 0 || \
824 [string compare $tok [lindex $varctok($v) $c]] < 0} {
825 set c $ka
826 set b [lindex $vdownptr($v) $ka]
827 } else {
828 set b [lindex $vleftptr($v) $c]
830 while {$b != 0 && \
831 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
832 set c $b
833 set b [lindex $vleftptr($v) $c]
835 if {$c == $ka} {
836 lset vdownptr($v) $ka $a
837 lset vbackptr($v) $a 0
838 } else {
839 lset vleftptr($v) $c $a
840 lset vbackptr($v) $a $c
842 lset vleftptr($v) $a $b
843 if {$b != 0} {
844 lset vbackptr($v) $b $a
846 lset vlastins($v) $ka $a
849 foreach id [array names sortkids] {
850 if {[llength $children($v,$id)] > 1} {
851 set children($v,$id) [lsort -command [list vtokcmp $v] \
852 $children($v,$id)]
855 set t2 [clock clicks -milliseconds]
856 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
859 # Fix up the graph after we have found out that in view $v,
860 # $p (a commit that we have already seen) is actually the parent
861 # of the last commit in arc $a.
862 proc fix_reversal {p a v} {
863 global varcid varcstart varctok vupptr
865 set pa $varcid($v,$p)
866 if {$p ne [lindex $varcstart($v) $pa]} {
867 splitvarc $p $v
868 set pa $varcid($v,$p)
870 # seeds always need to be renumbered
871 if {[lindex $vupptr($v) $pa] == 0 ||
872 [string compare [lindex $varctok($v) $a] \
873 [lindex $varctok($v) $pa]] > 0} {
874 renumbervarc $pa $v
878 proc insertrow {id p v} {
879 global cmitlisted children parents varcid varctok vtokmod
880 global varccommits ordertok commitidx numcommits curview
881 global targetid targetrow
883 readcommit $id
884 set vid $v,$id
885 set cmitlisted($vid) 1
886 set children($vid) {}
887 set parents($vid) [list $p]
888 set a [newvarc $v $id]
889 set varcid($vid) $a
890 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
891 modify_arc $v $a
893 lappend varccommits($v,$a) $id
894 set vp $v,$p
895 if {[llength [lappend children($vp) $id]] > 1} {
896 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
897 catch {unset ordertok}
899 fix_reversal $p $a $v
900 incr commitidx($v)
901 if {$v == $curview} {
902 set numcommits $commitidx($v)
903 setcanvscroll
904 if {[info exists targetid]} {
905 if {![comes_before $targetid $p]} {
906 incr targetrow
912 proc insertfakerow {id p} {
913 global varcid varccommits parents children cmitlisted
914 global commitidx varctok vtokmod targetid targetrow curview numcommits
916 set v $curview
917 set a $varcid($v,$p)
918 set i [lsearch -exact $varccommits($v,$a) $p]
919 if {$i < 0} {
920 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
921 return
923 set children($v,$id) {}
924 set parents($v,$id) [list $p]
925 set varcid($v,$id) $a
926 lappend children($v,$p) $id
927 set cmitlisted($v,$id) 1
928 set numcommits [incr commitidx($v)]
929 # note we deliberately don't update varcstart($v) even if $i == 0
930 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
931 modify_arc $v $a $i
932 if {[info exists targetid]} {
933 if {![comes_before $targetid $p]} {
934 incr targetrow
937 setcanvscroll
938 drawvisible
941 proc removefakerow {id} {
942 global varcid varccommits parents children commitidx
943 global varctok vtokmod cmitlisted currentid selectedline
944 global targetid curview numcommits
946 set v $curview
947 if {[llength $parents($v,$id)] != 1} {
948 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
949 return
951 set p [lindex $parents($v,$id) 0]
952 set a $varcid($v,$id)
953 set i [lsearch -exact $varccommits($v,$a) $id]
954 if {$i < 0} {
955 puts "oops: removefakerow can't find [shortids $id] on arc $a"
956 return
958 unset varcid($v,$id)
959 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
960 unset parents($v,$id)
961 unset children($v,$id)
962 unset cmitlisted($v,$id)
963 set numcommits [incr commitidx($v) -1]
964 set j [lsearch -exact $children($v,$p) $id]
965 if {$j >= 0} {
966 set children($v,$p) [lreplace $children($v,$p) $j $j]
968 modify_arc $v $a $i
969 if {[info exist currentid] && $id eq $currentid} {
970 unset currentid
971 set selectedline {}
973 if {[info exists targetid] && $targetid eq $id} {
974 set targetid $p
976 setcanvscroll
977 drawvisible
980 proc first_real_child {vp} {
981 global children nullid nullid2
983 foreach id $children($vp) {
984 if {$id ne $nullid && $id ne $nullid2} {
985 return $id
988 return {}
991 proc last_real_child {vp} {
992 global children nullid nullid2
994 set kids $children($vp)
995 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
996 set id [lindex $kids $i]
997 if {$id ne $nullid && $id ne $nullid2} {
998 return $id
1001 return {}
1004 proc vtokcmp {v a b} {
1005 global varctok varcid
1007 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1008 [lindex $varctok($v) $varcid($v,$b)]]
1011 # This assumes that if lim is not given, the caller has checked that
1012 # arc a's token is less than $vtokmod($v)
1013 proc modify_arc {v a {lim {}}} {
1014 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1016 if {$lim ne {}} {
1017 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1018 if {$c > 0} return
1019 if {$c == 0} {
1020 set r [lindex $varcrow($v) $a]
1021 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1024 set vtokmod($v) [lindex $varctok($v) $a]
1025 set varcmod($v) $a
1026 if {$v == $curview} {
1027 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1028 set a [lindex $vupptr($v) $a]
1029 set lim {}
1031 set r 0
1032 if {$a != 0} {
1033 if {$lim eq {}} {
1034 set lim [llength $varccommits($v,$a)]
1036 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1038 set vrowmod($v) $r
1039 undolayout $r
1043 proc update_arcrows {v} {
1044 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1045 global varcid vrownum varcorder varcix varccommits
1046 global vupptr vdownptr vleftptr varctok
1047 global displayorder parentlist curview cached_commitrow
1049 if {$vrowmod($v) == $commitidx($v)} return
1050 if {$v == $curview} {
1051 if {[llength $displayorder] > $vrowmod($v)} {
1052 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1053 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1055 catch {unset cached_commitrow}
1057 set narctot [expr {[llength $varctok($v)] - 1}]
1058 set a $varcmod($v)
1059 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1060 # go up the tree until we find something that has a row number,
1061 # or we get to a seed
1062 set a [lindex $vupptr($v) $a]
1064 if {$a == 0} {
1065 set a [lindex $vdownptr($v) 0]
1066 if {$a == 0} return
1067 set vrownum($v) {0}
1068 set varcorder($v) [list $a]
1069 lset varcix($v) $a 0
1070 lset varcrow($v) $a 0
1071 set arcn 0
1072 set row 0
1073 } else {
1074 set arcn [lindex $varcix($v) $a]
1075 if {[llength $vrownum($v)] > $arcn + 1} {
1076 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1077 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1079 set row [lindex $varcrow($v) $a]
1081 while {1} {
1082 set p $a
1083 incr row [llength $varccommits($v,$a)]
1084 # go down if possible
1085 set b [lindex $vdownptr($v) $a]
1086 if {$b == 0} {
1087 # if not, go left, or go up until we can go left
1088 while {$a != 0} {
1089 set b [lindex $vleftptr($v) $a]
1090 if {$b != 0} break
1091 set a [lindex $vupptr($v) $a]
1093 if {$a == 0} break
1095 set a $b
1096 incr arcn
1097 lappend vrownum($v) $row
1098 lappend varcorder($v) $a
1099 lset varcix($v) $a $arcn
1100 lset varcrow($v) $a $row
1102 set vtokmod($v) [lindex $varctok($v) $p]
1103 set varcmod($v) $p
1104 set vrowmod($v) $row
1105 if {[info exists currentid]} {
1106 set selectedline [rowofcommit $currentid]
1110 # Test whether view $v contains commit $id
1111 proc commitinview {id v} {
1112 global varcid
1114 return [info exists varcid($v,$id)]
1117 # Return the row number for commit $id in the current view
1118 proc rowofcommit {id} {
1119 global varcid varccommits varcrow curview cached_commitrow
1120 global varctok vtokmod
1122 set v $curview
1123 if {![info exists varcid($v,$id)]} {
1124 puts "oops rowofcommit no arc for [shortids $id]"
1125 return {}
1127 set a $varcid($v,$id)
1128 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1129 update_arcrows $v
1131 if {[info exists cached_commitrow($id)]} {
1132 return $cached_commitrow($id)
1134 set i [lsearch -exact $varccommits($v,$a) $id]
1135 if {$i < 0} {
1136 puts "oops didn't find commit [shortids $id] in arc $a"
1137 return {}
1139 incr i [lindex $varcrow($v) $a]
1140 set cached_commitrow($id) $i
1141 return $i
1144 # Returns 1 if a is on an earlier row than b, otherwise 0
1145 proc comes_before {a b} {
1146 global varcid varctok curview
1148 set v $curview
1149 if {$a eq $b || ![info exists varcid($v,$a)] || \
1150 ![info exists varcid($v,$b)]} {
1151 return 0
1153 if {$varcid($v,$a) != $varcid($v,$b)} {
1154 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1155 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1157 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1160 proc bsearch {l elt} {
1161 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1162 return 0
1164 set lo 0
1165 set hi [llength $l]
1166 while {$hi - $lo > 1} {
1167 set mid [expr {int(($lo + $hi) / 2)}]
1168 set t [lindex $l $mid]
1169 if {$elt < $t} {
1170 set hi $mid
1171 } elseif {$elt > $t} {
1172 set lo $mid
1173 } else {
1174 return $mid
1177 return $lo
1180 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1181 proc make_disporder {start end} {
1182 global vrownum curview commitidx displayorder parentlist
1183 global varccommits varcorder parents vrowmod varcrow
1184 global d_valid_start d_valid_end
1186 if {$end > $vrowmod($curview)} {
1187 update_arcrows $curview
1189 set ai [bsearch $vrownum($curview) $start]
1190 set start [lindex $vrownum($curview) $ai]
1191 set narc [llength $vrownum($curview)]
1192 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1193 set a [lindex $varcorder($curview) $ai]
1194 set l [llength $displayorder]
1195 set al [llength $varccommits($curview,$a)]
1196 if {$l < $r + $al} {
1197 if {$l < $r} {
1198 set pad [ntimes [expr {$r - $l}] {}]
1199 set displayorder [concat $displayorder $pad]
1200 set parentlist [concat $parentlist $pad]
1201 } elseif {$l > $r} {
1202 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1203 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1205 foreach id $varccommits($curview,$a) {
1206 lappend displayorder $id
1207 lappend parentlist $parents($curview,$id)
1209 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1210 set i $r
1211 foreach id $varccommits($curview,$a) {
1212 lset displayorder $i $id
1213 lset parentlist $i $parents($curview,$id)
1214 incr i
1217 incr r $al
1221 proc commitonrow {row} {
1222 global displayorder
1224 set id [lindex $displayorder $row]
1225 if {$id eq {}} {
1226 make_disporder $row [expr {$row + 1}]
1227 set id [lindex $displayorder $row]
1229 return $id
1232 proc closevarcs {v} {
1233 global varctok varccommits varcid parents children
1234 global cmitlisted commitidx commitinterest vtokmod
1236 set missing_parents 0
1237 set scripts {}
1238 set narcs [llength $varctok($v)]
1239 for {set a 1} {$a < $narcs} {incr a} {
1240 set id [lindex $varccommits($v,$a) end]
1241 foreach p $parents($v,$id) {
1242 if {[info exists varcid($v,$p)]} continue
1243 # add p as a new commit
1244 incr missing_parents
1245 set cmitlisted($v,$p) 0
1246 set parents($v,$p) {}
1247 if {[llength $children($v,$p)] == 1 &&
1248 [llength $parents($v,$id)] == 1} {
1249 set b $a
1250 } else {
1251 set b [newvarc $v $p]
1253 set varcid($v,$p) $b
1254 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1255 modify_arc $v $b
1257 lappend varccommits($v,$b) $p
1258 incr commitidx($v)
1259 if {[info exists commitinterest($p)]} {
1260 foreach script $commitinterest($p) {
1261 lappend scripts [string map [list "%I" $p] $script]
1263 unset commitinterest($id)
1267 if {$missing_parents > 0} {
1268 foreach s $scripts {
1269 eval $s
1274 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1275 # Assumes we already have an arc for $rwid.
1276 proc rewrite_commit {v id rwid} {
1277 global children parents varcid varctok vtokmod varccommits
1279 foreach ch $children($v,$id) {
1280 # make $rwid be $ch's parent in place of $id
1281 set i [lsearch -exact $parents($v,$ch) $id]
1282 if {$i < 0} {
1283 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1285 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1286 # add $ch to $rwid's children and sort the list if necessary
1287 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1288 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1289 $children($v,$rwid)]
1291 # fix the graph after joining $id to $rwid
1292 set a $varcid($v,$ch)
1293 fix_reversal $rwid $a $v
1294 # parentlist is wrong for the last element of arc $a
1295 # even if displayorder is right, hence the 3rd arg here
1296 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1300 proc getcommitlines {fd inst view updating} {
1301 global cmitlisted commitinterest leftover
1302 global commitidx commitdata vdatemode
1303 global parents children curview hlview
1304 global idpending ordertok
1305 global varccommits varcid varctok vtokmod vfilelimit
1307 set stuff [read $fd 500000]
1308 # git log doesn't terminate the last commit with a null...
1309 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1310 set stuff "\0"
1312 if {$stuff == {}} {
1313 if {![eof $fd]} {
1314 return 1
1316 global commfd viewcomplete viewactive viewname
1317 global viewinstances
1318 unset commfd($inst)
1319 set i [lsearch -exact $viewinstances($view) $inst]
1320 if {$i >= 0} {
1321 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1323 # set it blocking so we wait for the process to terminate
1324 fconfigure $fd -blocking 1
1325 if {[catch {close $fd} err]} {
1326 set fv {}
1327 if {$view != $curview} {
1328 set fv " for the \"$viewname($view)\" view"
1330 if {[string range $err 0 4] == "usage"} {
1331 set err "Gitk: error reading commits$fv:\
1332 bad arguments to git log."
1333 if {$viewname($view) eq "Command line"} {
1334 append err \
1335 " (Note: arguments to gitk are passed to git log\
1336 to allow selection of commits to be displayed.)"
1338 } else {
1339 set err "Error reading commits$fv: $err"
1341 error_popup $err
1343 if {[incr viewactive($view) -1] <= 0} {
1344 set viewcomplete($view) 1
1345 # Check if we have seen any ids listed as parents that haven't
1346 # appeared in the list
1347 closevarcs $view
1348 notbusy $view
1350 if {$view == $curview} {
1351 run chewcommits
1353 return 0
1355 set start 0
1356 set gotsome 0
1357 set scripts {}
1358 while 1 {
1359 set i [string first "\0" $stuff $start]
1360 if {$i < 0} {
1361 append leftover($inst) [string range $stuff $start end]
1362 break
1364 if {$start == 0} {
1365 set cmit $leftover($inst)
1366 append cmit [string range $stuff 0 [expr {$i - 1}]]
1367 set leftover($inst) {}
1368 } else {
1369 set cmit [string range $stuff $start [expr {$i - 1}]]
1371 set start [expr {$i + 1}]
1372 set j [string first "\n" $cmit]
1373 set ok 0
1374 set listed 1
1375 if {$j >= 0 && [string match "commit *" $cmit]} {
1376 set ids [string range $cmit 7 [expr {$j - 1}]]
1377 if {[string match {[-^<>]*} $ids]} {
1378 switch -- [string index $ids 0] {
1379 "-" {set listed 0}
1380 "^" {set listed 2}
1381 "<" {set listed 3}
1382 ">" {set listed 4}
1384 set ids [string range $ids 1 end]
1386 set ok 1
1387 foreach id $ids {
1388 if {[string length $id] != 40} {
1389 set ok 0
1390 break
1394 if {!$ok} {
1395 set shortcmit $cmit
1396 if {[string length $shortcmit] > 80} {
1397 set shortcmit "[string range $shortcmit 0 80]..."
1399 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1400 exit 1
1402 set id [lindex $ids 0]
1403 set vid $view,$id
1405 if {!$listed && $updating && ![info exists varcid($vid)] &&
1406 $vfilelimit($view) ne {}} {
1407 # git log doesn't rewrite parents for unlisted commits
1408 # when doing path limiting, so work around that here
1409 # by working out the rewritten parent with git rev-list
1410 # and if we already know about it, using the rewritten
1411 # parent as a substitute parent for $id's children.
1412 if {![catch {
1413 set rwid [exec git rev-list --first-parent --max-count=1 \
1414 $id -- $vfilelimit($view)]
1415 }]} {
1416 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1417 # use $rwid in place of $id
1418 rewrite_commit $view $id $rwid
1419 continue
1424 set a 0
1425 if {[info exists varcid($vid)]} {
1426 if {$cmitlisted($vid) || !$listed} continue
1427 set a $varcid($vid)
1429 if {$listed} {
1430 set olds [lrange $ids 1 end]
1431 } else {
1432 set olds {}
1434 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1435 set cmitlisted($vid) $listed
1436 set parents($vid) $olds
1437 if {![info exists children($vid)]} {
1438 set children($vid) {}
1439 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1440 set k [lindex $children($vid) 0]
1441 if {[llength $parents($view,$k)] == 1 &&
1442 (!$vdatemode($view) ||
1443 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1444 set a $varcid($view,$k)
1447 if {$a == 0} {
1448 # new arc
1449 set a [newvarc $view $id]
1451 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1452 modify_arc $view $a
1454 if {![info exists varcid($vid)]} {
1455 set varcid($vid) $a
1456 lappend varccommits($view,$a) $id
1457 incr commitidx($view)
1460 set i 0
1461 foreach p $olds {
1462 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1463 set vp $view,$p
1464 if {[llength [lappend children($vp) $id]] > 1 &&
1465 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1466 set children($vp) [lsort -command [list vtokcmp $view] \
1467 $children($vp)]
1468 catch {unset ordertok}
1470 if {[info exists varcid($view,$p)]} {
1471 fix_reversal $p $a $view
1474 incr i
1477 if {[info exists commitinterest($id)]} {
1478 foreach script $commitinterest($id) {
1479 lappend scripts [string map [list "%I" $id] $script]
1481 unset commitinterest($id)
1483 set gotsome 1
1485 if {$gotsome} {
1486 global numcommits hlview
1488 if {$view == $curview} {
1489 set numcommits $commitidx($view)
1490 run chewcommits
1492 if {[info exists hlview] && $view == $hlview} {
1493 # we never actually get here...
1494 run vhighlightmore
1496 foreach s $scripts {
1497 eval $s
1500 return 2
1503 proc chewcommits {} {
1504 global curview hlview viewcomplete
1505 global pending_select
1507 layoutmore
1508 if {$viewcomplete($curview)} {
1509 global commitidx varctok
1510 global numcommits startmsecs
1512 if {[info exists pending_select]} {
1513 update
1514 reset_pending_select {}
1516 if {[commitinview $pending_select $curview]} {
1517 selectline [rowofcommit $pending_select] 1
1518 } else {
1519 set row [first_real_row]
1520 selectline $row 1
1523 if {$commitidx($curview) > 0} {
1524 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1525 #puts "overall $ms ms for $numcommits commits"
1526 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1527 } else {
1528 show_status [mc "No commits selected"]
1530 notbusy layout
1532 return 0
1535 proc readcommit {id} {
1536 if {[catch {set contents [exec git cat-file commit $id]}]} return
1537 parsecommit $id $contents 0
1540 proc parsecommit {id contents listed} {
1541 global commitinfo cdate
1543 set inhdr 1
1544 set comment {}
1545 set headline {}
1546 set auname {}
1547 set audate {}
1548 set comname {}
1549 set comdate {}
1550 set hdrend [string first "\n\n" $contents]
1551 if {$hdrend < 0} {
1552 # should never happen...
1553 set hdrend [string length $contents]
1555 set header [string range $contents 0 [expr {$hdrend - 1}]]
1556 set comment [string range $contents [expr {$hdrend + 2}] end]
1557 foreach line [split $header "\n"] {
1558 set tag [lindex $line 0]
1559 if {$tag == "author"} {
1560 set audate [lindex $line end-1]
1561 set auname [lrange $line 1 end-2]
1562 } elseif {$tag == "committer"} {
1563 set comdate [lindex $line end-1]
1564 set comname [lrange $line 1 end-2]
1567 set headline {}
1568 # take the first non-blank line of the comment as the headline
1569 set headline [string trimleft $comment]
1570 set i [string first "\n" $headline]
1571 if {$i >= 0} {
1572 set headline [string range $headline 0 $i]
1574 set headline [string trimright $headline]
1575 set i [string first "\r" $headline]
1576 if {$i >= 0} {
1577 set headline [string trimright [string range $headline 0 $i]]
1579 if {!$listed} {
1580 # git log indents the comment by 4 spaces;
1581 # if we got this via git cat-file, add the indentation
1582 set newcomment {}
1583 foreach line [split $comment "\n"] {
1584 append newcomment " "
1585 append newcomment $line
1586 append newcomment "\n"
1588 set comment $newcomment
1590 if {$comdate != {}} {
1591 set cdate($id) $comdate
1593 set commitinfo($id) [list $headline $auname $audate \
1594 $comname $comdate $comment]
1597 proc getcommit {id} {
1598 global commitdata commitinfo
1600 if {[info exists commitdata($id)]} {
1601 parsecommit $id $commitdata($id) 1
1602 } else {
1603 readcommit $id
1604 if {![info exists commitinfo($id)]} {
1605 set commitinfo($id) [list [mc "No commit information available"]]
1608 return 1
1611 proc readrefs {} {
1612 global tagids idtags headids idheads tagobjid
1613 global otherrefids idotherrefs mainhead mainheadid
1614 global selecthead selectheadid
1616 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1617 catch {unset $v}
1619 set refd [open [list | git show-ref -d] r]
1620 while {[gets $refd line] >= 0} {
1621 if {[string index $line 40] ne " "} continue
1622 set id [string range $line 0 39]
1623 set ref [string range $line 41 end]
1624 if {![string match "refs/*" $ref]} continue
1625 set name [string range $ref 5 end]
1626 if {[string match "remotes/*" $name]} {
1627 if {![string match "*/HEAD" $name]} {
1628 set headids($name) $id
1629 lappend idheads($id) $name
1631 } elseif {[string match "heads/*" $name]} {
1632 set name [string range $name 6 end]
1633 set headids($name) $id
1634 lappend idheads($id) $name
1635 } elseif {[string match "tags/*" $name]} {
1636 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1637 # which is what we want since the former is the commit ID
1638 set name [string range $name 5 end]
1639 if {[string match "*^{}" $name]} {
1640 set name [string range $name 0 end-3]
1641 } else {
1642 set tagobjid($name) $id
1644 set tagids($name) $id
1645 lappend idtags($id) $name
1646 } else {
1647 set otherrefids($name) $id
1648 lappend idotherrefs($id) $name
1651 catch {close $refd}
1652 set mainhead {}
1653 set mainheadid {}
1654 catch {
1655 set mainheadid [exec git rev-parse HEAD]
1656 set thehead [exec git symbolic-ref HEAD]
1657 if {[string match "refs/heads/*" $thehead]} {
1658 set mainhead [string range $thehead 11 end]
1661 set selectheadid {}
1662 if {$selecthead ne {}} {
1663 catch {
1664 set selectheadid [exec git rev-parse --verify $selecthead]
1669 # skip over fake commits
1670 proc first_real_row {} {
1671 global nullid nullid2 numcommits
1673 for {set row 0} {$row < $numcommits} {incr row} {
1674 set id [commitonrow $row]
1675 if {$id ne $nullid && $id ne $nullid2} {
1676 break
1679 return $row
1682 # update things for a head moved to a child of its previous location
1683 proc movehead {id name} {
1684 global headids idheads
1686 removehead $headids($name) $name
1687 set headids($name) $id
1688 lappend idheads($id) $name
1691 # update things when a head has been removed
1692 proc removehead {id name} {
1693 global headids idheads
1695 if {$idheads($id) eq $name} {
1696 unset idheads($id)
1697 } else {
1698 set i [lsearch -exact $idheads($id) $name]
1699 if {$i >= 0} {
1700 set idheads($id) [lreplace $idheads($id) $i $i]
1703 unset headids($name)
1706 proc show_error {w top msg} {
1707 message $w.m -text $msg -justify center -aspect 400
1708 pack $w.m -side top -fill x -padx 20 -pady 20
1709 button $w.ok -text [mc OK] -command "destroy $top"
1710 pack $w.ok -side bottom -fill x
1711 bind $top <Visibility> "grab $top; focus $top"
1712 bind $top <Key-Return> "destroy $top"
1713 tkwait window $top
1716 proc error_popup msg {
1717 set w .error
1718 toplevel $w
1719 wm transient $w .
1720 show_error $w $w $msg
1723 proc confirm_popup msg {
1724 global confirm_ok
1725 set confirm_ok 0
1726 set w .confirm
1727 toplevel $w
1728 wm transient $w .
1729 message $w.m -text $msg -justify center -aspect 400
1730 pack $w.m -side top -fill x -padx 20 -pady 20
1731 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1732 pack $w.ok -side left -fill x
1733 button $w.cancel -text [mc Cancel] -command "destroy $w"
1734 pack $w.cancel -side right -fill x
1735 bind $w <Visibility> "grab $w; focus $w"
1736 tkwait window $w
1737 return $confirm_ok
1740 proc setoptions {} {
1741 option add *Panedwindow.showHandle 1 startupFile
1742 option add *Panedwindow.sashRelief raised startupFile
1743 option add *Button.font uifont startupFile
1744 option add *Checkbutton.font uifont startupFile
1745 option add *Radiobutton.font uifont startupFile
1746 option add *Menu.font uifont startupFile
1747 option add *Menubutton.font uifont startupFile
1748 option add *Label.font uifont startupFile
1749 option add *Message.font uifont startupFile
1750 option add *Entry.font uifont startupFile
1753 proc makewindow {} {
1754 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1755 global tabstop
1756 global findtype findtypemenu findloc findstring fstring geometry
1757 global entries sha1entry sha1string sha1but
1758 global diffcontextstring diffcontext
1759 global ignorespace
1760 global maincursor textcursor curtextcursor
1761 global rowctxmenu fakerowmenu mergemax wrapcomment
1762 global highlight_files gdttype
1763 global searchstring sstring
1764 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1765 global headctxmenu progresscanv progressitem progresscoords statusw
1766 global fprogitem fprogcoord lastprogupdate progupdatepending
1767 global rprogitem rprogcoord rownumsel numcommits
1768 global have_tk85
1770 menu .bar
1771 .bar add cascade -label [mc "File"] -menu .bar.file
1772 menu .bar.file
1773 .bar.file add command -label [mc "Update"] -command updatecommits
1774 .bar.file add command -label [mc "Reload"] -command reloadcommits
1775 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1776 .bar.file add command -label [mc "List references"] -command showrefs
1777 .bar.file add command -label [mc "Quit"] -command doquit
1778 menu .bar.edit
1779 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1780 .bar.edit add command -label [mc "Preferences"] -command doprefs
1782 menu .bar.view
1783 .bar add cascade -label [mc "View"] -menu .bar.view
1784 .bar.view add command -label [mc "New view..."] -command {newview 0}
1785 .bar.view add command -label [mc "Edit view..."] -command editview \
1786 -state disabled
1787 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1788 .bar.view add separator
1789 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1790 -variable selectedview -value 0
1792 menu .bar.help
1793 .bar add cascade -label [mc "Help"] -menu .bar.help
1794 .bar.help add command -label [mc "About gitk"] -command about
1795 .bar.help add command -label [mc "Key bindings"] -command keys
1796 .bar.help configure
1797 . configure -menu .bar
1799 # the gui has upper and lower half, parts of a paned window.
1800 panedwindow .ctop -orient vertical
1802 # possibly use assumed geometry
1803 if {![info exists geometry(pwsash0)]} {
1804 set geometry(topheight) [expr {15 * $linespc}]
1805 set geometry(topwidth) [expr {80 * $charspc}]
1806 set geometry(botheight) [expr {15 * $linespc}]
1807 set geometry(botwidth) [expr {50 * $charspc}]
1808 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1809 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1812 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1813 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1814 frame .tf.histframe
1815 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1817 # create three canvases
1818 set cscroll .tf.histframe.csb
1819 set canv .tf.histframe.pwclist.canv
1820 canvas $canv \
1821 -selectbackground $selectbgcolor \
1822 -background $bgcolor -bd 0 \
1823 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1824 .tf.histframe.pwclist add $canv
1825 set canv2 .tf.histframe.pwclist.canv2
1826 canvas $canv2 \
1827 -selectbackground $selectbgcolor \
1828 -background $bgcolor -bd 0 -yscrollincr $linespc
1829 .tf.histframe.pwclist add $canv2
1830 set canv3 .tf.histframe.pwclist.canv3
1831 canvas $canv3 \
1832 -selectbackground $selectbgcolor \
1833 -background $bgcolor -bd 0 -yscrollincr $linespc
1834 .tf.histframe.pwclist add $canv3
1835 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1836 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1838 # a scroll bar to rule them
1839 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1840 pack $cscroll -side right -fill y
1841 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1842 lappend bglist $canv $canv2 $canv3
1843 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1845 # we have two button bars at bottom of top frame. Bar 1
1846 frame .tf.bar
1847 frame .tf.lbar -height 15
1849 set sha1entry .tf.bar.sha1
1850 set entries $sha1entry
1851 set sha1but .tf.bar.sha1label
1852 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1853 -command gotocommit -width 8
1854 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1855 pack .tf.bar.sha1label -side left
1856 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1857 trace add variable sha1string write sha1change
1858 pack $sha1entry -side left -pady 2
1860 image create bitmap bm-left -data {
1861 #define left_width 16
1862 #define left_height 16
1863 static unsigned char left_bits[] = {
1864 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1865 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1866 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1868 image create bitmap bm-right -data {
1869 #define right_width 16
1870 #define right_height 16
1871 static unsigned char right_bits[] = {
1872 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1873 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1874 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1876 button .tf.bar.leftbut -image bm-left -command goback \
1877 -state disabled -width 26
1878 pack .tf.bar.leftbut -side left -fill y
1879 button .tf.bar.rightbut -image bm-right -command goforw \
1880 -state disabled -width 26
1881 pack .tf.bar.rightbut -side left -fill y
1883 label .tf.bar.rowlabel -text [mc "Row"]
1884 set rownumsel {}
1885 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1886 -relief sunken -anchor e
1887 label .tf.bar.rowlabel2 -text "/"
1888 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1889 -relief sunken -anchor e
1890 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1891 -side left
1892 global selectedline
1893 trace add variable selectedline write selectedline_change
1895 # Status label and progress bar
1896 set statusw .tf.bar.status
1897 label $statusw -width 15 -relief sunken
1898 pack $statusw -side left -padx 5
1899 set h [expr {[font metrics uifont -linespace] + 2}]
1900 set progresscanv .tf.bar.progress
1901 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1902 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1903 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1904 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1905 pack $progresscanv -side right -expand 1 -fill x
1906 set progresscoords {0 0}
1907 set fprogcoord 0
1908 set rprogcoord 0
1909 bind $progresscanv <Configure> adjustprogress
1910 set lastprogupdate [clock clicks -milliseconds]
1911 set progupdatepending 0
1913 # build up the bottom bar of upper window
1914 label .tf.lbar.flabel -text "[mc "Find"] "
1915 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1916 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1917 label .tf.lbar.flab2 -text " [mc "commit"] "
1918 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1919 -side left -fill y
1920 set gdttype [mc "containing:"]
1921 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1922 [mc "containing:"] \
1923 [mc "touching paths:"] \
1924 [mc "adding/removing string:"]]
1925 trace add variable gdttype write gdttype_change
1926 pack .tf.lbar.gdttype -side left -fill y
1928 set findstring {}
1929 set fstring .tf.lbar.findstring
1930 lappend entries $fstring
1931 entry $fstring -width 30 -font textfont -textvariable findstring
1932 trace add variable findstring write find_change
1933 set findtype [mc "Exact"]
1934 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1935 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1936 trace add variable findtype write findcom_change
1937 set findloc [mc "All fields"]
1938 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1939 [mc "Comments"] [mc "Author"] [mc "Committer"]
1940 trace add variable findloc write find_change
1941 pack .tf.lbar.findloc -side right
1942 pack .tf.lbar.findtype -side right
1943 pack $fstring -side left -expand 1 -fill x
1945 # Finish putting the upper half of the viewer together
1946 pack .tf.lbar -in .tf -side bottom -fill x
1947 pack .tf.bar -in .tf -side bottom -fill x
1948 pack .tf.histframe -fill both -side top -expand 1
1949 .ctop add .tf
1950 .ctop paneconfigure .tf -height $geometry(topheight)
1951 .ctop paneconfigure .tf -width $geometry(topwidth)
1953 # now build up the bottom
1954 panedwindow .pwbottom -orient horizontal
1956 # lower left, a text box over search bar, scroll bar to the right
1957 # if we know window height, then that will set the lower text height, otherwise
1958 # we set lower text height which will drive window height
1959 if {[info exists geometry(main)]} {
1960 frame .bleft -width $geometry(botwidth)
1961 } else {
1962 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1964 frame .bleft.top
1965 frame .bleft.mid
1966 frame .bleft.bottom
1968 button .bleft.top.search -text [mc "Search"] -command dosearch
1969 pack .bleft.top.search -side left -padx 5
1970 set sstring .bleft.top.sstring
1971 entry $sstring -width 20 -font textfont -textvariable searchstring
1972 lappend entries $sstring
1973 trace add variable searchstring write incrsearch
1974 pack $sstring -side left -expand 1 -fill x
1975 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1976 -command changediffdisp -variable diffelide -value {0 0}
1977 radiobutton .bleft.mid.old -text [mc "Old version"] \
1978 -command changediffdisp -variable diffelide -value {0 1}
1979 radiobutton .bleft.mid.new -text [mc "New version"] \
1980 -command changediffdisp -variable diffelide -value {1 0}
1981 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1982 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1983 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1984 -from 1 -increment 1 -to 10000000 \
1985 -validate all -validatecommand "diffcontextvalidate %P" \
1986 -textvariable diffcontextstring
1987 .bleft.mid.diffcontext set $diffcontext
1988 trace add variable diffcontextstring write diffcontextchange
1989 lappend entries .bleft.mid.diffcontext
1990 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1991 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1992 -command changeignorespace -variable ignorespace
1993 pack .bleft.mid.ignspace -side left -padx 5
1994 set ctext .bleft.bottom.ctext
1995 text $ctext -background $bgcolor -foreground $fgcolor \
1996 -state disabled -font textfont \
1997 -yscrollcommand scrolltext -wrap none \
1998 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1999 if {$have_tk85} {
2000 $ctext conf -tabstyle wordprocessor
2002 scrollbar .bleft.bottom.sb -command "$ctext yview"
2003 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2004 -width 10
2005 pack .bleft.top -side top -fill x
2006 pack .bleft.mid -side top -fill x
2007 grid $ctext .bleft.bottom.sb -sticky nsew
2008 grid .bleft.bottom.sbhorizontal -sticky ew
2009 grid columnconfigure .bleft.bottom 0 -weight 1
2010 grid rowconfigure .bleft.bottom 0 -weight 1
2011 grid rowconfigure .bleft.bottom 1 -weight 0
2012 pack .bleft.bottom -side top -fill both -expand 1
2013 lappend bglist $ctext
2014 lappend fglist $ctext
2016 $ctext tag conf comment -wrap $wrapcomment
2017 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2018 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2019 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2020 $ctext tag conf d1 -fore [lindex $diffcolors 1]
2021 $ctext tag conf m0 -fore red
2022 $ctext tag conf m1 -fore blue
2023 $ctext tag conf m2 -fore green
2024 $ctext tag conf m3 -fore purple
2025 $ctext tag conf m4 -fore brown
2026 $ctext tag conf m5 -fore "#009090"
2027 $ctext tag conf m6 -fore magenta
2028 $ctext tag conf m7 -fore "#808000"
2029 $ctext tag conf m8 -fore "#009000"
2030 $ctext tag conf m9 -fore "#ff0080"
2031 $ctext tag conf m10 -fore cyan
2032 $ctext tag conf m11 -fore "#b07070"
2033 $ctext tag conf m12 -fore "#70b0f0"
2034 $ctext tag conf m13 -fore "#70f0b0"
2035 $ctext tag conf m14 -fore "#f0b070"
2036 $ctext tag conf m15 -fore "#ff70b0"
2037 $ctext tag conf mmax -fore darkgrey
2038 set mergemax 16
2039 $ctext tag conf mresult -font textfontbold
2040 $ctext tag conf msep -font textfontbold
2041 $ctext tag conf found -back yellow
2043 .pwbottom add .bleft
2044 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2046 # lower right
2047 frame .bright
2048 frame .bright.mode
2049 radiobutton .bright.mode.patch -text [mc "Patch"] \
2050 -command reselectline -variable cmitmode -value "patch"
2051 radiobutton .bright.mode.tree -text [mc "Tree"] \
2052 -command reselectline -variable cmitmode -value "tree"
2053 grid .bright.mode.patch .bright.mode.tree -sticky ew
2054 pack .bright.mode -side top -fill x
2055 set cflist .bright.cfiles
2056 set indent [font measure mainfont "nn"]
2057 text $cflist \
2058 -selectbackground $selectbgcolor \
2059 -background $bgcolor -foreground $fgcolor \
2060 -font mainfont \
2061 -tabs [list $indent [expr {2 * $indent}]] \
2062 -yscrollcommand ".bright.sb set" \
2063 -cursor [. cget -cursor] \
2064 -spacing1 1 -spacing3 1
2065 lappend bglist $cflist
2066 lappend fglist $cflist
2067 scrollbar .bright.sb -command "$cflist yview"
2068 pack .bright.sb -side right -fill y
2069 pack $cflist -side left -fill both -expand 1
2070 $cflist tag configure highlight \
2071 -background [$cflist cget -selectbackground]
2072 $cflist tag configure bold -font mainfontbold
2074 .pwbottom add .bright
2075 .ctop add .pwbottom
2077 # restore window width & height if known
2078 if {[info exists geometry(main)]} {
2079 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2080 if {$w > [winfo screenwidth .]} {
2081 set w [winfo screenwidth .]
2083 if {$h > [winfo screenheight .]} {
2084 set h [winfo screenheight .]
2086 wm geometry . "${w}x$h"
2090 if {[tk windowingsystem] eq {aqua}} {
2091 set M1B M1
2092 } else {
2093 set M1B Control
2096 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2097 pack .ctop -fill both -expand 1
2098 bindall <1> {selcanvline %W %x %y}
2099 #bindall <B1-Motion> {selcanvline %W %x %y}
2100 if {[tk windowingsystem] == "win32"} {
2101 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2102 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2103 } else {
2104 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2105 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2106 if {[tk windowingsystem] eq "aqua"} {
2107 bindall <MouseWheel> {
2108 set delta [expr {- (%D)}]
2109 allcanvs yview scroll $delta units
2113 bindall <2> "canvscan mark %W %x %y"
2114 bindall <B2-Motion> "canvscan dragto %W %x %y"
2115 bindkey <Home> selfirstline
2116 bindkey <End> sellastline
2117 bind . <Key-Up> "selnextline -1"
2118 bind . <Key-Down> "selnextline 1"
2119 bind . <Shift-Key-Up> "dofind -1 0"
2120 bind . <Shift-Key-Down> "dofind 1 0"
2121 bindkey <Key-Right> "goforw"
2122 bindkey <Key-Left> "goback"
2123 bind . <Key-Prior> "selnextpage -1"
2124 bind . <Key-Next> "selnextpage 1"
2125 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2126 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2127 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2128 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2129 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2130 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2131 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2132 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2133 bindkey <Key-space> "$ctext yview scroll 1 pages"
2134 bindkey p "selnextline -1"
2135 bindkey n "selnextline 1"
2136 bindkey z "goback"
2137 bindkey x "goforw"
2138 bindkey i "selnextline -1"
2139 bindkey k "selnextline 1"
2140 bindkey j "goback"
2141 bindkey l "goforw"
2142 bindkey b prevfile
2143 bindkey d "$ctext yview scroll 18 units"
2144 bindkey u "$ctext yview scroll -18 units"
2145 bindkey / {dofind 1 1}
2146 bindkey <Key-Return> {dofind 1 1}
2147 bindkey ? {dofind -1 1}
2148 bindkey f nextfile
2149 bindkey <F5> updatecommits
2150 bind . <$M1B-q> doquit
2151 bind . <$M1B-f> {dofind 1 1}
2152 bind . <$M1B-g> {dofind 1 0}
2153 bind . <$M1B-r> dosearchback
2154 bind . <$M1B-s> dosearch
2155 bind . <$M1B-equal> {incrfont 1}
2156 bind . <$M1B-plus> {incrfont 1}
2157 bind . <$M1B-KP_Add> {incrfont 1}
2158 bind . <$M1B-minus> {incrfont -1}
2159 bind . <$M1B-KP_Subtract> {incrfont -1}
2160 wm protocol . WM_DELETE_WINDOW doquit
2161 bind . <Destroy> {stop_backends}
2162 bind . <Button-1> "click %W"
2163 bind $fstring <Key-Return> {dofind 1 1}
2164 bind $sha1entry <Key-Return> gotocommit
2165 bind $sha1entry <<PasteSelection>> clearsha1
2166 bind $cflist <1> {sel_flist %W %x %y; break}
2167 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2168 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2169 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
2171 set maincursor [. cget -cursor]
2172 set textcursor [$ctext cget -cursor]
2173 set curtextcursor $textcursor
2175 set rowctxmenu .rowctxmenu
2176 menu $rowctxmenu -tearoff 0
2177 $rowctxmenu add command -label [mc "Diff this -> selected"] \
2178 -command {diffvssel 0}
2179 $rowctxmenu add command -label [mc "Diff selected -> this"] \
2180 -command {diffvssel 1}
2181 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2182 $rowctxmenu add command -label [mc "Create tag"] -command mktag
2183 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2184 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2185 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2186 -command cherrypick
2187 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2188 -command resethead
2190 set fakerowmenu .fakerowmenu
2191 menu $fakerowmenu -tearoff 0
2192 $fakerowmenu add command -label [mc "Diff this -> selected"] \
2193 -command {diffvssel 0}
2194 $fakerowmenu add command -label [mc "Diff selected -> this"] \
2195 -command {diffvssel 1}
2196 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2197 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2198 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2199 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2201 set headctxmenu .headctxmenu
2202 menu $headctxmenu -tearoff 0
2203 $headctxmenu add command -label [mc "Check out this branch"] \
2204 -command cobranch
2205 $headctxmenu add command -label [mc "Remove this branch"] \
2206 -command rmbranch
2208 global flist_menu
2209 set flist_menu .flistctxmenu
2210 menu $flist_menu -tearoff 0
2211 $flist_menu add command -label [mc "Highlight this too"] \
2212 -command {flist_hl 0}
2213 $flist_menu add command -label [mc "Highlight this only"] \
2214 -command {flist_hl 1}
2215 $flist_menu add command -label [mc "External diff"] \
2216 -command {external_diff}
2217 $flist_menu add command -label [mc "Blame parent commit"] \
2218 -command {external_blame 1}
2221 # Windows sends all mouse wheel events to the current focused window, not
2222 # the one where the mouse hovers, so bind those events here and redirect
2223 # to the correct window
2224 proc windows_mousewheel_redirector {W X Y D} {
2225 global canv canv2 canv3
2226 set w [winfo containing -displayof $W $X $Y]
2227 if {$w ne ""} {
2228 set u [expr {$D < 0 ? 5 : -5}]
2229 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2230 allcanvs yview scroll $u units
2231 } else {
2232 catch {
2233 $w yview scroll $u units
2239 # Update row number label when selectedline changes
2240 proc selectedline_change {n1 n2 op} {
2241 global selectedline rownumsel
2243 if {$selectedline eq {}} {
2244 set rownumsel {}
2245 } else {
2246 set rownumsel [expr {$selectedline + 1}]
2250 # mouse-2 makes all windows scan vertically, but only the one
2251 # the cursor is in scans horizontally
2252 proc canvscan {op w x y} {
2253 global canv canv2 canv3
2254 foreach c [list $canv $canv2 $canv3] {
2255 if {$c == $w} {
2256 $c scan $op $x $y
2257 } else {
2258 $c scan $op 0 $y
2263 proc scrollcanv {cscroll f0 f1} {
2264 $cscroll set $f0 $f1
2265 drawvisible
2266 flushhighlights
2269 # when we make a key binding for the toplevel, make sure
2270 # it doesn't get triggered when that key is pressed in the
2271 # find string entry widget.
2272 proc bindkey {ev script} {
2273 global entries
2274 bind . $ev $script
2275 set escript [bind Entry $ev]
2276 if {$escript == {}} {
2277 set escript [bind Entry <Key>]
2279 foreach e $entries {
2280 bind $e $ev "$escript; break"
2284 # set the focus back to the toplevel for any click outside
2285 # the entry widgets
2286 proc click {w} {
2287 global ctext entries
2288 foreach e [concat $entries $ctext] {
2289 if {$w == $e} return
2291 focus .
2294 # Adjust the progress bar for a change in requested extent or canvas size
2295 proc adjustprogress {} {
2296 global progresscanv progressitem progresscoords
2297 global fprogitem fprogcoord lastprogupdate progupdatepending
2298 global rprogitem rprogcoord
2300 set w [expr {[winfo width $progresscanv] - 4}]
2301 set x0 [expr {$w * [lindex $progresscoords 0]}]
2302 set x1 [expr {$w * [lindex $progresscoords 1]}]
2303 set h [winfo height $progresscanv]
2304 $progresscanv coords $progressitem $x0 0 $x1 $h
2305 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2306 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2307 set now [clock clicks -milliseconds]
2308 if {$now >= $lastprogupdate + 100} {
2309 set progupdatepending 0
2310 update
2311 } elseif {!$progupdatepending} {
2312 set progupdatepending 1
2313 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2317 proc doprogupdate {} {
2318 global lastprogupdate progupdatepending
2320 if {$progupdatepending} {
2321 set progupdatepending 0
2322 set lastprogupdate [clock clicks -milliseconds]
2323 update
2327 proc savestuff {w} {
2328 global canv canv2 canv3 mainfont textfont uifont tabstop
2329 global stuffsaved findmergefiles maxgraphpct
2330 global maxwidth showneartags showlocalchanges
2331 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2332 global cmitmode wrapcomment datetimeformat limitdiffs
2333 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2334 global autoselect extdifftool
2336 if {$stuffsaved} return
2337 if {![winfo viewable .]} return
2338 catch {
2339 set f [open "~/.gitk-new" w]
2340 puts $f [list set mainfont $mainfont]
2341 puts $f [list set textfont $textfont]
2342 puts $f [list set uifont $uifont]
2343 puts $f [list set tabstop $tabstop]
2344 puts $f [list set findmergefiles $findmergefiles]
2345 puts $f [list set maxgraphpct $maxgraphpct]
2346 puts $f [list set maxwidth $maxwidth]
2347 puts $f [list set cmitmode $cmitmode]
2348 puts $f [list set wrapcomment $wrapcomment]
2349 puts $f [list set autoselect $autoselect]
2350 puts $f [list set showneartags $showneartags]
2351 puts $f [list set showlocalchanges $showlocalchanges]
2352 puts $f [list set datetimeformat $datetimeformat]
2353 puts $f [list set limitdiffs $limitdiffs]
2354 puts $f [list set bgcolor $bgcolor]
2355 puts $f [list set fgcolor $fgcolor]
2356 puts $f [list set colors $colors]
2357 puts $f [list set diffcolors $diffcolors]
2358 puts $f [list set diffcontext $diffcontext]
2359 puts $f [list set selectbgcolor $selectbgcolor]
2360 puts $f [list set extdifftool $extdifftool]
2362 puts $f "set geometry(main) [wm geometry .]"
2363 puts $f "set geometry(topwidth) [winfo width .tf]"
2364 puts $f "set geometry(topheight) [winfo height .tf]"
2365 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2366 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2367 puts $f "set geometry(botwidth) [winfo width .bleft]"
2368 puts $f "set geometry(botheight) [winfo height .bleft]"
2370 puts -nonewline $f "set permviews {"
2371 for {set v 0} {$v < $nextviewnum} {incr v} {
2372 if {$viewperm($v)} {
2373 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2376 puts $f "}"
2377 close $f
2378 file rename -force "~/.gitk-new" "~/.gitk"
2380 set stuffsaved 1
2383 proc resizeclistpanes {win w} {
2384 global oldwidth
2385 if {[info exists oldwidth($win)]} {
2386 set s0 [$win sash coord 0]
2387 set s1 [$win sash coord 1]
2388 if {$w < 60} {
2389 set sash0 [expr {int($w/2 - 2)}]
2390 set sash1 [expr {int($w*5/6 - 2)}]
2391 } else {
2392 set factor [expr {1.0 * $w / $oldwidth($win)}]
2393 set sash0 [expr {int($factor * [lindex $s0 0])}]
2394 set sash1 [expr {int($factor * [lindex $s1 0])}]
2395 if {$sash0 < 30} {
2396 set sash0 30
2398 if {$sash1 < $sash0 + 20} {
2399 set sash1 [expr {$sash0 + 20}]
2401 if {$sash1 > $w - 10} {
2402 set sash1 [expr {$w - 10}]
2403 if {$sash0 > $sash1 - 20} {
2404 set sash0 [expr {$sash1 - 20}]
2408 $win sash place 0 $sash0 [lindex $s0 1]
2409 $win sash place 1 $sash1 [lindex $s1 1]
2411 set oldwidth($win) $w
2414 proc resizecdetpanes {win w} {
2415 global oldwidth
2416 if {[info exists oldwidth($win)]} {
2417 set s0 [$win sash coord 0]
2418 if {$w < 60} {
2419 set sash0 [expr {int($w*3/4 - 2)}]
2420 } else {
2421 set factor [expr {1.0 * $w / $oldwidth($win)}]
2422 set sash0 [expr {int($factor * [lindex $s0 0])}]
2423 if {$sash0 < 45} {
2424 set sash0 45
2426 if {$sash0 > $w - 15} {
2427 set sash0 [expr {$w - 15}]
2430 $win sash place 0 $sash0 [lindex $s0 1]
2432 set oldwidth($win) $w
2435 proc allcanvs args {
2436 global canv canv2 canv3
2437 eval $canv $args
2438 eval $canv2 $args
2439 eval $canv3 $args
2442 proc bindall {event action} {
2443 global canv canv2 canv3
2444 bind $canv $event $action
2445 bind $canv2 $event $action
2446 bind $canv3 $event $action
2449 proc about {} {
2450 global uifont
2451 set w .about
2452 if {[winfo exists $w]} {
2453 raise $w
2454 return
2456 toplevel $w
2457 wm title $w [mc "About gitk"]
2458 message $w.m -text [mc "
2459 Gitk - a commit viewer for git
2461 Copyright © 2005-2008 Paul Mackerras
2463 Use and redistribute under the terms of the GNU General Public License"] \
2464 -justify center -aspect 400 -border 2 -bg white -relief groove
2465 pack $w.m -side top -fill x -padx 2 -pady 2
2466 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2467 pack $w.ok -side bottom
2468 bind $w <Visibility> "focus $w.ok"
2469 bind $w <Key-Escape> "destroy $w"
2470 bind $w <Key-Return> "destroy $w"
2473 proc keys {} {
2474 set w .keys
2475 if {[winfo exists $w]} {
2476 raise $w
2477 return
2479 if {[tk windowingsystem] eq {aqua}} {
2480 set M1T Cmd
2481 } else {
2482 set M1T Ctrl
2484 toplevel $w
2485 wm title $w [mc "Gitk key bindings"]
2486 message $w.m -text "
2487 [mc "Gitk key bindings:"]
2489 [mc "<%s-Q> Quit" $M1T]
2490 [mc "<Home> Move to first commit"]
2491 [mc "<End> Move to last commit"]
2492 [mc "<Up>, p, i Move up one commit"]
2493 [mc "<Down>, n, k Move down one commit"]
2494 [mc "<Left>, z, j Go back in history list"]
2495 [mc "<Right>, x, l Go forward in history list"]
2496 [mc "<PageUp> Move up one page in commit list"]
2497 [mc "<PageDown> Move down one page in commit list"]
2498 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2499 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2500 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2501 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2502 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2503 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2504 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2505 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2506 [mc "<Delete>, b Scroll diff view up one page"]
2507 [mc "<Backspace> Scroll diff view up one page"]
2508 [mc "<Space> Scroll diff view down one page"]
2509 [mc "u Scroll diff view up 18 lines"]
2510 [mc "d Scroll diff view down 18 lines"]
2511 [mc "<%s-F> Find" $M1T]
2512 [mc "<%s-G> Move to next find hit" $M1T]
2513 [mc "<Return> Move to next find hit"]
2514 [mc "/ Move to next find hit, or redo find"]
2515 [mc "? Move to previous find hit"]
2516 [mc "f Scroll diff view to next file"]
2517 [mc "<%s-S> Search for next hit in diff view" $M1T]
2518 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2519 [mc "<%s-KP+> Increase font size" $M1T]
2520 [mc "<%s-plus> Increase font size" $M1T]
2521 [mc "<%s-KP-> Decrease font size" $M1T]
2522 [mc "<%s-minus> Decrease font size" $M1T]
2523 [mc "<F5> Update"]
2525 -justify left -bg white -border 2 -relief groove
2526 pack $w.m -side top -fill both -padx 2 -pady 2
2527 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2528 pack $w.ok -side bottom
2529 bind $w <Visibility> "focus $w.ok"
2530 bind $w <Key-Escape> "destroy $w"
2531 bind $w <Key-Return> "destroy $w"
2534 # Procedures for manipulating the file list window at the
2535 # bottom right of the overall window.
2537 proc treeview {w l openlevs} {
2538 global treecontents treediropen treeheight treeparent treeindex
2540 set ix 0
2541 set treeindex() 0
2542 set lev 0
2543 set prefix {}
2544 set prefixend -1
2545 set prefendstack {}
2546 set htstack {}
2547 set ht 0
2548 set treecontents() {}
2549 $w conf -state normal
2550 foreach f $l {
2551 while {[string range $f 0 $prefixend] ne $prefix} {
2552 if {$lev <= $openlevs} {
2553 $w mark set e:$treeindex($prefix) "end -1c"
2554 $w mark gravity e:$treeindex($prefix) left
2556 set treeheight($prefix) $ht
2557 incr ht [lindex $htstack end]
2558 set htstack [lreplace $htstack end end]
2559 set prefixend [lindex $prefendstack end]
2560 set prefendstack [lreplace $prefendstack end end]
2561 set prefix [string range $prefix 0 $prefixend]
2562 incr lev -1
2564 set tail [string range $f [expr {$prefixend+1}] end]
2565 while {[set slash [string first "/" $tail]] >= 0} {
2566 lappend htstack $ht
2567 set ht 0
2568 lappend prefendstack $prefixend
2569 incr prefixend [expr {$slash + 1}]
2570 set d [string range $tail 0 $slash]
2571 lappend treecontents($prefix) $d
2572 set oldprefix $prefix
2573 append prefix $d
2574 set treecontents($prefix) {}
2575 set treeindex($prefix) [incr ix]
2576 set treeparent($prefix) $oldprefix
2577 set tail [string range $tail [expr {$slash+1}] end]
2578 if {$lev <= $openlevs} {
2579 set ht 1
2580 set treediropen($prefix) [expr {$lev < $openlevs}]
2581 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2582 $w mark set d:$ix "end -1c"
2583 $w mark gravity d:$ix left
2584 set str "\n"
2585 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2586 $w insert end $str
2587 $w image create end -align center -image $bm -padx 1 \
2588 -name a:$ix
2589 $w insert end $d [highlight_tag $prefix]
2590 $w mark set s:$ix "end -1c"
2591 $w mark gravity s:$ix left
2593 incr lev
2595 if {$tail ne {}} {
2596 if {$lev <= $openlevs} {
2597 incr ht
2598 set str "\n"
2599 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2600 $w insert end $str
2601 $w insert end $tail [highlight_tag $f]
2603 lappend treecontents($prefix) $tail
2606 while {$htstack ne {}} {
2607 set treeheight($prefix) $ht
2608 incr ht [lindex $htstack end]
2609 set htstack [lreplace $htstack end end]
2610 set prefixend [lindex $prefendstack end]
2611 set prefendstack [lreplace $prefendstack end end]
2612 set prefix [string range $prefix 0 $prefixend]
2614 $w conf -state disabled
2617 proc linetoelt {l} {
2618 global treeheight treecontents
2620 set y 2
2621 set prefix {}
2622 while {1} {
2623 foreach e $treecontents($prefix) {
2624 if {$y == $l} {
2625 return "$prefix$e"
2627 set n 1
2628 if {[string index $e end] eq "/"} {
2629 set n $treeheight($prefix$e)
2630 if {$y + $n > $l} {
2631 append prefix $e
2632 incr y
2633 break
2636 incr y $n
2641 proc highlight_tree {y prefix} {
2642 global treeheight treecontents cflist
2644 foreach e $treecontents($prefix) {
2645 set path $prefix$e
2646 if {[highlight_tag $path] ne {}} {
2647 $cflist tag add bold $y.0 "$y.0 lineend"
2649 incr y
2650 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2651 set y [highlight_tree $y $path]
2654 return $y
2657 proc treeclosedir {w dir} {
2658 global treediropen treeheight treeparent treeindex
2660 set ix $treeindex($dir)
2661 $w conf -state normal
2662 $w delete s:$ix e:$ix
2663 set treediropen($dir) 0
2664 $w image configure a:$ix -image tri-rt
2665 $w conf -state disabled
2666 set n [expr {1 - $treeheight($dir)}]
2667 while {$dir ne {}} {
2668 incr treeheight($dir) $n
2669 set dir $treeparent($dir)
2673 proc treeopendir {w dir} {
2674 global treediropen treeheight treeparent treecontents treeindex
2676 set ix $treeindex($dir)
2677 $w conf -state normal
2678 $w image configure a:$ix -image tri-dn
2679 $w mark set e:$ix s:$ix
2680 $w mark gravity e:$ix right
2681 set lev 0
2682 set str "\n"
2683 set n [llength $treecontents($dir)]
2684 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2685 incr lev
2686 append str "\t"
2687 incr treeheight($x) $n
2689 foreach e $treecontents($dir) {
2690 set de $dir$e
2691 if {[string index $e end] eq "/"} {
2692 set iy $treeindex($de)
2693 $w mark set d:$iy e:$ix
2694 $w mark gravity d:$iy left
2695 $w insert e:$ix $str
2696 set treediropen($de) 0
2697 $w image create e:$ix -align center -image tri-rt -padx 1 \
2698 -name a:$iy
2699 $w insert e:$ix $e [highlight_tag $de]
2700 $w mark set s:$iy e:$ix
2701 $w mark gravity s:$iy left
2702 set treeheight($de) 1
2703 } else {
2704 $w insert e:$ix $str
2705 $w insert e:$ix $e [highlight_tag $de]
2708 $w mark gravity e:$ix left
2709 $w conf -state disabled
2710 set treediropen($dir) 1
2711 set top [lindex [split [$w index @0,0] .] 0]
2712 set ht [$w cget -height]
2713 set l [lindex [split [$w index s:$ix] .] 0]
2714 if {$l < $top} {
2715 $w yview $l.0
2716 } elseif {$l + $n + 1 > $top + $ht} {
2717 set top [expr {$l + $n + 2 - $ht}]
2718 if {$l < $top} {
2719 set top $l
2721 $w yview $top.0
2725 proc treeclick {w x y} {
2726 global treediropen cmitmode ctext cflist cflist_top
2728 if {$cmitmode ne "tree"} return
2729 if {![info exists cflist_top]} return
2730 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2731 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2732 $cflist tag add highlight $l.0 "$l.0 lineend"
2733 set cflist_top $l
2734 if {$l == 1} {
2735 $ctext yview 1.0
2736 return
2738 set e [linetoelt $l]
2739 if {[string index $e end] ne "/"} {
2740 showfile $e
2741 } elseif {$treediropen($e)} {
2742 treeclosedir $w $e
2743 } else {
2744 treeopendir $w $e
2748 proc setfilelist {id} {
2749 global treefilelist cflist
2751 treeview $cflist $treefilelist($id) 0
2754 image create bitmap tri-rt -background black -foreground blue -data {
2755 #define tri-rt_width 13
2756 #define tri-rt_height 13
2757 static unsigned char tri-rt_bits[] = {
2758 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2759 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2760 0x00, 0x00};
2761 } -maskdata {
2762 #define tri-rt-mask_width 13
2763 #define tri-rt-mask_height 13
2764 static unsigned char tri-rt-mask_bits[] = {
2765 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2766 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2767 0x08, 0x00};
2769 image create bitmap tri-dn -background black -foreground blue -data {
2770 #define tri-dn_width 13
2771 #define tri-dn_height 13
2772 static unsigned char tri-dn_bits[] = {
2773 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2774 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2775 0x00, 0x00};
2776 } -maskdata {
2777 #define tri-dn-mask_width 13
2778 #define tri-dn-mask_height 13
2779 static unsigned char tri-dn-mask_bits[] = {
2780 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2781 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2782 0x00, 0x00};
2785 image create bitmap reficon-T -background black -foreground yellow -data {
2786 #define tagicon_width 13
2787 #define tagicon_height 9
2788 static unsigned char tagicon_bits[] = {
2789 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2790 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2791 } -maskdata {
2792 #define tagicon-mask_width 13
2793 #define tagicon-mask_height 9
2794 static unsigned char tagicon-mask_bits[] = {
2795 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2796 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2798 set rectdata {
2799 #define headicon_width 13
2800 #define headicon_height 9
2801 static unsigned char headicon_bits[] = {
2802 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2803 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2805 set rectmask {
2806 #define headicon-mask_width 13
2807 #define headicon-mask_height 9
2808 static unsigned char headicon-mask_bits[] = {
2809 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2810 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2812 image create bitmap reficon-H -background black -foreground green \
2813 -data $rectdata -maskdata $rectmask
2814 image create bitmap reficon-o -background black -foreground "#ddddff" \
2815 -data $rectdata -maskdata $rectmask
2817 proc init_flist {first} {
2818 global cflist cflist_top difffilestart
2820 $cflist conf -state normal
2821 $cflist delete 0.0 end
2822 if {$first ne {}} {
2823 $cflist insert end $first
2824 set cflist_top 1
2825 $cflist tag add highlight 1.0 "1.0 lineend"
2826 } else {
2827 catch {unset cflist_top}
2829 $cflist conf -state disabled
2830 set difffilestart {}
2833 proc highlight_tag {f} {
2834 global highlight_paths
2836 foreach p $highlight_paths {
2837 if {[string match $p $f]} {
2838 return "bold"
2841 return {}
2844 proc highlight_filelist {} {
2845 global cmitmode cflist
2847 $cflist conf -state normal
2848 if {$cmitmode ne "tree"} {
2849 set end [lindex [split [$cflist index end] .] 0]
2850 for {set l 2} {$l < $end} {incr l} {
2851 set line [$cflist get $l.0 "$l.0 lineend"]
2852 if {[highlight_tag $line] ne {}} {
2853 $cflist tag add bold $l.0 "$l.0 lineend"
2856 } else {
2857 highlight_tree 2 {}
2859 $cflist conf -state disabled
2862 proc unhighlight_filelist {} {
2863 global cflist
2865 $cflist conf -state normal
2866 $cflist tag remove bold 1.0 end
2867 $cflist conf -state disabled
2870 proc add_flist {fl} {
2871 global cflist
2873 $cflist conf -state normal
2874 foreach f $fl {
2875 $cflist insert end "\n"
2876 $cflist insert end $f [highlight_tag $f]
2878 $cflist conf -state disabled
2881 proc sel_flist {w x y} {
2882 global ctext difffilestart cflist cflist_top cmitmode
2884 if {$cmitmode eq "tree"} return
2885 if {![info exists cflist_top]} return
2886 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2887 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2888 $cflist tag add highlight $l.0 "$l.0 lineend"
2889 set cflist_top $l
2890 if {$l == 1} {
2891 $ctext yview 1.0
2892 } else {
2893 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2897 proc pop_flist_menu {w X Y x y} {
2898 global ctext cflist cmitmode flist_menu flist_menu_file
2899 global treediffs diffids
2901 stopfinding
2902 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2903 if {$l <= 1} return
2904 if {$cmitmode eq "tree"} {
2905 set e [linetoelt $l]
2906 if {[string index $e end] eq "/"} return
2907 } else {
2908 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2910 set flist_menu_file $e
2911 set xdiffstate "normal"
2912 if {$cmitmode eq "tree"} {
2913 set xdiffstate "disabled"
2915 # Disable "External diff" item in tree mode
2916 $flist_menu entryconf 2 -state $xdiffstate
2917 tk_popup $flist_menu $X $Y
2920 proc flist_hl {only} {
2921 global flist_menu_file findstring gdttype
2923 set x [shellquote $flist_menu_file]
2924 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2925 set findstring $x
2926 } else {
2927 append findstring " " $x
2929 set gdttype [mc "touching paths:"]
2932 proc save_file_from_commit {filename output what} {
2933 global nullfile
2935 if {[catch {exec git show $filename -- > $output} err]} {
2936 if {[string match "fatal: bad revision *" $err]} {
2937 return $nullfile
2939 error_popup "Error getting \"$filename\" from $what: $err"
2940 return {}
2942 return $output
2945 proc external_diff_get_one_file {diffid filename diffdir} {
2946 global nullid nullid2 nullfile
2947 global gitdir
2949 if {$diffid == $nullid} {
2950 set difffile [file join [file dirname $gitdir] $filename]
2951 if {[file exists $difffile]} {
2952 return $difffile
2954 return $nullfile
2956 if {$diffid == $nullid2} {
2957 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2958 return [save_file_from_commit :$filename $difffile index]
2960 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2961 return [save_file_from_commit $diffid:$filename $difffile \
2962 "revision $diffid"]
2965 proc external_diff {} {
2966 global gitktmpdir nullid nullid2
2967 global flist_menu_file
2968 global diffids
2969 global diffnum
2970 global gitdir extdifftool
2972 if {[llength $diffids] == 1} {
2973 # no reference commit given
2974 set diffidto [lindex $diffids 0]
2975 if {$diffidto eq $nullid} {
2976 # diffing working copy with index
2977 set diffidfrom $nullid2
2978 } elseif {$diffidto eq $nullid2} {
2979 # diffing index with HEAD
2980 set diffidfrom "HEAD"
2981 } else {
2982 # use first parent commit
2983 global parentlist selectedline
2984 set diffidfrom [lindex $parentlist $selectedline 0]
2986 } else {
2987 set diffidfrom [lindex $diffids 0]
2988 set diffidto [lindex $diffids 1]
2991 # make sure that several diffs wont collide
2992 if {![info exists gitktmpdir]} {
2993 set gitktmpdir [file join [file dirname $gitdir] \
2994 [format ".gitk-tmp.%s" [pid]]]
2995 if {[catch {file mkdir $gitktmpdir} err]} {
2996 error_popup "Error creating temporary directory $gitktmpdir: $err"
2997 unset gitktmpdir
2998 return
3000 set diffnum 0
3002 incr diffnum
3003 set diffdir [file join $gitktmpdir $diffnum]
3004 if {[catch {file mkdir $diffdir} err]} {
3005 error_popup "Error creating temporary directory $diffdir: $err"
3006 return
3009 # gather files to diff
3010 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3011 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3013 if {$difffromfile ne {} && $difftofile ne {}} {
3014 set cmd [concat | [shellsplit $extdifftool] \
3015 [list $difffromfile $difftofile]]
3016 if {[catch {set fl [open $cmd r]} err]} {
3017 file delete -force $diffdir
3018 error_popup [mc "$extdifftool: command failed: $err"]
3019 } else {
3020 fconfigure $fl -blocking 0
3021 filerun $fl [list delete_at_eof $fl $diffdir]
3026 proc external_blame {parent_idx} {
3027 global flist_menu_file
3028 global nullid nullid2
3029 global parentlist selectedline currentid
3031 if {$parent_idx > 0} {
3032 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3033 } else {
3034 set base_commit $currentid
3037 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3038 error_popup [mc "No such commit"]
3039 return
3042 if {[catch {exec git gui blame $base_commit $flist_menu_file &} err]} {
3043 error_popup [mc "git gui blame: command failed: $err"]
3047 # delete $dir when we see eof on $f (presumably because the child has exited)
3048 proc delete_at_eof {f dir} {
3049 while {[gets $f line] >= 0} {}
3050 if {[eof $f]} {
3051 if {[catch {close $f} err]} {
3052 error_popup "External diff viewer failed: $err"
3054 file delete -force $dir
3055 return 0
3057 return 1
3060 # Functions for adding and removing shell-type quoting
3062 proc shellquote {str} {
3063 if {![string match "*\['\"\\ \t]*" $str]} {
3064 return $str
3066 if {![string match "*\['\"\\]*" $str]} {
3067 return "\"$str\""
3069 if {![string match "*'*" $str]} {
3070 return "'$str'"
3072 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3075 proc shellarglist {l} {
3076 set str {}
3077 foreach a $l {
3078 if {$str ne {}} {
3079 append str " "
3081 append str [shellquote $a]
3083 return $str
3086 proc shelldequote {str} {
3087 set ret {}
3088 set used -1
3089 while {1} {
3090 incr used
3091 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3092 append ret [string range $str $used end]
3093 set used [string length $str]
3094 break
3096 set first [lindex $first 0]
3097 set ch [string index $str $first]
3098 if {$first > $used} {
3099 append ret [string range $str $used [expr {$first - 1}]]
3100 set used $first
3102 if {$ch eq " " || $ch eq "\t"} break
3103 incr used
3104 if {$ch eq "'"} {
3105 set first [string first "'" $str $used]
3106 if {$first < 0} {
3107 error "unmatched single-quote"
3109 append ret [string range $str $used [expr {$first - 1}]]
3110 set used $first
3111 continue
3113 if {$ch eq "\\"} {
3114 if {$used >= [string length $str]} {
3115 error "trailing backslash"
3117 append ret [string index $str $used]
3118 continue
3120 # here ch == "\""
3121 while {1} {
3122 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3123 error "unmatched double-quote"
3125 set first [lindex $first 0]
3126 set ch [string index $str $first]
3127 if {$first > $used} {
3128 append ret [string range $str $used [expr {$first - 1}]]
3129 set used $first
3131 if {$ch eq "\""} break
3132 incr used
3133 append ret [string index $str $used]
3134 incr used
3137 return [list $used $ret]
3140 proc shellsplit {str} {
3141 set l {}
3142 while {1} {
3143 set str [string trimleft $str]
3144 if {$str eq {}} break
3145 set dq [shelldequote $str]
3146 set n [lindex $dq 0]
3147 set word [lindex $dq 1]
3148 set str [string range $str $n end]
3149 lappend l $word
3151 return $l
3154 # Code to implement multiple views
3156 proc newview {ishighlight} {
3157 global nextviewnum newviewname newviewperm newishighlight
3158 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3160 set newishighlight $ishighlight
3161 set top .gitkview
3162 if {[winfo exists $top]} {
3163 raise $top
3164 return
3166 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3167 set newviewperm($nextviewnum) 0
3168 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3169 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3170 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3173 proc editview {} {
3174 global curview
3175 global viewname viewperm newviewname newviewperm
3176 global viewargs newviewargs viewargscmd newviewargscmd
3178 set top .gitkvedit-$curview
3179 if {[winfo exists $top]} {
3180 raise $top
3181 return
3183 set newviewname($curview) $viewname($curview)
3184 set newviewperm($curview) $viewperm($curview)
3185 set newviewargs($curview) [shellarglist $viewargs($curview)]
3186 set newviewargscmd($curview) $viewargscmd($curview)
3187 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3190 proc vieweditor {top n title} {
3191 global newviewname newviewperm viewfiles bgcolor
3193 toplevel $top
3194 wm title $top $title
3195 label $top.nl -text [mc "Name"]
3196 entry $top.name -width 20 -textvariable newviewname($n)
3197 grid $top.nl $top.name -sticky w -pady 5
3198 checkbutton $top.perm -text [mc "Remember this view"] \
3199 -variable newviewperm($n)
3200 grid $top.perm - -pady 5 -sticky w
3201 message $top.al -aspect 1000 \
3202 -text [mc "Commits to include (arguments to git log):"]
3203 grid $top.al - -sticky w -pady 5
3204 entry $top.args -width 50 -textvariable newviewargs($n) \
3205 -background $bgcolor
3206 grid $top.args - -sticky ew -padx 5
3208 message $top.ac -aspect 1000 \
3209 -text [mc "Command to generate more commits to include:"]
3210 grid $top.ac - -sticky w -pady 5
3211 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3212 -background white
3213 grid $top.argscmd - -sticky ew -padx 5
3215 message $top.l -aspect 1000 \
3216 -text [mc "Enter files and directories to include, one per line:"]
3217 grid $top.l - -sticky w
3218 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3219 if {[info exists viewfiles($n)]} {
3220 foreach f $viewfiles($n) {
3221 $top.t insert end $f
3222 $top.t insert end "\n"
3224 $top.t delete {end - 1c} end
3225 $top.t mark set insert 0.0
3227 grid $top.t - -sticky ew -padx 5
3228 frame $top.buts
3229 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3230 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3231 grid $top.buts.ok $top.buts.can
3232 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3233 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3234 grid $top.buts - -pady 10 -sticky ew
3235 focus $top.t
3238 proc doviewmenu {m first cmd op argv} {
3239 set nmenu [$m index end]
3240 for {set i $first} {$i <= $nmenu} {incr i} {
3241 if {[$m entrycget $i -command] eq $cmd} {
3242 eval $m $op $i $argv
3243 break
3248 proc allviewmenus {n op args} {
3249 # global viewhlmenu
3251 doviewmenu .bar.view 5 [list showview $n] $op $args
3252 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3255 proc newviewok {top n} {
3256 global nextviewnum newviewperm newviewname newishighlight
3257 global viewname viewfiles viewperm selectedview curview
3258 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3260 if {[catch {
3261 set newargs [shellsplit $newviewargs($n)]
3262 } err]} {
3263 error_popup "[mc "Error in commit selection arguments:"] $err"
3264 wm raise $top
3265 focus $top
3266 return
3268 set files {}
3269 foreach f [split [$top.t get 0.0 end] "\n"] {
3270 set ft [string trim $f]
3271 if {$ft ne {}} {
3272 lappend files $ft
3275 if {![info exists viewfiles($n)]} {
3276 # creating a new view
3277 incr nextviewnum
3278 set viewname($n) $newviewname($n)
3279 set viewperm($n) $newviewperm($n)
3280 set viewfiles($n) $files
3281 set viewargs($n) $newargs
3282 set viewargscmd($n) $newviewargscmd($n)
3283 addviewmenu $n
3284 if {!$newishighlight} {
3285 run showview $n
3286 } else {
3287 run addvhighlight $n
3289 } else {
3290 # editing an existing view
3291 set viewperm($n) $newviewperm($n)
3292 if {$newviewname($n) ne $viewname($n)} {
3293 set viewname($n) $newviewname($n)
3294 doviewmenu .bar.view 5 [list showview $n] \
3295 entryconf [list -label $viewname($n)]
3296 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3297 # entryconf [list -label $viewname($n) -value $viewname($n)]
3299 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3300 $newviewargscmd($n) ne $viewargscmd($n)} {
3301 set viewfiles($n) $files
3302 set viewargs($n) $newargs
3303 set viewargscmd($n) $newviewargscmd($n)
3304 if {$curview == $n} {
3305 run reloadcommits
3309 catch {destroy $top}
3312 proc delview {} {
3313 global curview viewperm hlview selectedhlview
3315 if {$curview == 0} return
3316 if {[info exists hlview] && $hlview == $curview} {
3317 set selectedhlview [mc "None"]
3318 unset hlview
3320 allviewmenus $curview delete
3321 set viewperm($curview) 0
3322 showview 0
3325 proc addviewmenu {n} {
3326 global viewname viewhlmenu
3328 .bar.view add radiobutton -label $viewname($n) \
3329 -command [list showview $n] -variable selectedview -value $n
3330 #$viewhlmenu add radiobutton -label $viewname($n) \
3331 # -command [list addvhighlight $n] -variable selectedhlview
3334 proc showview {n} {
3335 global curview cached_commitrow ordertok
3336 global displayorder parentlist rowidlist rowisopt rowfinal
3337 global colormap rowtextx nextcolor canvxmax
3338 global numcommits viewcomplete
3339 global selectedline currentid canv canvy0
3340 global treediffs
3341 global pending_select mainheadid
3342 global commitidx
3343 global selectedview
3344 global hlview selectedhlview commitinterest
3346 if {$n == $curview} return
3347 set selid {}
3348 set ymax [lindex [$canv cget -scrollregion] 3]
3349 set span [$canv yview]
3350 set ytop [expr {[lindex $span 0] * $ymax}]
3351 set ybot [expr {[lindex $span 1] * $ymax}]
3352 set yscreen [expr {($ybot - $ytop) / 2}]
3353 if {$selectedline ne {}} {
3354 set selid $currentid
3355 set y [yc $selectedline]
3356 if {$ytop < $y && $y < $ybot} {
3357 set yscreen [expr {$y - $ytop}]
3359 } elseif {[info exists pending_select]} {
3360 set selid $pending_select
3361 unset pending_select
3363 unselectline
3364 normalline
3365 catch {unset treediffs}
3366 clear_display
3367 if {[info exists hlview] && $hlview == $n} {
3368 unset hlview
3369 set selectedhlview [mc "None"]
3371 catch {unset commitinterest}
3372 catch {unset cached_commitrow}
3373 catch {unset ordertok}
3375 set curview $n
3376 set selectedview $n
3377 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3378 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3380 run refill_reflist
3381 if {![info exists viewcomplete($n)]} {
3382 getcommits $selid
3383 return
3386 set displayorder {}
3387 set parentlist {}
3388 set rowidlist {}
3389 set rowisopt {}
3390 set rowfinal {}
3391 set numcommits $commitidx($n)
3393 catch {unset colormap}
3394 catch {unset rowtextx}
3395 set nextcolor 0
3396 set canvxmax [$canv cget -width]
3397 set curview $n
3398 set row 0
3399 setcanvscroll
3400 set yf 0
3401 set row {}
3402 if {$selid ne {} && [commitinview $selid $n]} {
3403 set row [rowofcommit $selid]
3404 # try to get the selected row in the same position on the screen
3405 set ymax [lindex [$canv cget -scrollregion] 3]
3406 set ytop [expr {[yc $row] - $yscreen}]
3407 if {$ytop < 0} {
3408 set ytop 0
3410 set yf [expr {$ytop * 1.0 / $ymax}]
3412 allcanvs yview moveto $yf
3413 drawvisible
3414 if {$row ne {}} {
3415 selectline $row 0
3416 } elseif {!$viewcomplete($n)} {
3417 reset_pending_select $selid
3418 } else {
3419 reset_pending_select {}
3421 if {[commitinview $pending_select $curview]} {
3422 selectline [rowofcommit $pending_select] 1
3423 } else {
3424 set row [first_real_row]
3425 if {$row < $numcommits} {
3426 selectline $row 0
3430 if {!$viewcomplete($n)} {
3431 if {$numcommits == 0} {
3432 show_status [mc "Reading commits..."]
3434 } elseif {$numcommits == 0} {
3435 show_status [mc "No commits selected"]
3439 # Stuff relating to the highlighting facility
3441 proc ishighlighted {id} {
3442 global vhighlights fhighlights nhighlights rhighlights
3444 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3445 return $nhighlights($id)
3447 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3448 return $vhighlights($id)
3450 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3451 return $fhighlights($id)
3453 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3454 return $rhighlights($id)
3456 return 0
3459 proc bolden {row font} {
3460 global canv linehtag selectedline boldrows
3462 lappend boldrows $row
3463 $canv itemconf $linehtag($row) -font $font
3464 if {$row == $selectedline} {
3465 $canv delete secsel
3466 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3467 -outline {{}} -tags secsel \
3468 -fill [$canv cget -selectbackground]]
3469 $canv lower $t
3473 proc bolden_name {row font} {
3474 global canv2 linentag selectedline boldnamerows
3476 lappend boldnamerows $row
3477 $canv2 itemconf $linentag($row) -font $font
3478 if {$row == $selectedline} {
3479 $canv2 delete secsel
3480 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3481 -outline {{}} -tags secsel \
3482 -fill [$canv2 cget -selectbackground]]
3483 $canv2 lower $t
3487 proc unbolden {} {
3488 global boldrows
3490 set stillbold {}
3491 foreach row $boldrows {
3492 if {![ishighlighted [commitonrow $row]]} {
3493 bolden $row mainfont
3494 } else {
3495 lappend stillbold $row
3498 set boldrows $stillbold
3501 proc addvhighlight {n} {
3502 global hlview viewcomplete curview vhl_done commitidx
3504 if {[info exists hlview]} {
3505 delvhighlight
3507 set hlview $n
3508 if {$n != $curview && ![info exists viewcomplete($n)]} {
3509 start_rev_list $n
3511 set vhl_done $commitidx($hlview)
3512 if {$vhl_done > 0} {
3513 drawvisible
3517 proc delvhighlight {} {
3518 global hlview vhighlights
3520 if {![info exists hlview]} return
3521 unset hlview
3522 catch {unset vhighlights}
3523 unbolden
3526 proc vhighlightmore {} {
3527 global hlview vhl_done commitidx vhighlights curview
3529 set max $commitidx($hlview)
3530 set vr [visiblerows]
3531 set r0 [lindex $vr 0]
3532 set r1 [lindex $vr 1]
3533 for {set i $vhl_done} {$i < $max} {incr i} {
3534 set id [commitonrow $i $hlview]
3535 if {[commitinview $id $curview]} {
3536 set row [rowofcommit $id]
3537 if {$r0 <= $row && $row <= $r1} {
3538 if {![highlighted $row]} {
3539 bolden $row mainfontbold
3541 set vhighlights($id) 1
3545 set vhl_done $max
3546 return 0
3549 proc askvhighlight {row id} {
3550 global hlview vhighlights iddrawn
3552 if {[commitinview $id $hlview]} {
3553 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3554 bolden $row mainfontbold
3556 set vhighlights($id) 1
3557 } else {
3558 set vhighlights($id) 0
3562 proc hfiles_change {} {
3563 global highlight_files filehighlight fhighlights fh_serial
3564 global highlight_paths gdttype
3566 if {[info exists filehighlight]} {
3567 # delete previous highlights
3568 catch {close $filehighlight}
3569 unset filehighlight
3570 catch {unset fhighlights}
3571 unbolden
3572 unhighlight_filelist
3574 set highlight_paths {}
3575 after cancel do_file_hl $fh_serial
3576 incr fh_serial
3577 if {$highlight_files ne {}} {
3578 after 300 do_file_hl $fh_serial
3582 proc gdttype_change {name ix op} {
3583 global gdttype highlight_files findstring findpattern
3585 stopfinding
3586 if {$findstring ne {}} {
3587 if {$gdttype eq [mc "containing:"]} {
3588 if {$highlight_files ne {}} {
3589 set highlight_files {}
3590 hfiles_change
3592 findcom_change
3593 } else {
3594 if {$findpattern ne {}} {
3595 set findpattern {}
3596 findcom_change
3598 set highlight_files $findstring
3599 hfiles_change
3601 drawvisible
3603 # enable/disable findtype/findloc menus too
3606 proc find_change {name ix op} {
3607 global gdttype findstring highlight_files
3609 stopfinding
3610 if {$gdttype eq [mc "containing:"]} {
3611 findcom_change
3612 } else {
3613 if {$highlight_files ne $findstring} {
3614 set highlight_files $findstring
3615 hfiles_change
3618 drawvisible
3621 proc findcom_change args {
3622 global nhighlights boldnamerows
3623 global findpattern findtype findstring gdttype
3625 stopfinding
3626 # delete previous highlights, if any
3627 foreach row $boldnamerows {
3628 bolden_name $row mainfont
3630 set boldnamerows {}
3631 catch {unset nhighlights}
3632 unbolden
3633 unmarkmatches
3634 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3635 set findpattern {}
3636 } elseif {$findtype eq [mc "Regexp"]} {
3637 set findpattern $findstring
3638 } else {
3639 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3640 $findstring]
3641 set findpattern "*$e*"
3645 proc makepatterns {l} {
3646 set ret {}
3647 foreach e $l {
3648 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3649 if {[string index $ee end] eq "/"} {
3650 lappend ret "$ee*"
3651 } else {
3652 lappend ret $ee
3653 lappend ret "$ee/*"
3656 return $ret
3659 proc do_file_hl {serial} {
3660 global highlight_files filehighlight highlight_paths gdttype fhl_list
3662 if {$gdttype eq [mc "touching paths:"]} {
3663 if {[catch {set paths [shellsplit $highlight_files]}]} return
3664 set highlight_paths [makepatterns $paths]
3665 highlight_filelist
3666 set gdtargs [concat -- $paths]
3667 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3668 set gdtargs [list "-S$highlight_files"]
3669 } else {
3670 # must be "containing:", i.e. we're searching commit info
3671 return
3673 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3674 set filehighlight [open $cmd r+]
3675 fconfigure $filehighlight -blocking 0
3676 filerun $filehighlight readfhighlight
3677 set fhl_list {}
3678 drawvisible
3679 flushhighlights
3682 proc flushhighlights {} {
3683 global filehighlight fhl_list
3685 if {[info exists filehighlight]} {
3686 lappend fhl_list {}
3687 puts $filehighlight ""
3688 flush $filehighlight
3692 proc askfilehighlight {row id} {
3693 global filehighlight fhighlights fhl_list
3695 lappend fhl_list $id
3696 set fhighlights($id) -1
3697 puts $filehighlight $id
3700 proc readfhighlight {} {
3701 global filehighlight fhighlights curview iddrawn
3702 global fhl_list find_dirn
3704 if {![info exists filehighlight]} {
3705 return 0
3707 set nr 0
3708 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3709 set line [string trim $line]
3710 set i [lsearch -exact $fhl_list $line]
3711 if {$i < 0} continue
3712 for {set j 0} {$j < $i} {incr j} {
3713 set id [lindex $fhl_list $j]
3714 set fhighlights($id) 0
3716 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3717 if {$line eq {}} continue
3718 if {![commitinview $line $curview]} continue
3719 set row [rowofcommit $line]
3720 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3721 bolden $row mainfontbold
3723 set fhighlights($line) 1
3725 if {[eof $filehighlight]} {
3726 # strange...
3727 puts "oops, git diff-tree died"
3728 catch {close $filehighlight}
3729 unset filehighlight
3730 return 0
3732 if {[info exists find_dirn]} {
3733 run findmore
3735 return 1
3738 proc doesmatch {f} {
3739 global findtype findpattern
3741 if {$findtype eq [mc "Regexp"]} {
3742 return [regexp $findpattern $f]
3743 } elseif {$findtype eq [mc "IgnCase"]} {
3744 return [string match -nocase $findpattern $f]
3745 } else {
3746 return [string match $findpattern $f]
3750 proc askfindhighlight {row id} {
3751 global nhighlights commitinfo iddrawn
3752 global findloc
3753 global markingmatches
3755 if {![info exists commitinfo($id)]} {
3756 getcommit $id
3758 set info $commitinfo($id)
3759 set isbold 0
3760 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3761 foreach f $info ty $fldtypes {
3762 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3763 [doesmatch $f]} {
3764 if {$ty eq [mc "Author"]} {
3765 set isbold 2
3766 break
3768 set isbold 1
3771 if {$isbold && [info exists iddrawn($id)]} {
3772 if {![ishighlighted $id]} {
3773 bolden $row mainfontbold
3774 if {$isbold > 1} {
3775 bolden_name $row mainfontbold
3778 if {$markingmatches} {
3779 markrowmatches $row $id
3782 set nhighlights($id) $isbold
3785 proc markrowmatches {row id} {
3786 global canv canv2 linehtag linentag commitinfo findloc
3788 set headline [lindex $commitinfo($id) 0]
3789 set author [lindex $commitinfo($id) 1]
3790 $canv delete match$row
3791 $canv2 delete match$row
3792 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3793 set m [findmatches $headline]
3794 if {$m ne {}} {
3795 markmatches $canv $row $headline $linehtag($row) $m \
3796 [$canv itemcget $linehtag($row) -font] $row
3799 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3800 set m [findmatches $author]
3801 if {$m ne {}} {
3802 markmatches $canv2 $row $author $linentag($row) $m \
3803 [$canv2 itemcget $linentag($row) -font] $row
3808 proc vrel_change {name ix op} {
3809 global highlight_related
3811 rhighlight_none
3812 if {$highlight_related ne [mc "None"]} {
3813 run drawvisible
3817 # prepare for testing whether commits are descendents or ancestors of a
3818 proc rhighlight_sel {a} {
3819 global descendent desc_todo ancestor anc_todo
3820 global highlight_related
3822 catch {unset descendent}
3823 set desc_todo [list $a]
3824 catch {unset ancestor}
3825 set anc_todo [list $a]
3826 if {$highlight_related ne [mc "None"]} {
3827 rhighlight_none
3828 run drawvisible
3832 proc rhighlight_none {} {
3833 global rhighlights
3835 catch {unset rhighlights}
3836 unbolden
3839 proc is_descendent {a} {
3840 global curview children descendent desc_todo
3842 set v $curview
3843 set la [rowofcommit $a]
3844 set todo $desc_todo
3845 set leftover {}
3846 set done 0
3847 for {set i 0} {$i < [llength $todo]} {incr i} {
3848 set do [lindex $todo $i]
3849 if {[rowofcommit $do] < $la} {
3850 lappend leftover $do
3851 continue
3853 foreach nk $children($v,$do) {
3854 if {![info exists descendent($nk)]} {
3855 set descendent($nk) 1
3856 lappend todo $nk
3857 if {$nk eq $a} {
3858 set done 1
3862 if {$done} {
3863 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3864 return
3867 set descendent($a) 0
3868 set desc_todo $leftover
3871 proc is_ancestor {a} {
3872 global curview parents ancestor anc_todo
3874 set v $curview
3875 set la [rowofcommit $a]
3876 set todo $anc_todo
3877 set leftover {}
3878 set done 0
3879 for {set i 0} {$i < [llength $todo]} {incr i} {
3880 set do [lindex $todo $i]
3881 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3882 lappend leftover $do
3883 continue
3885 foreach np $parents($v,$do) {
3886 if {![info exists ancestor($np)]} {
3887 set ancestor($np) 1
3888 lappend todo $np
3889 if {$np eq $a} {
3890 set done 1
3894 if {$done} {
3895 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3896 return
3899 set ancestor($a) 0
3900 set anc_todo $leftover
3903 proc askrelhighlight {row id} {
3904 global descendent highlight_related iddrawn rhighlights
3905 global selectedline ancestor
3907 if {$selectedline eq {}} return
3908 set isbold 0
3909 if {$highlight_related eq [mc "Descendant"] ||
3910 $highlight_related eq [mc "Not descendant"]} {
3911 if {![info exists descendent($id)]} {
3912 is_descendent $id
3914 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3915 set isbold 1
3917 } elseif {$highlight_related eq [mc "Ancestor"] ||
3918 $highlight_related eq [mc "Not ancestor"]} {
3919 if {![info exists ancestor($id)]} {
3920 is_ancestor $id
3922 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3923 set isbold 1
3926 if {[info exists iddrawn($id)]} {
3927 if {$isbold && ![ishighlighted $id]} {
3928 bolden $row mainfontbold
3931 set rhighlights($id) $isbold
3934 # Graph layout functions
3936 proc shortids {ids} {
3937 set res {}
3938 foreach id $ids {
3939 if {[llength $id] > 1} {
3940 lappend res [shortids $id]
3941 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3942 lappend res [string range $id 0 7]
3943 } else {
3944 lappend res $id
3947 return $res
3950 proc ntimes {n o} {
3951 set ret {}
3952 set o [list $o]
3953 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3954 if {($n & $mask) != 0} {
3955 set ret [concat $ret $o]
3957 set o [concat $o $o]
3959 return $ret
3962 proc ordertoken {id} {
3963 global ordertok curview varcid varcstart varctok curview parents children
3964 global nullid nullid2
3966 if {[info exists ordertok($id)]} {
3967 return $ordertok($id)
3969 set origid $id
3970 set todo {}
3971 while {1} {
3972 if {[info exists varcid($curview,$id)]} {
3973 set a $varcid($curview,$id)
3974 set p [lindex $varcstart($curview) $a]
3975 } else {
3976 set p [lindex $children($curview,$id) 0]
3978 if {[info exists ordertok($p)]} {
3979 set tok $ordertok($p)
3980 break
3982 set id [first_real_child $curview,$p]
3983 if {$id eq {}} {
3984 # it's a root
3985 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3986 break
3988 if {[llength $parents($curview,$id)] == 1} {
3989 lappend todo [list $p {}]
3990 } else {
3991 set j [lsearch -exact $parents($curview,$id) $p]
3992 if {$j < 0} {
3993 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3995 lappend todo [list $p [strrep $j]]
3998 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3999 set p [lindex $todo $i 0]
4000 append tok [lindex $todo $i 1]
4001 set ordertok($p) $tok
4003 set ordertok($origid) $tok
4004 return $tok
4007 # Work out where id should go in idlist so that order-token
4008 # values increase from left to right
4009 proc idcol {idlist id {i 0}} {
4010 set t [ordertoken $id]
4011 if {$i < 0} {
4012 set i 0
4014 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4015 if {$i > [llength $idlist]} {
4016 set i [llength $idlist]
4018 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4019 incr i
4020 } else {
4021 if {$t > [ordertoken [lindex $idlist $i]]} {
4022 while {[incr i] < [llength $idlist] &&
4023 $t >= [ordertoken [lindex $idlist $i]]} {}
4026 return $i
4029 proc initlayout {} {
4030 global rowidlist rowisopt rowfinal displayorder parentlist
4031 global numcommits canvxmax canv
4032 global nextcolor
4033 global colormap rowtextx
4035 set numcommits 0
4036 set displayorder {}
4037 set parentlist {}
4038 set nextcolor 0
4039 set rowidlist {}
4040 set rowisopt {}
4041 set rowfinal {}
4042 set canvxmax [$canv cget -width]
4043 catch {unset colormap}
4044 catch {unset rowtextx}
4045 setcanvscroll
4048 proc setcanvscroll {} {
4049 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4050 global lastscrollset lastscrollrows
4052 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4053 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4054 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4055 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4056 set lastscrollset [clock clicks -milliseconds]
4057 set lastscrollrows $numcommits
4060 proc visiblerows {} {
4061 global canv numcommits linespc
4063 set ymax [lindex [$canv cget -scrollregion] 3]
4064 if {$ymax eq {} || $ymax == 0} return
4065 set f [$canv yview]
4066 set y0 [expr {int([lindex $f 0] * $ymax)}]
4067 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4068 if {$r0 < 0} {
4069 set r0 0
4071 set y1 [expr {int([lindex $f 1] * $ymax)}]
4072 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4073 if {$r1 >= $numcommits} {
4074 set r1 [expr {$numcommits - 1}]
4076 return [list $r0 $r1]
4079 proc layoutmore {} {
4080 global commitidx viewcomplete curview
4081 global numcommits pending_select curview
4082 global lastscrollset lastscrollrows commitinterest
4084 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4085 [clock clicks -milliseconds] - $lastscrollset > 500} {
4086 setcanvscroll
4088 if {[info exists pending_select] &&
4089 [commitinview $pending_select $curview]} {
4090 update
4091 selectline [rowofcommit $pending_select] 1
4093 drawvisible
4096 proc doshowlocalchanges {} {
4097 global curview mainheadid
4099 if {$mainheadid eq {}} return
4100 if {[commitinview $mainheadid $curview]} {
4101 dodiffindex
4102 } else {
4103 lappend commitinterest($mainheadid) {dodiffindex}
4107 proc dohidelocalchanges {} {
4108 global nullid nullid2 lserial curview
4110 if {[commitinview $nullid $curview]} {
4111 removefakerow $nullid
4113 if {[commitinview $nullid2 $curview]} {
4114 removefakerow $nullid2
4116 incr lserial
4119 # spawn off a process to do git diff-index --cached HEAD
4120 proc dodiffindex {} {
4121 global lserial showlocalchanges
4122 global isworktree
4124 if {!$showlocalchanges || !$isworktree} return
4125 incr lserial
4126 set fd [open "|git diff-index --cached HEAD" r]
4127 fconfigure $fd -blocking 0
4128 set i [reg_instance $fd]
4129 filerun $fd [list readdiffindex $fd $lserial $i]
4132 proc readdiffindex {fd serial inst} {
4133 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4135 set isdiff 1
4136 if {[gets $fd line] < 0} {
4137 if {![eof $fd]} {
4138 return 1
4140 set isdiff 0
4142 # we only need to see one line and we don't really care what it says...
4143 stop_instance $inst
4145 if {$serial != $lserial} {
4146 return 0
4149 # now see if there are any local changes not checked in to the index
4150 set fd [open "|git diff-files" r]
4151 fconfigure $fd -blocking 0
4152 set i [reg_instance $fd]
4153 filerun $fd [list readdifffiles $fd $serial $i]
4155 if {$isdiff && ![commitinview $nullid2 $curview]} {
4156 # add the line for the changes in the index to the graph
4157 set hl [mc "Local changes checked in to index but not committed"]
4158 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4159 set commitdata($nullid2) "\n $hl\n"
4160 if {[commitinview $nullid $curview]} {
4161 removefakerow $nullid
4163 insertfakerow $nullid2 $mainheadid
4164 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4165 removefakerow $nullid2
4167 return 0
4170 proc readdifffiles {fd serial inst} {
4171 global mainheadid nullid nullid2 curview
4172 global commitinfo commitdata lserial
4174 set isdiff 1
4175 if {[gets $fd line] < 0} {
4176 if {![eof $fd]} {
4177 return 1
4179 set isdiff 0
4181 # we only need to see one line and we don't really care what it says...
4182 stop_instance $inst
4184 if {$serial != $lserial} {
4185 return 0
4188 if {$isdiff && ![commitinview $nullid $curview]} {
4189 # add the line for the local diff to the graph
4190 set hl [mc "Local uncommitted changes, not checked in to index"]
4191 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4192 set commitdata($nullid) "\n $hl\n"
4193 if {[commitinview $nullid2 $curview]} {
4194 set p $nullid2
4195 } else {
4196 set p $mainheadid
4198 insertfakerow $nullid $p
4199 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4200 removefakerow $nullid
4202 return 0
4205 proc nextuse {id row} {
4206 global curview children
4208 if {[info exists children($curview,$id)]} {
4209 foreach kid $children($curview,$id) {
4210 if {![commitinview $kid $curview]} {
4211 return -1
4213 if {[rowofcommit $kid] > $row} {
4214 return [rowofcommit $kid]
4218 if {[commitinview $id $curview]} {
4219 return [rowofcommit $id]
4221 return -1
4224 proc prevuse {id row} {
4225 global curview children
4227 set ret -1
4228 if {[info exists children($curview,$id)]} {
4229 foreach kid $children($curview,$id) {
4230 if {![commitinview $kid $curview]} break
4231 if {[rowofcommit $kid] < $row} {
4232 set ret [rowofcommit $kid]
4236 return $ret
4239 proc make_idlist {row} {
4240 global displayorder parentlist uparrowlen downarrowlen mingaplen
4241 global commitidx curview children
4243 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4244 if {$r < 0} {
4245 set r 0
4247 set ra [expr {$row - $downarrowlen}]
4248 if {$ra < 0} {
4249 set ra 0
4251 set rb [expr {$row + $uparrowlen}]
4252 if {$rb > $commitidx($curview)} {
4253 set rb $commitidx($curview)
4255 make_disporder $r [expr {$rb + 1}]
4256 set ids {}
4257 for {} {$r < $ra} {incr r} {
4258 set nextid [lindex $displayorder [expr {$r + 1}]]
4259 foreach p [lindex $parentlist $r] {
4260 if {$p eq $nextid} continue
4261 set rn [nextuse $p $r]
4262 if {$rn >= $row &&
4263 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4264 lappend ids [list [ordertoken $p] $p]
4268 for {} {$r < $row} {incr r} {
4269 set nextid [lindex $displayorder [expr {$r + 1}]]
4270 foreach p [lindex $parentlist $r] {
4271 if {$p eq $nextid} continue
4272 set rn [nextuse $p $r]
4273 if {$rn < 0 || $rn >= $row} {
4274 lappend ids [list [ordertoken $p] $p]
4278 set id [lindex $displayorder $row]
4279 lappend ids [list [ordertoken $id] $id]
4280 while {$r < $rb} {
4281 foreach p [lindex $parentlist $r] {
4282 set firstkid [lindex $children($curview,$p) 0]
4283 if {[rowofcommit $firstkid] < $row} {
4284 lappend ids [list [ordertoken $p] $p]
4287 incr r
4288 set id [lindex $displayorder $r]
4289 if {$id ne {}} {
4290 set firstkid [lindex $children($curview,$id) 0]
4291 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4292 lappend ids [list [ordertoken $id] $id]
4296 set idlist {}
4297 foreach idx [lsort -unique $ids] {
4298 lappend idlist [lindex $idx 1]
4300 return $idlist
4303 proc rowsequal {a b} {
4304 while {[set i [lsearch -exact $a {}]] >= 0} {
4305 set a [lreplace $a $i $i]
4307 while {[set i [lsearch -exact $b {}]] >= 0} {
4308 set b [lreplace $b $i $i]
4310 return [expr {$a eq $b}]
4313 proc makeupline {id row rend col} {
4314 global rowidlist uparrowlen downarrowlen mingaplen
4316 for {set r $rend} {1} {set r $rstart} {
4317 set rstart [prevuse $id $r]
4318 if {$rstart < 0} return
4319 if {$rstart < $row} break
4321 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4322 set rstart [expr {$rend - $uparrowlen - 1}]
4324 for {set r $rstart} {[incr r] <= $row} {} {
4325 set idlist [lindex $rowidlist $r]
4326 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4327 set col [idcol $idlist $id $col]
4328 lset rowidlist $r [linsert $idlist $col $id]
4329 changedrow $r
4334 proc layoutrows {row endrow} {
4335 global rowidlist rowisopt rowfinal displayorder
4336 global uparrowlen downarrowlen maxwidth mingaplen
4337 global children parentlist
4338 global commitidx viewcomplete curview
4340 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4341 set idlist {}
4342 if {$row > 0} {
4343 set rm1 [expr {$row - 1}]
4344 foreach id [lindex $rowidlist $rm1] {
4345 if {$id ne {}} {
4346 lappend idlist $id
4349 set final [lindex $rowfinal $rm1]
4351 for {} {$row < $endrow} {incr row} {
4352 set rm1 [expr {$row - 1}]
4353 if {$rm1 < 0 || $idlist eq {}} {
4354 set idlist [make_idlist $row]
4355 set final 1
4356 } else {
4357 set id [lindex $displayorder $rm1]
4358 set col [lsearch -exact $idlist $id]
4359 set idlist [lreplace $idlist $col $col]
4360 foreach p [lindex $parentlist $rm1] {
4361 if {[lsearch -exact $idlist $p] < 0} {
4362 set col [idcol $idlist $p $col]
4363 set idlist [linsert $idlist $col $p]
4364 # if not the first child, we have to insert a line going up
4365 if {$id ne [lindex $children($curview,$p) 0]} {
4366 makeupline $p $rm1 $row $col
4370 set id [lindex $displayorder $row]
4371 if {$row > $downarrowlen} {
4372 set termrow [expr {$row - $downarrowlen - 1}]
4373 foreach p [lindex $parentlist $termrow] {
4374 set i [lsearch -exact $idlist $p]
4375 if {$i < 0} continue
4376 set nr [nextuse $p $termrow]
4377 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4378 set idlist [lreplace $idlist $i $i]
4382 set col [lsearch -exact $idlist $id]
4383 if {$col < 0} {
4384 set col [idcol $idlist $id]
4385 set idlist [linsert $idlist $col $id]
4386 if {$children($curview,$id) ne {}} {
4387 makeupline $id $rm1 $row $col
4390 set r [expr {$row + $uparrowlen - 1}]
4391 if {$r < $commitidx($curview)} {
4392 set x $col
4393 foreach p [lindex $parentlist $r] {
4394 if {[lsearch -exact $idlist $p] >= 0} continue
4395 set fk [lindex $children($curview,$p) 0]
4396 if {[rowofcommit $fk] < $row} {
4397 set x [idcol $idlist $p $x]
4398 set idlist [linsert $idlist $x $p]
4401 if {[incr r] < $commitidx($curview)} {
4402 set p [lindex $displayorder $r]
4403 if {[lsearch -exact $idlist $p] < 0} {
4404 set fk [lindex $children($curview,$p) 0]
4405 if {$fk ne {} && [rowofcommit $fk] < $row} {
4406 set x [idcol $idlist $p $x]
4407 set idlist [linsert $idlist $x $p]
4413 if {$final && !$viewcomplete($curview) &&
4414 $row + $uparrowlen + $mingaplen + $downarrowlen
4415 >= $commitidx($curview)} {
4416 set final 0
4418 set l [llength $rowidlist]
4419 if {$row == $l} {
4420 lappend rowidlist $idlist
4421 lappend rowisopt 0
4422 lappend rowfinal $final
4423 } elseif {$row < $l} {
4424 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4425 lset rowidlist $row $idlist
4426 changedrow $row
4428 lset rowfinal $row $final
4429 } else {
4430 set pad [ntimes [expr {$row - $l}] {}]
4431 set rowidlist [concat $rowidlist $pad]
4432 lappend rowidlist $idlist
4433 set rowfinal [concat $rowfinal $pad]
4434 lappend rowfinal $final
4435 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4438 return $row
4441 proc changedrow {row} {
4442 global displayorder iddrawn rowisopt need_redisplay
4444 set l [llength $rowisopt]
4445 if {$row < $l} {
4446 lset rowisopt $row 0
4447 if {$row + 1 < $l} {
4448 lset rowisopt [expr {$row + 1}] 0
4449 if {$row + 2 < $l} {
4450 lset rowisopt [expr {$row + 2}] 0
4454 set id [lindex $displayorder $row]
4455 if {[info exists iddrawn($id)]} {
4456 set need_redisplay 1
4460 proc insert_pad {row col npad} {
4461 global rowidlist
4463 set pad [ntimes $npad {}]
4464 set idlist [lindex $rowidlist $row]
4465 set bef [lrange $idlist 0 [expr {$col - 1}]]
4466 set aft [lrange $idlist $col end]
4467 set i [lsearch -exact $aft {}]
4468 if {$i > 0} {
4469 set aft [lreplace $aft $i $i]
4471 lset rowidlist $row [concat $bef $pad $aft]
4472 changedrow $row
4475 proc optimize_rows {row col endrow} {
4476 global rowidlist rowisopt displayorder curview children
4478 if {$row < 1} {
4479 set row 1
4481 for {} {$row < $endrow} {incr row; set col 0} {
4482 if {[lindex $rowisopt $row]} continue
4483 set haspad 0
4484 set y0 [expr {$row - 1}]
4485 set ym [expr {$row - 2}]
4486 set idlist [lindex $rowidlist $row]
4487 set previdlist [lindex $rowidlist $y0]
4488 if {$idlist eq {} || $previdlist eq {}} continue
4489 if {$ym >= 0} {
4490 set pprevidlist [lindex $rowidlist $ym]
4491 if {$pprevidlist eq {}} continue
4492 } else {
4493 set pprevidlist {}
4495 set x0 -1
4496 set xm -1
4497 for {} {$col < [llength $idlist]} {incr col} {
4498 set id [lindex $idlist $col]
4499 if {[lindex $previdlist $col] eq $id} continue
4500 if {$id eq {}} {
4501 set haspad 1
4502 continue
4504 set x0 [lsearch -exact $previdlist $id]
4505 if {$x0 < 0} continue
4506 set z [expr {$x0 - $col}]
4507 set isarrow 0
4508 set z0 {}
4509 if {$ym >= 0} {
4510 set xm [lsearch -exact $pprevidlist $id]
4511 if {$xm >= 0} {
4512 set z0 [expr {$xm - $x0}]
4515 if {$z0 eq {}} {
4516 # if row y0 is the first child of $id then it's not an arrow
4517 if {[lindex $children($curview,$id) 0] ne
4518 [lindex $displayorder $y0]} {
4519 set isarrow 1
4522 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4523 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4524 set isarrow 1
4526 # Looking at lines from this row to the previous row,
4527 # make them go straight up if they end in an arrow on
4528 # the previous row; otherwise make them go straight up
4529 # or at 45 degrees.
4530 if {$z < -1 || ($z < 0 && $isarrow)} {
4531 # Line currently goes left too much;
4532 # insert pads in the previous row, then optimize it
4533 set npad [expr {-1 - $z + $isarrow}]
4534 insert_pad $y0 $x0 $npad
4535 if {$y0 > 0} {
4536 optimize_rows $y0 $x0 $row
4538 set previdlist [lindex $rowidlist $y0]
4539 set x0 [lsearch -exact $previdlist $id]
4540 set z [expr {$x0 - $col}]
4541 if {$z0 ne {}} {
4542 set pprevidlist [lindex $rowidlist $ym]
4543 set xm [lsearch -exact $pprevidlist $id]
4544 set z0 [expr {$xm - $x0}]
4546 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4547 # Line currently goes right too much;
4548 # insert pads in this line
4549 set npad [expr {$z - 1 + $isarrow}]
4550 insert_pad $row $col $npad
4551 set idlist [lindex $rowidlist $row]
4552 incr col $npad
4553 set z [expr {$x0 - $col}]
4554 set haspad 1
4556 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4557 # this line links to its first child on row $row-2
4558 set id [lindex $displayorder $ym]
4559 set xc [lsearch -exact $pprevidlist $id]
4560 if {$xc >= 0} {
4561 set z0 [expr {$xc - $x0}]
4564 # avoid lines jigging left then immediately right
4565 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4566 insert_pad $y0 $x0 1
4567 incr x0
4568 optimize_rows $y0 $x0 $row
4569 set previdlist [lindex $rowidlist $y0]
4572 if {!$haspad} {
4573 # Find the first column that doesn't have a line going right
4574 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4575 set id [lindex $idlist $col]
4576 if {$id eq {}} break
4577 set x0 [lsearch -exact $previdlist $id]
4578 if {$x0 < 0} {
4579 # check if this is the link to the first child
4580 set kid [lindex $displayorder $y0]
4581 if {[lindex $children($curview,$id) 0] eq $kid} {
4582 # it is, work out offset to child
4583 set x0 [lsearch -exact $previdlist $kid]
4586 if {$x0 <= $col} break
4588 # Insert a pad at that column as long as it has a line and
4589 # isn't the last column
4590 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4591 set idlist [linsert $idlist $col {}]
4592 lset rowidlist $row $idlist
4593 changedrow $row
4599 proc xc {row col} {
4600 global canvx0 linespc
4601 return [expr {$canvx0 + $col * $linespc}]
4604 proc yc {row} {
4605 global canvy0 linespc
4606 return [expr {$canvy0 + $row * $linespc}]
4609 proc linewidth {id} {
4610 global thickerline lthickness
4612 set wid $lthickness
4613 if {[info exists thickerline] && $id eq $thickerline} {
4614 set wid [expr {2 * $lthickness}]
4616 return $wid
4619 proc rowranges {id} {
4620 global curview children uparrowlen downarrowlen
4621 global rowidlist
4623 set kids $children($curview,$id)
4624 if {$kids eq {}} {
4625 return {}
4627 set ret {}
4628 lappend kids $id
4629 foreach child $kids {
4630 if {![commitinview $child $curview]} break
4631 set row [rowofcommit $child]
4632 if {![info exists prev]} {
4633 lappend ret [expr {$row + 1}]
4634 } else {
4635 if {$row <= $prevrow} {
4636 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4638 # see if the line extends the whole way from prevrow to row
4639 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4640 [lsearch -exact [lindex $rowidlist \
4641 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4642 # it doesn't, see where it ends
4643 set r [expr {$prevrow + $downarrowlen}]
4644 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4645 while {[incr r -1] > $prevrow &&
4646 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4647 } else {
4648 while {[incr r] <= $row &&
4649 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4650 incr r -1
4652 lappend ret $r
4653 # see where it starts up again
4654 set r [expr {$row - $uparrowlen}]
4655 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4656 while {[incr r] < $row &&
4657 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4658 } else {
4659 while {[incr r -1] >= $prevrow &&
4660 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4661 incr r
4663 lappend ret $r
4666 if {$child eq $id} {
4667 lappend ret $row
4669 set prev $child
4670 set prevrow $row
4672 return $ret
4675 proc drawlineseg {id row endrow arrowlow} {
4676 global rowidlist displayorder iddrawn linesegs
4677 global canv colormap linespc curview maxlinelen parentlist
4679 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4680 set le [expr {$row + 1}]
4681 set arrowhigh 1
4682 while {1} {
4683 set c [lsearch -exact [lindex $rowidlist $le] $id]
4684 if {$c < 0} {
4685 incr le -1
4686 break
4688 lappend cols $c
4689 set x [lindex $displayorder $le]
4690 if {$x eq $id} {
4691 set arrowhigh 0
4692 break
4694 if {[info exists iddrawn($x)] || $le == $endrow} {
4695 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4696 if {$c >= 0} {
4697 lappend cols $c
4698 set arrowhigh 0
4700 break
4702 incr le
4704 if {$le <= $row} {
4705 return $row
4708 set lines {}
4709 set i 0
4710 set joinhigh 0
4711 if {[info exists linesegs($id)]} {
4712 set lines $linesegs($id)
4713 foreach li $lines {
4714 set r0 [lindex $li 0]
4715 if {$r0 > $row} {
4716 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4717 set joinhigh 1
4719 break
4721 incr i
4724 set joinlow 0
4725 if {$i > 0} {
4726 set li [lindex $lines [expr {$i-1}]]
4727 set r1 [lindex $li 1]
4728 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4729 set joinlow 1
4733 set x [lindex $cols [expr {$le - $row}]]
4734 set xp [lindex $cols [expr {$le - 1 - $row}]]
4735 set dir [expr {$xp - $x}]
4736 if {$joinhigh} {
4737 set ith [lindex $lines $i 2]
4738 set coords [$canv coords $ith]
4739 set ah [$canv itemcget $ith -arrow]
4740 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4741 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4742 if {$x2 ne {} && $x - $x2 == $dir} {
4743 set coords [lrange $coords 0 end-2]
4745 } else {
4746 set coords [list [xc $le $x] [yc $le]]
4748 if {$joinlow} {
4749 set itl [lindex $lines [expr {$i-1}] 2]
4750 set al [$canv itemcget $itl -arrow]
4751 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4752 } elseif {$arrowlow} {
4753 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4754 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4755 set arrowlow 0
4758 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4759 for {set y $le} {[incr y -1] > $row} {} {
4760 set x $xp
4761 set xp [lindex $cols [expr {$y - 1 - $row}]]
4762 set ndir [expr {$xp - $x}]
4763 if {$dir != $ndir || $xp < 0} {
4764 lappend coords [xc $y $x] [yc $y]
4766 set dir $ndir
4768 if {!$joinlow} {
4769 if {$xp < 0} {
4770 # join parent line to first child
4771 set ch [lindex $displayorder $row]
4772 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4773 if {$xc < 0} {
4774 puts "oops: drawlineseg: child $ch not on row $row"
4775 } elseif {$xc != $x} {
4776 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4777 set d [expr {int(0.5 * $linespc)}]
4778 set x1 [xc $row $x]
4779 if {$xc < $x} {
4780 set x2 [expr {$x1 - $d}]
4781 } else {
4782 set x2 [expr {$x1 + $d}]
4784 set y2 [yc $row]
4785 set y1 [expr {$y2 + $d}]
4786 lappend coords $x1 $y1 $x2 $y2
4787 } elseif {$xc < $x - 1} {
4788 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4789 } elseif {$xc > $x + 1} {
4790 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4792 set x $xc
4794 lappend coords [xc $row $x] [yc $row]
4795 } else {
4796 set xn [xc $row $xp]
4797 set yn [yc $row]
4798 lappend coords $xn $yn
4800 if {!$joinhigh} {
4801 assigncolor $id
4802 set t [$canv create line $coords -width [linewidth $id] \
4803 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4804 $canv lower $t
4805 bindline $t $id
4806 set lines [linsert $lines $i [list $row $le $t]]
4807 } else {
4808 $canv coords $ith $coords
4809 if {$arrow ne $ah} {
4810 $canv itemconf $ith -arrow $arrow
4812 lset lines $i 0 $row
4814 } else {
4815 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4816 set ndir [expr {$xo - $xp}]
4817 set clow [$canv coords $itl]
4818 if {$dir == $ndir} {
4819 set clow [lrange $clow 2 end]
4821 set coords [concat $coords $clow]
4822 if {!$joinhigh} {
4823 lset lines [expr {$i-1}] 1 $le
4824 } else {
4825 # coalesce two pieces
4826 $canv delete $ith
4827 set b [lindex $lines [expr {$i-1}] 0]
4828 set e [lindex $lines $i 1]
4829 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4831 $canv coords $itl $coords
4832 if {$arrow ne $al} {
4833 $canv itemconf $itl -arrow $arrow
4837 set linesegs($id) $lines
4838 return $le
4841 proc drawparentlinks {id row} {
4842 global rowidlist canv colormap curview parentlist
4843 global idpos linespc
4845 set rowids [lindex $rowidlist $row]
4846 set col [lsearch -exact $rowids $id]
4847 if {$col < 0} return
4848 set olds [lindex $parentlist $row]
4849 set row2 [expr {$row + 1}]
4850 set x [xc $row $col]
4851 set y [yc $row]
4852 set y2 [yc $row2]
4853 set d [expr {int(0.5 * $linespc)}]
4854 set ymid [expr {$y + $d}]
4855 set ids [lindex $rowidlist $row2]
4856 # rmx = right-most X coord used
4857 set rmx 0
4858 foreach p $olds {
4859 set i [lsearch -exact $ids $p]
4860 if {$i < 0} {
4861 puts "oops, parent $p of $id not in list"
4862 continue
4864 set x2 [xc $row2 $i]
4865 if {$x2 > $rmx} {
4866 set rmx $x2
4868 set j [lsearch -exact $rowids $p]
4869 if {$j < 0} {
4870 # drawlineseg will do this one for us
4871 continue
4873 assigncolor $p
4874 # should handle duplicated parents here...
4875 set coords [list $x $y]
4876 if {$i != $col} {
4877 # if attaching to a vertical segment, draw a smaller
4878 # slant for visual distinctness
4879 if {$i == $j} {
4880 if {$i < $col} {
4881 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4882 } else {
4883 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4885 } elseif {$i < $col && $i < $j} {
4886 # segment slants towards us already
4887 lappend coords [xc $row $j] $y
4888 } else {
4889 if {$i < $col - 1} {
4890 lappend coords [expr {$x2 + $linespc}] $y
4891 } elseif {$i > $col + 1} {
4892 lappend coords [expr {$x2 - $linespc}] $y
4894 lappend coords $x2 $y2
4896 } else {
4897 lappend coords $x2 $y2
4899 set t [$canv create line $coords -width [linewidth $p] \
4900 -fill $colormap($p) -tags lines.$p]
4901 $canv lower $t
4902 bindline $t $p
4904 if {$rmx > [lindex $idpos($id) 1]} {
4905 lset idpos($id) 1 $rmx
4906 redrawtags $id
4910 proc drawlines {id} {
4911 global canv
4913 $canv itemconf lines.$id -width [linewidth $id]
4916 proc drawcmittext {id row col} {
4917 global linespc canv canv2 canv3 fgcolor curview
4918 global cmitlisted commitinfo rowidlist parentlist
4919 global rowtextx idpos idtags idheads idotherrefs
4920 global linehtag linentag linedtag selectedline
4921 global canvxmax boldrows boldnamerows fgcolor
4922 global mainheadid nullid nullid2 circleitem circlecolors
4924 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4925 set listed $cmitlisted($curview,$id)
4926 if {$id eq $nullid} {
4927 set ofill red
4928 } elseif {$id eq $nullid2} {
4929 set ofill green
4930 } elseif {$id eq $mainheadid} {
4931 set ofill yellow
4932 } else {
4933 set ofill [lindex $circlecolors $listed]
4935 set x [xc $row $col]
4936 set y [yc $row]
4937 set orad [expr {$linespc / 3}]
4938 if {$listed <= 2} {
4939 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4940 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4941 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4942 } elseif {$listed == 3} {
4943 # triangle pointing left for left-side commits
4944 set t [$canv create polygon \
4945 [expr {$x - $orad}] $y \
4946 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4947 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4948 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4949 } else {
4950 # triangle pointing right for right-side commits
4951 set t [$canv create polygon \
4952 [expr {$x + $orad - 1}] $y \
4953 [expr {$x - $orad}] [expr {$y - $orad}] \
4954 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4955 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4957 set circleitem($row) $t
4958 $canv raise $t
4959 $canv bind $t <1> {selcanvline {} %x %y}
4960 set rmx [llength [lindex $rowidlist $row]]
4961 set olds [lindex $parentlist $row]
4962 if {$olds ne {}} {
4963 set nextids [lindex $rowidlist [expr {$row + 1}]]
4964 foreach p $olds {
4965 set i [lsearch -exact $nextids $p]
4966 if {$i > $rmx} {
4967 set rmx $i
4971 set xt [xc $row $rmx]
4972 set rowtextx($row) $xt
4973 set idpos($id) [list $x $xt $y]
4974 if {[info exists idtags($id)] || [info exists idheads($id)]
4975 || [info exists idotherrefs($id)]} {
4976 set xt [drawtags $id $x $xt $y]
4978 set headline [lindex $commitinfo($id) 0]
4979 set name [lindex $commitinfo($id) 1]
4980 set date [lindex $commitinfo($id) 2]
4981 set date [formatdate $date]
4982 set font mainfont
4983 set nfont mainfont
4984 set isbold [ishighlighted $id]
4985 if {$isbold > 0} {
4986 lappend boldrows $row
4987 set font mainfontbold
4988 if {$isbold > 1} {
4989 lappend boldnamerows $row
4990 set nfont mainfontbold
4993 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4994 -text $headline -font $font -tags text]
4995 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4996 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4997 -text $name -font $nfont -tags text]
4998 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4999 -text $date -font mainfont -tags text]
5000 if {$selectedline == $row} {
5001 make_secsel $row
5003 set xr [expr {$xt + [font measure $font $headline]}]
5004 if {$xr > $canvxmax} {
5005 set canvxmax $xr
5006 setcanvscroll
5010 proc drawcmitrow {row} {
5011 global displayorder rowidlist nrows_drawn
5012 global iddrawn markingmatches
5013 global commitinfo numcommits
5014 global filehighlight fhighlights findpattern nhighlights
5015 global hlview vhighlights
5016 global highlight_related rhighlights
5018 if {$row >= $numcommits} return
5020 set id [lindex $displayorder $row]
5021 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5022 askvhighlight $row $id
5024 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5025 askfilehighlight $row $id
5027 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5028 askfindhighlight $row $id
5030 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5031 askrelhighlight $row $id
5033 if {![info exists iddrawn($id)]} {
5034 set col [lsearch -exact [lindex $rowidlist $row] $id]
5035 if {$col < 0} {
5036 puts "oops, row $row id $id not in list"
5037 return
5039 if {![info exists commitinfo($id)]} {
5040 getcommit $id
5042 assigncolor $id
5043 drawcmittext $id $row $col
5044 set iddrawn($id) 1
5045 incr nrows_drawn
5047 if {$markingmatches} {
5048 markrowmatches $row $id
5052 proc drawcommits {row {endrow {}}} {
5053 global numcommits iddrawn displayorder curview need_redisplay
5054 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5056 if {$row < 0} {
5057 set row 0
5059 if {$endrow eq {}} {
5060 set endrow $row
5062 if {$endrow >= $numcommits} {
5063 set endrow [expr {$numcommits - 1}]
5066 set rl1 [expr {$row - $downarrowlen - 3}]
5067 if {$rl1 < 0} {
5068 set rl1 0
5070 set ro1 [expr {$row - 3}]
5071 if {$ro1 < 0} {
5072 set ro1 0
5074 set r2 [expr {$endrow + $uparrowlen + 3}]
5075 if {$r2 > $numcommits} {
5076 set r2 $numcommits
5078 for {set r $rl1} {$r < $r2} {incr r} {
5079 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5080 if {$rl1 < $r} {
5081 layoutrows $rl1 $r
5083 set rl1 [expr {$r + 1}]
5086 if {$rl1 < $r} {
5087 layoutrows $rl1 $r
5089 optimize_rows $ro1 0 $r2
5090 if {$need_redisplay || $nrows_drawn > 2000} {
5091 clear_display
5092 drawvisible
5095 # make the lines join to already-drawn rows either side
5096 set r [expr {$row - 1}]
5097 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5098 set r $row
5100 set er [expr {$endrow + 1}]
5101 if {$er >= $numcommits ||
5102 ![info exists iddrawn([lindex $displayorder $er])]} {
5103 set er $endrow
5105 for {} {$r <= $er} {incr r} {
5106 set id [lindex $displayorder $r]
5107 set wasdrawn [info exists iddrawn($id)]
5108 drawcmitrow $r
5109 if {$r == $er} break
5110 set nextid [lindex $displayorder [expr {$r + 1}]]
5111 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5112 drawparentlinks $id $r
5114 set rowids [lindex $rowidlist $r]
5115 foreach lid $rowids {
5116 if {$lid eq {}} continue
5117 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5118 if {$lid eq $id} {
5119 # see if this is the first child of any of its parents
5120 foreach p [lindex $parentlist $r] {
5121 if {[lsearch -exact $rowids $p] < 0} {
5122 # make this line extend up to the child
5123 set lineend($p) [drawlineseg $p $r $er 0]
5126 } else {
5127 set lineend($lid) [drawlineseg $lid $r $er 1]
5133 proc undolayout {row} {
5134 global uparrowlen mingaplen downarrowlen
5135 global rowidlist rowisopt rowfinal need_redisplay
5137 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5138 if {$r < 0} {
5139 set r 0
5141 if {[llength $rowidlist] > $r} {
5142 incr r -1
5143 set rowidlist [lrange $rowidlist 0 $r]
5144 set rowfinal [lrange $rowfinal 0 $r]
5145 set rowisopt [lrange $rowisopt 0 $r]
5146 set need_redisplay 1
5147 run drawvisible
5151 proc drawvisible {} {
5152 global canv linespc curview vrowmod selectedline targetrow targetid
5153 global need_redisplay cscroll numcommits
5155 set fs [$canv yview]
5156 set ymax [lindex [$canv cget -scrollregion] 3]
5157 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5158 set f0 [lindex $fs 0]
5159 set f1 [lindex $fs 1]
5160 set y0 [expr {int($f0 * $ymax)}]
5161 set y1 [expr {int($f1 * $ymax)}]
5163 if {[info exists targetid]} {
5164 if {[commitinview $targetid $curview]} {
5165 set r [rowofcommit $targetid]
5166 if {$r != $targetrow} {
5167 # Fix up the scrollregion and change the scrolling position
5168 # now that our target row has moved.
5169 set diff [expr {($r - $targetrow) * $linespc}]
5170 set targetrow $r
5171 setcanvscroll
5172 set ymax [lindex [$canv cget -scrollregion] 3]
5173 incr y0 $diff
5174 incr y1 $diff
5175 set f0 [expr {$y0 / $ymax}]
5176 set f1 [expr {$y1 / $ymax}]
5177 allcanvs yview moveto $f0
5178 $cscroll set $f0 $f1
5179 set need_redisplay 1
5181 } else {
5182 unset targetid
5186 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5187 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5188 if {$endrow >= $vrowmod($curview)} {
5189 update_arcrows $curview
5191 if {$selectedline ne {} &&
5192 $row <= $selectedline && $selectedline <= $endrow} {
5193 set targetrow $selectedline
5194 } elseif {[info exists targetid]} {
5195 set targetrow [expr {int(($row + $endrow) / 2)}]
5197 if {[info exists targetrow]} {
5198 if {$targetrow >= $numcommits} {
5199 set targetrow [expr {$numcommits - 1}]
5201 set targetid [commitonrow $targetrow]
5203 drawcommits $row $endrow
5206 proc clear_display {} {
5207 global iddrawn linesegs need_redisplay nrows_drawn
5208 global vhighlights fhighlights nhighlights rhighlights
5209 global linehtag linentag linedtag boldrows boldnamerows
5211 allcanvs delete all
5212 catch {unset iddrawn}
5213 catch {unset linesegs}
5214 catch {unset linehtag}
5215 catch {unset linentag}
5216 catch {unset linedtag}
5217 set boldrows {}
5218 set boldnamerows {}
5219 catch {unset vhighlights}
5220 catch {unset fhighlights}
5221 catch {unset nhighlights}
5222 catch {unset rhighlights}
5223 set need_redisplay 0
5224 set nrows_drawn 0
5227 proc findcrossings {id} {
5228 global rowidlist parentlist numcommits displayorder
5230 set cross {}
5231 set ccross {}
5232 foreach {s e} [rowranges $id] {
5233 if {$e >= $numcommits} {
5234 set e [expr {$numcommits - 1}]
5236 if {$e <= $s} continue
5237 for {set row $e} {[incr row -1] >= $s} {} {
5238 set x [lsearch -exact [lindex $rowidlist $row] $id]
5239 if {$x < 0} break
5240 set olds [lindex $parentlist $row]
5241 set kid [lindex $displayorder $row]
5242 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5243 if {$kidx < 0} continue
5244 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5245 foreach p $olds {
5246 set px [lsearch -exact $nextrow $p]
5247 if {$px < 0} continue
5248 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5249 if {[lsearch -exact $ccross $p] >= 0} continue
5250 if {$x == $px + ($kidx < $px? -1: 1)} {
5251 lappend ccross $p
5252 } elseif {[lsearch -exact $cross $p] < 0} {
5253 lappend cross $p
5259 return [concat $ccross {{}} $cross]
5262 proc assigncolor {id} {
5263 global colormap colors nextcolor
5264 global parents children children curview
5266 if {[info exists colormap($id)]} return
5267 set ncolors [llength $colors]
5268 if {[info exists children($curview,$id)]} {
5269 set kids $children($curview,$id)
5270 } else {
5271 set kids {}
5273 if {[llength $kids] == 1} {
5274 set child [lindex $kids 0]
5275 if {[info exists colormap($child)]
5276 && [llength $parents($curview,$child)] == 1} {
5277 set colormap($id) $colormap($child)
5278 return
5281 set badcolors {}
5282 set origbad {}
5283 foreach x [findcrossings $id] {
5284 if {$x eq {}} {
5285 # delimiter between corner crossings and other crossings
5286 if {[llength $badcolors] >= $ncolors - 1} break
5287 set origbad $badcolors
5289 if {[info exists colormap($x)]
5290 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5291 lappend badcolors $colormap($x)
5294 if {[llength $badcolors] >= $ncolors} {
5295 set badcolors $origbad
5297 set origbad $badcolors
5298 if {[llength $badcolors] < $ncolors - 1} {
5299 foreach child $kids {
5300 if {[info exists colormap($child)]
5301 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5302 lappend badcolors $colormap($child)
5304 foreach p $parents($curview,$child) {
5305 if {[info exists colormap($p)]
5306 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5307 lappend badcolors $colormap($p)
5311 if {[llength $badcolors] >= $ncolors} {
5312 set badcolors $origbad
5315 for {set i 0} {$i <= $ncolors} {incr i} {
5316 set c [lindex $colors $nextcolor]
5317 if {[incr nextcolor] >= $ncolors} {
5318 set nextcolor 0
5320 if {[lsearch -exact $badcolors $c]} break
5322 set colormap($id) $c
5325 proc bindline {t id} {
5326 global canv
5328 $canv bind $t <Enter> "lineenter %x %y $id"
5329 $canv bind $t <Motion> "linemotion %x %y $id"
5330 $canv bind $t <Leave> "lineleave $id"
5331 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5334 proc drawtags {id x xt y1} {
5335 global idtags idheads idotherrefs mainhead
5336 global linespc lthickness
5337 global canv rowtextx curview fgcolor bgcolor
5339 set marks {}
5340 set ntags 0
5341 set nheads 0
5342 if {[info exists idtags($id)]} {
5343 set marks $idtags($id)
5344 set ntags [llength $marks]
5346 if {[info exists idheads($id)]} {
5347 set marks [concat $marks $idheads($id)]
5348 set nheads [llength $idheads($id)]
5350 if {[info exists idotherrefs($id)]} {
5351 set marks [concat $marks $idotherrefs($id)]
5353 if {$marks eq {}} {
5354 return $xt
5357 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5358 set yt [expr {$y1 - 0.5 * $linespc}]
5359 set yb [expr {$yt + $linespc - 1}]
5360 set xvals {}
5361 set wvals {}
5362 set i -1
5363 foreach tag $marks {
5364 incr i
5365 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5366 set wid [font measure mainfontbold $tag]
5367 } else {
5368 set wid [font measure mainfont $tag]
5370 lappend xvals $xt
5371 lappend wvals $wid
5372 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5374 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5375 -width $lthickness -fill black -tags tag.$id]
5376 $canv lower $t
5377 foreach tag $marks x $xvals wid $wvals {
5378 set xl [expr {$x + $delta}]
5379 set xr [expr {$x + $delta + $wid + $lthickness}]
5380 set font mainfont
5381 if {[incr ntags -1] >= 0} {
5382 # draw a tag
5383 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5384 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5385 -width 1 -outline black -fill yellow -tags tag.$id]
5386 $canv bind $t <1> [list showtag $tag 1]
5387 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5388 } else {
5389 # draw a head or other ref
5390 if {[incr nheads -1] >= 0} {
5391 set col green
5392 if {$tag eq $mainhead} {
5393 set font mainfontbold
5395 } else {
5396 set col "#ddddff"
5398 set xl [expr {$xl - $delta/2}]
5399 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5400 -width 1 -outline black -fill $col -tags tag.$id
5401 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5402 set rwid [font measure mainfont $remoteprefix]
5403 set xi [expr {$x + 1}]
5404 set yti [expr {$yt + 1}]
5405 set xri [expr {$x + $rwid}]
5406 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5407 -width 0 -fill "#ffddaa" -tags tag.$id
5410 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5411 -font $font -tags [list tag.$id text]]
5412 if {$ntags >= 0} {
5413 $canv bind $t <1> [list showtag $tag 1]
5414 } elseif {$nheads >= 0} {
5415 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5418 return $xt
5421 proc xcoord {i level ln} {
5422 global canvx0 xspc1 xspc2
5424 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5425 if {$i > 0 && $i == $level} {
5426 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5427 } elseif {$i > $level} {
5428 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5430 return $x
5433 proc show_status {msg} {
5434 global canv fgcolor
5436 clear_display
5437 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5438 -tags text -fill $fgcolor
5441 # Don't change the text pane cursor if it is currently the hand cursor,
5442 # showing that we are over a sha1 ID link.
5443 proc settextcursor {c} {
5444 global ctext curtextcursor
5446 if {[$ctext cget -cursor] == $curtextcursor} {
5447 $ctext config -cursor $c
5449 set curtextcursor $c
5452 proc nowbusy {what {name {}}} {
5453 global isbusy busyname statusw
5455 if {[array names isbusy] eq {}} {
5456 . config -cursor watch
5457 settextcursor watch
5459 set isbusy($what) 1
5460 set busyname($what) $name
5461 if {$name ne {}} {
5462 $statusw conf -text $name
5466 proc notbusy {what} {
5467 global isbusy maincursor textcursor busyname statusw
5469 catch {
5470 unset isbusy($what)
5471 if {$busyname($what) ne {} &&
5472 [$statusw cget -text] eq $busyname($what)} {
5473 $statusw conf -text {}
5476 if {[array names isbusy] eq {}} {
5477 . config -cursor $maincursor
5478 settextcursor $textcursor
5482 proc findmatches {f} {
5483 global findtype findstring
5484 if {$findtype == [mc "Regexp"]} {
5485 set matches [regexp -indices -all -inline $findstring $f]
5486 } else {
5487 set fs $findstring
5488 if {$findtype == [mc "IgnCase"]} {
5489 set f [string tolower $f]
5490 set fs [string tolower $fs]
5492 set matches {}
5493 set i 0
5494 set l [string length $fs]
5495 while {[set j [string first $fs $f $i]] >= 0} {
5496 lappend matches [list $j [expr {$j+$l-1}]]
5497 set i [expr {$j + $l}]
5500 return $matches
5503 proc dofind {{dirn 1} {wrap 1}} {
5504 global findstring findstartline findcurline selectedline numcommits
5505 global gdttype filehighlight fh_serial find_dirn findallowwrap
5507 if {[info exists find_dirn]} {
5508 if {$find_dirn == $dirn} return
5509 stopfinding
5511 focus .
5512 if {$findstring eq {} || $numcommits == 0} return
5513 if {$selectedline eq {}} {
5514 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5515 } else {
5516 set findstartline $selectedline
5518 set findcurline $findstartline
5519 nowbusy finding [mc "Searching"]
5520 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5521 after cancel do_file_hl $fh_serial
5522 do_file_hl $fh_serial
5524 set find_dirn $dirn
5525 set findallowwrap $wrap
5526 run findmore
5529 proc stopfinding {} {
5530 global find_dirn findcurline fprogcoord
5532 if {[info exists find_dirn]} {
5533 unset find_dirn
5534 unset findcurline
5535 notbusy finding
5536 set fprogcoord 0
5537 adjustprogress
5541 proc findmore {} {
5542 global commitdata commitinfo numcommits findpattern findloc
5543 global findstartline findcurline findallowwrap
5544 global find_dirn gdttype fhighlights fprogcoord
5545 global curview varcorder vrownum varccommits vrowmod
5547 if {![info exists find_dirn]} {
5548 return 0
5550 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5551 set l $findcurline
5552 set moretodo 0
5553 if {$find_dirn > 0} {
5554 incr l
5555 if {$l >= $numcommits} {
5556 set l 0
5558 if {$l <= $findstartline} {
5559 set lim [expr {$findstartline + 1}]
5560 } else {
5561 set lim $numcommits
5562 set moretodo $findallowwrap
5564 } else {
5565 if {$l == 0} {
5566 set l $numcommits
5568 incr l -1
5569 if {$l >= $findstartline} {
5570 set lim [expr {$findstartline - 1}]
5571 } else {
5572 set lim -1
5573 set moretodo $findallowwrap
5576 set n [expr {($lim - $l) * $find_dirn}]
5577 if {$n > 500} {
5578 set n 500
5579 set moretodo 1
5581 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5582 update_arcrows $curview
5584 set found 0
5585 set domore 1
5586 set ai [bsearch $vrownum($curview) $l]
5587 set a [lindex $varcorder($curview) $ai]
5588 set arow [lindex $vrownum($curview) $ai]
5589 set ids [lindex $varccommits($curview,$a)]
5590 set arowend [expr {$arow + [llength $ids]}]
5591 if {$gdttype eq [mc "containing:"]} {
5592 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5593 if {$l < $arow || $l >= $arowend} {
5594 incr ai $find_dirn
5595 set a [lindex $varcorder($curview) $ai]
5596 set arow [lindex $vrownum($curview) $ai]
5597 set ids [lindex $varccommits($curview,$a)]
5598 set arowend [expr {$arow + [llength $ids]}]
5600 set id [lindex $ids [expr {$l - $arow}]]
5601 # shouldn't happen unless git log doesn't give all the commits...
5602 if {![info exists commitdata($id)] ||
5603 ![doesmatch $commitdata($id)]} {
5604 continue
5606 if {![info exists commitinfo($id)]} {
5607 getcommit $id
5609 set info $commitinfo($id)
5610 foreach f $info ty $fldtypes {
5611 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5612 [doesmatch $f]} {
5613 set found 1
5614 break
5617 if {$found} break
5619 } else {
5620 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5621 if {$l < $arow || $l >= $arowend} {
5622 incr ai $find_dirn
5623 set a [lindex $varcorder($curview) $ai]
5624 set arow [lindex $vrownum($curview) $ai]
5625 set ids [lindex $varccommits($curview,$a)]
5626 set arowend [expr {$arow + [llength $ids]}]
5628 set id [lindex $ids [expr {$l - $arow}]]
5629 if {![info exists fhighlights($id)]} {
5630 # this sets fhighlights($id) to -1
5631 askfilehighlight $l $id
5633 if {$fhighlights($id) > 0} {
5634 set found $domore
5635 break
5637 if {$fhighlights($id) < 0} {
5638 if {$domore} {
5639 set domore 0
5640 set findcurline [expr {$l - $find_dirn}]
5645 if {$found || ($domore && !$moretodo)} {
5646 unset findcurline
5647 unset find_dirn
5648 notbusy finding
5649 set fprogcoord 0
5650 adjustprogress
5651 if {$found} {
5652 findselectline $l
5653 } else {
5654 bell
5656 return 0
5658 if {!$domore} {
5659 flushhighlights
5660 } else {
5661 set findcurline [expr {$l - $find_dirn}]
5663 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5664 if {$n < 0} {
5665 incr n $numcommits
5667 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5668 adjustprogress
5669 return $domore
5672 proc findselectline {l} {
5673 global findloc commentend ctext findcurline markingmatches gdttype
5675 set markingmatches 1
5676 set findcurline $l
5677 selectline $l 1
5678 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5679 # highlight the matches in the comments
5680 set f [$ctext get 1.0 $commentend]
5681 set matches [findmatches $f]
5682 foreach match $matches {
5683 set start [lindex $match 0]
5684 set end [expr {[lindex $match 1] + 1}]
5685 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5688 drawvisible
5691 # mark the bits of a headline or author that match a find string
5692 proc markmatches {canv l str tag matches font row} {
5693 global selectedline
5695 set bbox [$canv bbox $tag]
5696 set x0 [lindex $bbox 0]
5697 set y0 [lindex $bbox 1]
5698 set y1 [lindex $bbox 3]
5699 foreach match $matches {
5700 set start [lindex $match 0]
5701 set end [lindex $match 1]
5702 if {$start > $end} continue
5703 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5704 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5705 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5706 [expr {$x0+$xlen+2}] $y1 \
5707 -outline {} -tags [list match$l matches] -fill yellow]
5708 $canv lower $t
5709 if {$row == $selectedline} {
5710 $canv raise $t secsel
5715 proc unmarkmatches {} {
5716 global markingmatches
5718 allcanvs delete matches
5719 set markingmatches 0
5720 stopfinding
5723 proc selcanvline {w x y} {
5724 global canv canvy0 ctext linespc
5725 global rowtextx
5726 set ymax [lindex [$canv cget -scrollregion] 3]
5727 if {$ymax == {}} return
5728 set yfrac [lindex [$canv yview] 0]
5729 set y [expr {$y + $yfrac * $ymax}]
5730 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5731 if {$l < 0} {
5732 set l 0
5734 if {$w eq $canv} {
5735 set xmax [lindex [$canv cget -scrollregion] 2]
5736 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5737 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5739 unmarkmatches
5740 selectline $l 1
5743 proc commit_descriptor {p} {
5744 global commitinfo
5745 if {![info exists commitinfo($p)]} {
5746 getcommit $p
5748 set l "..."
5749 if {[llength $commitinfo($p)] > 1} {
5750 set l [lindex $commitinfo($p) 0]
5752 return "$p ($l)\n"
5755 # append some text to the ctext widget, and make any SHA1 ID
5756 # that we know about be a clickable link.
5757 proc appendwithlinks {text tags} {
5758 global ctext linknum curview pendinglinks
5760 set start [$ctext index "end - 1c"]
5761 $ctext insert end $text $tags
5762 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5763 foreach l $links {
5764 set s [lindex $l 0]
5765 set e [lindex $l 1]
5766 set linkid [string range $text $s $e]
5767 incr e
5768 $ctext tag delete link$linknum
5769 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5770 setlink $linkid link$linknum
5771 incr linknum
5775 proc setlink {id lk} {
5776 global curview ctext pendinglinks commitinterest
5778 if {[commitinview $id $curview]} {
5779 $ctext tag conf $lk -foreground blue -underline 1
5780 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5781 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5782 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5783 } else {
5784 lappend pendinglinks($id) $lk
5785 lappend commitinterest($id) {makelink %I}
5789 proc makelink {id} {
5790 global pendinglinks
5792 if {![info exists pendinglinks($id)]} return
5793 foreach lk $pendinglinks($id) {
5794 setlink $id $lk
5796 unset pendinglinks($id)
5799 proc linkcursor {w inc} {
5800 global linkentercount curtextcursor
5802 if {[incr linkentercount $inc] > 0} {
5803 $w configure -cursor hand2
5804 } else {
5805 $w configure -cursor $curtextcursor
5806 if {$linkentercount < 0} {
5807 set linkentercount 0
5812 proc viewnextline {dir} {
5813 global canv linespc
5815 $canv delete hover
5816 set ymax [lindex [$canv cget -scrollregion] 3]
5817 set wnow [$canv yview]
5818 set wtop [expr {[lindex $wnow 0] * $ymax}]
5819 set newtop [expr {$wtop + $dir * $linespc}]
5820 if {$newtop < 0} {
5821 set newtop 0
5822 } elseif {$newtop > $ymax} {
5823 set newtop $ymax
5825 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5828 # add a list of tag or branch names at position pos
5829 # returns the number of names inserted
5830 proc appendrefs {pos ids var} {
5831 global ctext linknum curview $var maxrefs
5833 if {[catch {$ctext index $pos}]} {
5834 return 0
5836 $ctext conf -state normal
5837 $ctext delete $pos "$pos lineend"
5838 set tags {}
5839 foreach id $ids {
5840 foreach tag [set $var\($id\)] {
5841 lappend tags [list $tag $id]
5844 if {[llength $tags] > $maxrefs} {
5845 $ctext insert $pos "many ([llength $tags])"
5846 } else {
5847 set tags [lsort -index 0 -decreasing $tags]
5848 set sep {}
5849 foreach ti $tags {
5850 set id [lindex $ti 1]
5851 set lk link$linknum
5852 incr linknum
5853 $ctext tag delete $lk
5854 $ctext insert $pos $sep
5855 $ctext insert $pos [lindex $ti 0] $lk
5856 setlink $id $lk
5857 set sep ", "
5860 $ctext conf -state disabled
5861 return [llength $tags]
5864 # called when we have finished computing the nearby tags
5865 proc dispneartags {delay} {
5866 global selectedline currentid showneartags tagphase
5868 if {$selectedline eq {} || !$showneartags} return
5869 after cancel dispnexttag
5870 if {$delay} {
5871 after 200 dispnexttag
5872 set tagphase -1
5873 } else {
5874 after idle dispnexttag
5875 set tagphase 0
5879 proc dispnexttag {} {
5880 global selectedline currentid showneartags tagphase ctext
5882 if {$selectedline eq {} || !$showneartags} return
5883 switch -- $tagphase {
5885 set dtags [desctags $currentid]
5886 if {$dtags ne {}} {
5887 appendrefs precedes $dtags idtags
5891 set atags [anctags $currentid]
5892 if {$atags ne {}} {
5893 appendrefs follows $atags idtags
5897 set dheads [descheads $currentid]
5898 if {$dheads ne {}} {
5899 if {[appendrefs branch $dheads idheads] > 1
5900 && [$ctext get "branch -3c"] eq "h"} {
5901 # turn "Branch" into "Branches"
5902 $ctext conf -state normal
5903 $ctext insert "branch -2c" "es"
5904 $ctext conf -state disabled
5909 if {[incr tagphase] <= 2} {
5910 after idle dispnexttag
5914 proc make_secsel {l} {
5915 global linehtag linentag linedtag canv canv2 canv3
5917 if {![info exists linehtag($l)]} return
5918 $canv delete secsel
5919 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5920 -tags secsel -fill [$canv cget -selectbackground]]
5921 $canv lower $t
5922 $canv2 delete secsel
5923 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5924 -tags secsel -fill [$canv2 cget -selectbackground]]
5925 $canv2 lower $t
5926 $canv3 delete secsel
5927 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5928 -tags secsel -fill [$canv3 cget -selectbackground]]
5929 $canv3 lower $t
5932 proc selectline {l isnew} {
5933 global canv ctext commitinfo selectedline
5934 global canvy0 linespc parents children curview
5935 global currentid sha1entry
5936 global commentend idtags linknum
5937 global mergemax numcommits pending_select
5938 global cmitmode showneartags allcommits
5939 global targetrow targetid lastscrollrows
5940 global autoselect
5942 catch {unset pending_select}
5943 $canv delete hover
5944 normalline
5945 unsel_reflist
5946 stopfinding
5947 if {$l < 0 || $l >= $numcommits} return
5948 set id [commitonrow $l]
5949 set targetid $id
5950 set targetrow $l
5951 set selectedline $l
5952 set currentid $id
5953 if {$lastscrollrows < $numcommits} {
5954 setcanvscroll
5957 set y [expr {$canvy0 + $l * $linespc}]
5958 set ymax [lindex [$canv cget -scrollregion] 3]
5959 set ytop [expr {$y - $linespc - 1}]
5960 set ybot [expr {$y + $linespc + 1}]
5961 set wnow [$canv yview]
5962 set wtop [expr {[lindex $wnow 0] * $ymax}]
5963 set wbot [expr {[lindex $wnow 1] * $ymax}]
5964 set wh [expr {$wbot - $wtop}]
5965 set newtop $wtop
5966 if {$ytop < $wtop} {
5967 if {$ybot < $wtop} {
5968 set newtop [expr {$y - $wh / 2.0}]
5969 } else {
5970 set newtop $ytop
5971 if {$newtop > $wtop - $linespc} {
5972 set newtop [expr {$wtop - $linespc}]
5975 } elseif {$ybot > $wbot} {
5976 if {$ytop > $wbot} {
5977 set newtop [expr {$y - $wh / 2.0}]
5978 } else {
5979 set newtop [expr {$ybot - $wh}]
5980 if {$newtop < $wtop + $linespc} {
5981 set newtop [expr {$wtop + $linespc}]
5985 if {$newtop != $wtop} {
5986 if {$newtop < 0} {
5987 set newtop 0
5989 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5990 drawvisible
5993 make_secsel $l
5995 if {$isnew} {
5996 addtohistory [list selbyid $id]
5999 $sha1entry delete 0 end
6000 $sha1entry insert 0 $id
6001 if {$autoselect} {
6002 $sha1entry selection from 0
6003 $sha1entry selection to end
6005 rhighlight_sel $id
6007 $ctext conf -state normal
6008 clear_ctext
6009 set linknum 0
6010 if {![info exists commitinfo($id)]} {
6011 getcommit $id
6013 set info $commitinfo($id)
6014 set date [formatdate [lindex $info 2]]
6015 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6016 set date [formatdate [lindex $info 4]]
6017 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6018 if {[info exists idtags($id)]} {
6019 $ctext insert end [mc "Tags:"]
6020 foreach tag $idtags($id) {
6021 $ctext insert end " $tag"
6023 $ctext insert end "\n"
6026 set headers {}
6027 set olds $parents($curview,$id)
6028 if {[llength $olds] > 1} {
6029 set np 0
6030 foreach p $olds {
6031 if {$np >= $mergemax} {
6032 set tag mmax
6033 } else {
6034 set tag m$np
6036 $ctext insert end "[mc "Parent"]: " $tag
6037 appendwithlinks [commit_descriptor $p] {}
6038 incr np
6040 } else {
6041 foreach p $olds {
6042 append headers "[mc "Parent"]: [commit_descriptor $p]"
6046 foreach c $children($curview,$id) {
6047 append headers "[mc "Child"]: [commit_descriptor $c]"
6050 # make anything that looks like a SHA1 ID be a clickable link
6051 appendwithlinks $headers {}
6052 if {$showneartags} {
6053 if {![info exists allcommits]} {
6054 getallcommits
6056 $ctext insert end "[mc "Branch"]: "
6057 $ctext mark set branch "end -1c"
6058 $ctext mark gravity branch left
6059 $ctext insert end "\n[mc "Follows"]: "
6060 $ctext mark set follows "end -1c"
6061 $ctext mark gravity follows left
6062 $ctext insert end "\n[mc "Precedes"]: "
6063 $ctext mark set precedes "end -1c"
6064 $ctext mark gravity precedes left
6065 $ctext insert end "\n"
6066 dispneartags 1
6068 $ctext insert end "\n"
6069 set comment [lindex $info 5]
6070 if {[string first "\r" $comment] >= 0} {
6071 set comment [string map {"\r" "\n "} $comment]
6073 appendwithlinks $comment {comment}
6075 $ctext tag remove found 1.0 end
6076 $ctext conf -state disabled
6077 set commentend [$ctext index "end - 1c"]
6079 init_flist [mc "Comments"]
6080 if {$cmitmode eq "tree"} {
6081 gettree $id
6082 } elseif {[llength $olds] <= 1} {
6083 startdiff $id
6084 } else {
6085 mergediff $id
6089 proc selfirstline {} {
6090 unmarkmatches
6091 selectline 0 1
6094 proc sellastline {} {
6095 global numcommits
6096 unmarkmatches
6097 set l [expr {$numcommits - 1}]
6098 selectline $l 1
6101 proc selnextline {dir} {
6102 global selectedline
6103 focus .
6104 if {$selectedline eq {}} return
6105 set l [expr {$selectedline + $dir}]
6106 unmarkmatches
6107 selectline $l 1
6110 proc selnextpage {dir} {
6111 global canv linespc selectedline numcommits
6113 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6114 if {$lpp < 1} {
6115 set lpp 1
6117 allcanvs yview scroll [expr {$dir * $lpp}] units
6118 drawvisible
6119 if {$selectedline eq {}} return
6120 set l [expr {$selectedline + $dir * $lpp}]
6121 if {$l < 0} {
6122 set l 0
6123 } elseif {$l >= $numcommits} {
6124 set l [expr $numcommits - 1]
6126 unmarkmatches
6127 selectline $l 1
6130 proc unselectline {} {
6131 global selectedline currentid
6133 set selectedline {}
6134 catch {unset currentid}
6135 allcanvs delete secsel
6136 rhighlight_none
6139 proc reselectline {} {
6140 global selectedline
6142 if {$selectedline ne {}} {
6143 selectline $selectedline 0
6147 proc addtohistory {cmd} {
6148 global history historyindex curview
6150 set elt [list $curview $cmd]
6151 if {$historyindex > 0
6152 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6153 return
6156 if {$historyindex < [llength $history]} {
6157 set history [lreplace $history $historyindex end $elt]
6158 } else {
6159 lappend history $elt
6161 incr historyindex
6162 if {$historyindex > 1} {
6163 .tf.bar.leftbut conf -state normal
6164 } else {
6165 .tf.bar.leftbut conf -state disabled
6167 .tf.bar.rightbut conf -state disabled
6170 proc godo {elt} {
6171 global curview
6173 set view [lindex $elt 0]
6174 set cmd [lindex $elt 1]
6175 if {$curview != $view} {
6176 showview $view
6178 eval $cmd
6181 proc goback {} {
6182 global history historyindex
6183 focus .
6185 if {$historyindex > 1} {
6186 incr historyindex -1
6187 godo [lindex $history [expr {$historyindex - 1}]]
6188 .tf.bar.rightbut conf -state normal
6190 if {$historyindex <= 1} {
6191 .tf.bar.leftbut conf -state disabled
6195 proc goforw {} {
6196 global history historyindex
6197 focus .
6199 if {$historyindex < [llength $history]} {
6200 set cmd [lindex $history $historyindex]
6201 incr historyindex
6202 godo $cmd
6203 .tf.bar.leftbut conf -state normal
6205 if {$historyindex >= [llength $history]} {
6206 .tf.bar.rightbut conf -state disabled
6210 proc gettree {id} {
6211 global treefilelist treeidlist diffids diffmergeid treepending
6212 global nullid nullid2
6214 set diffids $id
6215 catch {unset diffmergeid}
6216 if {![info exists treefilelist($id)]} {
6217 if {![info exists treepending]} {
6218 if {$id eq $nullid} {
6219 set cmd [list | git ls-files]
6220 } elseif {$id eq $nullid2} {
6221 set cmd [list | git ls-files --stage -t]
6222 } else {
6223 set cmd [list | git ls-tree -r $id]
6225 if {[catch {set gtf [open $cmd r]}]} {
6226 return
6228 set treepending $id
6229 set treefilelist($id) {}
6230 set treeidlist($id) {}
6231 fconfigure $gtf -blocking 0
6232 filerun $gtf [list gettreeline $gtf $id]
6234 } else {
6235 setfilelist $id
6239 proc gettreeline {gtf id} {
6240 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6242 set nl 0
6243 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6244 if {$diffids eq $nullid} {
6245 set fname $line
6246 } else {
6247 set i [string first "\t" $line]
6248 if {$i < 0} continue
6249 set fname [string range $line [expr {$i+1}] end]
6250 set line [string range $line 0 [expr {$i-1}]]
6251 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6252 set sha1 [lindex $line 2]
6253 if {[string index $fname 0] eq "\""} {
6254 set fname [lindex $fname 0]
6256 lappend treeidlist($id) $sha1
6258 lappend treefilelist($id) $fname
6260 if {![eof $gtf]} {
6261 return [expr {$nl >= 1000? 2: 1}]
6263 close $gtf
6264 unset treepending
6265 if {$cmitmode ne "tree"} {
6266 if {![info exists diffmergeid]} {
6267 gettreediffs $diffids
6269 } elseif {$id ne $diffids} {
6270 gettree $diffids
6271 } else {
6272 setfilelist $id
6274 return 0
6277 proc showfile {f} {
6278 global treefilelist treeidlist diffids nullid nullid2
6279 global ctext commentend
6281 set i [lsearch -exact $treefilelist($diffids) $f]
6282 if {$i < 0} {
6283 puts "oops, $f not in list for id $diffids"
6284 return
6286 if {$diffids eq $nullid} {
6287 if {[catch {set bf [open $f r]} err]} {
6288 puts "oops, can't read $f: $err"
6289 return
6291 } else {
6292 set blob [lindex $treeidlist($diffids) $i]
6293 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6294 puts "oops, error reading blob $blob: $err"
6295 return
6298 fconfigure $bf -blocking 0
6299 filerun $bf [list getblobline $bf $diffids]
6300 $ctext config -state normal
6301 clear_ctext $commentend
6302 $ctext insert end "\n"
6303 $ctext insert end "$f\n" filesep
6304 $ctext config -state disabled
6305 $ctext yview $commentend
6306 settabs 0
6309 proc getblobline {bf id} {
6310 global diffids cmitmode ctext
6312 if {$id ne $diffids || $cmitmode ne "tree"} {
6313 catch {close $bf}
6314 return 0
6316 $ctext config -state normal
6317 set nl 0
6318 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6319 $ctext insert end "$line\n"
6321 if {[eof $bf]} {
6322 # delete last newline
6323 $ctext delete "end - 2c" "end - 1c"
6324 close $bf
6325 return 0
6327 $ctext config -state disabled
6328 return [expr {$nl >= 1000? 2: 1}]
6331 proc mergediff {id} {
6332 global diffmergeid mdifffd
6333 global diffids
6334 global parents
6335 global diffcontext
6336 global limitdiffs vfilelimit curview
6338 set diffmergeid $id
6339 set diffids $id
6340 # this doesn't seem to actually affect anything...
6341 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6342 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6343 set cmd [concat $cmd -- $vfilelimit($curview)]
6345 if {[catch {set mdf [open $cmd r]} err]} {
6346 error_popup "[mc "Error getting merge diffs:"] $err"
6347 return
6349 fconfigure $mdf -blocking 0
6350 set mdifffd($id) $mdf
6351 set np [llength $parents($curview,$id)]
6352 settabs $np
6353 filerun $mdf [list getmergediffline $mdf $id $np]
6356 proc getmergediffline {mdf id np} {
6357 global diffmergeid ctext cflist mergemax
6358 global difffilestart mdifffd
6360 $ctext conf -state normal
6361 set nr 0
6362 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6363 if {![info exists diffmergeid] || $id != $diffmergeid
6364 || $mdf != $mdifffd($id)} {
6365 close $mdf
6366 return 0
6368 if {[regexp {^diff --cc (.*)} $line match fname]} {
6369 # start of a new file
6370 $ctext insert end "\n"
6371 set here [$ctext index "end - 1c"]
6372 lappend difffilestart $here
6373 add_flist [list $fname]
6374 set l [expr {(78 - [string length $fname]) / 2}]
6375 set pad [string range "----------------------------------------" 1 $l]
6376 $ctext insert end "$pad $fname $pad\n" filesep
6377 } elseif {[regexp {^@@} $line]} {
6378 $ctext insert end "$line\n" hunksep
6379 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6380 # do nothing
6381 } else {
6382 # parse the prefix - one ' ', '-' or '+' for each parent
6383 set spaces {}
6384 set minuses {}
6385 set pluses {}
6386 set isbad 0
6387 for {set j 0} {$j < $np} {incr j} {
6388 set c [string range $line $j $j]
6389 if {$c == " "} {
6390 lappend spaces $j
6391 } elseif {$c == "-"} {
6392 lappend minuses $j
6393 } elseif {$c == "+"} {
6394 lappend pluses $j
6395 } else {
6396 set isbad 1
6397 break
6400 set tags {}
6401 set num {}
6402 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6403 # line doesn't appear in result, parents in $minuses have the line
6404 set num [lindex $minuses 0]
6405 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6406 # line appears in result, parents in $pluses don't have the line
6407 lappend tags mresult
6408 set num [lindex $spaces 0]
6410 if {$num ne {}} {
6411 if {$num >= $mergemax} {
6412 set num "max"
6414 lappend tags m$num
6416 $ctext insert end "$line\n" $tags
6419 $ctext conf -state disabled
6420 if {[eof $mdf]} {
6421 close $mdf
6422 return 0
6424 return [expr {$nr >= 1000? 2: 1}]
6427 proc startdiff {ids} {
6428 global treediffs diffids treepending diffmergeid nullid nullid2
6430 settabs 1
6431 set diffids $ids
6432 catch {unset diffmergeid}
6433 if {![info exists treediffs($ids)] ||
6434 [lsearch -exact $ids $nullid] >= 0 ||
6435 [lsearch -exact $ids $nullid2] >= 0} {
6436 if {![info exists treepending]} {
6437 gettreediffs $ids
6439 } else {
6440 addtocflist $ids
6444 proc path_filter {filter name} {
6445 foreach p $filter {
6446 set l [string length $p]
6447 if {[string index $p end] eq "/"} {
6448 if {[string compare -length $l $p $name] == 0} {
6449 return 1
6451 } else {
6452 if {[string compare -length $l $p $name] == 0 &&
6453 ([string length $name] == $l ||
6454 [string index $name $l] eq "/")} {
6455 return 1
6459 return 0
6462 proc addtocflist {ids} {
6463 global treediffs
6465 add_flist $treediffs($ids)
6466 getblobdiffs $ids
6469 proc diffcmd {ids flags} {
6470 global nullid nullid2
6472 set i [lsearch -exact $ids $nullid]
6473 set j [lsearch -exact $ids $nullid2]
6474 if {$i >= 0} {
6475 if {[llength $ids] > 1 && $j < 0} {
6476 # comparing working directory with some specific revision
6477 set cmd [concat | git diff-index $flags]
6478 if {$i == 0} {
6479 lappend cmd -R [lindex $ids 1]
6480 } else {
6481 lappend cmd [lindex $ids 0]
6483 } else {
6484 # comparing working directory with index
6485 set cmd [concat | git diff-files $flags]
6486 if {$j == 1} {
6487 lappend cmd -R
6490 } elseif {$j >= 0} {
6491 set cmd [concat | git diff-index --cached $flags]
6492 if {[llength $ids] > 1} {
6493 # comparing index with specific revision
6494 if {$i == 0} {
6495 lappend cmd -R [lindex $ids 1]
6496 } else {
6497 lappend cmd [lindex $ids 0]
6499 } else {
6500 # comparing index with HEAD
6501 lappend cmd HEAD
6503 } else {
6504 set cmd [concat | git diff-tree -r $flags $ids]
6506 return $cmd
6509 proc gettreediffs {ids} {
6510 global treediff treepending
6512 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6514 set treepending $ids
6515 set treediff {}
6516 fconfigure $gdtf -blocking 0
6517 filerun $gdtf [list gettreediffline $gdtf $ids]
6520 proc gettreediffline {gdtf ids} {
6521 global treediff treediffs treepending diffids diffmergeid
6522 global cmitmode vfilelimit curview limitdiffs
6524 set nr 0
6525 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6526 set i [string first "\t" $line]
6527 if {$i >= 0} {
6528 set file [string range $line [expr {$i+1}] end]
6529 if {[string index $file 0] eq "\""} {
6530 set file [lindex $file 0]
6532 lappend treediff $file
6535 if {![eof $gdtf]} {
6536 return [expr {$nr >= 1000? 2: 1}]
6538 close $gdtf
6539 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6540 set flist {}
6541 foreach f $treediff {
6542 if {[path_filter $vfilelimit($curview) $f]} {
6543 lappend flist $f
6546 set treediffs($ids) $flist
6547 } else {
6548 set treediffs($ids) $treediff
6550 unset treepending
6551 if {$cmitmode eq "tree"} {
6552 gettree $diffids
6553 } elseif {$ids != $diffids} {
6554 if {![info exists diffmergeid]} {
6555 gettreediffs $diffids
6557 } else {
6558 addtocflist $ids
6560 return 0
6563 # empty string or positive integer
6564 proc diffcontextvalidate {v} {
6565 return [regexp {^(|[1-9][0-9]*)$} $v]
6568 proc diffcontextchange {n1 n2 op} {
6569 global diffcontextstring diffcontext
6571 if {[string is integer -strict $diffcontextstring]} {
6572 if {$diffcontextstring > 0} {
6573 set diffcontext $diffcontextstring
6574 reselectline
6579 proc changeignorespace {} {
6580 reselectline
6583 proc getblobdiffs {ids} {
6584 global blobdifffd diffids env
6585 global diffinhdr treediffs
6586 global diffcontext
6587 global ignorespace
6588 global limitdiffs vfilelimit curview
6590 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6591 if {$ignorespace} {
6592 append cmd " -w"
6594 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6595 set cmd [concat $cmd -- $vfilelimit($curview)]
6597 if {[catch {set bdf [open $cmd r]} err]} {
6598 puts "error getting diffs: $err"
6599 return
6601 set diffinhdr 0
6602 fconfigure $bdf -blocking 0
6603 set blobdifffd($ids) $bdf
6604 filerun $bdf [list getblobdiffline $bdf $diffids]
6607 proc setinlist {var i val} {
6608 global $var
6610 while {[llength [set $var]] < $i} {
6611 lappend $var {}
6613 if {[llength [set $var]] == $i} {
6614 lappend $var $val
6615 } else {
6616 lset $var $i $val
6620 proc makediffhdr {fname ids} {
6621 global ctext curdiffstart treediffs
6623 set i [lsearch -exact $treediffs($ids) $fname]
6624 if {$i >= 0} {
6625 setinlist difffilestart $i $curdiffstart
6627 set l [expr {(78 - [string length $fname]) / 2}]
6628 set pad [string range "----------------------------------------" 1 $l]
6629 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6632 proc getblobdiffline {bdf ids} {
6633 global diffids blobdifffd ctext curdiffstart
6634 global diffnexthead diffnextnote difffilestart
6635 global diffinhdr treediffs
6637 set nr 0
6638 $ctext conf -state normal
6639 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6640 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6641 close $bdf
6642 return 0
6644 if {![string compare -length 11 "diff --git " $line]} {
6645 # trim off "diff --git "
6646 set line [string range $line 11 end]
6647 set diffinhdr 1
6648 # start of a new file
6649 $ctext insert end "\n"
6650 set curdiffstart [$ctext index "end - 1c"]
6651 $ctext insert end "\n" filesep
6652 # If the name hasn't changed the length will be odd,
6653 # the middle char will be a space, and the two bits either
6654 # side will be a/name and b/name, or "a/name" and "b/name".
6655 # If the name has changed we'll get "rename from" and
6656 # "rename to" or "copy from" and "copy to" lines following this,
6657 # and we'll use them to get the filenames.
6658 # This complexity is necessary because spaces in the filename(s)
6659 # don't get escaped.
6660 set l [string length $line]
6661 set i [expr {$l / 2}]
6662 if {!(($l & 1) && [string index $line $i] eq " " &&
6663 [string range $line 2 [expr {$i - 1}]] eq \
6664 [string range $line [expr {$i + 3}] end])} {
6665 continue
6667 # unescape if quoted and chop off the a/ from the front
6668 if {[string index $line 0] eq "\""} {
6669 set fname [string range [lindex $line 0] 2 end]
6670 } else {
6671 set fname [string range $line 2 [expr {$i - 1}]]
6673 makediffhdr $fname $ids
6675 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6676 $line match f1l f1c f2l f2c rest]} {
6677 $ctext insert end "$line\n" hunksep
6678 set diffinhdr 0
6680 } elseif {$diffinhdr} {
6681 if {![string compare -length 12 "rename from " $line]} {
6682 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6683 if {[string index $fname 0] eq "\""} {
6684 set fname [lindex $fname 0]
6686 set i [lsearch -exact $treediffs($ids) $fname]
6687 if {$i >= 0} {
6688 setinlist difffilestart $i $curdiffstart
6690 } elseif {![string compare -length 10 $line "rename to "] ||
6691 ![string compare -length 8 $line "copy to "]} {
6692 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6693 if {[string index $fname 0] eq "\""} {
6694 set fname [lindex $fname 0]
6696 makediffhdr $fname $ids
6697 } elseif {[string compare -length 3 $line "---"] == 0} {
6698 # do nothing
6699 continue
6700 } elseif {[string compare -length 3 $line "+++"] == 0} {
6701 set diffinhdr 0
6702 continue
6704 $ctext insert end "$line\n" filesep
6706 } else {
6707 set x [string range $line 0 0]
6708 if {$x == "-" || $x == "+"} {
6709 set tag [expr {$x == "+"}]
6710 $ctext insert end "$line\n" d$tag
6711 } elseif {$x == " "} {
6712 $ctext insert end "$line\n"
6713 } else {
6714 # "\ No newline at end of file",
6715 # or something else we don't recognize
6716 $ctext insert end "$line\n" hunksep
6720 $ctext conf -state disabled
6721 if {[eof $bdf]} {
6722 close $bdf
6723 return 0
6725 return [expr {$nr >= 1000? 2: 1}]
6728 proc changediffdisp {} {
6729 global ctext diffelide
6731 $ctext tag conf d0 -elide [lindex $diffelide 0]
6732 $ctext tag conf d1 -elide [lindex $diffelide 1]
6735 proc highlightfile {loc cline} {
6736 global ctext cflist cflist_top
6738 $ctext yview $loc
6739 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6740 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6741 $cflist see $cline.0
6742 set cflist_top $cline
6745 proc prevfile {} {
6746 global difffilestart ctext cmitmode
6748 if {$cmitmode eq "tree"} return
6749 set prev 0.0
6750 set prevline 1
6751 set here [$ctext index @0,0]
6752 foreach loc $difffilestart {
6753 if {[$ctext compare $loc >= $here]} {
6754 highlightfile $prev $prevline
6755 return
6757 set prev $loc
6758 incr prevline
6760 highlightfile $prev $prevline
6763 proc nextfile {} {
6764 global difffilestart ctext cmitmode
6766 if {$cmitmode eq "tree"} return
6767 set here [$ctext index @0,0]
6768 set line 1
6769 foreach loc $difffilestart {
6770 incr line
6771 if {[$ctext compare $loc > $here]} {
6772 highlightfile $loc $line
6773 return
6778 proc clear_ctext {{first 1.0}} {
6779 global ctext smarktop smarkbot
6780 global pendinglinks
6782 set l [lindex [split $first .] 0]
6783 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6784 set smarktop $l
6786 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6787 set smarkbot $l
6789 $ctext delete $first end
6790 if {$first eq "1.0"} {
6791 catch {unset pendinglinks}
6795 proc settabs {{firstab {}}} {
6796 global firsttabstop tabstop ctext have_tk85
6798 if {$firstab ne {} && $have_tk85} {
6799 set firsttabstop $firstab
6801 set w [font measure textfont "0"]
6802 if {$firsttabstop != 0} {
6803 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6804 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6805 } elseif {$have_tk85 || $tabstop != 8} {
6806 $ctext conf -tabs [expr {$tabstop * $w}]
6807 } else {
6808 $ctext conf -tabs {}
6812 proc incrsearch {name ix op} {
6813 global ctext searchstring searchdirn
6815 $ctext tag remove found 1.0 end
6816 if {[catch {$ctext index anchor}]} {
6817 # no anchor set, use start of selection, or of visible area
6818 set sel [$ctext tag ranges sel]
6819 if {$sel ne {}} {
6820 $ctext mark set anchor [lindex $sel 0]
6821 } elseif {$searchdirn eq "-forwards"} {
6822 $ctext mark set anchor @0,0
6823 } else {
6824 $ctext mark set anchor @0,[winfo height $ctext]
6827 if {$searchstring ne {}} {
6828 set here [$ctext search $searchdirn -- $searchstring anchor]
6829 if {$here ne {}} {
6830 $ctext see $here
6832 searchmarkvisible 1
6836 proc dosearch {} {
6837 global sstring ctext searchstring searchdirn
6839 focus $sstring
6840 $sstring icursor end
6841 set searchdirn -forwards
6842 if {$searchstring ne {}} {
6843 set sel [$ctext tag ranges sel]
6844 if {$sel ne {}} {
6845 set start "[lindex $sel 0] + 1c"
6846 } elseif {[catch {set start [$ctext index anchor]}]} {
6847 set start "@0,0"
6849 set match [$ctext search -count mlen -- $searchstring $start]
6850 $ctext tag remove sel 1.0 end
6851 if {$match eq {}} {
6852 bell
6853 return
6855 $ctext see $match
6856 set mend "$match + $mlen c"
6857 $ctext tag add sel $match $mend
6858 $ctext mark unset anchor
6862 proc dosearchback {} {
6863 global sstring ctext searchstring searchdirn
6865 focus $sstring
6866 $sstring icursor end
6867 set searchdirn -backwards
6868 if {$searchstring ne {}} {
6869 set sel [$ctext tag ranges sel]
6870 if {$sel ne {}} {
6871 set start [lindex $sel 0]
6872 } elseif {[catch {set start [$ctext index anchor]}]} {
6873 set start @0,[winfo height $ctext]
6875 set match [$ctext search -backwards -count ml -- $searchstring $start]
6876 $ctext tag remove sel 1.0 end
6877 if {$match eq {}} {
6878 bell
6879 return
6881 $ctext see $match
6882 set mend "$match + $ml c"
6883 $ctext tag add sel $match $mend
6884 $ctext mark unset anchor
6888 proc searchmark {first last} {
6889 global ctext searchstring
6891 set mend $first.0
6892 while {1} {
6893 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6894 if {$match eq {}} break
6895 set mend "$match + $mlen c"
6896 $ctext tag add found $match $mend
6900 proc searchmarkvisible {doall} {
6901 global ctext smarktop smarkbot
6903 set topline [lindex [split [$ctext index @0,0] .] 0]
6904 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6905 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6906 # no overlap with previous
6907 searchmark $topline $botline
6908 set smarktop $topline
6909 set smarkbot $botline
6910 } else {
6911 if {$topline < $smarktop} {
6912 searchmark $topline [expr {$smarktop-1}]
6913 set smarktop $topline
6915 if {$botline > $smarkbot} {
6916 searchmark [expr {$smarkbot+1}] $botline
6917 set smarkbot $botline
6922 proc scrolltext {f0 f1} {
6923 global searchstring
6925 .bleft.bottom.sb set $f0 $f1
6926 if {$searchstring ne {}} {
6927 searchmarkvisible 0
6931 proc setcoords {} {
6932 global linespc charspc canvx0 canvy0
6933 global xspc1 xspc2 lthickness
6935 set linespc [font metrics mainfont -linespace]
6936 set charspc [font measure mainfont "m"]
6937 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6938 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6939 set lthickness [expr {int($linespc / 9) + 1}]
6940 set xspc1(0) $linespc
6941 set xspc2 $linespc
6944 proc redisplay {} {
6945 global canv
6946 global selectedline
6948 set ymax [lindex [$canv cget -scrollregion] 3]
6949 if {$ymax eq {} || $ymax == 0} return
6950 set span [$canv yview]
6951 clear_display
6952 setcanvscroll
6953 allcanvs yview moveto [lindex $span 0]
6954 drawvisible
6955 if {$selectedline ne {}} {
6956 selectline $selectedline 0
6957 allcanvs yview moveto [lindex $span 0]
6961 proc parsefont {f n} {
6962 global fontattr
6964 set fontattr($f,family) [lindex $n 0]
6965 set s [lindex $n 1]
6966 if {$s eq {} || $s == 0} {
6967 set s 10
6968 } elseif {$s < 0} {
6969 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6971 set fontattr($f,size) $s
6972 set fontattr($f,weight) normal
6973 set fontattr($f,slant) roman
6974 foreach style [lrange $n 2 end] {
6975 switch -- $style {
6976 "normal" -
6977 "bold" {set fontattr($f,weight) $style}
6978 "roman" -
6979 "italic" {set fontattr($f,slant) $style}
6984 proc fontflags {f {isbold 0}} {
6985 global fontattr
6987 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6988 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6989 -slant $fontattr($f,slant)]
6992 proc fontname {f} {
6993 global fontattr
6995 set n [list $fontattr($f,family) $fontattr($f,size)]
6996 if {$fontattr($f,weight) eq "bold"} {
6997 lappend n "bold"
6999 if {$fontattr($f,slant) eq "italic"} {
7000 lappend n "italic"
7002 return $n
7005 proc incrfont {inc} {
7006 global mainfont textfont ctext canv cflist showrefstop
7007 global stopped entries fontattr
7009 unmarkmatches
7010 set s $fontattr(mainfont,size)
7011 incr s $inc
7012 if {$s < 1} {
7013 set s 1
7015 set fontattr(mainfont,size) $s
7016 font config mainfont -size $s
7017 font config mainfontbold -size $s
7018 set mainfont [fontname mainfont]
7019 set s $fontattr(textfont,size)
7020 incr s $inc
7021 if {$s < 1} {
7022 set s 1
7024 set fontattr(textfont,size) $s
7025 font config textfont -size $s
7026 font config textfontbold -size $s
7027 set textfont [fontname textfont]
7028 setcoords
7029 settabs
7030 redisplay
7033 proc clearsha1 {} {
7034 global sha1entry sha1string
7035 if {[string length $sha1string] == 40} {
7036 $sha1entry delete 0 end
7040 proc sha1change {n1 n2 op} {
7041 global sha1string currentid sha1but
7042 if {$sha1string == {}
7043 || ([info exists currentid] && $sha1string == $currentid)} {
7044 set state disabled
7045 } else {
7046 set state normal
7048 if {[$sha1but cget -state] == $state} return
7049 if {$state == "normal"} {
7050 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7051 } else {
7052 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7056 proc gotocommit {} {
7057 global sha1string tagids headids curview varcid
7059 if {$sha1string == {}
7060 || ([info exists currentid] && $sha1string == $currentid)} return
7061 if {[info exists tagids($sha1string)]} {
7062 set id $tagids($sha1string)
7063 } elseif {[info exists headids($sha1string)]} {
7064 set id $headids($sha1string)
7065 } else {
7066 set id [string tolower $sha1string]
7067 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7068 set matches [array names varcid "$curview,$id*"]
7069 if {$matches ne {}} {
7070 if {[llength $matches] > 1} {
7071 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7072 return
7074 set id [lindex [split [lindex $matches 0] ","] 1]
7078 if {[commitinview $id $curview]} {
7079 selectline [rowofcommit $id] 1
7080 return
7082 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7083 set msg [mc "SHA1 id %s is not known" $sha1string]
7084 } else {
7085 set msg [mc "Tag/Head %s is not known" $sha1string]
7087 error_popup $msg
7090 proc lineenter {x y id} {
7091 global hoverx hovery hoverid hovertimer
7092 global commitinfo canv
7094 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7095 set hoverx $x
7096 set hovery $y
7097 set hoverid $id
7098 if {[info exists hovertimer]} {
7099 after cancel $hovertimer
7101 set hovertimer [after 500 linehover]
7102 $canv delete hover
7105 proc linemotion {x y id} {
7106 global hoverx hovery hoverid hovertimer
7108 if {[info exists hoverid] && $id == $hoverid} {
7109 set hoverx $x
7110 set hovery $y
7111 if {[info exists hovertimer]} {
7112 after cancel $hovertimer
7114 set hovertimer [after 500 linehover]
7118 proc lineleave {id} {
7119 global hoverid hovertimer canv
7121 if {[info exists hoverid] && $id == $hoverid} {
7122 $canv delete hover
7123 if {[info exists hovertimer]} {
7124 after cancel $hovertimer
7125 unset hovertimer
7127 unset hoverid
7131 proc linehover {} {
7132 global hoverx hovery hoverid hovertimer
7133 global canv linespc lthickness
7134 global commitinfo
7136 set text [lindex $commitinfo($hoverid) 0]
7137 set ymax [lindex [$canv cget -scrollregion] 3]
7138 if {$ymax == {}} return
7139 set yfrac [lindex [$canv yview] 0]
7140 set x [expr {$hoverx + 2 * $linespc}]
7141 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7142 set x0 [expr {$x - 2 * $lthickness}]
7143 set y0 [expr {$y - 2 * $lthickness}]
7144 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7145 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7146 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7147 -fill \#ffff80 -outline black -width 1 -tags hover]
7148 $canv raise $t
7149 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7150 -font mainfont]
7151 $canv raise $t
7154 proc clickisonarrow {id y} {
7155 global lthickness
7157 set ranges [rowranges $id]
7158 set thresh [expr {2 * $lthickness + 6}]
7159 set n [expr {[llength $ranges] - 1}]
7160 for {set i 1} {$i < $n} {incr i} {
7161 set row [lindex $ranges $i]
7162 if {abs([yc $row] - $y) < $thresh} {
7163 return $i
7166 return {}
7169 proc arrowjump {id n y} {
7170 global canv
7172 # 1 <-> 2, 3 <-> 4, etc...
7173 set n [expr {(($n - 1) ^ 1) + 1}]
7174 set row [lindex [rowranges $id] $n]
7175 set yt [yc $row]
7176 set ymax [lindex [$canv cget -scrollregion] 3]
7177 if {$ymax eq {} || $ymax <= 0} return
7178 set view [$canv yview]
7179 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7180 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7181 if {$yfrac < 0} {
7182 set yfrac 0
7184 allcanvs yview moveto $yfrac
7187 proc lineclick {x y id isnew} {
7188 global ctext commitinfo children canv thickerline curview
7190 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7191 unmarkmatches
7192 unselectline
7193 normalline
7194 $canv delete hover
7195 # draw this line thicker than normal
7196 set thickerline $id
7197 drawlines $id
7198 if {$isnew} {
7199 set ymax [lindex [$canv cget -scrollregion] 3]
7200 if {$ymax eq {}} return
7201 set yfrac [lindex [$canv yview] 0]
7202 set y [expr {$y + $yfrac * $ymax}]
7204 set dirn [clickisonarrow $id $y]
7205 if {$dirn ne {}} {
7206 arrowjump $id $dirn $y
7207 return
7210 if {$isnew} {
7211 addtohistory [list lineclick $x $y $id 0]
7213 # fill the details pane with info about this line
7214 $ctext conf -state normal
7215 clear_ctext
7216 settabs 0
7217 $ctext insert end "[mc "Parent"]:\t"
7218 $ctext insert end $id link0
7219 setlink $id link0
7220 set info $commitinfo($id)
7221 $ctext insert end "\n\t[lindex $info 0]\n"
7222 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7223 set date [formatdate [lindex $info 2]]
7224 $ctext insert end "\t[mc "Date"]:\t$date\n"
7225 set kids $children($curview,$id)
7226 if {$kids ne {}} {
7227 $ctext insert end "\n[mc "Children"]:"
7228 set i 0
7229 foreach child $kids {
7230 incr i
7231 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7232 set info $commitinfo($child)
7233 $ctext insert end "\n\t"
7234 $ctext insert end $child link$i
7235 setlink $child link$i
7236 $ctext insert end "\n\t[lindex $info 0]"
7237 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7238 set date [formatdate [lindex $info 2]]
7239 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7242 $ctext conf -state disabled
7243 init_flist {}
7246 proc normalline {} {
7247 global thickerline
7248 if {[info exists thickerline]} {
7249 set id $thickerline
7250 unset thickerline
7251 drawlines $id
7255 proc selbyid {id} {
7256 global curview
7257 if {[commitinview $id $curview]} {
7258 selectline [rowofcommit $id] 1
7262 proc mstime {} {
7263 global startmstime
7264 if {![info exists startmstime]} {
7265 set startmstime [clock clicks -milliseconds]
7267 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7270 proc rowmenu {x y id} {
7271 global rowctxmenu selectedline rowmenuid curview
7272 global nullid nullid2 fakerowmenu mainhead
7274 stopfinding
7275 set rowmenuid $id
7276 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7277 set state disabled
7278 } else {
7279 set state normal
7281 if {$id ne $nullid && $id ne $nullid2} {
7282 set menu $rowctxmenu
7283 if {$mainhead ne {}} {
7284 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7285 } else {
7286 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7288 } else {
7289 set menu $fakerowmenu
7291 $menu entryconfigure [mc "Diff this -> selected"] -state $state
7292 $menu entryconfigure [mc "Diff selected -> this"] -state $state
7293 $menu entryconfigure [mc "Make patch"] -state $state
7294 tk_popup $menu $x $y
7297 proc diffvssel {dirn} {
7298 global rowmenuid selectedline
7300 if {$selectedline eq {}} return
7301 if {$dirn} {
7302 set oldid [commitonrow $selectedline]
7303 set newid $rowmenuid
7304 } else {
7305 set oldid $rowmenuid
7306 set newid [commitonrow $selectedline]
7308 addtohistory [list doseldiff $oldid $newid]
7309 doseldiff $oldid $newid
7312 proc doseldiff {oldid newid} {
7313 global ctext
7314 global commitinfo
7316 $ctext conf -state normal
7317 clear_ctext
7318 init_flist [mc "Top"]
7319 $ctext insert end "[mc "From"] "
7320 $ctext insert end $oldid link0
7321 setlink $oldid link0
7322 $ctext insert end "\n "
7323 $ctext insert end [lindex $commitinfo($oldid) 0]
7324 $ctext insert end "\n\n[mc "To"] "
7325 $ctext insert end $newid link1
7326 setlink $newid link1
7327 $ctext insert end "\n "
7328 $ctext insert end [lindex $commitinfo($newid) 0]
7329 $ctext insert end "\n"
7330 $ctext conf -state disabled
7331 $ctext tag remove found 1.0 end
7332 startdiff [list $oldid $newid]
7335 proc mkpatch {} {
7336 global rowmenuid currentid commitinfo patchtop patchnum
7338 if {![info exists currentid]} return
7339 set oldid $currentid
7340 set oldhead [lindex $commitinfo($oldid) 0]
7341 set newid $rowmenuid
7342 set newhead [lindex $commitinfo($newid) 0]
7343 set top .patch
7344 set patchtop $top
7345 catch {destroy $top}
7346 toplevel $top
7347 label $top.title -text [mc "Generate patch"]
7348 grid $top.title - -pady 10
7349 label $top.from -text [mc "From:"]
7350 entry $top.fromsha1 -width 40 -relief flat
7351 $top.fromsha1 insert 0 $oldid
7352 $top.fromsha1 conf -state readonly
7353 grid $top.from $top.fromsha1 -sticky w
7354 entry $top.fromhead -width 60 -relief flat
7355 $top.fromhead insert 0 $oldhead
7356 $top.fromhead conf -state readonly
7357 grid x $top.fromhead -sticky w
7358 label $top.to -text [mc "To:"]
7359 entry $top.tosha1 -width 40 -relief flat
7360 $top.tosha1 insert 0 $newid
7361 $top.tosha1 conf -state readonly
7362 grid $top.to $top.tosha1 -sticky w
7363 entry $top.tohead -width 60 -relief flat
7364 $top.tohead insert 0 $newhead
7365 $top.tohead conf -state readonly
7366 grid x $top.tohead -sticky w
7367 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7368 grid $top.rev x -pady 10
7369 label $top.flab -text [mc "Output file:"]
7370 entry $top.fname -width 60
7371 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7372 incr patchnum
7373 grid $top.flab $top.fname -sticky w
7374 frame $top.buts
7375 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7376 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7377 grid $top.buts.gen $top.buts.can
7378 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7379 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7380 grid $top.buts - -pady 10 -sticky ew
7381 focus $top.fname
7384 proc mkpatchrev {} {
7385 global patchtop
7387 set oldid [$patchtop.fromsha1 get]
7388 set oldhead [$patchtop.fromhead get]
7389 set newid [$patchtop.tosha1 get]
7390 set newhead [$patchtop.tohead get]
7391 foreach e [list fromsha1 fromhead tosha1 tohead] \
7392 v [list $newid $newhead $oldid $oldhead] {
7393 $patchtop.$e conf -state normal
7394 $patchtop.$e delete 0 end
7395 $patchtop.$e insert 0 $v
7396 $patchtop.$e conf -state readonly
7400 proc mkpatchgo {} {
7401 global patchtop nullid nullid2
7403 set oldid [$patchtop.fromsha1 get]
7404 set newid [$patchtop.tosha1 get]
7405 set fname [$patchtop.fname get]
7406 set cmd [diffcmd [list $oldid $newid] -p]
7407 # trim off the initial "|"
7408 set cmd [lrange $cmd 1 end]
7409 lappend cmd >$fname &
7410 if {[catch {eval exec $cmd} err]} {
7411 error_popup "[mc "Error creating patch:"] $err"
7413 catch {destroy $patchtop}
7414 unset patchtop
7417 proc mkpatchcan {} {
7418 global patchtop
7420 catch {destroy $patchtop}
7421 unset patchtop
7424 proc mktag {} {
7425 global rowmenuid mktagtop commitinfo
7427 set top .maketag
7428 set mktagtop $top
7429 catch {destroy $top}
7430 toplevel $top
7431 label $top.title -text [mc "Create tag"]
7432 grid $top.title - -pady 10
7433 label $top.id -text [mc "ID:"]
7434 entry $top.sha1 -width 40 -relief flat
7435 $top.sha1 insert 0 $rowmenuid
7436 $top.sha1 conf -state readonly
7437 grid $top.id $top.sha1 -sticky w
7438 entry $top.head -width 60 -relief flat
7439 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7440 $top.head conf -state readonly
7441 grid x $top.head -sticky w
7442 label $top.tlab -text [mc "Tag name:"]
7443 entry $top.tag -width 60
7444 grid $top.tlab $top.tag -sticky w
7445 frame $top.buts
7446 button $top.buts.gen -text [mc "Create"] -command mktaggo
7447 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7448 grid $top.buts.gen $top.buts.can
7449 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7450 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7451 grid $top.buts - -pady 10 -sticky ew
7452 focus $top.tag
7455 proc domktag {} {
7456 global mktagtop env tagids idtags
7458 set id [$mktagtop.sha1 get]
7459 set tag [$mktagtop.tag get]
7460 if {$tag == {}} {
7461 error_popup [mc "No tag name specified"]
7462 return
7464 if {[info exists tagids($tag)]} {
7465 error_popup [mc "Tag \"%s\" already exists" $tag]
7466 return
7468 if {[catch {
7469 exec git tag $tag $id
7470 } err]} {
7471 error_popup "[mc "Error creating tag:"] $err"
7472 return
7475 set tagids($tag) $id
7476 lappend idtags($id) $tag
7477 redrawtags $id
7478 addedtag $id
7479 dispneartags 0
7480 run refill_reflist
7483 proc redrawtags {id} {
7484 global canv linehtag idpos currentid curview cmitlisted
7485 global canvxmax iddrawn circleitem mainheadid circlecolors
7487 if {![commitinview $id $curview]} return
7488 if {![info exists iddrawn($id)]} return
7489 set row [rowofcommit $id]
7490 if {$id eq $mainheadid} {
7491 set ofill yellow
7492 } else {
7493 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7495 $canv itemconf $circleitem($row) -fill $ofill
7496 $canv delete tag.$id
7497 set xt [eval drawtags $id $idpos($id)]
7498 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7499 set text [$canv itemcget $linehtag($row) -text]
7500 set font [$canv itemcget $linehtag($row) -font]
7501 set xr [expr {$xt + [font measure $font $text]}]
7502 if {$xr > $canvxmax} {
7503 set canvxmax $xr
7504 setcanvscroll
7506 if {[info exists currentid] && $currentid == $id} {
7507 make_secsel $row
7511 proc mktagcan {} {
7512 global mktagtop
7514 catch {destroy $mktagtop}
7515 unset mktagtop
7518 proc mktaggo {} {
7519 domktag
7520 mktagcan
7523 proc writecommit {} {
7524 global rowmenuid wrcomtop commitinfo wrcomcmd
7526 set top .writecommit
7527 set wrcomtop $top
7528 catch {destroy $top}
7529 toplevel $top
7530 label $top.title -text [mc "Write commit to file"]
7531 grid $top.title - -pady 10
7532 label $top.id -text [mc "ID:"]
7533 entry $top.sha1 -width 40 -relief flat
7534 $top.sha1 insert 0 $rowmenuid
7535 $top.sha1 conf -state readonly
7536 grid $top.id $top.sha1 -sticky w
7537 entry $top.head -width 60 -relief flat
7538 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7539 $top.head conf -state readonly
7540 grid x $top.head -sticky w
7541 label $top.clab -text [mc "Command:"]
7542 entry $top.cmd -width 60 -textvariable wrcomcmd
7543 grid $top.clab $top.cmd -sticky w -pady 10
7544 label $top.flab -text [mc "Output file:"]
7545 entry $top.fname -width 60
7546 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7547 grid $top.flab $top.fname -sticky w
7548 frame $top.buts
7549 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7550 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7551 grid $top.buts.gen $top.buts.can
7552 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7553 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7554 grid $top.buts - -pady 10 -sticky ew
7555 focus $top.fname
7558 proc wrcomgo {} {
7559 global wrcomtop
7561 set id [$wrcomtop.sha1 get]
7562 set cmd "echo $id | [$wrcomtop.cmd get]"
7563 set fname [$wrcomtop.fname get]
7564 if {[catch {exec sh -c $cmd >$fname &} err]} {
7565 error_popup "[mc "Error writing commit:"] $err"
7567 catch {destroy $wrcomtop}
7568 unset wrcomtop
7571 proc wrcomcan {} {
7572 global wrcomtop
7574 catch {destroy $wrcomtop}
7575 unset wrcomtop
7578 proc mkbranch {} {
7579 global rowmenuid mkbrtop
7581 set top .makebranch
7582 catch {destroy $top}
7583 toplevel $top
7584 label $top.title -text [mc "Create new branch"]
7585 grid $top.title - -pady 10
7586 label $top.id -text [mc "ID:"]
7587 entry $top.sha1 -width 40 -relief flat
7588 $top.sha1 insert 0 $rowmenuid
7589 $top.sha1 conf -state readonly
7590 grid $top.id $top.sha1 -sticky w
7591 label $top.nlab -text [mc "Name:"]
7592 entry $top.name -width 40
7593 grid $top.nlab $top.name -sticky w
7594 frame $top.buts
7595 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7596 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7597 grid $top.buts.go $top.buts.can
7598 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7599 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7600 grid $top.buts - -pady 10 -sticky ew
7601 focus $top.name
7604 proc mkbrgo {top} {
7605 global headids idheads
7607 set name [$top.name get]
7608 set id [$top.sha1 get]
7609 if {$name eq {}} {
7610 error_popup [mc "Please specify a name for the new branch"]
7611 return
7613 catch {destroy $top}
7614 nowbusy newbranch
7615 update
7616 if {[catch {
7617 exec git branch $name $id
7618 } err]} {
7619 notbusy newbranch
7620 error_popup $err
7621 } else {
7622 set headids($name) $id
7623 lappend idheads($id) $name
7624 addedhead $id $name
7625 notbusy newbranch
7626 redrawtags $id
7627 dispneartags 0
7628 run refill_reflist
7632 proc cherrypick {} {
7633 global rowmenuid curview
7634 global mainhead mainheadid
7636 set oldhead [exec git rev-parse HEAD]
7637 set dheads [descheads $rowmenuid]
7638 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7639 set ok [confirm_popup [mc "Commit %s is already\
7640 included in branch %s -- really re-apply it?" \
7641 [string range $rowmenuid 0 7] $mainhead]]
7642 if {!$ok} return
7644 nowbusy cherrypick [mc "Cherry-picking"]
7645 update
7646 # Unfortunately git-cherry-pick writes stuff to stderr even when
7647 # no error occurs, and exec takes that as an indication of error...
7648 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7649 notbusy cherrypick
7650 error_popup $err
7651 return
7653 set newhead [exec git rev-parse HEAD]
7654 if {$newhead eq $oldhead} {
7655 notbusy cherrypick
7656 error_popup [mc "No changes committed"]
7657 return
7659 addnewchild $newhead $oldhead
7660 if {[commitinview $oldhead $curview]} {
7661 insertrow $newhead $oldhead $curview
7662 if {$mainhead ne {}} {
7663 movehead $newhead $mainhead
7664 movedhead $newhead $mainhead
7666 set mainheadid $newhead
7667 redrawtags $oldhead
7668 redrawtags $newhead
7669 selbyid $newhead
7671 notbusy cherrypick
7674 proc resethead {} {
7675 global mainhead rowmenuid confirm_ok resettype
7677 set confirm_ok 0
7678 set w ".confirmreset"
7679 toplevel $w
7680 wm transient $w .
7681 wm title $w [mc "Confirm reset"]
7682 message $w.m -text \
7683 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7684 -justify center -aspect 1000
7685 pack $w.m -side top -fill x -padx 20 -pady 20
7686 frame $w.f -relief sunken -border 2
7687 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7688 grid $w.f.rt -sticky w
7689 set resettype mixed
7690 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7691 -text [mc "Soft: Leave working tree and index untouched"]
7692 grid $w.f.soft -sticky w
7693 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7694 -text [mc "Mixed: Leave working tree untouched, reset index"]
7695 grid $w.f.mixed -sticky w
7696 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7697 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7698 grid $w.f.hard -sticky w
7699 pack $w.f -side top -fill x
7700 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7701 pack $w.ok -side left -fill x -padx 20 -pady 20
7702 button $w.cancel -text [mc Cancel] -command "destroy $w"
7703 pack $w.cancel -side right -fill x -padx 20 -pady 20
7704 bind $w <Visibility> "grab $w; focus $w"
7705 tkwait window $w
7706 if {!$confirm_ok} return
7707 if {[catch {set fd [open \
7708 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7709 error_popup $err
7710 } else {
7711 dohidelocalchanges
7712 filerun $fd [list readresetstat $fd]
7713 nowbusy reset [mc "Resetting"]
7714 selbyid $rowmenuid
7718 proc readresetstat {fd} {
7719 global mainhead mainheadid showlocalchanges rprogcoord
7721 if {[gets $fd line] >= 0} {
7722 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7723 set rprogcoord [expr {1.0 * $m / $n}]
7724 adjustprogress
7726 return 1
7728 set rprogcoord 0
7729 adjustprogress
7730 notbusy reset
7731 if {[catch {close $fd} err]} {
7732 error_popup $err
7734 set oldhead $mainheadid
7735 set newhead [exec git rev-parse HEAD]
7736 if {$newhead ne $oldhead} {
7737 movehead $newhead $mainhead
7738 movedhead $newhead $mainhead
7739 set mainheadid $newhead
7740 redrawtags $oldhead
7741 redrawtags $newhead
7743 if {$showlocalchanges} {
7744 doshowlocalchanges
7746 return 0
7749 # context menu for a head
7750 proc headmenu {x y id head} {
7751 global headmenuid headmenuhead headctxmenu mainhead
7753 stopfinding
7754 set headmenuid $id
7755 set headmenuhead $head
7756 set state normal
7757 if {$head eq $mainhead} {
7758 set state disabled
7760 $headctxmenu entryconfigure 0 -state $state
7761 $headctxmenu entryconfigure 1 -state $state
7762 tk_popup $headctxmenu $x $y
7765 proc cobranch {} {
7766 global headmenuid headmenuhead headids
7767 global showlocalchanges mainheadid
7769 # check the tree is clean first??
7770 nowbusy checkout [mc "Checking out"]
7771 update
7772 dohidelocalchanges
7773 if {[catch {
7774 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7775 } err]} {
7776 notbusy checkout
7777 error_popup $err
7778 if {$showlocalchanges} {
7779 dodiffindex
7781 } else {
7782 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7786 proc readcheckoutstat {fd newhead newheadid} {
7787 global mainhead mainheadid headids showlocalchanges progresscoords
7789 if {[gets $fd line] >= 0} {
7790 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7791 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7792 adjustprogress
7794 return 1
7796 set progresscoords {0 0}
7797 adjustprogress
7798 notbusy checkout
7799 if {[catch {close $fd} err]} {
7800 error_popup $err
7802 set oldmainid $mainheadid
7803 set mainhead $newhead
7804 set mainheadid $newheadid
7805 redrawtags $oldmainid
7806 redrawtags $newheadid
7807 selbyid $newheadid
7808 if {$showlocalchanges} {
7809 dodiffindex
7813 proc rmbranch {} {
7814 global headmenuid headmenuhead mainhead
7815 global idheads
7817 set head $headmenuhead
7818 set id $headmenuid
7819 # this check shouldn't be needed any more...
7820 if {$head eq $mainhead} {
7821 error_popup [mc "Cannot delete the currently checked-out branch"]
7822 return
7824 set dheads [descheads $id]
7825 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7826 # the stuff on this branch isn't on any other branch
7827 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7828 branch.\nReally delete branch %s?" $head $head]]} return
7830 nowbusy rmbranch
7831 update
7832 if {[catch {exec git branch -D $head} err]} {
7833 notbusy rmbranch
7834 error_popup $err
7835 return
7837 removehead $id $head
7838 removedhead $id $head
7839 redrawtags $id
7840 notbusy rmbranch
7841 dispneartags 0
7842 run refill_reflist
7845 # Display a list of tags and heads
7846 proc showrefs {} {
7847 global showrefstop bgcolor fgcolor selectbgcolor
7848 global bglist fglist reflistfilter reflist maincursor
7850 set top .showrefs
7851 set showrefstop $top
7852 if {[winfo exists $top]} {
7853 raise $top
7854 refill_reflist
7855 return
7857 toplevel $top
7858 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7859 text $top.list -background $bgcolor -foreground $fgcolor \
7860 -selectbackground $selectbgcolor -font mainfont \
7861 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7862 -width 30 -height 20 -cursor $maincursor \
7863 -spacing1 1 -spacing3 1 -state disabled
7864 $top.list tag configure highlight -background $selectbgcolor
7865 lappend bglist $top.list
7866 lappend fglist $top.list
7867 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7868 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7869 grid $top.list $top.ysb -sticky nsew
7870 grid $top.xsb x -sticky ew
7871 frame $top.f
7872 label $top.f.l -text "[mc "Filter"]: "
7873 entry $top.f.e -width 20 -textvariable reflistfilter
7874 set reflistfilter "*"
7875 trace add variable reflistfilter write reflistfilter_change
7876 pack $top.f.e -side right -fill x -expand 1
7877 pack $top.f.l -side left
7878 grid $top.f - -sticky ew -pady 2
7879 button $top.close -command [list destroy $top] -text [mc "Close"]
7880 grid $top.close -
7881 grid columnconfigure $top 0 -weight 1
7882 grid rowconfigure $top 0 -weight 1
7883 bind $top.list <1> {break}
7884 bind $top.list <B1-Motion> {break}
7885 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7886 set reflist {}
7887 refill_reflist
7890 proc sel_reflist {w x y} {
7891 global showrefstop reflist headids tagids otherrefids
7893 if {![winfo exists $showrefstop]} return
7894 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7895 set ref [lindex $reflist [expr {$l-1}]]
7896 set n [lindex $ref 0]
7897 switch -- [lindex $ref 1] {
7898 "H" {selbyid $headids($n)}
7899 "T" {selbyid $tagids($n)}
7900 "o" {selbyid $otherrefids($n)}
7902 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7905 proc unsel_reflist {} {
7906 global showrefstop
7908 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7909 $showrefstop.list tag remove highlight 0.0 end
7912 proc reflistfilter_change {n1 n2 op} {
7913 global reflistfilter
7915 after cancel refill_reflist
7916 after 200 refill_reflist
7919 proc refill_reflist {} {
7920 global reflist reflistfilter showrefstop headids tagids otherrefids
7921 global curview commitinterest
7923 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7924 set refs {}
7925 foreach n [array names headids] {
7926 if {[string match $reflistfilter $n]} {
7927 if {[commitinview $headids($n) $curview]} {
7928 lappend refs [list $n H]
7929 } else {
7930 set commitinterest($headids($n)) {run refill_reflist}
7934 foreach n [array names tagids] {
7935 if {[string match $reflistfilter $n]} {
7936 if {[commitinview $tagids($n) $curview]} {
7937 lappend refs [list $n T]
7938 } else {
7939 set commitinterest($tagids($n)) {run refill_reflist}
7943 foreach n [array names otherrefids] {
7944 if {[string match $reflistfilter $n]} {
7945 if {[commitinview $otherrefids($n) $curview]} {
7946 lappend refs [list $n o]
7947 } else {
7948 set commitinterest($otherrefids($n)) {run refill_reflist}
7952 set refs [lsort -index 0 $refs]
7953 if {$refs eq $reflist} return
7955 # Update the contents of $showrefstop.list according to the
7956 # differences between $reflist (old) and $refs (new)
7957 $showrefstop.list conf -state normal
7958 $showrefstop.list insert end "\n"
7959 set i 0
7960 set j 0
7961 while {$i < [llength $reflist] || $j < [llength $refs]} {
7962 if {$i < [llength $reflist]} {
7963 if {$j < [llength $refs]} {
7964 set cmp [string compare [lindex $reflist $i 0] \
7965 [lindex $refs $j 0]]
7966 if {$cmp == 0} {
7967 set cmp [string compare [lindex $reflist $i 1] \
7968 [lindex $refs $j 1]]
7970 } else {
7971 set cmp -1
7973 } else {
7974 set cmp 1
7976 switch -- $cmp {
7977 -1 {
7978 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7979 incr i
7982 incr i
7983 incr j
7986 set l [expr {$j + 1}]
7987 $showrefstop.list image create $l.0 -align baseline \
7988 -image reficon-[lindex $refs $j 1] -padx 2
7989 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7990 incr j
7994 set reflist $refs
7995 # delete last newline
7996 $showrefstop.list delete end-2c end-1c
7997 $showrefstop.list conf -state disabled
8000 # Stuff for finding nearby tags
8001 proc getallcommits {} {
8002 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8003 global idheads idtags idotherrefs allparents tagobjid
8005 if {![info exists allcommits]} {
8006 set nextarc 0
8007 set allcommits 0
8008 set seeds {}
8009 set allcwait 0
8010 set cachedarcs 0
8011 set allccache [file join [gitdir] "gitk.cache"]
8012 if {![catch {
8013 set f [open $allccache r]
8014 set allcwait 1
8015 getcache $f
8016 }]} return
8019 if {$allcwait} {
8020 return
8022 set cmd [list | git rev-list --parents]
8023 set allcupdate [expr {$seeds ne {}}]
8024 if {!$allcupdate} {
8025 set ids "--all"
8026 } else {
8027 set refs [concat [array names idheads] [array names idtags] \
8028 [array names idotherrefs]]
8029 set ids {}
8030 set tagobjs {}
8031 foreach name [array names tagobjid] {
8032 lappend tagobjs $tagobjid($name)
8034 foreach id [lsort -unique $refs] {
8035 if {![info exists allparents($id)] &&
8036 [lsearch -exact $tagobjs $id] < 0} {
8037 lappend ids $id
8040 if {$ids ne {}} {
8041 foreach id $seeds {
8042 lappend ids "^$id"
8046 if {$ids ne {}} {
8047 set fd [open [concat $cmd $ids] r]
8048 fconfigure $fd -blocking 0
8049 incr allcommits
8050 nowbusy allcommits
8051 filerun $fd [list getallclines $fd]
8052 } else {
8053 dispneartags 0
8057 # Since most commits have 1 parent and 1 child, we group strings of
8058 # such commits into "arcs" joining branch/merge points (BMPs), which
8059 # are commits that either don't have 1 parent or don't have 1 child.
8061 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8062 # arcout(id) - outgoing arcs for BMP
8063 # arcids(a) - list of IDs on arc including end but not start
8064 # arcstart(a) - BMP ID at start of arc
8065 # arcend(a) - BMP ID at end of arc
8066 # growing(a) - arc a is still growing
8067 # arctags(a) - IDs out of arcids (excluding end) that have tags
8068 # archeads(a) - IDs out of arcids (excluding end) that have heads
8069 # The start of an arc is at the descendent end, so "incoming" means
8070 # coming from descendents, and "outgoing" means going towards ancestors.
8072 proc getallclines {fd} {
8073 global allparents allchildren idtags idheads nextarc
8074 global arcnos arcids arctags arcout arcend arcstart archeads growing
8075 global seeds allcommits cachedarcs allcupdate
8077 set nid 0
8078 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8079 set id [lindex $line 0]
8080 if {[info exists allparents($id)]} {
8081 # seen it already
8082 continue
8084 set cachedarcs 0
8085 set olds [lrange $line 1 end]
8086 set allparents($id) $olds
8087 if {![info exists allchildren($id)]} {
8088 set allchildren($id) {}
8089 set arcnos($id) {}
8090 lappend seeds $id
8091 } else {
8092 set a $arcnos($id)
8093 if {[llength $olds] == 1 && [llength $a] == 1} {
8094 lappend arcids($a) $id
8095 if {[info exists idtags($id)]} {
8096 lappend arctags($a) $id
8098 if {[info exists idheads($id)]} {
8099 lappend archeads($a) $id
8101 if {[info exists allparents($olds)]} {
8102 # seen parent already
8103 if {![info exists arcout($olds)]} {
8104 splitarc $olds
8106 lappend arcids($a) $olds
8107 set arcend($a) $olds
8108 unset growing($a)
8110 lappend allchildren($olds) $id
8111 lappend arcnos($olds) $a
8112 continue
8115 foreach a $arcnos($id) {
8116 lappend arcids($a) $id
8117 set arcend($a) $id
8118 unset growing($a)
8121 set ao {}
8122 foreach p $olds {
8123 lappend allchildren($p) $id
8124 set a [incr nextarc]
8125 set arcstart($a) $id
8126 set archeads($a) {}
8127 set arctags($a) {}
8128 set archeads($a) {}
8129 set arcids($a) {}
8130 lappend ao $a
8131 set growing($a) 1
8132 if {[info exists allparents($p)]} {
8133 # seen it already, may need to make a new branch
8134 if {![info exists arcout($p)]} {
8135 splitarc $p
8137 lappend arcids($a) $p
8138 set arcend($a) $p
8139 unset growing($a)
8141 lappend arcnos($p) $a
8143 set arcout($id) $ao
8145 if {$nid > 0} {
8146 global cached_dheads cached_dtags cached_atags
8147 catch {unset cached_dheads}
8148 catch {unset cached_dtags}
8149 catch {unset cached_atags}
8151 if {![eof $fd]} {
8152 return [expr {$nid >= 1000? 2: 1}]
8154 set cacheok 1
8155 if {[catch {
8156 fconfigure $fd -blocking 1
8157 close $fd
8158 } err]} {
8159 # got an error reading the list of commits
8160 # if we were updating, try rereading the whole thing again
8161 if {$allcupdate} {
8162 incr allcommits -1
8163 dropcache $err
8164 return
8166 error_popup "[mc "Error reading commit topology information;\
8167 branch and preceding/following tag information\
8168 will be incomplete."]\n($err)"
8169 set cacheok 0
8171 if {[incr allcommits -1] == 0} {
8172 notbusy allcommits
8173 if {$cacheok} {
8174 run savecache
8177 dispneartags 0
8178 return 0
8181 proc recalcarc {a} {
8182 global arctags archeads arcids idtags idheads
8184 set at {}
8185 set ah {}
8186 foreach id [lrange $arcids($a) 0 end-1] {
8187 if {[info exists idtags($id)]} {
8188 lappend at $id
8190 if {[info exists idheads($id)]} {
8191 lappend ah $id
8194 set arctags($a) $at
8195 set archeads($a) $ah
8198 proc splitarc {p} {
8199 global arcnos arcids nextarc arctags archeads idtags idheads
8200 global arcstart arcend arcout allparents growing
8202 set a $arcnos($p)
8203 if {[llength $a] != 1} {
8204 puts "oops splitarc called but [llength $a] arcs already"
8205 return
8207 set a [lindex $a 0]
8208 set i [lsearch -exact $arcids($a) $p]
8209 if {$i < 0} {
8210 puts "oops splitarc $p not in arc $a"
8211 return
8213 set na [incr nextarc]
8214 if {[info exists arcend($a)]} {
8215 set arcend($na) $arcend($a)
8216 } else {
8217 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8218 set j [lsearch -exact $arcnos($l) $a]
8219 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8221 set tail [lrange $arcids($a) [expr {$i+1}] end]
8222 set arcids($a) [lrange $arcids($a) 0 $i]
8223 set arcend($a) $p
8224 set arcstart($na) $p
8225 set arcout($p) $na
8226 set arcids($na) $tail
8227 if {[info exists growing($a)]} {
8228 set growing($na) 1
8229 unset growing($a)
8232 foreach id $tail {
8233 if {[llength $arcnos($id)] == 1} {
8234 set arcnos($id) $na
8235 } else {
8236 set j [lsearch -exact $arcnos($id) $a]
8237 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8241 # reconstruct tags and heads lists
8242 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8243 recalcarc $a
8244 recalcarc $na
8245 } else {
8246 set arctags($na) {}
8247 set archeads($na) {}
8251 # Update things for a new commit added that is a child of one
8252 # existing commit. Used when cherry-picking.
8253 proc addnewchild {id p} {
8254 global allparents allchildren idtags nextarc
8255 global arcnos arcids arctags arcout arcend arcstart archeads growing
8256 global seeds allcommits
8258 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8259 set allparents($id) [list $p]
8260 set allchildren($id) {}
8261 set arcnos($id) {}
8262 lappend seeds $id
8263 lappend allchildren($p) $id
8264 set a [incr nextarc]
8265 set arcstart($a) $id
8266 set archeads($a) {}
8267 set arctags($a) {}
8268 set arcids($a) [list $p]
8269 set arcend($a) $p
8270 if {![info exists arcout($p)]} {
8271 splitarc $p
8273 lappend arcnos($p) $a
8274 set arcout($id) [list $a]
8277 # This implements a cache for the topology information.
8278 # The cache saves, for each arc, the start and end of the arc,
8279 # the ids on the arc, and the outgoing arcs from the end.
8280 proc readcache {f} {
8281 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8282 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8283 global allcwait
8285 set a $nextarc
8286 set lim $cachedarcs
8287 if {$lim - $a > 500} {
8288 set lim [expr {$a + 500}]
8290 if {[catch {
8291 if {$a == $lim} {
8292 # finish reading the cache and setting up arctags, etc.
8293 set line [gets $f]
8294 if {$line ne "1"} {error "bad final version"}
8295 close $f
8296 foreach id [array names idtags] {
8297 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8298 [llength $allparents($id)] == 1} {
8299 set a [lindex $arcnos($id) 0]
8300 if {$arctags($a) eq {}} {
8301 recalcarc $a
8305 foreach id [array names idheads] {
8306 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8307 [llength $allparents($id)] == 1} {
8308 set a [lindex $arcnos($id) 0]
8309 if {$archeads($a) eq {}} {
8310 recalcarc $a
8314 foreach id [lsort -unique $possible_seeds] {
8315 if {$arcnos($id) eq {}} {
8316 lappend seeds $id
8319 set allcwait 0
8320 } else {
8321 while {[incr a] <= $lim} {
8322 set line [gets $f]
8323 if {[llength $line] != 3} {error "bad line"}
8324 set s [lindex $line 0]
8325 set arcstart($a) $s
8326 lappend arcout($s) $a
8327 if {![info exists arcnos($s)]} {
8328 lappend possible_seeds $s
8329 set arcnos($s) {}
8331 set e [lindex $line 1]
8332 if {$e eq {}} {
8333 set growing($a) 1
8334 } else {
8335 set arcend($a) $e
8336 if {![info exists arcout($e)]} {
8337 set arcout($e) {}
8340 set arcids($a) [lindex $line 2]
8341 foreach id $arcids($a) {
8342 lappend allparents($s) $id
8343 set s $id
8344 lappend arcnos($id) $a
8346 if {![info exists allparents($s)]} {
8347 set allparents($s) {}
8349 set arctags($a) {}
8350 set archeads($a) {}
8352 set nextarc [expr {$a - 1}]
8354 } err]} {
8355 dropcache $err
8356 return 0
8358 if {!$allcwait} {
8359 getallcommits
8361 return $allcwait
8364 proc getcache {f} {
8365 global nextarc cachedarcs possible_seeds
8367 if {[catch {
8368 set line [gets $f]
8369 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8370 # make sure it's an integer
8371 set cachedarcs [expr {int([lindex $line 1])}]
8372 if {$cachedarcs < 0} {error "bad number of arcs"}
8373 set nextarc 0
8374 set possible_seeds {}
8375 run readcache $f
8376 } err]} {
8377 dropcache $err
8379 return 0
8382 proc dropcache {err} {
8383 global allcwait nextarc cachedarcs seeds
8385 #puts "dropping cache ($err)"
8386 foreach v {arcnos arcout arcids arcstart arcend growing \
8387 arctags archeads allparents allchildren} {
8388 global $v
8389 catch {unset $v}
8391 set allcwait 0
8392 set nextarc 0
8393 set cachedarcs 0
8394 set seeds {}
8395 getallcommits
8398 proc writecache {f} {
8399 global cachearc cachedarcs allccache
8400 global arcstart arcend arcnos arcids arcout
8402 set a $cachearc
8403 set lim $cachedarcs
8404 if {$lim - $a > 1000} {
8405 set lim [expr {$a + 1000}]
8407 if {[catch {
8408 while {[incr a] <= $lim} {
8409 if {[info exists arcend($a)]} {
8410 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8411 } else {
8412 puts $f [list $arcstart($a) {} $arcids($a)]
8415 } err]} {
8416 catch {close $f}
8417 catch {file delete $allccache}
8418 #puts "writing cache failed ($err)"
8419 return 0
8421 set cachearc [expr {$a - 1}]
8422 if {$a > $cachedarcs} {
8423 puts $f "1"
8424 close $f
8425 return 0
8427 return 1
8430 proc savecache {} {
8431 global nextarc cachedarcs cachearc allccache
8433 if {$nextarc == $cachedarcs} return
8434 set cachearc 0
8435 set cachedarcs $nextarc
8436 catch {
8437 set f [open $allccache w]
8438 puts $f [list 1 $cachedarcs]
8439 run writecache $f
8443 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8444 # or 0 if neither is true.
8445 proc anc_or_desc {a b} {
8446 global arcout arcstart arcend arcnos cached_isanc
8448 if {$arcnos($a) eq $arcnos($b)} {
8449 # Both are on the same arc(s); either both are the same BMP,
8450 # or if one is not a BMP, the other is also not a BMP or is
8451 # the BMP at end of the arc (and it only has 1 incoming arc).
8452 # Or both can be BMPs with no incoming arcs.
8453 if {$a eq $b || $arcnos($a) eq {}} {
8454 return 0
8456 # assert {[llength $arcnos($a)] == 1}
8457 set arc [lindex $arcnos($a) 0]
8458 set i [lsearch -exact $arcids($arc) $a]
8459 set j [lsearch -exact $arcids($arc) $b]
8460 if {$i < 0 || $i > $j} {
8461 return 1
8462 } else {
8463 return -1
8467 if {![info exists arcout($a)]} {
8468 set arc [lindex $arcnos($a) 0]
8469 if {[info exists arcend($arc)]} {
8470 set aend $arcend($arc)
8471 } else {
8472 set aend {}
8474 set a $arcstart($arc)
8475 } else {
8476 set aend $a
8478 if {![info exists arcout($b)]} {
8479 set arc [lindex $arcnos($b) 0]
8480 if {[info exists arcend($arc)]} {
8481 set bend $arcend($arc)
8482 } else {
8483 set bend {}
8485 set b $arcstart($arc)
8486 } else {
8487 set bend $b
8489 if {$a eq $bend} {
8490 return 1
8492 if {$b eq $aend} {
8493 return -1
8495 if {[info exists cached_isanc($a,$bend)]} {
8496 if {$cached_isanc($a,$bend)} {
8497 return 1
8500 if {[info exists cached_isanc($b,$aend)]} {
8501 if {$cached_isanc($b,$aend)} {
8502 return -1
8504 if {[info exists cached_isanc($a,$bend)]} {
8505 return 0
8509 set todo [list $a $b]
8510 set anc($a) a
8511 set anc($b) b
8512 for {set i 0} {$i < [llength $todo]} {incr i} {
8513 set x [lindex $todo $i]
8514 if {$anc($x) eq {}} {
8515 continue
8517 foreach arc $arcnos($x) {
8518 set xd $arcstart($arc)
8519 if {$xd eq $bend} {
8520 set cached_isanc($a,$bend) 1
8521 set cached_isanc($b,$aend) 0
8522 return 1
8523 } elseif {$xd eq $aend} {
8524 set cached_isanc($b,$aend) 1
8525 set cached_isanc($a,$bend) 0
8526 return -1
8528 if {![info exists anc($xd)]} {
8529 set anc($xd) $anc($x)
8530 lappend todo $xd
8531 } elseif {$anc($xd) ne $anc($x)} {
8532 set anc($xd) {}
8536 set cached_isanc($a,$bend) 0
8537 set cached_isanc($b,$aend) 0
8538 return 0
8541 # This identifies whether $desc has an ancestor that is
8542 # a growing tip of the graph and which is not an ancestor of $anc
8543 # and returns 0 if so and 1 if not.
8544 # If we subsequently discover a tag on such a growing tip, and that
8545 # turns out to be a descendent of $anc (which it could, since we
8546 # don't necessarily see children before parents), then $desc
8547 # isn't a good choice to display as a descendent tag of
8548 # $anc (since it is the descendent of another tag which is
8549 # a descendent of $anc). Similarly, $anc isn't a good choice to
8550 # display as a ancestor tag of $desc.
8552 proc is_certain {desc anc} {
8553 global arcnos arcout arcstart arcend growing problems
8555 set certain {}
8556 if {[llength $arcnos($anc)] == 1} {
8557 # tags on the same arc are certain
8558 if {$arcnos($desc) eq $arcnos($anc)} {
8559 return 1
8561 if {![info exists arcout($anc)]} {
8562 # if $anc is partway along an arc, use the start of the arc instead
8563 set a [lindex $arcnos($anc) 0]
8564 set anc $arcstart($a)
8567 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8568 set x $desc
8569 } else {
8570 set a [lindex $arcnos($desc) 0]
8571 set x $arcend($a)
8573 if {$x == $anc} {
8574 return 1
8576 set anclist [list $x]
8577 set dl($x) 1
8578 set nnh 1
8579 set ngrowanc 0
8580 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8581 set x [lindex $anclist $i]
8582 if {$dl($x)} {
8583 incr nnh -1
8585 set done($x) 1
8586 foreach a $arcout($x) {
8587 if {[info exists growing($a)]} {
8588 if {![info exists growanc($x)] && $dl($x)} {
8589 set growanc($x) 1
8590 incr ngrowanc
8592 } else {
8593 set y $arcend($a)
8594 if {[info exists dl($y)]} {
8595 if {$dl($y)} {
8596 if {!$dl($x)} {
8597 set dl($y) 0
8598 if {![info exists done($y)]} {
8599 incr nnh -1
8601 if {[info exists growanc($x)]} {
8602 incr ngrowanc -1
8604 set xl [list $y]
8605 for {set k 0} {$k < [llength $xl]} {incr k} {
8606 set z [lindex $xl $k]
8607 foreach c $arcout($z) {
8608 if {[info exists arcend($c)]} {
8609 set v $arcend($c)
8610 if {[info exists dl($v)] && $dl($v)} {
8611 set dl($v) 0
8612 if {![info exists done($v)]} {
8613 incr nnh -1
8615 if {[info exists growanc($v)]} {
8616 incr ngrowanc -1
8618 lappend xl $v
8625 } elseif {$y eq $anc || !$dl($x)} {
8626 set dl($y) 0
8627 lappend anclist $y
8628 } else {
8629 set dl($y) 1
8630 lappend anclist $y
8631 incr nnh
8636 foreach x [array names growanc] {
8637 if {$dl($x)} {
8638 return 0
8640 return 0
8642 return 1
8645 proc validate_arctags {a} {
8646 global arctags idtags
8648 set i -1
8649 set na $arctags($a)
8650 foreach id $arctags($a) {
8651 incr i
8652 if {![info exists idtags($id)]} {
8653 set na [lreplace $na $i $i]
8654 incr i -1
8657 set arctags($a) $na
8660 proc validate_archeads {a} {
8661 global archeads idheads
8663 set i -1
8664 set na $archeads($a)
8665 foreach id $archeads($a) {
8666 incr i
8667 if {![info exists idheads($id)]} {
8668 set na [lreplace $na $i $i]
8669 incr i -1
8672 set archeads($a) $na
8675 # Return the list of IDs that have tags that are descendents of id,
8676 # ignoring IDs that are descendents of IDs already reported.
8677 proc desctags {id} {
8678 global arcnos arcstart arcids arctags idtags allparents
8679 global growing cached_dtags
8681 if {![info exists allparents($id)]} {
8682 return {}
8684 set t1 [clock clicks -milliseconds]
8685 set argid $id
8686 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8687 # part-way along an arc; check that arc first
8688 set a [lindex $arcnos($id) 0]
8689 if {$arctags($a) ne {}} {
8690 validate_arctags $a
8691 set i [lsearch -exact $arcids($a) $id]
8692 set tid {}
8693 foreach t $arctags($a) {
8694 set j [lsearch -exact $arcids($a) $t]
8695 if {$j >= $i} break
8696 set tid $t
8698 if {$tid ne {}} {
8699 return $tid
8702 set id $arcstart($a)
8703 if {[info exists idtags($id)]} {
8704 return $id
8707 if {[info exists cached_dtags($id)]} {
8708 return $cached_dtags($id)
8711 set origid $id
8712 set todo [list $id]
8713 set queued($id) 1
8714 set nc 1
8715 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8716 set id [lindex $todo $i]
8717 set done($id) 1
8718 set ta [info exists hastaggedancestor($id)]
8719 if {!$ta} {
8720 incr nc -1
8722 # ignore tags on starting node
8723 if {!$ta && $i > 0} {
8724 if {[info exists idtags($id)]} {
8725 set tagloc($id) $id
8726 set ta 1
8727 } elseif {[info exists cached_dtags($id)]} {
8728 set tagloc($id) $cached_dtags($id)
8729 set ta 1
8732 foreach a $arcnos($id) {
8733 set d $arcstart($a)
8734 if {!$ta && $arctags($a) ne {}} {
8735 validate_arctags $a
8736 if {$arctags($a) ne {}} {
8737 lappend tagloc($id) [lindex $arctags($a) end]
8740 if {$ta || $arctags($a) ne {}} {
8741 set tomark [list $d]
8742 for {set j 0} {$j < [llength $tomark]} {incr j} {
8743 set dd [lindex $tomark $j]
8744 if {![info exists hastaggedancestor($dd)]} {
8745 if {[info exists done($dd)]} {
8746 foreach b $arcnos($dd) {
8747 lappend tomark $arcstart($b)
8749 if {[info exists tagloc($dd)]} {
8750 unset tagloc($dd)
8752 } elseif {[info exists queued($dd)]} {
8753 incr nc -1
8755 set hastaggedancestor($dd) 1
8759 if {![info exists queued($d)]} {
8760 lappend todo $d
8761 set queued($d) 1
8762 if {![info exists hastaggedancestor($d)]} {
8763 incr nc
8768 set tags {}
8769 foreach id [array names tagloc] {
8770 if {![info exists hastaggedancestor($id)]} {
8771 foreach t $tagloc($id) {
8772 if {[lsearch -exact $tags $t] < 0} {
8773 lappend tags $t
8778 set t2 [clock clicks -milliseconds]
8779 set loopix $i
8781 # remove tags that are descendents of other tags
8782 for {set i 0} {$i < [llength $tags]} {incr i} {
8783 set a [lindex $tags $i]
8784 for {set j 0} {$j < $i} {incr j} {
8785 set b [lindex $tags $j]
8786 set r [anc_or_desc $a $b]
8787 if {$r == 1} {
8788 set tags [lreplace $tags $j $j]
8789 incr j -1
8790 incr i -1
8791 } elseif {$r == -1} {
8792 set tags [lreplace $tags $i $i]
8793 incr i -1
8794 break
8799 if {[array names growing] ne {}} {
8800 # graph isn't finished, need to check if any tag could get
8801 # eclipsed by another tag coming later. Simply ignore any
8802 # tags that could later get eclipsed.
8803 set ctags {}
8804 foreach t $tags {
8805 if {[is_certain $t $origid]} {
8806 lappend ctags $t
8809 if {$tags eq $ctags} {
8810 set cached_dtags($origid) $tags
8811 } else {
8812 set tags $ctags
8814 } else {
8815 set cached_dtags($origid) $tags
8817 set t3 [clock clicks -milliseconds]
8818 if {0 && $t3 - $t1 >= 100} {
8819 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8820 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8822 return $tags
8825 proc anctags {id} {
8826 global arcnos arcids arcout arcend arctags idtags allparents
8827 global growing cached_atags
8829 if {![info exists allparents($id)]} {
8830 return {}
8832 set t1 [clock clicks -milliseconds]
8833 set argid $id
8834 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8835 # part-way along an arc; check that arc first
8836 set a [lindex $arcnos($id) 0]
8837 if {$arctags($a) ne {}} {
8838 validate_arctags $a
8839 set i [lsearch -exact $arcids($a) $id]
8840 foreach t $arctags($a) {
8841 set j [lsearch -exact $arcids($a) $t]
8842 if {$j > $i} {
8843 return $t
8847 if {![info exists arcend($a)]} {
8848 return {}
8850 set id $arcend($a)
8851 if {[info exists idtags($id)]} {
8852 return $id
8855 if {[info exists cached_atags($id)]} {
8856 return $cached_atags($id)
8859 set origid $id
8860 set todo [list $id]
8861 set queued($id) 1
8862 set taglist {}
8863 set nc 1
8864 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8865 set id [lindex $todo $i]
8866 set done($id) 1
8867 set td [info exists hastaggeddescendent($id)]
8868 if {!$td} {
8869 incr nc -1
8871 # ignore tags on starting node
8872 if {!$td && $i > 0} {
8873 if {[info exists idtags($id)]} {
8874 set tagloc($id) $id
8875 set td 1
8876 } elseif {[info exists cached_atags($id)]} {
8877 set tagloc($id) $cached_atags($id)
8878 set td 1
8881 foreach a $arcout($id) {
8882 if {!$td && $arctags($a) ne {}} {
8883 validate_arctags $a
8884 if {$arctags($a) ne {}} {
8885 lappend tagloc($id) [lindex $arctags($a) 0]
8888 if {![info exists arcend($a)]} continue
8889 set d $arcend($a)
8890 if {$td || $arctags($a) ne {}} {
8891 set tomark [list $d]
8892 for {set j 0} {$j < [llength $tomark]} {incr j} {
8893 set dd [lindex $tomark $j]
8894 if {![info exists hastaggeddescendent($dd)]} {
8895 if {[info exists done($dd)]} {
8896 foreach b $arcout($dd) {
8897 if {[info exists arcend($b)]} {
8898 lappend tomark $arcend($b)
8901 if {[info exists tagloc($dd)]} {
8902 unset tagloc($dd)
8904 } elseif {[info exists queued($dd)]} {
8905 incr nc -1
8907 set hastaggeddescendent($dd) 1
8911 if {![info exists queued($d)]} {
8912 lappend todo $d
8913 set queued($d) 1
8914 if {![info exists hastaggeddescendent($d)]} {
8915 incr nc
8920 set t2 [clock clicks -milliseconds]
8921 set loopix $i
8922 set tags {}
8923 foreach id [array names tagloc] {
8924 if {![info exists hastaggeddescendent($id)]} {
8925 foreach t $tagloc($id) {
8926 if {[lsearch -exact $tags $t] < 0} {
8927 lappend tags $t
8933 # remove tags that are ancestors of other tags
8934 for {set i 0} {$i < [llength $tags]} {incr i} {
8935 set a [lindex $tags $i]
8936 for {set j 0} {$j < $i} {incr j} {
8937 set b [lindex $tags $j]
8938 set r [anc_or_desc $a $b]
8939 if {$r == -1} {
8940 set tags [lreplace $tags $j $j]
8941 incr j -1
8942 incr i -1
8943 } elseif {$r == 1} {
8944 set tags [lreplace $tags $i $i]
8945 incr i -1
8946 break
8951 if {[array names growing] ne {}} {
8952 # graph isn't finished, need to check if any tag could get
8953 # eclipsed by another tag coming later. Simply ignore any
8954 # tags that could later get eclipsed.
8955 set ctags {}
8956 foreach t $tags {
8957 if {[is_certain $origid $t]} {
8958 lappend ctags $t
8961 if {$tags eq $ctags} {
8962 set cached_atags($origid) $tags
8963 } else {
8964 set tags $ctags
8966 } else {
8967 set cached_atags($origid) $tags
8969 set t3 [clock clicks -milliseconds]
8970 if {0 && $t3 - $t1 >= 100} {
8971 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8972 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8974 return $tags
8977 # Return the list of IDs that have heads that are descendents of id,
8978 # including id itself if it has a head.
8979 proc descheads {id} {
8980 global arcnos arcstart arcids archeads idheads cached_dheads
8981 global allparents
8983 if {![info exists allparents($id)]} {
8984 return {}
8986 set aret {}
8987 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8988 # part-way along an arc; check it first
8989 set a [lindex $arcnos($id) 0]
8990 if {$archeads($a) ne {}} {
8991 validate_archeads $a
8992 set i [lsearch -exact $arcids($a) $id]
8993 foreach t $archeads($a) {
8994 set j [lsearch -exact $arcids($a) $t]
8995 if {$j > $i} break
8996 lappend aret $t
8999 set id $arcstart($a)
9001 set origid $id
9002 set todo [list $id]
9003 set seen($id) 1
9004 set ret {}
9005 for {set i 0} {$i < [llength $todo]} {incr i} {
9006 set id [lindex $todo $i]
9007 if {[info exists cached_dheads($id)]} {
9008 set ret [concat $ret $cached_dheads($id)]
9009 } else {
9010 if {[info exists idheads($id)]} {
9011 lappend ret $id
9013 foreach a $arcnos($id) {
9014 if {$archeads($a) ne {}} {
9015 validate_archeads $a
9016 if {$archeads($a) ne {}} {
9017 set ret [concat $ret $archeads($a)]
9020 set d $arcstart($a)
9021 if {![info exists seen($d)]} {
9022 lappend todo $d
9023 set seen($d) 1
9028 set ret [lsort -unique $ret]
9029 set cached_dheads($origid) $ret
9030 return [concat $ret $aret]
9033 proc addedtag {id} {
9034 global arcnos arcout cached_dtags cached_atags
9036 if {![info exists arcnos($id)]} return
9037 if {![info exists arcout($id)]} {
9038 recalcarc [lindex $arcnos($id) 0]
9040 catch {unset cached_dtags}
9041 catch {unset cached_atags}
9044 proc addedhead {hid head} {
9045 global arcnos arcout cached_dheads
9047 if {![info exists arcnos($hid)]} return
9048 if {![info exists arcout($hid)]} {
9049 recalcarc [lindex $arcnos($hid) 0]
9051 catch {unset cached_dheads}
9054 proc removedhead {hid head} {
9055 global cached_dheads
9057 catch {unset cached_dheads}
9060 proc movedhead {hid head} {
9061 global arcnos arcout cached_dheads
9063 if {![info exists arcnos($hid)]} return
9064 if {![info exists arcout($hid)]} {
9065 recalcarc [lindex $arcnos($hid) 0]
9067 catch {unset cached_dheads}
9070 proc changedrefs {} {
9071 global cached_dheads cached_dtags cached_atags
9072 global arctags archeads arcnos arcout idheads idtags
9074 foreach id [concat [array names idheads] [array names idtags]] {
9075 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9076 set a [lindex $arcnos($id) 0]
9077 if {![info exists donearc($a)]} {
9078 recalcarc $a
9079 set donearc($a) 1
9083 catch {unset cached_dtags}
9084 catch {unset cached_atags}
9085 catch {unset cached_dheads}
9088 proc rereadrefs {} {
9089 global idtags idheads idotherrefs mainheadid
9091 set refids [concat [array names idtags] \
9092 [array names idheads] [array names idotherrefs]]
9093 foreach id $refids {
9094 if {![info exists ref($id)]} {
9095 set ref($id) [listrefs $id]
9098 set oldmainhead $mainheadid
9099 readrefs
9100 changedrefs
9101 set refids [lsort -unique [concat $refids [array names idtags] \
9102 [array names idheads] [array names idotherrefs]]]
9103 foreach id $refids {
9104 set v [listrefs $id]
9105 if {![info exists ref($id)] || $ref($id) != $v} {
9106 redrawtags $id
9109 if {$oldmainhead ne $mainheadid} {
9110 redrawtags $oldmainhead
9111 redrawtags $mainheadid
9113 run refill_reflist
9116 proc listrefs {id} {
9117 global idtags idheads idotherrefs
9119 set x {}
9120 if {[info exists idtags($id)]} {
9121 set x $idtags($id)
9123 set y {}
9124 if {[info exists idheads($id)]} {
9125 set y $idheads($id)
9127 set z {}
9128 if {[info exists idotherrefs($id)]} {
9129 set z $idotherrefs($id)
9131 return [list $x $y $z]
9134 proc showtag {tag isnew} {
9135 global ctext tagcontents tagids linknum tagobjid
9137 if {$isnew} {
9138 addtohistory [list showtag $tag 0]
9140 $ctext conf -state normal
9141 clear_ctext
9142 settabs 0
9143 set linknum 0
9144 if {![info exists tagcontents($tag)]} {
9145 catch {
9146 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9149 if {[info exists tagcontents($tag)]} {
9150 set text $tagcontents($tag)
9151 } else {
9152 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9154 appendwithlinks $text {}
9155 $ctext conf -state disabled
9156 init_flist {}
9159 proc doquit {} {
9160 global stopped
9161 global gitktmpdir
9163 set stopped 100
9164 savestuff .
9165 destroy .
9167 if {[info exists gitktmpdir]} {
9168 catch {file delete -force $gitktmpdir}
9172 proc mkfontdisp {font top which} {
9173 global fontattr fontpref $font
9175 set fontpref($font) [set $font]
9176 button $top.${font}but -text $which -font optionfont \
9177 -command [list choosefont $font $which]
9178 label $top.$font -relief flat -font $font \
9179 -text $fontattr($font,family) -justify left
9180 grid x $top.${font}but $top.$font -sticky w
9183 proc choosefont {font which} {
9184 global fontparam fontlist fonttop fontattr
9186 set fontparam(which) $which
9187 set fontparam(font) $font
9188 set fontparam(family) [font actual $font -family]
9189 set fontparam(size) $fontattr($font,size)
9190 set fontparam(weight) $fontattr($font,weight)
9191 set fontparam(slant) $fontattr($font,slant)
9192 set top .gitkfont
9193 set fonttop $top
9194 if {![winfo exists $top]} {
9195 font create sample
9196 eval font config sample [font actual $font]
9197 toplevel $top
9198 wm title $top [mc "Gitk font chooser"]
9199 label $top.l -textvariable fontparam(which)
9200 pack $top.l -side top
9201 set fontlist [lsort [font families]]
9202 frame $top.f
9203 listbox $top.f.fam -listvariable fontlist \
9204 -yscrollcommand [list $top.f.sb set]
9205 bind $top.f.fam <<ListboxSelect>> selfontfam
9206 scrollbar $top.f.sb -command [list $top.f.fam yview]
9207 pack $top.f.sb -side right -fill y
9208 pack $top.f.fam -side left -fill both -expand 1
9209 pack $top.f -side top -fill both -expand 1
9210 frame $top.g
9211 spinbox $top.g.size -from 4 -to 40 -width 4 \
9212 -textvariable fontparam(size) \
9213 -validatecommand {string is integer -strict %s}
9214 checkbutton $top.g.bold -padx 5 \
9215 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9216 -variable fontparam(weight) -onvalue bold -offvalue normal
9217 checkbutton $top.g.ital -padx 5 \
9218 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9219 -variable fontparam(slant) -onvalue italic -offvalue roman
9220 pack $top.g.size $top.g.bold $top.g.ital -side left
9221 pack $top.g -side top
9222 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9223 -background white
9224 $top.c create text 100 25 -anchor center -text $which -font sample \
9225 -fill black -tags text
9226 bind $top.c <Configure> [list centertext $top.c]
9227 pack $top.c -side top -fill x
9228 frame $top.buts
9229 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9230 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9231 grid $top.buts.ok $top.buts.can
9232 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9233 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9234 pack $top.buts -side bottom -fill x
9235 trace add variable fontparam write chg_fontparam
9236 } else {
9237 raise $top
9238 $top.c itemconf text -text $which
9240 set i [lsearch -exact $fontlist $fontparam(family)]
9241 if {$i >= 0} {
9242 $top.f.fam selection set $i
9243 $top.f.fam see $i
9247 proc centertext {w} {
9248 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9251 proc fontok {} {
9252 global fontparam fontpref prefstop
9254 set f $fontparam(font)
9255 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9256 if {$fontparam(weight) eq "bold"} {
9257 lappend fontpref($f) "bold"
9259 if {$fontparam(slant) eq "italic"} {
9260 lappend fontpref($f) "italic"
9262 set w $prefstop.$f
9263 $w conf -text $fontparam(family) -font $fontpref($f)
9265 fontcan
9268 proc fontcan {} {
9269 global fonttop fontparam
9271 if {[info exists fonttop]} {
9272 catch {destroy $fonttop}
9273 catch {font delete sample}
9274 unset fonttop
9275 unset fontparam
9279 proc selfontfam {} {
9280 global fonttop fontparam
9282 set i [$fonttop.f.fam curselection]
9283 if {$i ne {}} {
9284 set fontparam(family) [$fonttop.f.fam get $i]
9288 proc chg_fontparam {v sub op} {
9289 global fontparam
9291 font config sample -$sub $fontparam($sub)
9294 proc doprefs {} {
9295 global maxwidth maxgraphpct
9296 global oldprefs prefstop showneartags showlocalchanges
9297 global bgcolor fgcolor ctext diffcolors selectbgcolor
9298 global tabstop limitdiffs autoselect extdifftool
9300 set top .gitkprefs
9301 set prefstop $top
9302 if {[winfo exists $top]} {
9303 raise $top
9304 return
9306 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9307 limitdiffs tabstop} {
9308 set oldprefs($v) [set $v]
9310 toplevel $top
9311 wm title $top [mc "Gitk preferences"]
9312 label $top.ldisp -text [mc "Commit list display options"]
9313 grid $top.ldisp - -sticky w -pady 10
9314 label $top.spacer -text " "
9315 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9316 -font optionfont
9317 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9318 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9319 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9320 -font optionfont
9321 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9322 grid x $top.maxpctl $top.maxpct -sticky w
9323 frame $top.showlocal
9324 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9325 checkbutton $top.showlocal.b -variable showlocalchanges
9326 pack $top.showlocal.b $top.showlocal.l -side left
9327 grid x $top.showlocal -sticky w
9328 frame $top.autoselect
9329 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9330 checkbutton $top.autoselect.b -variable autoselect
9331 pack $top.autoselect.b $top.autoselect.l -side left
9332 grid x $top.autoselect -sticky w
9334 label $top.ddisp -text [mc "Diff display options"]
9335 grid $top.ddisp - -sticky w -pady 10
9336 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9337 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9338 grid x $top.tabstopl $top.tabstop -sticky w
9339 frame $top.ntag
9340 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9341 checkbutton $top.ntag.b -variable showneartags
9342 pack $top.ntag.b $top.ntag.l -side left
9343 grid x $top.ntag -sticky w
9344 frame $top.ldiff
9345 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9346 checkbutton $top.ldiff.b -variable limitdiffs
9347 pack $top.ldiff.b $top.ldiff.l -side left
9348 grid x $top.ldiff -sticky w
9350 entry $top.extdifft -textvariable extdifftool
9351 frame $top.extdifff
9352 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9353 -padx 10
9354 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9355 -command choose_extdiff
9356 pack $top.extdifff.l $top.extdifff.b -side left
9357 grid x $top.extdifff $top.extdifft -sticky w
9359 label $top.cdisp -text [mc "Colors: press to choose"]
9360 grid $top.cdisp - -sticky w -pady 10
9361 label $top.bg -padx 40 -relief sunk -background $bgcolor
9362 button $top.bgbut -text [mc "Background"] -font optionfont \
9363 -command [list choosecolor bgcolor {} $top.bg background setbg]
9364 grid x $top.bgbut $top.bg -sticky w
9365 label $top.fg -padx 40 -relief sunk -background $fgcolor
9366 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9367 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9368 grid x $top.fgbut $top.fg -sticky w
9369 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9370 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9371 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9372 [list $ctext tag conf d0 -foreground]]
9373 grid x $top.diffoldbut $top.diffold -sticky w
9374 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9375 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9376 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9377 [list $ctext tag conf d1 -foreground]]
9378 grid x $top.diffnewbut $top.diffnew -sticky w
9379 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9380 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9381 -command [list choosecolor diffcolors 2 $top.hunksep \
9382 "diff hunk header" \
9383 [list $ctext tag conf hunksep -foreground]]
9384 grid x $top.hunksepbut $top.hunksep -sticky w
9385 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9386 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9387 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9388 grid x $top.selbgbut $top.selbgsep -sticky w
9390 label $top.cfont -text [mc "Fonts: press to choose"]
9391 grid $top.cfont - -sticky w -pady 10
9392 mkfontdisp mainfont $top [mc "Main font"]
9393 mkfontdisp textfont $top [mc "Diff display font"]
9394 mkfontdisp uifont $top [mc "User interface font"]
9396 frame $top.buts
9397 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9398 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9399 grid $top.buts.ok $top.buts.can
9400 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9401 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9402 grid $top.buts - - -pady 10 -sticky ew
9403 bind $top <Visibility> "focus $top.buts.ok"
9406 proc choose_extdiff {} {
9407 global extdifftool
9409 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9410 if {$prog ne {}} {
9411 set extdifftool $prog
9415 proc choosecolor {v vi w x cmd} {
9416 global $v
9418 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9419 -title [mc "Gitk: choose color for %s" $x]]
9420 if {$c eq {}} return
9421 $w conf -background $c
9422 lset $v $vi $c
9423 eval $cmd $c
9426 proc setselbg {c} {
9427 global bglist cflist
9428 foreach w $bglist {
9429 $w configure -selectbackground $c
9431 $cflist tag configure highlight \
9432 -background [$cflist cget -selectbackground]
9433 allcanvs itemconf secsel -fill $c
9436 proc setbg {c} {
9437 global bglist
9439 foreach w $bglist {
9440 $w conf -background $c
9444 proc setfg {c} {
9445 global fglist canv
9447 foreach w $fglist {
9448 $w conf -foreground $c
9450 allcanvs itemconf text -fill $c
9451 $canv itemconf circle -outline $c
9454 proc prefscan {} {
9455 global oldprefs prefstop
9457 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9458 limitdiffs tabstop} {
9459 global $v
9460 set $v $oldprefs($v)
9462 catch {destroy $prefstop}
9463 unset prefstop
9464 fontcan
9467 proc prefsok {} {
9468 global maxwidth maxgraphpct
9469 global oldprefs prefstop showneartags showlocalchanges
9470 global fontpref mainfont textfont uifont
9471 global limitdiffs treediffs
9473 catch {destroy $prefstop}
9474 unset prefstop
9475 fontcan
9476 set fontchanged 0
9477 if {$mainfont ne $fontpref(mainfont)} {
9478 set mainfont $fontpref(mainfont)
9479 parsefont mainfont $mainfont
9480 eval font configure mainfont [fontflags mainfont]
9481 eval font configure mainfontbold [fontflags mainfont 1]
9482 setcoords
9483 set fontchanged 1
9485 if {$textfont ne $fontpref(textfont)} {
9486 set textfont $fontpref(textfont)
9487 parsefont textfont $textfont
9488 eval font configure textfont [fontflags textfont]
9489 eval font configure textfontbold [fontflags textfont 1]
9491 if {$uifont ne $fontpref(uifont)} {
9492 set uifont $fontpref(uifont)
9493 parsefont uifont $uifont
9494 eval font configure uifont [fontflags uifont]
9496 settabs
9497 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9498 if {$showlocalchanges} {
9499 doshowlocalchanges
9500 } else {
9501 dohidelocalchanges
9504 if {$limitdiffs != $oldprefs(limitdiffs)} {
9505 # treediffs elements are limited by path
9506 catch {unset treediffs}
9508 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9509 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9510 redisplay
9511 } elseif {$showneartags != $oldprefs(showneartags) ||
9512 $limitdiffs != $oldprefs(limitdiffs)} {
9513 reselectline
9517 proc formatdate {d} {
9518 global datetimeformat
9519 if {$d ne {}} {
9520 set d [clock format $d -format $datetimeformat]
9522 return $d
9525 # This list of encoding names and aliases is distilled from
9526 # http://www.iana.org/assignments/character-sets.
9527 # Not all of them are supported by Tcl.
9528 set encoding_aliases {
9529 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9530 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9531 { ISO-10646-UTF-1 csISO10646UTF1 }
9532 { ISO_646.basic:1983 ref csISO646basic1983 }
9533 { INVARIANT csINVARIANT }
9534 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9535 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9536 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9537 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9538 { NATS-DANO iso-ir-9-1 csNATSDANO }
9539 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9540 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9541 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9542 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9543 { ISO-2022-KR csISO2022KR }
9544 { EUC-KR csEUCKR }
9545 { ISO-2022-JP csISO2022JP }
9546 { ISO-2022-JP-2 csISO2022JP2 }
9547 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9548 csISO13JISC6220jp }
9549 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9550 { IT iso-ir-15 ISO646-IT csISO15Italian }
9551 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9552 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9553 { greek7-old iso-ir-18 csISO18Greek7Old }
9554 { latin-greek iso-ir-19 csISO19LatinGreek }
9555 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9556 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9557 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9558 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9559 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9560 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9561 { INIS iso-ir-49 csISO49INIS }
9562 { INIS-8 iso-ir-50 csISO50INIS8 }
9563 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9564 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9565 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9566 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9567 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9568 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9569 csISO60Norwegian1 }
9570 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9571 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9572 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9573 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9574 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9575 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9576 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9577 { greek7 iso-ir-88 csISO88Greek7 }
9578 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9579 { iso-ir-90 csISO90 }
9580 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9581 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9582 csISO92JISC62991984b }
9583 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9584 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9585 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9586 csISO95JIS62291984handadd }
9587 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9588 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9589 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9590 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9591 CP819 csISOLatin1 }
9592 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9593 { T.61-7bit iso-ir-102 csISO102T617bit }
9594 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9595 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9596 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9597 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9598 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9599 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9600 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9601 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9602 arabic csISOLatinArabic }
9603 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9604 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9605 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9606 greek greek8 csISOLatinGreek }
9607 { T.101-G2 iso-ir-128 csISO128T101G2 }
9608 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9609 csISOLatinHebrew }
9610 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9611 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9612 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9613 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9614 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9615 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9616 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9617 csISOLatinCyrillic }
9618 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9619 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9620 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9621 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9622 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9623 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9624 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9625 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9626 { ISO_10367-box iso-ir-155 csISO10367Box }
9627 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9628 { latin-lap lap iso-ir-158 csISO158Lap }
9629 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9630 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9631 { us-dk csUSDK }
9632 { dk-us csDKUS }
9633 { JIS_X0201 X0201 csHalfWidthKatakana }
9634 { KSC5636 ISO646-KR csKSC5636 }
9635 { ISO-10646-UCS-2 csUnicode }
9636 { ISO-10646-UCS-4 csUCS4 }
9637 { DEC-MCS dec csDECMCS }
9638 { hp-roman8 roman8 r8 csHPRoman8 }
9639 { macintosh mac csMacintosh }
9640 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9641 csIBM037 }
9642 { IBM038 EBCDIC-INT cp038 csIBM038 }
9643 { IBM273 CP273 csIBM273 }
9644 { IBM274 EBCDIC-BE CP274 csIBM274 }
9645 { IBM275 EBCDIC-BR cp275 csIBM275 }
9646 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9647 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9648 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9649 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9650 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9651 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9652 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9653 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9654 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9655 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9656 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9657 { IBM437 cp437 437 csPC8CodePage437 }
9658 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9659 { IBM775 cp775 csPC775Baltic }
9660 { IBM850 cp850 850 csPC850Multilingual }
9661 { IBM851 cp851 851 csIBM851 }
9662 { IBM852 cp852 852 csPCp852 }
9663 { IBM855 cp855 855 csIBM855 }
9664 { IBM857 cp857 857 csIBM857 }
9665 { IBM860 cp860 860 csIBM860 }
9666 { IBM861 cp861 861 cp-is csIBM861 }
9667 { IBM862 cp862 862 csPC862LatinHebrew }
9668 { IBM863 cp863 863 csIBM863 }
9669 { IBM864 cp864 csIBM864 }
9670 { IBM865 cp865 865 csIBM865 }
9671 { IBM866 cp866 866 csIBM866 }
9672 { IBM868 CP868 cp-ar csIBM868 }
9673 { IBM869 cp869 869 cp-gr csIBM869 }
9674 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9675 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9676 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9677 { IBM891 cp891 csIBM891 }
9678 { IBM903 cp903 csIBM903 }
9679 { IBM904 cp904 904 csIBBM904 }
9680 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9681 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9682 { IBM1026 CP1026 csIBM1026 }
9683 { EBCDIC-AT-DE csIBMEBCDICATDE }
9684 { EBCDIC-AT-DE-A csEBCDICATDEA }
9685 { EBCDIC-CA-FR csEBCDICCAFR }
9686 { EBCDIC-DK-NO csEBCDICDKNO }
9687 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9688 { EBCDIC-FI-SE csEBCDICFISE }
9689 { EBCDIC-FI-SE-A csEBCDICFISEA }
9690 { EBCDIC-FR csEBCDICFR }
9691 { EBCDIC-IT csEBCDICIT }
9692 { EBCDIC-PT csEBCDICPT }
9693 { EBCDIC-ES csEBCDICES }
9694 { EBCDIC-ES-A csEBCDICESA }
9695 { EBCDIC-ES-S csEBCDICESS }
9696 { EBCDIC-UK csEBCDICUK }
9697 { EBCDIC-US csEBCDICUS }
9698 { UNKNOWN-8BIT csUnknown8BiT }
9699 { MNEMONIC csMnemonic }
9700 { MNEM csMnem }
9701 { VISCII csVISCII }
9702 { VIQR csVIQR }
9703 { KOI8-R csKOI8R }
9704 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9705 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9706 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9707 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9708 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9709 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9710 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9711 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9712 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9713 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9714 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9715 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9716 { IBM1047 IBM-1047 }
9717 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9718 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9719 { UNICODE-1-1 csUnicode11 }
9720 { CESU-8 csCESU-8 }
9721 { BOCU-1 csBOCU-1 }
9722 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9723 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9724 l8 }
9725 { ISO-8859-15 ISO_8859-15 Latin-9 }
9726 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9727 { GBK CP936 MS936 windows-936 }
9728 { JIS_Encoding csJISEncoding }
9729 { Shift_JIS MS_Kanji csShiftJIS }
9730 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9731 EUC-JP }
9732 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9733 { ISO-10646-UCS-Basic csUnicodeASCII }
9734 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9735 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9736 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9737 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9738 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9739 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9740 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9741 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9742 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9743 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9744 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9745 { Ventura-US csVenturaUS }
9746 { Ventura-International csVenturaInternational }
9747 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9748 { PC8-Turkish csPC8Turkish }
9749 { IBM-Symbols csIBMSymbols }
9750 { IBM-Thai csIBMThai }
9751 { HP-Legal csHPLegal }
9752 { HP-Pi-font csHPPiFont }
9753 { HP-Math8 csHPMath8 }
9754 { Adobe-Symbol-Encoding csHPPSMath }
9755 { HP-DeskTop csHPDesktop }
9756 { Ventura-Math csVenturaMath }
9757 { Microsoft-Publishing csMicrosoftPublishing }
9758 { Windows-31J csWindows31J }
9759 { GB2312 csGB2312 }
9760 { Big5 csBig5 }
9763 proc tcl_encoding {enc} {
9764 global encoding_aliases
9765 set names [encoding names]
9766 set lcnames [string tolower $names]
9767 set enc [string tolower $enc]
9768 set i [lsearch -exact $lcnames $enc]
9769 if {$i < 0} {
9770 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9771 if {[regsub {^iso[-_]} $enc iso encx]} {
9772 set i [lsearch -exact $lcnames $encx]
9775 if {$i < 0} {
9776 foreach l $encoding_aliases {
9777 set ll [string tolower $l]
9778 if {[lsearch -exact $ll $enc] < 0} continue
9779 # look through the aliases for one that tcl knows about
9780 foreach e $ll {
9781 set i [lsearch -exact $lcnames $e]
9782 if {$i < 0} {
9783 if {[regsub {^iso[-_]} $e iso ex]} {
9784 set i [lsearch -exact $lcnames $ex]
9787 if {$i >= 0} break
9789 break
9792 if {$i >= 0} {
9793 return [lindex $names $i]
9795 return {}
9798 # First check that Tcl/Tk is recent enough
9799 if {[catch {package require Tk 8.4} err]} {
9800 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9801 Gitk requires at least Tcl/Tk 8.4."]
9802 exit 1
9805 # defaults...
9806 set wrcomcmd "git diff-tree --stdin -p --pretty"
9808 set gitencoding {}
9809 catch {
9810 set gitencoding [exec git config --get i18n.commitencoding]
9812 if {$gitencoding == ""} {
9813 set gitencoding "utf-8"
9815 set tclencoding [tcl_encoding $gitencoding]
9816 if {$tclencoding == {}} {
9817 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9820 set mainfont {Helvetica 9}
9821 set textfont {Courier 9}
9822 set uifont {Helvetica 9 bold}
9823 set tabstop 8
9824 set findmergefiles 0
9825 set maxgraphpct 50
9826 set maxwidth 16
9827 set revlistorder 0
9828 set fastdate 0
9829 set uparrowlen 5
9830 set downarrowlen 5
9831 set mingaplen 100
9832 set cmitmode "patch"
9833 set wrapcomment "none"
9834 set showneartags 1
9835 set maxrefs 20
9836 set maxlinelen 200
9837 set showlocalchanges 1
9838 set limitdiffs 1
9839 set datetimeformat "%Y-%m-%d %H:%M:%S"
9840 set autoselect 1
9842 set extdifftool "meld"
9844 set colors {green red blue magenta darkgrey brown orange}
9845 set bgcolor white
9846 set fgcolor black
9847 set diffcolors {red "#00a000" blue}
9848 set diffcontext 3
9849 set ignorespace 0
9850 set selectbgcolor gray85
9852 set circlecolors {white blue gray blue blue}
9854 ## For msgcat loading, first locate the installation location.
9855 if { [info exists ::env(GITK_MSGSDIR)] } {
9856 ## Msgsdir was manually set in the environment.
9857 set gitk_msgsdir $::env(GITK_MSGSDIR)
9858 } else {
9859 ## Let's guess the prefix from argv0.
9860 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9861 set gitk_libdir [file join $gitk_prefix share gitk lib]
9862 set gitk_msgsdir [file join $gitk_libdir msgs]
9863 unset gitk_prefix
9866 ## Internationalization (i18n) through msgcat and gettext. See
9867 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9868 package require msgcat
9869 namespace import ::msgcat::mc
9870 ## And eventually load the actual message catalog
9871 ::msgcat::mcload $gitk_msgsdir
9873 catch {source ~/.gitk}
9875 font create optionfont -family sans-serif -size -12
9877 parsefont mainfont $mainfont
9878 eval font create mainfont [fontflags mainfont]
9879 eval font create mainfontbold [fontflags mainfont 1]
9881 parsefont textfont $textfont
9882 eval font create textfont [fontflags textfont]
9883 eval font create textfontbold [fontflags textfont 1]
9885 parsefont uifont $uifont
9886 eval font create uifont [fontflags uifont]
9888 setoptions
9890 # check that we can find a .git directory somewhere...
9891 if {[catch {set gitdir [gitdir]}]} {
9892 show_error {} . [mc "Cannot find a git repository here."]
9893 exit 1
9895 if {![file isdirectory $gitdir]} {
9896 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9897 exit 1
9900 set selecthead {}
9901 set selectheadid {}
9903 set revtreeargs {}
9904 set cmdline_files {}
9905 set i 0
9906 set revtreeargscmd {}
9907 foreach arg $argv {
9908 switch -glob -- $arg {
9909 "" { }
9910 "--" {
9911 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9912 break
9914 "--select-commit=*" {
9915 set selecthead [string range $arg 16 end]
9917 "--argscmd=*" {
9918 set revtreeargscmd [string range $arg 10 end]
9920 default {
9921 lappend revtreeargs $arg
9924 incr i
9927 if {$selecthead eq "HEAD"} {
9928 set selecthead {}
9931 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9932 # no -- on command line, but some arguments (other than --argscmd)
9933 if {[catch {
9934 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9935 set cmdline_files [split $f "\n"]
9936 set n [llength $cmdline_files]
9937 set revtreeargs [lrange $revtreeargs 0 end-$n]
9938 # Unfortunately git rev-parse doesn't produce an error when
9939 # something is both a revision and a filename. To be consistent
9940 # with git log and git rev-list, check revtreeargs for filenames.
9941 foreach arg $revtreeargs {
9942 if {[file exists $arg]} {
9943 show_error {} . [mc "Ambiguous argument '%s': both revision\
9944 and filename" $arg]
9945 exit 1
9948 } err]} {
9949 # unfortunately we get both stdout and stderr in $err,
9950 # so look for "fatal:".
9951 set i [string first "fatal:" $err]
9952 if {$i > 0} {
9953 set err [string range $err [expr {$i + 6}] end]
9955 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9956 exit 1
9960 set nullid "0000000000000000000000000000000000000000"
9961 set nullid2 "0000000000000000000000000000000000000001"
9962 set nullfile "/dev/null"
9964 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9966 set runq {}
9967 set history {}
9968 set historyindex 0
9969 set fh_serial 0
9970 set nhl_names {}
9971 set highlight_paths {}
9972 set findpattern {}
9973 set searchdirn -forwards
9974 set boldrows {}
9975 set boldnamerows {}
9976 set diffelide {0 0}
9977 set markingmatches 0
9978 set linkentercount 0
9979 set need_redisplay 0
9980 set nrows_drawn 0
9981 set firsttabstop 0
9983 set nextviewnum 1
9984 set curview 0
9985 set selectedview 0
9986 set selectedhlview [mc "None"]
9987 set highlight_related [mc "None"]
9988 set highlight_files {}
9989 set viewfiles(0) {}
9990 set viewperm(0) 0
9991 set viewargs(0) {}
9992 set viewargscmd(0) {}
9994 set selectedline {}
9995 set numcommits 0
9996 set loginstance 0
9997 set cmdlineok 0
9998 set stopped 0
9999 set stuffsaved 0
10000 set patchnum 0
10001 set lserial 0
10002 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10003 setcoords
10004 makewindow
10005 # wait for the window to become visible
10006 tkwait visibility .
10007 wm title . "[file tail $argv0]: [file tail [pwd]]"
10008 readrefs
10010 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10011 # create a view for the files/dirs specified on the command line
10012 set curview 1
10013 set selectedview 1
10014 set nextviewnum 2
10015 set viewname(1) [mc "Command line"]
10016 set viewfiles(1) $cmdline_files
10017 set viewargs(1) $revtreeargs
10018 set viewargscmd(1) $revtreeargscmd
10019 set viewperm(1) 0
10020 set vdatemode(1) 0
10021 addviewmenu 1
10022 .bar.view entryconf [mc "Edit view..."] -state normal
10023 .bar.view entryconf [mc "Delete view"] -state normal
10026 if {[info exists permviews]} {
10027 foreach v $permviews {
10028 set n $nextviewnum
10029 incr nextviewnum
10030 set viewname($n) [lindex $v 0]
10031 set viewfiles($n) [lindex $v 1]
10032 set viewargs($n) [lindex $v 2]
10033 set viewargscmd($n) [lindex $v 3]
10034 set viewperm($n) 1
10035 addviewmenu $n
10038 getcommits {}