Have a command that specifically invokes 'p4' (via system)
[git/dscho.git] / gitk-git / gitk
blobd093a39506798c750cc838f0085f6721e0f733a9
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
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
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
43 fileevent $fd readable {}
44 if {$runq eq {}} {
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
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 repeat [eval $script]
71 set t1 [clock clicks -milliseconds]
72 set t [expr {$t1 - $t0}]
73 set runq [lrange $runq 1 end]
74 if {$repeat ne {} && $repeat} {
75 if {$fd eq {} || $repeat == 2} {
76 # script returns 1 if it wants to be readded
77 # file readers return 2 if they could do more straight away
78 lappend runq [list $fd $script]
79 } else {
80 fileevent $fd readable [list filereadable $fd $script]
82 } elseif {$fd eq {}} {
83 unset isonrunq($script)
85 set t0 $t1
86 if {$t1 - $tstart >= 80} break
88 if {$runq ne {}} {
89 after idle dorunq
93 proc reg_instance {fd} {
94 global commfd leftover loginstance
96 set i [incr loginstance]
97 set commfd($i) $fd
98 set leftover($i) {}
99 return $i
102 proc unmerged_files {files} {
103 global nr_unmerged
105 # find the list of unmerged files
106 set mlist {}
107 set nr_unmerged 0
108 if {[catch {
109 set fd [open "| git ls-files -u" r]
110 } err]} {
111 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
112 exit 1
114 while {[gets $fd line] >= 0} {
115 set i [string first "\t" $line]
116 if {$i < 0} continue
117 set fname [string range $line [expr {$i+1}] end]
118 if {[lsearch -exact $mlist $fname] >= 0} continue
119 incr nr_unmerged
120 if {$files eq {} || [path_filter $files $fname]} {
121 lappend mlist $fname
124 catch {close $fd}
125 return $mlist
128 proc parseviewargs {n arglist} {
129 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
131 set vdatemode($n) 0
132 set vmergeonly($n) 0
133 set glflags {}
134 set diffargs {}
135 set nextisval 0
136 set revargs {}
137 set origargs $arglist
138 set allknown 1
139 set filtered 0
140 set i -1
141 foreach arg $arglist {
142 incr i
143 if {$nextisval} {
144 lappend glflags $arg
145 set nextisval 0
146 continue
148 switch -glob -- $arg {
149 "-d" -
150 "--date-order" {
151 set vdatemode($n) 1
152 # remove from origargs in case we hit an unknown option
153 set origargs [lreplace $origargs $i $i]
154 incr i -1
156 # These request or affect diff output, which we don't want.
157 # Some could be used to set our defaults for diff display.
158 "-[puabwcrRBMC]" -
159 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163 "--ignore-space-change" - "-U*" - "--unified=*" {
164 lappend diffargs $arg
166 # These cause our parsing of git log's output to fail, or else
167 # they're options we want to set ourselves, so ignore them.
168 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169 "--name-only" - "--name-status" - "--color" - "--color-words" -
170 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174 "--objects" - "--objects-edge" - "--reverse" {
176 # These are harmless, and some are even useful
177 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
178 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
179 "--full-history" - "--dense" - "--sparse" -
180 "--follow" - "--left-right" - "--encoding=*" {
181 lappend glflags $arg
183 # These mean that we get a subset of the commits
184 "--diff-filter=*" - "--no-merges" - "--unpacked" -
185 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
186 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
187 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
188 "--remove-empty" - "--first-parent" - "--cherry-pick" -
189 "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
190 set filtered 1
191 lappend glflags $arg
193 # This appears to be the only one that has a value as a
194 # separate word following it
195 "-n" {
196 set filtered 1
197 set nextisval 1
198 lappend glflags $arg
200 "--not" {
201 set notflag [expr {!$notflag}]
202 lappend revargs $arg
204 "--all" {
205 lappend revargs $arg
207 "--merge" {
208 set vmergeonly($n) 1
209 # git rev-parse doesn't understand --merge
210 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
212 # Other flag arguments including -<n>
213 "-*" {
214 if {[string is digit -strict [string range $arg 1 end]]} {
215 set filtered 1
216 } else {
217 # a flag argument that we don't recognize;
218 # that means we can't optimize
219 set allknown 0
221 lappend glflags $arg
223 # Non-flag arguments specify commits or ranges of commits
224 default {
225 if {[string match "*...*" $arg]} {
226 lappend revargs --gitk-symmetric-diff-marker
228 lappend revargs $arg
232 set vdflags($n) $diffargs
233 set vflags($n) $glflags
234 set vrevs($n) $revargs
235 set vfiltered($n) $filtered
236 set vorigargs($n) $origargs
237 return $allknown
240 proc parseviewrevs {view revs} {
241 global vposids vnegids
243 if {$revs eq {}} {
244 set revs HEAD
246 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
247 # we get stdout followed by stderr in $err
248 # for an unknown rev, git rev-parse echoes it and then errors out
249 set errlines [split $err "\n"]
250 set badrev {}
251 for {set l 0} {$l < [llength $errlines]} {incr l} {
252 set line [lindex $errlines $l]
253 if {!([string length $line] == 40 && [string is xdigit $line])} {
254 if {[string match "fatal:*" $line]} {
255 if {[string match "fatal: ambiguous argument*" $line]
256 && $badrev ne {}} {
257 if {[llength $badrev] == 1} {
258 set err "unknown revision $badrev"
259 } else {
260 set err "unknown revisions: [join $badrev ", "]"
262 } else {
263 set err [join [lrange $errlines $l end] "\n"]
265 break
267 lappend badrev $line
270 error_popup "Error parsing revisions: $err"
271 return {}
273 set ret {}
274 set pos {}
275 set neg {}
276 set sdm 0
277 foreach id [split $ids "\n"] {
278 if {$id eq "--gitk-symmetric-diff-marker"} {
279 set sdm 4
280 } elseif {[string match "^*" $id]} {
281 if {$sdm != 1} {
282 lappend ret $id
283 if {$sdm == 3} {
284 set sdm 0
287 lappend neg [string range $id 1 end]
288 } else {
289 if {$sdm != 2} {
290 lappend ret $id
291 } else {
292 lset ret end [lindex $ret end]...$id
294 lappend pos $id
296 incr sdm -1
298 set vposids($view) $pos
299 set vnegids($view) $neg
300 return $ret
303 # Start off a git log process and arrange to read its output
304 proc start_rev_list {view} {
305 global startmsecs commitidx viewcomplete curview
306 global tclencoding
307 global viewargs viewargscmd viewfiles vfilelimit
308 global showlocalchanges commitinterest
309 global viewactive viewinstances vmergeonly
310 global mainheadid
311 global vcanopt vflags vrevs vorigargs
313 set startmsecs [clock clicks -milliseconds]
314 set commitidx($view) 0
315 # these are set this way for the error exits
316 set viewcomplete($view) 1
317 set viewactive($view) 0
318 varcinit $view
320 set args $viewargs($view)
321 if {$viewargscmd($view) ne {}} {
322 if {[catch {
323 set str [exec sh -c $viewargscmd($view)]
324 } err]} {
325 error_popup "Error executing --argscmd command: $err"
326 return 0
328 set args [concat $args [split $str "\n"]]
330 set vcanopt($view) [parseviewargs $view $args]
332 set files $viewfiles($view)
333 if {$vmergeonly($view)} {
334 set files [unmerged_files $files]
335 if {$files eq {}} {
336 global nr_unmerged
337 if {$nr_unmerged == 0} {
338 error_popup [mc "No files selected: --merge specified but\
339 no files are unmerged."]
340 } else {
341 error_popup [mc "No files selected: --merge specified but\
342 no unmerged files are within file limit."]
344 return 0
347 set vfilelimit($view) $files
349 if {$vcanopt($view)} {
350 set revs [parseviewrevs $view $vrevs($view)]
351 if {$revs eq {}} {
352 return 0
354 set args [concat $vflags($view) $revs]
355 } else {
356 set args $vorigargs($view)
359 if {[catch {
360 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
361 --boundary $args "--" $files] r]
362 } err]} {
363 error_popup "[mc "Error executing git log:"] $err"
364 return 0
366 set i [reg_instance $fd]
367 set viewinstances($view) [list $i]
368 if {$showlocalchanges && $mainheadid ne {}} {
369 lappend commitinterest($mainheadid) {dodiffindex}
371 fconfigure $fd -blocking 0 -translation lf -eofchar {}
372 if {$tclencoding != {}} {
373 fconfigure $fd -encoding $tclencoding
375 filerun $fd [list getcommitlines $fd $i $view 0]
376 nowbusy $view [mc "Reading"]
377 set viewcomplete($view) 0
378 set viewactive($view) 1
379 return 1
382 proc stop_instance {inst} {
383 global commfd leftover
385 set fd $commfd($inst)
386 catch {
387 set pid [pid $fd]
389 if {$::tcl_platform(platform) eq {windows}} {
390 exec kill -f $pid
391 } else {
392 exec kill $pid
395 catch {close $fd}
396 nukefile $fd
397 unset commfd($inst)
398 unset leftover($inst)
401 proc stop_backends {} {
402 global commfd
404 foreach inst [array names commfd] {
405 stop_instance $inst
409 proc stop_rev_list {view} {
410 global viewinstances
412 foreach inst $viewinstances($view) {
413 stop_instance $inst
415 set viewinstances($view) {}
418 proc reset_pending_select {selid} {
419 global pending_select mainheadid
421 if {$selid ne {}} {
422 set pending_select $selid
423 } else {
424 set pending_select $mainheadid
428 proc getcommits {selid} {
429 global canv curview need_redisplay viewactive
431 initlayout
432 if {[start_rev_list $curview]} {
433 reset_pending_select $selid
434 show_status [mc "Reading commits..."]
435 set need_redisplay 1
436 } else {
437 show_status [mc "No commits selected"]
441 proc updatecommits {} {
442 global curview vcanopt vorigargs vfilelimit viewinstances
443 global viewactive viewcomplete tclencoding
444 global startmsecs showneartags showlocalchanges
445 global mainheadid pending_select
446 global isworktree
447 global varcid vposids vnegids vflags vrevs
449 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
450 set oldmainid $mainheadid
451 rereadrefs
452 if {$showlocalchanges} {
453 if {$mainheadid ne $oldmainid} {
454 dohidelocalchanges
456 if {[commitinview $mainheadid $curview]} {
457 dodiffindex
460 set view $curview
461 if {$vcanopt($view)} {
462 set oldpos $vposids($view)
463 set oldneg $vnegids($view)
464 set revs [parseviewrevs $view $vrevs($view)]
465 if {$revs eq {}} {
466 return
468 # note: getting the delta when negative refs change is hard,
469 # and could require multiple git log invocations, so in that
470 # case we ask git log for all the commits (not just the delta)
471 if {$oldneg eq $vnegids($view)} {
472 set newrevs {}
473 set npos 0
474 # take out positive refs that we asked for before or
475 # that we have already seen
476 foreach rev $revs {
477 if {[string length $rev] == 40} {
478 if {[lsearch -exact $oldpos $rev] < 0
479 && ![info exists varcid($view,$rev)]} {
480 lappend newrevs $rev
481 incr npos
483 } else {
484 lappend $newrevs $rev
487 if {$npos == 0} return
488 set revs $newrevs
489 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
491 set args [concat $vflags($view) $revs --not $oldpos]
492 } else {
493 set args $vorigargs($view)
495 if {[catch {
496 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
497 --boundary $args "--" $vfilelimit($view)] r]
498 } err]} {
499 error_popup "Error executing git log: $err"
500 return
502 if {$viewactive($view) == 0} {
503 set startmsecs [clock clicks -milliseconds]
505 set i [reg_instance $fd]
506 lappend viewinstances($view) $i
507 fconfigure $fd -blocking 0 -translation lf -eofchar {}
508 if {$tclencoding != {}} {
509 fconfigure $fd -encoding $tclencoding
511 filerun $fd [list getcommitlines $fd $i $view 1]
512 incr viewactive($view)
513 set viewcomplete($view) 0
514 reset_pending_select {}
515 nowbusy $view "Reading"
516 if {$showneartags} {
517 getallcommits
521 proc reloadcommits {} {
522 global curview viewcomplete selectedline currentid thickerline
523 global showneartags treediffs commitinterest cached_commitrow
524 global targetid
526 set selid {}
527 if {$selectedline ne {}} {
528 set selid $currentid
531 if {!$viewcomplete($curview)} {
532 stop_rev_list $curview
534 resetvarcs $curview
535 set selectedline {}
536 catch {unset currentid}
537 catch {unset thickerline}
538 catch {unset treediffs}
539 readrefs
540 changedrefs
541 if {$showneartags} {
542 getallcommits
544 clear_display
545 catch {unset commitinterest}
546 catch {unset cached_commitrow}
547 catch {unset targetid}
548 setcanvscroll
549 getcommits $selid
550 return 0
553 # This makes a string representation of a positive integer which
554 # sorts as a string in numerical order
555 proc strrep {n} {
556 if {$n < 16} {
557 return [format "%x" $n]
558 } elseif {$n < 256} {
559 return [format "x%.2x" $n]
560 } elseif {$n < 65536} {
561 return [format "y%.4x" $n]
563 return [format "z%.8x" $n]
566 # Procedures used in reordering commits from git log (without
567 # --topo-order) into the order for display.
569 proc varcinit {view} {
570 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
571 global vtokmod varcmod vrowmod varcix vlastins
573 set varcstart($view) {{}}
574 set vupptr($view) {0}
575 set vdownptr($view) {0}
576 set vleftptr($view) {0}
577 set vbackptr($view) {0}
578 set varctok($view) {{}}
579 set varcrow($view) {{}}
580 set vtokmod($view) {}
581 set varcmod($view) 0
582 set vrowmod($view) 0
583 set varcix($view) {{}}
584 set vlastins($view) {0}
587 proc resetvarcs {view} {
588 global varcid varccommits parents children vseedcount ordertok
590 foreach vid [array names varcid $view,*] {
591 unset varcid($vid)
592 unset children($vid)
593 unset parents($vid)
595 # some commits might have children but haven't been seen yet
596 foreach vid [array names children $view,*] {
597 unset children($vid)
599 foreach va [array names varccommits $view,*] {
600 unset varccommits($va)
602 foreach vd [array names vseedcount $view,*] {
603 unset vseedcount($vd)
605 catch {unset ordertok}
608 # returns a list of the commits with no children
609 proc seeds {v} {
610 global vdownptr vleftptr varcstart
612 set ret {}
613 set a [lindex $vdownptr($v) 0]
614 while {$a != 0} {
615 lappend ret [lindex $varcstart($v) $a]
616 set a [lindex $vleftptr($v) $a]
618 return $ret
621 proc newvarc {view id} {
622 global varcid varctok parents children vdatemode
623 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
624 global commitdata commitinfo vseedcount varccommits vlastins
626 set a [llength $varctok($view)]
627 set vid $view,$id
628 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
629 if {![info exists commitinfo($id)]} {
630 parsecommit $id $commitdata($id) 1
632 set cdate [lindex $commitinfo($id) 4]
633 if {![string is integer -strict $cdate]} {
634 set cdate 0
636 if {![info exists vseedcount($view,$cdate)]} {
637 set vseedcount($view,$cdate) -1
639 set c [incr vseedcount($view,$cdate)]
640 set cdate [expr {$cdate ^ 0xffffffff}]
641 set tok "s[strrep $cdate][strrep $c]"
642 } else {
643 set tok {}
645 set ka 0
646 if {[llength $children($vid)] > 0} {
647 set kid [lindex $children($vid) end]
648 set k $varcid($view,$kid)
649 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
650 set ki $kid
651 set ka $k
652 set tok [lindex $varctok($view) $k]
655 if {$ka != 0} {
656 set i [lsearch -exact $parents($view,$ki) $id]
657 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
658 append tok [strrep $j]
660 set c [lindex $vlastins($view) $ka]
661 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
662 set c $ka
663 set b [lindex $vdownptr($view) $ka]
664 } else {
665 set b [lindex $vleftptr($view) $c]
667 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
668 set c $b
669 set b [lindex $vleftptr($view) $c]
671 if {$c == $ka} {
672 lset vdownptr($view) $ka $a
673 lappend vbackptr($view) 0
674 } else {
675 lset vleftptr($view) $c $a
676 lappend vbackptr($view) $c
678 lset vlastins($view) $ka $a
679 lappend vupptr($view) $ka
680 lappend vleftptr($view) $b
681 if {$b != 0} {
682 lset vbackptr($view) $b $a
684 lappend varctok($view) $tok
685 lappend varcstart($view) $id
686 lappend vdownptr($view) 0
687 lappend varcrow($view) {}
688 lappend varcix($view) {}
689 set varccommits($view,$a) {}
690 lappend vlastins($view) 0
691 return $a
694 proc splitvarc {p v} {
695 global varcid varcstart varccommits varctok
696 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
698 set oa $varcid($v,$p)
699 set ac $varccommits($v,$oa)
700 set i [lsearch -exact $varccommits($v,$oa) $p]
701 if {$i <= 0} return
702 set na [llength $varctok($v)]
703 # "%" sorts before "0"...
704 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
705 lappend varctok($v) $tok
706 lappend varcrow($v) {}
707 lappend varcix($v) {}
708 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
709 set varccommits($v,$na) [lrange $ac $i end]
710 lappend varcstart($v) $p
711 foreach id $varccommits($v,$na) {
712 set varcid($v,$id) $na
714 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
715 lappend vlastins($v) [lindex $vlastins($v) $oa]
716 lset vdownptr($v) $oa $na
717 lset vlastins($v) $oa 0
718 lappend vupptr($v) $oa
719 lappend vleftptr($v) 0
720 lappend vbackptr($v) 0
721 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
722 lset vupptr($v) $b $na
726 proc renumbervarc {a v} {
727 global parents children varctok varcstart varccommits
728 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
730 set t1 [clock clicks -milliseconds]
731 set todo {}
732 set isrelated($a) 1
733 set kidchanged($a) 1
734 set ntot 0
735 while {$a != 0} {
736 if {[info exists isrelated($a)]} {
737 lappend todo $a
738 set id [lindex $varccommits($v,$a) end]
739 foreach p $parents($v,$id) {
740 if {[info exists varcid($v,$p)]} {
741 set isrelated($varcid($v,$p)) 1
745 incr ntot
746 set b [lindex $vdownptr($v) $a]
747 if {$b == 0} {
748 while {$a != 0} {
749 set b [lindex $vleftptr($v) $a]
750 if {$b != 0} break
751 set a [lindex $vupptr($v) $a]
754 set a $b
756 foreach a $todo {
757 if {![info exists kidchanged($a)]} continue
758 set id [lindex $varcstart($v) $a]
759 if {[llength $children($v,$id)] > 1} {
760 set children($v,$id) [lsort -command [list vtokcmp $v] \
761 $children($v,$id)]
763 set oldtok [lindex $varctok($v) $a]
764 if {!$vdatemode($v)} {
765 set tok {}
766 } else {
767 set tok $oldtok
769 set ka 0
770 set kid [last_real_child $v,$id]
771 if {$kid ne {}} {
772 set k $varcid($v,$kid)
773 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
774 set ki $kid
775 set ka $k
776 set tok [lindex $varctok($v) $k]
779 if {$ka != 0} {
780 set i [lsearch -exact $parents($v,$ki) $id]
781 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
782 append tok [strrep $j]
784 if {$tok eq $oldtok} {
785 continue
787 set id [lindex $varccommits($v,$a) end]
788 foreach p $parents($v,$id) {
789 if {[info exists varcid($v,$p)]} {
790 set kidchanged($varcid($v,$p)) 1
791 } else {
792 set sortkids($p) 1
795 lset varctok($v) $a $tok
796 set b [lindex $vupptr($v) $a]
797 if {$b != $ka} {
798 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
799 modify_arc $v $ka
801 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
802 modify_arc $v $b
804 set c [lindex $vbackptr($v) $a]
805 set d [lindex $vleftptr($v) $a]
806 if {$c == 0} {
807 lset vdownptr($v) $b $d
808 } else {
809 lset vleftptr($v) $c $d
811 if {$d != 0} {
812 lset vbackptr($v) $d $c
814 if {[lindex $vlastins($v) $b] == $a} {
815 lset vlastins($v) $b $c
817 lset vupptr($v) $a $ka
818 set c [lindex $vlastins($v) $ka]
819 if {$c == 0 || \
820 [string compare $tok [lindex $varctok($v) $c]] < 0} {
821 set c $ka
822 set b [lindex $vdownptr($v) $ka]
823 } else {
824 set b [lindex $vleftptr($v) $c]
826 while {$b != 0 && \
827 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
828 set c $b
829 set b [lindex $vleftptr($v) $c]
831 if {$c == $ka} {
832 lset vdownptr($v) $ka $a
833 lset vbackptr($v) $a 0
834 } else {
835 lset vleftptr($v) $c $a
836 lset vbackptr($v) $a $c
838 lset vleftptr($v) $a $b
839 if {$b != 0} {
840 lset vbackptr($v) $b $a
842 lset vlastins($v) $ka $a
845 foreach id [array names sortkids] {
846 if {[llength $children($v,$id)] > 1} {
847 set children($v,$id) [lsort -command [list vtokcmp $v] \
848 $children($v,$id)]
851 set t2 [clock clicks -milliseconds]
852 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
855 # Fix up the graph after we have found out that in view $v,
856 # $p (a commit that we have already seen) is actually the parent
857 # of the last commit in arc $a.
858 proc fix_reversal {p a v} {
859 global varcid varcstart varctok vupptr
861 set pa $varcid($v,$p)
862 if {$p ne [lindex $varcstart($v) $pa]} {
863 splitvarc $p $v
864 set pa $varcid($v,$p)
866 # seeds always need to be renumbered
867 if {[lindex $vupptr($v) $pa] == 0 ||
868 [string compare [lindex $varctok($v) $a] \
869 [lindex $varctok($v) $pa]] > 0} {
870 renumbervarc $pa $v
874 proc insertrow {id p v} {
875 global cmitlisted children parents varcid varctok vtokmod
876 global varccommits ordertok commitidx numcommits curview
877 global targetid targetrow
879 readcommit $id
880 set vid $v,$id
881 set cmitlisted($vid) 1
882 set children($vid) {}
883 set parents($vid) [list $p]
884 set a [newvarc $v $id]
885 set varcid($vid) $a
886 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
887 modify_arc $v $a
889 lappend varccommits($v,$a) $id
890 set vp $v,$p
891 if {[llength [lappend children($vp) $id]] > 1} {
892 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
893 catch {unset ordertok}
895 fix_reversal $p $a $v
896 incr commitidx($v)
897 if {$v == $curview} {
898 set numcommits $commitidx($v)
899 setcanvscroll
900 if {[info exists targetid]} {
901 if {![comes_before $targetid $p]} {
902 incr targetrow
908 proc insertfakerow {id p} {
909 global varcid varccommits parents children cmitlisted
910 global commitidx varctok vtokmod targetid targetrow curview numcommits
912 set v $curview
913 set a $varcid($v,$p)
914 set i [lsearch -exact $varccommits($v,$a) $p]
915 if {$i < 0} {
916 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
917 return
919 set children($v,$id) {}
920 set parents($v,$id) [list $p]
921 set varcid($v,$id) $a
922 lappend children($v,$p) $id
923 set cmitlisted($v,$id) 1
924 set numcommits [incr commitidx($v)]
925 # note we deliberately don't update varcstart($v) even if $i == 0
926 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
927 modify_arc $v $a $i
928 if {[info exists targetid]} {
929 if {![comes_before $targetid $p]} {
930 incr targetrow
933 setcanvscroll
934 drawvisible
937 proc removefakerow {id} {
938 global varcid varccommits parents children commitidx
939 global varctok vtokmod cmitlisted currentid selectedline
940 global targetid curview numcommits
942 set v $curview
943 if {[llength $parents($v,$id)] != 1} {
944 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
945 return
947 set p [lindex $parents($v,$id) 0]
948 set a $varcid($v,$id)
949 set i [lsearch -exact $varccommits($v,$a) $id]
950 if {$i < 0} {
951 puts "oops: removefakerow can't find [shortids $id] on arc $a"
952 return
954 unset varcid($v,$id)
955 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
956 unset parents($v,$id)
957 unset children($v,$id)
958 unset cmitlisted($v,$id)
959 set numcommits [incr commitidx($v) -1]
960 set j [lsearch -exact $children($v,$p) $id]
961 if {$j >= 0} {
962 set children($v,$p) [lreplace $children($v,$p) $j $j]
964 modify_arc $v $a $i
965 if {[info exist currentid] && $id eq $currentid} {
966 unset currentid
967 set selectedline {}
969 if {[info exists targetid] && $targetid eq $id} {
970 set targetid $p
972 setcanvscroll
973 drawvisible
976 proc first_real_child {vp} {
977 global children nullid nullid2
979 foreach id $children($vp) {
980 if {$id ne $nullid && $id ne $nullid2} {
981 return $id
984 return {}
987 proc last_real_child {vp} {
988 global children nullid nullid2
990 set kids $children($vp)
991 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
992 set id [lindex $kids $i]
993 if {$id ne $nullid && $id ne $nullid2} {
994 return $id
997 return {}
1000 proc vtokcmp {v a b} {
1001 global varctok varcid
1003 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1004 [lindex $varctok($v) $varcid($v,$b)]]
1007 # This assumes that if lim is not given, the caller has checked that
1008 # arc a's token is less than $vtokmod($v)
1009 proc modify_arc {v a {lim {}}} {
1010 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1012 if {$lim ne {}} {
1013 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1014 if {$c > 0} return
1015 if {$c == 0} {
1016 set r [lindex $varcrow($v) $a]
1017 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1020 set vtokmod($v) [lindex $varctok($v) $a]
1021 set varcmod($v) $a
1022 if {$v == $curview} {
1023 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1024 set a [lindex $vupptr($v) $a]
1025 set lim {}
1027 set r 0
1028 if {$a != 0} {
1029 if {$lim eq {}} {
1030 set lim [llength $varccommits($v,$a)]
1032 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1034 set vrowmod($v) $r
1035 undolayout $r
1039 proc update_arcrows {v} {
1040 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1041 global varcid vrownum varcorder varcix varccommits
1042 global vupptr vdownptr vleftptr varctok
1043 global displayorder parentlist curview cached_commitrow
1045 if {$vrowmod($v) == $commitidx($v)} return
1046 if {$v == $curview} {
1047 if {[llength $displayorder] > $vrowmod($v)} {
1048 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1049 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1051 catch {unset cached_commitrow}
1053 set narctot [expr {[llength $varctok($v)] - 1}]
1054 set a $varcmod($v)
1055 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1056 # go up the tree until we find something that has a row number,
1057 # or we get to a seed
1058 set a [lindex $vupptr($v) $a]
1060 if {$a == 0} {
1061 set a [lindex $vdownptr($v) 0]
1062 if {$a == 0} return
1063 set vrownum($v) {0}
1064 set varcorder($v) [list $a]
1065 lset varcix($v) $a 0
1066 lset varcrow($v) $a 0
1067 set arcn 0
1068 set row 0
1069 } else {
1070 set arcn [lindex $varcix($v) $a]
1071 if {[llength $vrownum($v)] > $arcn + 1} {
1072 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1073 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1075 set row [lindex $varcrow($v) $a]
1077 while {1} {
1078 set p $a
1079 incr row [llength $varccommits($v,$a)]
1080 # go down if possible
1081 set b [lindex $vdownptr($v) $a]
1082 if {$b == 0} {
1083 # if not, go left, or go up until we can go left
1084 while {$a != 0} {
1085 set b [lindex $vleftptr($v) $a]
1086 if {$b != 0} break
1087 set a [lindex $vupptr($v) $a]
1089 if {$a == 0} break
1091 set a $b
1092 incr arcn
1093 lappend vrownum($v) $row
1094 lappend varcorder($v) $a
1095 lset varcix($v) $a $arcn
1096 lset varcrow($v) $a $row
1098 set vtokmod($v) [lindex $varctok($v) $p]
1099 set varcmod($v) $p
1100 set vrowmod($v) $row
1101 if {[info exists currentid]} {
1102 set selectedline [rowofcommit $currentid]
1106 # Test whether view $v contains commit $id
1107 proc commitinview {id v} {
1108 global varcid
1110 return [info exists varcid($v,$id)]
1113 # Return the row number for commit $id in the current view
1114 proc rowofcommit {id} {
1115 global varcid varccommits varcrow curview cached_commitrow
1116 global varctok vtokmod
1118 set v $curview
1119 if {![info exists varcid($v,$id)]} {
1120 puts "oops rowofcommit no arc for [shortids $id]"
1121 return {}
1123 set a $varcid($v,$id)
1124 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1125 update_arcrows $v
1127 if {[info exists cached_commitrow($id)]} {
1128 return $cached_commitrow($id)
1130 set i [lsearch -exact $varccommits($v,$a) $id]
1131 if {$i < 0} {
1132 puts "oops didn't find commit [shortids $id] in arc $a"
1133 return {}
1135 incr i [lindex $varcrow($v) $a]
1136 set cached_commitrow($id) $i
1137 return $i
1140 # Returns 1 if a is on an earlier row than b, otherwise 0
1141 proc comes_before {a b} {
1142 global varcid varctok curview
1144 set v $curview
1145 if {$a eq $b || ![info exists varcid($v,$a)] || \
1146 ![info exists varcid($v,$b)]} {
1147 return 0
1149 if {$varcid($v,$a) != $varcid($v,$b)} {
1150 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1151 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1153 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1156 proc bsearch {l elt} {
1157 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1158 return 0
1160 set lo 0
1161 set hi [llength $l]
1162 while {$hi - $lo > 1} {
1163 set mid [expr {int(($lo + $hi) / 2)}]
1164 set t [lindex $l $mid]
1165 if {$elt < $t} {
1166 set hi $mid
1167 } elseif {$elt > $t} {
1168 set lo $mid
1169 } else {
1170 return $mid
1173 return $lo
1176 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1177 proc make_disporder {start end} {
1178 global vrownum curview commitidx displayorder parentlist
1179 global varccommits varcorder parents vrowmod varcrow
1180 global d_valid_start d_valid_end
1182 if {$end > $vrowmod($curview)} {
1183 update_arcrows $curview
1185 set ai [bsearch $vrownum($curview) $start]
1186 set start [lindex $vrownum($curview) $ai]
1187 set narc [llength $vrownum($curview)]
1188 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1189 set a [lindex $varcorder($curview) $ai]
1190 set l [llength $displayorder]
1191 set al [llength $varccommits($curview,$a)]
1192 if {$l < $r + $al} {
1193 if {$l < $r} {
1194 set pad [ntimes [expr {$r - $l}] {}]
1195 set displayorder [concat $displayorder $pad]
1196 set parentlist [concat $parentlist $pad]
1197 } elseif {$l > $r} {
1198 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1199 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1201 foreach id $varccommits($curview,$a) {
1202 lappend displayorder $id
1203 lappend parentlist $parents($curview,$id)
1205 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1206 set i $r
1207 foreach id $varccommits($curview,$a) {
1208 lset displayorder $i $id
1209 lset parentlist $i $parents($curview,$id)
1210 incr i
1213 incr r $al
1217 proc commitonrow {row} {
1218 global displayorder
1220 set id [lindex $displayorder $row]
1221 if {$id eq {}} {
1222 make_disporder $row [expr {$row + 1}]
1223 set id [lindex $displayorder $row]
1225 return $id
1228 proc closevarcs {v} {
1229 global varctok varccommits varcid parents children
1230 global cmitlisted commitidx commitinterest vtokmod
1232 set missing_parents 0
1233 set scripts {}
1234 set narcs [llength $varctok($v)]
1235 for {set a 1} {$a < $narcs} {incr a} {
1236 set id [lindex $varccommits($v,$a) end]
1237 foreach p $parents($v,$id) {
1238 if {[info exists varcid($v,$p)]} continue
1239 # add p as a new commit
1240 incr missing_parents
1241 set cmitlisted($v,$p) 0
1242 set parents($v,$p) {}
1243 if {[llength $children($v,$p)] == 1 &&
1244 [llength $parents($v,$id)] == 1} {
1245 set b $a
1246 } else {
1247 set b [newvarc $v $p]
1249 set varcid($v,$p) $b
1250 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1251 modify_arc $v $b
1253 lappend varccommits($v,$b) $p
1254 incr commitidx($v)
1255 if {[info exists commitinterest($p)]} {
1256 foreach script $commitinterest($p) {
1257 lappend scripts [string map [list "%I" $p] $script]
1259 unset commitinterest($id)
1263 if {$missing_parents > 0} {
1264 foreach s $scripts {
1265 eval $s
1270 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1271 # Assumes we already have an arc for $rwid.
1272 proc rewrite_commit {v id rwid} {
1273 global children parents varcid varctok vtokmod varccommits
1275 foreach ch $children($v,$id) {
1276 # make $rwid be $ch's parent in place of $id
1277 set i [lsearch -exact $parents($v,$ch) $id]
1278 if {$i < 0} {
1279 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1281 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1282 # add $ch to $rwid's children and sort the list if necessary
1283 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1284 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1285 $children($v,$rwid)]
1287 # fix the graph after joining $id to $rwid
1288 set a $varcid($v,$ch)
1289 fix_reversal $rwid $a $v
1290 # parentlist is wrong for the last element of arc $a
1291 # even if displayorder is right, hence the 3rd arg here
1292 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1296 proc getcommitlines {fd inst view updating} {
1297 global cmitlisted commitinterest leftover
1298 global commitidx commitdata vdatemode
1299 global parents children curview hlview
1300 global idpending ordertok
1301 global varccommits varcid varctok vtokmod vfilelimit
1303 set stuff [read $fd 500000]
1304 # git log doesn't terminate the last commit with a null...
1305 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1306 set stuff "\0"
1308 if {$stuff == {}} {
1309 if {![eof $fd]} {
1310 return 1
1312 global commfd viewcomplete viewactive viewname
1313 global viewinstances
1314 unset commfd($inst)
1315 set i [lsearch -exact $viewinstances($view) $inst]
1316 if {$i >= 0} {
1317 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1319 # set it blocking so we wait for the process to terminate
1320 fconfigure $fd -blocking 1
1321 if {[catch {close $fd} err]} {
1322 set fv {}
1323 if {$view != $curview} {
1324 set fv " for the \"$viewname($view)\" view"
1326 if {[string range $err 0 4] == "usage"} {
1327 set err "Gitk: error reading commits$fv:\
1328 bad arguments to git log."
1329 if {$viewname($view) eq "Command line"} {
1330 append err \
1331 " (Note: arguments to gitk are passed to git log\
1332 to allow selection of commits to be displayed.)"
1334 } else {
1335 set err "Error reading commits$fv: $err"
1337 error_popup $err
1339 if {[incr viewactive($view) -1] <= 0} {
1340 set viewcomplete($view) 1
1341 # Check if we have seen any ids listed as parents that haven't
1342 # appeared in the list
1343 closevarcs $view
1344 notbusy $view
1346 if {$view == $curview} {
1347 run chewcommits
1349 return 0
1351 set start 0
1352 set gotsome 0
1353 set scripts {}
1354 while 1 {
1355 set i [string first "\0" $stuff $start]
1356 if {$i < 0} {
1357 append leftover($inst) [string range $stuff $start end]
1358 break
1360 if {$start == 0} {
1361 set cmit $leftover($inst)
1362 append cmit [string range $stuff 0 [expr {$i - 1}]]
1363 set leftover($inst) {}
1364 } else {
1365 set cmit [string range $stuff $start [expr {$i - 1}]]
1367 set start [expr {$i + 1}]
1368 set j [string first "\n" $cmit]
1369 set ok 0
1370 set listed 1
1371 if {$j >= 0 && [string match "commit *" $cmit]} {
1372 set ids [string range $cmit 7 [expr {$j - 1}]]
1373 if {[string match {[-^<>]*} $ids]} {
1374 switch -- [string index $ids 0] {
1375 "-" {set listed 0}
1376 "^" {set listed 2}
1377 "<" {set listed 3}
1378 ">" {set listed 4}
1380 set ids [string range $ids 1 end]
1382 set ok 1
1383 foreach id $ids {
1384 if {[string length $id] != 40} {
1385 set ok 0
1386 break
1390 if {!$ok} {
1391 set shortcmit $cmit
1392 if {[string length $shortcmit] > 80} {
1393 set shortcmit "[string range $shortcmit 0 80]..."
1395 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1396 exit 1
1398 set id [lindex $ids 0]
1399 set vid $view,$id
1401 if {!$listed && $updating && ![info exists varcid($vid)] &&
1402 $vfilelimit($view) ne {}} {
1403 # git log doesn't rewrite parents for unlisted commits
1404 # when doing path limiting, so work around that here
1405 # by working out the rewritten parent with git rev-list
1406 # and if we already know about it, using the rewritten
1407 # parent as a substitute parent for $id's children.
1408 if {![catch {
1409 set rwid [exec git rev-list --first-parent --max-count=1 \
1410 $id -- $vfilelimit($view)]
1411 }]} {
1412 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1413 # use $rwid in place of $id
1414 rewrite_commit $view $id $rwid
1415 continue
1420 set a 0
1421 if {[info exists varcid($vid)]} {
1422 if {$cmitlisted($vid) || !$listed} continue
1423 set a $varcid($vid)
1425 if {$listed} {
1426 set olds [lrange $ids 1 end]
1427 } else {
1428 set olds {}
1430 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1431 set cmitlisted($vid) $listed
1432 set parents($vid) $olds
1433 if {![info exists children($vid)]} {
1434 set children($vid) {}
1435 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1436 set k [lindex $children($vid) 0]
1437 if {[llength $parents($view,$k)] == 1 &&
1438 (!$vdatemode($view) ||
1439 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1440 set a $varcid($view,$k)
1443 if {$a == 0} {
1444 # new arc
1445 set a [newvarc $view $id]
1447 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1448 modify_arc $view $a
1450 if {![info exists varcid($vid)]} {
1451 set varcid($vid) $a
1452 lappend varccommits($view,$a) $id
1453 incr commitidx($view)
1456 set i 0
1457 foreach p $olds {
1458 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1459 set vp $view,$p
1460 if {[llength [lappend children($vp) $id]] > 1 &&
1461 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1462 set children($vp) [lsort -command [list vtokcmp $view] \
1463 $children($vp)]
1464 catch {unset ordertok}
1466 if {[info exists varcid($view,$p)]} {
1467 fix_reversal $p $a $view
1470 incr i
1473 if {[info exists commitinterest($id)]} {
1474 foreach script $commitinterest($id) {
1475 lappend scripts [string map [list "%I" $id] $script]
1477 unset commitinterest($id)
1479 set gotsome 1
1481 if {$gotsome} {
1482 global numcommits hlview
1484 if {$view == $curview} {
1485 set numcommits $commitidx($view)
1486 run chewcommits
1488 if {[info exists hlview] && $view == $hlview} {
1489 # we never actually get here...
1490 run vhighlightmore
1492 foreach s $scripts {
1493 eval $s
1496 return 2
1499 proc chewcommits {} {
1500 global curview hlview viewcomplete
1501 global pending_select
1503 layoutmore
1504 if {$viewcomplete($curview)} {
1505 global commitidx varctok
1506 global numcommits startmsecs
1508 if {[info exists pending_select]} {
1509 update
1510 reset_pending_select {}
1512 if {[commitinview $pending_select $curview]} {
1513 selectline [rowofcommit $pending_select] 1
1514 } else {
1515 set row [first_real_row]
1516 selectline $row 1
1519 if {$commitidx($curview) > 0} {
1520 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1521 #puts "overall $ms ms for $numcommits commits"
1522 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1523 } else {
1524 show_status [mc "No commits selected"]
1526 notbusy layout
1528 return 0
1531 proc readcommit {id} {
1532 if {[catch {set contents [exec git cat-file commit $id]}]} return
1533 parsecommit $id $contents 0
1536 proc parsecommit {id contents listed} {
1537 global commitinfo cdate
1539 set inhdr 1
1540 set comment {}
1541 set headline {}
1542 set auname {}
1543 set audate {}
1544 set comname {}
1545 set comdate {}
1546 set hdrend [string first "\n\n" $contents]
1547 if {$hdrend < 0} {
1548 # should never happen...
1549 set hdrend [string length $contents]
1551 set header [string range $contents 0 [expr {$hdrend - 1}]]
1552 set comment [string range $contents [expr {$hdrend + 2}] end]
1553 foreach line [split $header "\n"] {
1554 set tag [lindex $line 0]
1555 if {$tag == "author"} {
1556 set audate [lindex $line end-1]
1557 set auname [lrange $line 1 end-2]
1558 } elseif {$tag == "committer"} {
1559 set comdate [lindex $line end-1]
1560 set comname [lrange $line 1 end-2]
1563 set headline {}
1564 # take the first non-blank line of the comment as the headline
1565 set headline [string trimleft $comment]
1566 set i [string first "\n" $headline]
1567 if {$i >= 0} {
1568 set headline [string range $headline 0 $i]
1570 set headline [string trimright $headline]
1571 set i [string first "\r" $headline]
1572 if {$i >= 0} {
1573 set headline [string trimright [string range $headline 0 $i]]
1575 if {!$listed} {
1576 # git log indents the comment by 4 spaces;
1577 # if we got this via git cat-file, add the indentation
1578 set newcomment {}
1579 foreach line [split $comment "\n"] {
1580 append newcomment " "
1581 append newcomment $line
1582 append newcomment "\n"
1584 set comment $newcomment
1586 if {$comdate != {}} {
1587 set cdate($id) $comdate
1589 set commitinfo($id) [list $headline $auname $audate \
1590 $comname $comdate $comment]
1593 proc getcommit {id} {
1594 global commitdata commitinfo
1596 if {[info exists commitdata($id)]} {
1597 parsecommit $id $commitdata($id) 1
1598 } else {
1599 readcommit $id
1600 if {![info exists commitinfo($id)]} {
1601 set commitinfo($id) [list [mc "No commit information available"]]
1604 return 1
1607 proc readrefs {} {
1608 global tagids idtags headids idheads tagobjid
1609 global otherrefids idotherrefs mainhead mainheadid
1611 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1612 catch {unset $v}
1614 set refd [open [list | git show-ref -d] r]
1615 while {[gets $refd line] >= 0} {
1616 if {[string index $line 40] ne " "} continue
1617 set id [string range $line 0 39]
1618 set ref [string range $line 41 end]
1619 if {![string match "refs/*" $ref]} continue
1620 set name [string range $ref 5 end]
1621 if {[string match "remotes/*" $name]} {
1622 if {![string match "*/HEAD" $name]} {
1623 set headids($name) $id
1624 lappend idheads($id) $name
1626 } elseif {[string match "heads/*" $name]} {
1627 set name [string range $name 6 end]
1628 set headids($name) $id
1629 lappend idheads($id) $name
1630 } elseif {[string match "tags/*" $name]} {
1631 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1632 # which is what we want since the former is the commit ID
1633 set name [string range $name 5 end]
1634 if {[string match "*^{}" $name]} {
1635 set name [string range $name 0 end-3]
1636 } else {
1637 set tagobjid($name) $id
1639 set tagids($name) $id
1640 lappend idtags($id) $name
1641 } else {
1642 set otherrefids($name) $id
1643 lappend idotherrefs($id) $name
1646 catch {close $refd}
1647 set mainhead {}
1648 set mainheadid {}
1649 catch {
1650 set mainheadid [exec git rev-parse HEAD]
1651 set thehead [exec git symbolic-ref HEAD]
1652 if {[string match "refs/heads/*" $thehead]} {
1653 set mainhead [string range $thehead 11 end]
1658 # skip over fake commits
1659 proc first_real_row {} {
1660 global nullid nullid2 numcommits
1662 for {set row 0} {$row < $numcommits} {incr row} {
1663 set id [commitonrow $row]
1664 if {$id ne $nullid && $id ne $nullid2} {
1665 break
1668 return $row
1671 # update things for a head moved to a child of its previous location
1672 proc movehead {id name} {
1673 global headids idheads
1675 removehead $headids($name) $name
1676 set headids($name) $id
1677 lappend idheads($id) $name
1680 # update things when a head has been removed
1681 proc removehead {id name} {
1682 global headids idheads
1684 if {$idheads($id) eq $name} {
1685 unset idheads($id)
1686 } else {
1687 set i [lsearch -exact $idheads($id) $name]
1688 if {$i >= 0} {
1689 set idheads($id) [lreplace $idheads($id) $i $i]
1692 unset headids($name)
1695 proc show_error {w top msg} {
1696 message $w.m -text $msg -justify center -aspect 400
1697 pack $w.m -side top -fill x -padx 20 -pady 20
1698 button $w.ok -text [mc OK] -command "destroy $top"
1699 pack $w.ok -side bottom -fill x
1700 bind $top <Visibility> "grab $top; focus $top"
1701 bind $top <Key-Return> "destroy $top"
1702 tkwait window $top
1705 proc error_popup msg {
1706 set w .error
1707 toplevel $w
1708 wm transient $w .
1709 show_error $w $w $msg
1712 proc confirm_popup msg {
1713 global confirm_ok
1714 set confirm_ok 0
1715 set w .confirm
1716 toplevel $w
1717 wm transient $w .
1718 message $w.m -text $msg -justify center -aspect 400
1719 pack $w.m -side top -fill x -padx 20 -pady 20
1720 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1721 pack $w.ok -side left -fill x
1722 button $w.cancel -text [mc Cancel] -command "destroy $w"
1723 pack $w.cancel -side right -fill x
1724 bind $w <Visibility> "grab $w; focus $w"
1725 tkwait window $w
1726 return $confirm_ok
1729 proc setoptions {} {
1730 option add *Panedwindow.showHandle 1 startupFile
1731 option add *Panedwindow.sashRelief raised startupFile
1732 option add *Button.font uifont startupFile
1733 option add *Checkbutton.font uifont startupFile
1734 option add *Radiobutton.font uifont startupFile
1735 option add *Menu.font uifont startupFile
1736 option add *Menubutton.font uifont startupFile
1737 option add *Label.font uifont startupFile
1738 option add *Message.font uifont startupFile
1739 option add *Entry.font uifont startupFile
1742 proc makewindow {} {
1743 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1744 global tabstop
1745 global findtype findtypemenu findloc findstring fstring geometry
1746 global entries sha1entry sha1string sha1but
1747 global diffcontextstring diffcontext
1748 global ignorespace
1749 global maincursor textcursor curtextcursor
1750 global rowctxmenu fakerowmenu mergemax wrapcomment
1751 global highlight_files gdttype
1752 global searchstring sstring
1753 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1754 global headctxmenu progresscanv progressitem progresscoords statusw
1755 global fprogitem fprogcoord lastprogupdate progupdatepending
1756 global rprogitem rprogcoord rownumsel numcommits
1757 global have_tk85
1759 menu .bar
1760 .bar add cascade -label [mc "File"] -menu .bar.file
1761 menu .bar.file
1762 .bar.file add command -label [mc "Update"] -command updatecommits
1763 .bar.file add command -label [mc "Reload"] -command reloadcommits
1764 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1765 .bar.file add command -label [mc "List references"] -command showrefs
1766 .bar.file add command -label [mc "Quit"] -command doquit
1767 menu .bar.edit
1768 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1769 .bar.edit add command -label [mc "Preferences"] -command doprefs
1771 menu .bar.view
1772 .bar add cascade -label [mc "View"] -menu .bar.view
1773 .bar.view add command -label [mc "New view..."] -command {newview 0}
1774 .bar.view add command -label [mc "Edit view..."] -command editview \
1775 -state disabled
1776 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1777 .bar.view add separator
1778 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1779 -variable selectedview -value 0
1781 menu .bar.help
1782 .bar add cascade -label [mc "Help"] -menu .bar.help
1783 .bar.help add command -label [mc "About gitk"] -command about
1784 .bar.help add command -label [mc "Key bindings"] -command keys
1785 .bar.help configure
1786 . configure -menu .bar
1788 # the gui has upper and lower half, parts of a paned window.
1789 panedwindow .ctop -orient vertical
1791 # possibly use assumed geometry
1792 if {![info exists geometry(pwsash0)]} {
1793 set geometry(topheight) [expr {15 * $linespc}]
1794 set geometry(topwidth) [expr {80 * $charspc}]
1795 set geometry(botheight) [expr {15 * $linespc}]
1796 set geometry(botwidth) [expr {50 * $charspc}]
1797 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1798 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1801 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1802 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1803 frame .tf.histframe
1804 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1806 # create three canvases
1807 set cscroll .tf.histframe.csb
1808 set canv .tf.histframe.pwclist.canv
1809 canvas $canv \
1810 -selectbackground $selectbgcolor \
1811 -background $bgcolor -bd 0 \
1812 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1813 .tf.histframe.pwclist add $canv
1814 set canv2 .tf.histframe.pwclist.canv2
1815 canvas $canv2 \
1816 -selectbackground $selectbgcolor \
1817 -background $bgcolor -bd 0 -yscrollincr $linespc
1818 .tf.histframe.pwclist add $canv2
1819 set canv3 .tf.histframe.pwclist.canv3
1820 canvas $canv3 \
1821 -selectbackground $selectbgcolor \
1822 -background $bgcolor -bd 0 -yscrollincr $linespc
1823 .tf.histframe.pwclist add $canv3
1824 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1825 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1827 # a scroll bar to rule them
1828 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1829 pack $cscroll -side right -fill y
1830 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1831 lappend bglist $canv $canv2 $canv3
1832 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1834 # we have two button bars at bottom of top frame. Bar 1
1835 frame .tf.bar
1836 frame .tf.lbar -height 15
1838 set sha1entry .tf.bar.sha1
1839 set entries $sha1entry
1840 set sha1but .tf.bar.sha1label
1841 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1842 -command gotocommit -width 8
1843 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1844 pack .tf.bar.sha1label -side left
1845 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1846 trace add variable sha1string write sha1change
1847 pack $sha1entry -side left -pady 2
1849 image create bitmap bm-left -data {
1850 #define left_width 16
1851 #define left_height 16
1852 static unsigned char left_bits[] = {
1853 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1854 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1855 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1857 image create bitmap bm-right -data {
1858 #define right_width 16
1859 #define right_height 16
1860 static unsigned char right_bits[] = {
1861 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1862 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1863 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1865 button .tf.bar.leftbut -image bm-left -command goback \
1866 -state disabled -width 26
1867 pack .tf.bar.leftbut -side left -fill y
1868 button .tf.bar.rightbut -image bm-right -command goforw \
1869 -state disabled -width 26
1870 pack .tf.bar.rightbut -side left -fill y
1872 label .tf.bar.rowlabel -text [mc "Row"]
1873 set rownumsel {}
1874 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1875 -relief sunken -anchor e
1876 label .tf.bar.rowlabel2 -text "/"
1877 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1878 -relief sunken -anchor e
1879 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1880 -side left
1881 global selectedline
1882 trace add variable selectedline write selectedline_change
1884 # Status label and progress bar
1885 set statusw .tf.bar.status
1886 label $statusw -width 15 -relief sunken
1887 pack $statusw -side left -padx 5
1888 set h [expr {[font metrics uifont -linespace] + 2}]
1889 set progresscanv .tf.bar.progress
1890 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1891 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1892 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1893 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1894 pack $progresscanv -side right -expand 1 -fill x
1895 set progresscoords {0 0}
1896 set fprogcoord 0
1897 set rprogcoord 0
1898 bind $progresscanv <Configure> adjustprogress
1899 set lastprogupdate [clock clicks -milliseconds]
1900 set progupdatepending 0
1902 # build up the bottom bar of upper window
1903 label .tf.lbar.flabel -text "[mc "Find"] "
1904 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1905 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1906 label .tf.lbar.flab2 -text " [mc "commit"] "
1907 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1908 -side left -fill y
1909 set gdttype [mc "containing:"]
1910 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1911 [mc "containing:"] \
1912 [mc "touching paths:"] \
1913 [mc "adding/removing string:"]]
1914 trace add variable gdttype write gdttype_change
1915 pack .tf.lbar.gdttype -side left -fill y
1917 set findstring {}
1918 set fstring .tf.lbar.findstring
1919 lappend entries $fstring
1920 entry $fstring -width 30 -font textfont -textvariable findstring
1921 trace add variable findstring write find_change
1922 set findtype [mc "Exact"]
1923 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1924 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1925 trace add variable findtype write findcom_change
1926 set findloc [mc "All fields"]
1927 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1928 [mc "Comments"] [mc "Author"] [mc "Committer"]
1929 trace add variable findloc write find_change
1930 pack .tf.lbar.findloc -side right
1931 pack .tf.lbar.findtype -side right
1932 pack $fstring -side left -expand 1 -fill x
1934 # Finish putting the upper half of the viewer together
1935 pack .tf.lbar -in .tf -side bottom -fill x
1936 pack .tf.bar -in .tf -side bottom -fill x
1937 pack .tf.histframe -fill both -side top -expand 1
1938 .ctop add .tf
1939 .ctop paneconfigure .tf -height $geometry(topheight)
1940 .ctop paneconfigure .tf -width $geometry(topwidth)
1942 # now build up the bottom
1943 panedwindow .pwbottom -orient horizontal
1945 # lower left, a text box over search bar, scroll bar to the right
1946 # if we know window height, then that will set the lower text height, otherwise
1947 # we set lower text height which will drive window height
1948 if {[info exists geometry(main)]} {
1949 frame .bleft -width $geometry(botwidth)
1950 } else {
1951 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1953 frame .bleft.top
1954 frame .bleft.mid
1955 frame .bleft.bottom
1957 button .bleft.top.search -text [mc "Search"] -command dosearch
1958 pack .bleft.top.search -side left -padx 5
1959 set sstring .bleft.top.sstring
1960 entry $sstring -width 20 -font textfont -textvariable searchstring
1961 lappend entries $sstring
1962 trace add variable searchstring write incrsearch
1963 pack $sstring -side left -expand 1 -fill x
1964 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1965 -command changediffdisp -variable diffelide -value {0 0}
1966 radiobutton .bleft.mid.old -text [mc "Old version"] \
1967 -command changediffdisp -variable diffelide -value {0 1}
1968 radiobutton .bleft.mid.new -text [mc "New version"] \
1969 -command changediffdisp -variable diffelide -value {1 0}
1970 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1971 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1972 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1973 -from 1 -increment 1 -to 10000000 \
1974 -validate all -validatecommand "diffcontextvalidate %P" \
1975 -textvariable diffcontextstring
1976 .bleft.mid.diffcontext set $diffcontext
1977 trace add variable diffcontextstring write diffcontextchange
1978 lappend entries .bleft.mid.diffcontext
1979 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1980 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1981 -command changeignorespace -variable ignorespace
1982 pack .bleft.mid.ignspace -side left -padx 5
1983 set ctext .bleft.bottom.ctext
1984 text $ctext -background $bgcolor -foreground $fgcolor \
1985 -state disabled -font textfont \
1986 -yscrollcommand scrolltext -wrap none \
1987 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1988 if {$have_tk85} {
1989 $ctext conf -tabstyle wordprocessor
1991 scrollbar .bleft.bottom.sb -command "$ctext yview"
1992 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
1993 -width 10
1994 pack .bleft.top -side top -fill x
1995 pack .bleft.mid -side top -fill x
1996 grid $ctext .bleft.bottom.sb -sticky nsew
1997 grid .bleft.bottom.sbhorizontal -sticky ew
1998 grid columnconfigure .bleft.bottom 0 -weight 1
1999 grid rowconfigure .bleft.bottom 0 -weight 1
2000 grid rowconfigure .bleft.bottom 1 -weight 0
2001 pack .bleft.bottom -side top -fill both -expand 1
2002 lappend bglist $ctext
2003 lappend fglist $ctext
2005 $ctext tag conf comment -wrap $wrapcomment
2006 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2007 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2008 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2009 $ctext tag conf d1 -fore [lindex $diffcolors 1]
2010 $ctext tag conf m0 -fore red
2011 $ctext tag conf m1 -fore blue
2012 $ctext tag conf m2 -fore green
2013 $ctext tag conf m3 -fore purple
2014 $ctext tag conf m4 -fore brown
2015 $ctext tag conf m5 -fore "#009090"
2016 $ctext tag conf m6 -fore magenta
2017 $ctext tag conf m7 -fore "#808000"
2018 $ctext tag conf m8 -fore "#009000"
2019 $ctext tag conf m9 -fore "#ff0080"
2020 $ctext tag conf m10 -fore cyan
2021 $ctext tag conf m11 -fore "#b07070"
2022 $ctext tag conf m12 -fore "#70b0f0"
2023 $ctext tag conf m13 -fore "#70f0b0"
2024 $ctext tag conf m14 -fore "#f0b070"
2025 $ctext tag conf m15 -fore "#ff70b0"
2026 $ctext tag conf mmax -fore darkgrey
2027 set mergemax 16
2028 $ctext tag conf mresult -font textfontbold
2029 $ctext tag conf msep -font textfontbold
2030 $ctext tag conf found -back yellow
2032 .pwbottom add .bleft
2033 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2035 # lower right
2036 frame .bright
2037 frame .bright.mode
2038 radiobutton .bright.mode.patch -text [mc "Patch"] \
2039 -command reselectline -variable cmitmode -value "patch"
2040 radiobutton .bright.mode.tree -text [mc "Tree"] \
2041 -command reselectline -variable cmitmode -value "tree"
2042 grid .bright.mode.patch .bright.mode.tree -sticky ew
2043 pack .bright.mode -side top -fill x
2044 set cflist .bright.cfiles
2045 set indent [font measure mainfont "nn"]
2046 text $cflist \
2047 -selectbackground $selectbgcolor \
2048 -background $bgcolor -foreground $fgcolor \
2049 -font mainfont \
2050 -tabs [list $indent [expr {2 * $indent}]] \
2051 -yscrollcommand ".bright.sb set" \
2052 -cursor [. cget -cursor] \
2053 -spacing1 1 -spacing3 1
2054 lappend bglist $cflist
2055 lappend fglist $cflist
2056 scrollbar .bright.sb -command "$cflist yview"
2057 pack .bright.sb -side right -fill y
2058 pack $cflist -side left -fill both -expand 1
2059 $cflist tag configure highlight \
2060 -background [$cflist cget -selectbackground]
2061 $cflist tag configure bold -font mainfontbold
2063 .pwbottom add .bright
2064 .ctop add .pwbottom
2066 # restore window width & height if known
2067 if {[info exists geometry(main)]} {
2068 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2069 if {$w > [winfo screenwidth .]} {
2070 set w [winfo screenwidth .]
2072 if {$h > [winfo screenheight .]} {
2073 set h [winfo screenheight .]
2075 wm geometry . "${w}x$h"
2079 if {[tk windowingsystem] eq {aqua}} {
2080 set M1B M1
2081 } else {
2082 set M1B Control
2085 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2086 pack .ctop -fill both -expand 1
2087 bindall <1> {selcanvline %W %x %y}
2088 #bindall <B1-Motion> {selcanvline %W %x %y}
2089 if {[tk windowingsystem] == "win32"} {
2090 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2091 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2092 } else {
2093 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2094 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2095 if {[tk windowingsystem] eq "aqua"} {
2096 bindall <MouseWheel> {
2097 set delta [expr {- (%D)}]
2098 allcanvs yview scroll $delta units
2102 bindall <2> "canvscan mark %W %x %y"
2103 bindall <B2-Motion> "canvscan dragto %W %x %y"
2104 bindkey <Home> selfirstline
2105 bindkey <End> sellastline
2106 bind . <Key-Up> "selnextline -1"
2107 bind . <Key-Down> "selnextline 1"
2108 bind . <Shift-Key-Up> "dofind -1 0"
2109 bind . <Shift-Key-Down> "dofind 1 0"
2110 bindkey <Key-Right> "goforw"
2111 bindkey <Key-Left> "goback"
2112 bind . <Key-Prior> "selnextpage -1"
2113 bind . <Key-Next> "selnextpage 1"
2114 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2115 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2116 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2117 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2118 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2119 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2120 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2121 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2122 bindkey <Key-space> "$ctext yview scroll 1 pages"
2123 bindkey p "selnextline -1"
2124 bindkey n "selnextline 1"
2125 bindkey z "goback"
2126 bindkey x "goforw"
2127 bindkey i "selnextline -1"
2128 bindkey k "selnextline 1"
2129 bindkey j "goback"
2130 bindkey l "goforw"
2131 bindkey b prevfile
2132 bindkey d "$ctext yview scroll 18 units"
2133 bindkey u "$ctext yview scroll -18 units"
2134 bindkey / {dofind 1 1}
2135 bindkey <Key-Return> {dofind 1 1}
2136 bindkey ? {dofind -1 1}
2137 bindkey f nextfile
2138 bindkey <F5> updatecommits
2139 bind . <$M1B-q> doquit
2140 bind . <$M1B-f> {dofind 1 1}
2141 bind . <$M1B-g> {dofind 1 0}
2142 bind . <$M1B-r> dosearchback
2143 bind . <$M1B-s> dosearch
2144 bind . <$M1B-equal> {incrfont 1}
2145 bind . <$M1B-plus> {incrfont 1}
2146 bind . <$M1B-KP_Add> {incrfont 1}
2147 bind . <$M1B-minus> {incrfont -1}
2148 bind . <$M1B-KP_Subtract> {incrfont -1}
2149 wm protocol . WM_DELETE_WINDOW doquit
2150 bind . <Destroy> {stop_backends}
2151 bind . <Button-1> "click %W"
2152 bind $fstring <Key-Return> {dofind 1 1}
2153 bind $sha1entry <Key-Return> gotocommit
2154 bind $sha1entry <<PasteSelection>> clearsha1
2155 bind $cflist <1> {sel_flist %W %x %y; break}
2156 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2157 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2158 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
2160 set maincursor [. cget -cursor]
2161 set textcursor [$ctext cget -cursor]
2162 set curtextcursor $textcursor
2164 set rowctxmenu .rowctxmenu
2165 menu $rowctxmenu -tearoff 0
2166 $rowctxmenu add command -label [mc "Diff this -> selected"] \
2167 -command {diffvssel 0}
2168 $rowctxmenu add command -label [mc "Diff selected -> this"] \
2169 -command {diffvssel 1}
2170 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2171 $rowctxmenu add command -label [mc "Create tag"] -command mktag
2172 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2173 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2174 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2175 -command cherrypick
2176 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2177 -command resethead
2179 set fakerowmenu .fakerowmenu
2180 menu $fakerowmenu -tearoff 0
2181 $fakerowmenu add command -label [mc "Diff this -> selected"] \
2182 -command {diffvssel 0}
2183 $fakerowmenu add command -label [mc "Diff selected -> this"] \
2184 -command {diffvssel 1}
2185 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2186 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2187 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2188 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2190 set headctxmenu .headctxmenu
2191 menu $headctxmenu -tearoff 0
2192 $headctxmenu add command -label [mc "Check out this branch"] \
2193 -command cobranch
2194 $headctxmenu add command -label [mc "Remove this branch"] \
2195 -command rmbranch
2197 global flist_menu
2198 set flist_menu .flistctxmenu
2199 menu $flist_menu -tearoff 0
2200 $flist_menu add command -label [mc "Highlight this too"] \
2201 -command {flist_hl 0}
2202 $flist_menu add command -label [mc "Highlight this only"] \
2203 -command {flist_hl 1}
2204 $flist_menu add command -label [mc "External diff"] \
2205 -command {external_diff}
2208 # Windows sends all mouse wheel events to the current focused window, not
2209 # the one where the mouse hovers, so bind those events here and redirect
2210 # to the correct window
2211 proc windows_mousewheel_redirector {W X Y D} {
2212 global canv canv2 canv3
2213 set w [winfo containing -displayof $W $X $Y]
2214 if {$w ne ""} {
2215 set u [expr {$D < 0 ? 5 : -5}]
2216 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2217 allcanvs yview scroll $u units
2218 } else {
2219 catch {
2220 $w yview scroll $u units
2226 # Update row number label when selectedline changes
2227 proc selectedline_change {n1 n2 op} {
2228 global selectedline rownumsel
2230 if {$selectedline eq {}} {
2231 set rownumsel {}
2232 } else {
2233 set rownumsel [expr {$selectedline + 1}]
2237 # mouse-2 makes all windows scan vertically, but only the one
2238 # the cursor is in scans horizontally
2239 proc canvscan {op w x y} {
2240 global canv canv2 canv3
2241 foreach c [list $canv $canv2 $canv3] {
2242 if {$c == $w} {
2243 $c scan $op $x $y
2244 } else {
2245 $c scan $op 0 $y
2250 proc scrollcanv {cscroll f0 f1} {
2251 $cscroll set $f0 $f1
2252 drawvisible
2253 flushhighlights
2256 # when we make a key binding for the toplevel, make sure
2257 # it doesn't get triggered when that key is pressed in the
2258 # find string entry widget.
2259 proc bindkey {ev script} {
2260 global entries
2261 bind . $ev $script
2262 set escript [bind Entry $ev]
2263 if {$escript == {}} {
2264 set escript [bind Entry <Key>]
2266 foreach e $entries {
2267 bind $e $ev "$escript; break"
2271 # set the focus back to the toplevel for any click outside
2272 # the entry widgets
2273 proc click {w} {
2274 global ctext entries
2275 foreach e [concat $entries $ctext] {
2276 if {$w == $e} return
2278 focus .
2281 # Adjust the progress bar for a change in requested extent or canvas size
2282 proc adjustprogress {} {
2283 global progresscanv progressitem progresscoords
2284 global fprogitem fprogcoord lastprogupdate progupdatepending
2285 global rprogitem rprogcoord
2287 set w [expr {[winfo width $progresscanv] - 4}]
2288 set x0 [expr {$w * [lindex $progresscoords 0]}]
2289 set x1 [expr {$w * [lindex $progresscoords 1]}]
2290 set h [winfo height $progresscanv]
2291 $progresscanv coords $progressitem $x0 0 $x1 $h
2292 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2293 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2294 set now [clock clicks -milliseconds]
2295 if {$now >= $lastprogupdate + 100} {
2296 set progupdatepending 0
2297 update
2298 } elseif {!$progupdatepending} {
2299 set progupdatepending 1
2300 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2304 proc doprogupdate {} {
2305 global lastprogupdate progupdatepending
2307 if {$progupdatepending} {
2308 set progupdatepending 0
2309 set lastprogupdate [clock clicks -milliseconds]
2310 update
2314 proc savestuff {w} {
2315 global canv canv2 canv3 mainfont textfont uifont tabstop
2316 global stuffsaved findmergefiles maxgraphpct
2317 global maxwidth showneartags showlocalchanges
2318 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2319 global cmitmode wrapcomment datetimeformat limitdiffs
2320 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2321 global autoselect extdifftool
2323 if {$stuffsaved} return
2324 if {![winfo viewable .]} return
2325 catch {
2326 set f [open "~/.gitk-new" w]
2327 puts $f [list set mainfont $mainfont]
2328 puts $f [list set textfont $textfont]
2329 puts $f [list set uifont $uifont]
2330 puts $f [list set tabstop $tabstop]
2331 puts $f [list set findmergefiles $findmergefiles]
2332 puts $f [list set maxgraphpct $maxgraphpct]
2333 puts $f [list set maxwidth $maxwidth]
2334 puts $f [list set cmitmode $cmitmode]
2335 puts $f [list set wrapcomment $wrapcomment]
2336 puts $f [list set autoselect $autoselect]
2337 puts $f [list set showneartags $showneartags]
2338 puts $f [list set showlocalchanges $showlocalchanges]
2339 puts $f [list set datetimeformat $datetimeformat]
2340 puts $f [list set limitdiffs $limitdiffs]
2341 puts $f [list set bgcolor $bgcolor]
2342 puts $f [list set fgcolor $fgcolor]
2343 puts $f [list set colors $colors]
2344 puts $f [list set diffcolors $diffcolors]
2345 puts $f [list set diffcontext $diffcontext]
2346 puts $f [list set selectbgcolor $selectbgcolor]
2347 puts $f [list set extdifftool $extdifftool]
2349 puts $f "set geometry(main) [wm geometry .]"
2350 puts $f "set geometry(topwidth) [winfo width .tf]"
2351 puts $f "set geometry(topheight) [winfo height .tf]"
2352 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2353 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2354 puts $f "set geometry(botwidth) [winfo width .bleft]"
2355 puts $f "set geometry(botheight) [winfo height .bleft]"
2357 puts -nonewline $f "set permviews {"
2358 for {set v 0} {$v < $nextviewnum} {incr v} {
2359 if {$viewperm($v)} {
2360 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2363 puts $f "}"
2364 close $f
2365 file rename -force "~/.gitk-new" "~/.gitk"
2367 set stuffsaved 1
2370 proc resizeclistpanes {win w} {
2371 global oldwidth
2372 if {[info exists oldwidth($win)]} {
2373 set s0 [$win sash coord 0]
2374 set s1 [$win sash coord 1]
2375 if {$w < 60} {
2376 set sash0 [expr {int($w/2 - 2)}]
2377 set sash1 [expr {int($w*5/6 - 2)}]
2378 } else {
2379 set factor [expr {1.0 * $w / $oldwidth($win)}]
2380 set sash0 [expr {int($factor * [lindex $s0 0])}]
2381 set sash1 [expr {int($factor * [lindex $s1 0])}]
2382 if {$sash0 < 30} {
2383 set sash0 30
2385 if {$sash1 < $sash0 + 20} {
2386 set sash1 [expr {$sash0 + 20}]
2388 if {$sash1 > $w - 10} {
2389 set sash1 [expr {$w - 10}]
2390 if {$sash0 > $sash1 - 20} {
2391 set sash0 [expr {$sash1 - 20}]
2395 $win sash place 0 $sash0 [lindex $s0 1]
2396 $win sash place 1 $sash1 [lindex $s1 1]
2398 set oldwidth($win) $w
2401 proc resizecdetpanes {win w} {
2402 global oldwidth
2403 if {[info exists oldwidth($win)]} {
2404 set s0 [$win sash coord 0]
2405 if {$w < 60} {
2406 set sash0 [expr {int($w*3/4 - 2)}]
2407 } else {
2408 set factor [expr {1.0 * $w / $oldwidth($win)}]
2409 set sash0 [expr {int($factor * [lindex $s0 0])}]
2410 if {$sash0 < 45} {
2411 set sash0 45
2413 if {$sash0 > $w - 15} {
2414 set sash0 [expr {$w - 15}]
2417 $win sash place 0 $sash0 [lindex $s0 1]
2419 set oldwidth($win) $w
2422 proc allcanvs args {
2423 global canv canv2 canv3
2424 eval $canv $args
2425 eval $canv2 $args
2426 eval $canv3 $args
2429 proc bindall {event action} {
2430 global canv canv2 canv3
2431 bind $canv $event $action
2432 bind $canv2 $event $action
2433 bind $canv3 $event $action
2436 proc about {} {
2437 global uifont
2438 set w .about
2439 if {[winfo exists $w]} {
2440 raise $w
2441 return
2443 toplevel $w
2444 wm title $w [mc "About gitk"]
2445 message $w.m -text [mc "
2446 Gitk - a commit viewer for git
2448 Copyright © 2005-2008 Paul Mackerras
2450 Use and redistribute under the terms of the GNU General Public License"] \
2451 -justify center -aspect 400 -border 2 -bg white -relief groove
2452 pack $w.m -side top -fill x -padx 2 -pady 2
2453 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2454 pack $w.ok -side bottom
2455 bind $w <Visibility> "focus $w.ok"
2456 bind $w <Key-Escape> "destroy $w"
2457 bind $w <Key-Return> "destroy $w"
2460 proc keys {} {
2461 set w .keys
2462 if {[winfo exists $w]} {
2463 raise $w
2464 return
2466 if {[tk windowingsystem] eq {aqua}} {
2467 set M1T Cmd
2468 } else {
2469 set M1T Ctrl
2471 toplevel $w
2472 wm title $w [mc "Gitk key bindings"]
2473 message $w.m -text "
2474 [mc "Gitk key bindings:"]
2476 [mc "<%s-Q> Quit" $M1T]
2477 [mc "<Home> Move to first commit"]
2478 [mc "<End> Move to last commit"]
2479 [mc "<Up>, p, i Move up one commit"]
2480 [mc "<Down>, n, k Move down one commit"]
2481 [mc "<Left>, z, j Go back in history list"]
2482 [mc "<Right>, x, l Go forward in history list"]
2483 [mc "<PageUp> Move up one page in commit list"]
2484 [mc "<PageDown> Move down one page in commit list"]
2485 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2486 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2487 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2488 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2489 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2490 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2491 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2492 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2493 [mc "<Delete>, b Scroll diff view up one page"]
2494 [mc "<Backspace> Scroll diff view up one page"]
2495 [mc "<Space> Scroll diff view down one page"]
2496 [mc "u Scroll diff view up 18 lines"]
2497 [mc "d Scroll diff view down 18 lines"]
2498 [mc "<%s-F> Find" $M1T]
2499 [mc "<%s-G> Move to next find hit" $M1T]
2500 [mc "<Return> Move to next find hit"]
2501 [mc "/ Move to next find hit, or redo find"]
2502 [mc "? Move to previous find hit"]
2503 [mc "f Scroll diff view to next file"]
2504 [mc "<%s-S> Search for next hit in diff view" $M1T]
2505 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2506 [mc "<%s-KP+> Increase font size" $M1T]
2507 [mc "<%s-plus> Increase font size" $M1T]
2508 [mc "<%s-KP-> Decrease font size" $M1T]
2509 [mc "<%s-minus> Decrease font size" $M1T]
2510 [mc "<F5> Update"]
2512 -justify left -bg white -border 2 -relief groove
2513 pack $w.m -side top -fill both -padx 2 -pady 2
2514 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2515 pack $w.ok -side bottom
2516 bind $w <Visibility> "focus $w.ok"
2517 bind $w <Key-Escape> "destroy $w"
2518 bind $w <Key-Return> "destroy $w"
2521 # Procedures for manipulating the file list window at the
2522 # bottom right of the overall window.
2524 proc treeview {w l openlevs} {
2525 global treecontents treediropen treeheight treeparent treeindex
2527 set ix 0
2528 set treeindex() 0
2529 set lev 0
2530 set prefix {}
2531 set prefixend -1
2532 set prefendstack {}
2533 set htstack {}
2534 set ht 0
2535 set treecontents() {}
2536 $w conf -state normal
2537 foreach f $l {
2538 while {[string range $f 0 $prefixend] ne $prefix} {
2539 if {$lev <= $openlevs} {
2540 $w mark set e:$treeindex($prefix) "end -1c"
2541 $w mark gravity e:$treeindex($prefix) left
2543 set treeheight($prefix) $ht
2544 incr ht [lindex $htstack end]
2545 set htstack [lreplace $htstack end end]
2546 set prefixend [lindex $prefendstack end]
2547 set prefendstack [lreplace $prefendstack end end]
2548 set prefix [string range $prefix 0 $prefixend]
2549 incr lev -1
2551 set tail [string range $f [expr {$prefixend+1}] end]
2552 while {[set slash [string first "/" $tail]] >= 0} {
2553 lappend htstack $ht
2554 set ht 0
2555 lappend prefendstack $prefixend
2556 incr prefixend [expr {$slash + 1}]
2557 set d [string range $tail 0 $slash]
2558 lappend treecontents($prefix) $d
2559 set oldprefix $prefix
2560 append prefix $d
2561 set treecontents($prefix) {}
2562 set treeindex($prefix) [incr ix]
2563 set treeparent($prefix) $oldprefix
2564 set tail [string range $tail [expr {$slash+1}] end]
2565 if {$lev <= $openlevs} {
2566 set ht 1
2567 set treediropen($prefix) [expr {$lev < $openlevs}]
2568 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2569 $w mark set d:$ix "end -1c"
2570 $w mark gravity d:$ix left
2571 set str "\n"
2572 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2573 $w insert end $str
2574 $w image create end -align center -image $bm -padx 1 \
2575 -name a:$ix
2576 $w insert end $d [highlight_tag $prefix]
2577 $w mark set s:$ix "end -1c"
2578 $w mark gravity s:$ix left
2580 incr lev
2582 if {$tail ne {}} {
2583 if {$lev <= $openlevs} {
2584 incr ht
2585 set str "\n"
2586 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2587 $w insert end $str
2588 $w insert end $tail [highlight_tag $f]
2590 lappend treecontents($prefix) $tail
2593 while {$htstack ne {}} {
2594 set treeheight($prefix) $ht
2595 incr ht [lindex $htstack end]
2596 set htstack [lreplace $htstack end end]
2597 set prefixend [lindex $prefendstack end]
2598 set prefendstack [lreplace $prefendstack end end]
2599 set prefix [string range $prefix 0 $prefixend]
2601 $w conf -state disabled
2604 proc linetoelt {l} {
2605 global treeheight treecontents
2607 set y 2
2608 set prefix {}
2609 while {1} {
2610 foreach e $treecontents($prefix) {
2611 if {$y == $l} {
2612 return "$prefix$e"
2614 set n 1
2615 if {[string index $e end] eq "/"} {
2616 set n $treeheight($prefix$e)
2617 if {$y + $n > $l} {
2618 append prefix $e
2619 incr y
2620 break
2623 incr y $n
2628 proc highlight_tree {y prefix} {
2629 global treeheight treecontents cflist
2631 foreach e $treecontents($prefix) {
2632 set path $prefix$e
2633 if {[highlight_tag $path] ne {}} {
2634 $cflist tag add bold $y.0 "$y.0 lineend"
2636 incr y
2637 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2638 set y [highlight_tree $y $path]
2641 return $y
2644 proc treeclosedir {w dir} {
2645 global treediropen treeheight treeparent treeindex
2647 set ix $treeindex($dir)
2648 $w conf -state normal
2649 $w delete s:$ix e:$ix
2650 set treediropen($dir) 0
2651 $w image configure a:$ix -image tri-rt
2652 $w conf -state disabled
2653 set n [expr {1 - $treeheight($dir)}]
2654 while {$dir ne {}} {
2655 incr treeheight($dir) $n
2656 set dir $treeparent($dir)
2660 proc treeopendir {w dir} {
2661 global treediropen treeheight treeparent treecontents treeindex
2663 set ix $treeindex($dir)
2664 $w conf -state normal
2665 $w image configure a:$ix -image tri-dn
2666 $w mark set e:$ix s:$ix
2667 $w mark gravity e:$ix right
2668 set lev 0
2669 set str "\n"
2670 set n [llength $treecontents($dir)]
2671 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2672 incr lev
2673 append str "\t"
2674 incr treeheight($x) $n
2676 foreach e $treecontents($dir) {
2677 set de $dir$e
2678 if {[string index $e end] eq "/"} {
2679 set iy $treeindex($de)
2680 $w mark set d:$iy e:$ix
2681 $w mark gravity d:$iy left
2682 $w insert e:$ix $str
2683 set treediropen($de) 0
2684 $w image create e:$ix -align center -image tri-rt -padx 1 \
2685 -name a:$iy
2686 $w insert e:$ix $e [highlight_tag $de]
2687 $w mark set s:$iy e:$ix
2688 $w mark gravity s:$iy left
2689 set treeheight($de) 1
2690 } else {
2691 $w insert e:$ix $str
2692 $w insert e:$ix $e [highlight_tag $de]
2695 $w mark gravity e:$ix left
2696 $w conf -state disabled
2697 set treediropen($dir) 1
2698 set top [lindex [split [$w index @0,0] .] 0]
2699 set ht [$w cget -height]
2700 set l [lindex [split [$w index s:$ix] .] 0]
2701 if {$l < $top} {
2702 $w yview $l.0
2703 } elseif {$l + $n + 1 > $top + $ht} {
2704 set top [expr {$l + $n + 2 - $ht}]
2705 if {$l < $top} {
2706 set top $l
2708 $w yview $top.0
2712 proc treeclick {w x y} {
2713 global treediropen cmitmode ctext cflist cflist_top
2715 if {$cmitmode ne "tree"} return
2716 if {![info exists cflist_top]} return
2717 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2718 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2719 $cflist tag add highlight $l.0 "$l.0 lineend"
2720 set cflist_top $l
2721 if {$l == 1} {
2722 $ctext yview 1.0
2723 return
2725 set e [linetoelt $l]
2726 if {[string index $e end] ne "/"} {
2727 showfile $e
2728 } elseif {$treediropen($e)} {
2729 treeclosedir $w $e
2730 } else {
2731 treeopendir $w $e
2735 proc setfilelist {id} {
2736 global treefilelist cflist
2738 treeview $cflist $treefilelist($id) 0
2741 image create bitmap tri-rt -background black -foreground blue -data {
2742 #define tri-rt_width 13
2743 #define tri-rt_height 13
2744 static unsigned char tri-rt_bits[] = {
2745 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2746 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2747 0x00, 0x00};
2748 } -maskdata {
2749 #define tri-rt-mask_width 13
2750 #define tri-rt-mask_height 13
2751 static unsigned char tri-rt-mask_bits[] = {
2752 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2753 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2754 0x08, 0x00};
2756 image create bitmap tri-dn -background black -foreground blue -data {
2757 #define tri-dn_width 13
2758 #define tri-dn_height 13
2759 static unsigned char tri-dn_bits[] = {
2760 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2761 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2762 0x00, 0x00};
2763 } -maskdata {
2764 #define tri-dn-mask_width 13
2765 #define tri-dn-mask_height 13
2766 static unsigned char tri-dn-mask_bits[] = {
2767 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2768 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2769 0x00, 0x00};
2772 image create bitmap reficon-T -background black -foreground yellow -data {
2773 #define tagicon_width 13
2774 #define tagicon_height 9
2775 static unsigned char tagicon_bits[] = {
2776 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2777 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2778 } -maskdata {
2779 #define tagicon-mask_width 13
2780 #define tagicon-mask_height 9
2781 static unsigned char tagicon-mask_bits[] = {
2782 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2783 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2785 set rectdata {
2786 #define headicon_width 13
2787 #define headicon_height 9
2788 static unsigned char headicon_bits[] = {
2789 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2790 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2792 set rectmask {
2793 #define headicon-mask_width 13
2794 #define headicon-mask_height 9
2795 static unsigned char headicon-mask_bits[] = {
2796 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2797 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2799 image create bitmap reficon-H -background black -foreground green \
2800 -data $rectdata -maskdata $rectmask
2801 image create bitmap reficon-o -background black -foreground "#ddddff" \
2802 -data $rectdata -maskdata $rectmask
2804 proc init_flist {first} {
2805 global cflist cflist_top difffilestart
2807 $cflist conf -state normal
2808 $cflist delete 0.0 end
2809 if {$first ne {}} {
2810 $cflist insert end $first
2811 set cflist_top 1
2812 $cflist tag add highlight 1.0 "1.0 lineend"
2813 } else {
2814 catch {unset cflist_top}
2816 $cflist conf -state disabled
2817 set difffilestart {}
2820 proc highlight_tag {f} {
2821 global highlight_paths
2823 foreach p $highlight_paths {
2824 if {[string match $p $f]} {
2825 return "bold"
2828 return {}
2831 proc highlight_filelist {} {
2832 global cmitmode cflist
2834 $cflist conf -state normal
2835 if {$cmitmode ne "tree"} {
2836 set end [lindex [split [$cflist index end] .] 0]
2837 for {set l 2} {$l < $end} {incr l} {
2838 set line [$cflist get $l.0 "$l.0 lineend"]
2839 if {[highlight_tag $line] ne {}} {
2840 $cflist tag add bold $l.0 "$l.0 lineend"
2843 } else {
2844 highlight_tree 2 {}
2846 $cflist conf -state disabled
2849 proc unhighlight_filelist {} {
2850 global cflist
2852 $cflist conf -state normal
2853 $cflist tag remove bold 1.0 end
2854 $cflist conf -state disabled
2857 proc add_flist {fl} {
2858 global cflist
2860 $cflist conf -state normal
2861 foreach f $fl {
2862 $cflist insert end "\n"
2863 $cflist insert end $f [highlight_tag $f]
2865 $cflist conf -state disabled
2868 proc sel_flist {w x y} {
2869 global ctext difffilestart cflist cflist_top cmitmode
2871 if {$cmitmode eq "tree"} return
2872 if {![info exists cflist_top]} return
2873 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2874 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2875 $cflist tag add highlight $l.0 "$l.0 lineend"
2876 set cflist_top $l
2877 if {$l == 1} {
2878 $ctext yview 1.0
2879 } else {
2880 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2884 proc pop_flist_menu {w X Y x y} {
2885 global ctext cflist cmitmode flist_menu flist_menu_file
2886 global treediffs diffids
2888 stopfinding
2889 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2890 if {$l <= 1} return
2891 if {$cmitmode eq "tree"} {
2892 set e [linetoelt $l]
2893 if {[string index $e end] eq "/"} return
2894 } else {
2895 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2897 set flist_menu_file $e
2898 set xdiffstate "normal"
2899 if {$cmitmode eq "tree"} {
2900 set xdiffstate "disabled"
2902 # Disable "External diff" item in tree mode
2903 $flist_menu entryconf 2 -state $xdiffstate
2904 tk_popup $flist_menu $X $Y
2907 proc flist_hl {only} {
2908 global flist_menu_file findstring gdttype
2910 set x [shellquote $flist_menu_file]
2911 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2912 set findstring $x
2913 } else {
2914 append findstring " " $x
2916 set gdttype [mc "touching paths:"]
2919 proc save_file_from_commit {filename output what} {
2920 global nullfile
2922 if {[catch {exec git show $filename -- > $output} err]} {
2923 if {[string match "fatal: bad revision *" $err]} {
2924 return $nullfile
2926 error_popup "Error getting \"$filename\" from $what: $err"
2927 return {}
2929 return $output
2932 proc external_diff_get_one_file {diffid filename diffdir} {
2933 global nullid nullid2 nullfile
2934 global gitdir
2936 if {$diffid == $nullid} {
2937 set difffile [file join [file dirname $gitdir] $filename]
2938 if {[file exists $difffile]} {
2939 return $difffile
2941 return $nullfile
2943 if {$diffid == $nullid2} {
2944 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2945 return [save_file_from_commit :$filename $difffile index]
2947 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2948 return [save_file_from_commit $diffid:$filename $difffile \
2949 "revision $diffid"]
2952 proc external_diff {} {
2953 global gitktmpdir nullid nullid2
2954 global flist_menu_file
2955 global diffids
2956 global diffnum
2957 global gitdir extdifftool
2959 if {[llength $diffids] == 1} {
2960 # no reference commit given
2961 set diffidto [lindex $diffids 0]
2962 if {$diffidto eq $nullid} {
2963 # diffing working copy with index
2964 set diffidfrom $nullid2
2965 } elseif {$diffidto eq $nullid2} {
2966 # diffing index with HEAD
2967 set diffidfrom "HEAD"
2968 } else {
2969 # use first parent commit
2970 global parentlist selectedline
2971 set diffidfrom [lindex $parentlist $selectedline 0]
2973 } else {
2974 set diffidfrom [lindex $diffids 0]
2975 set diffidto [lindex $diffids 1]
2978 # make sure that several diffs wont collide
2979 if {![info exists gitktmpdir]} {
2980 set gitktmpdir [file join [file dirname $gitdir] \
2981 [format ".gitk-tmp.%s" [pid]]]
2982 if {[catch {file mkdir $gitktmpdir} err]} {
2983 error_popup "Error creating temporary directory $gitktmpdir: $err"
2984 unset gitktmpdir
2985 return
2987 set diffnum 0
2989 incr diffnum
2990 set diffdir [file join $gitktmpdir $diffnum]
2991 if {[catch {file mkdir $diffdir} err]} {
2992 error_popup "Error creating temporary directory $diffdir: $err"
2993 return
2996 # gather files to diff
2997 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
2998 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3000 if {$difffromfile ne {} && $difftofile ne {}} {
3001 set cmd [concat | [shellsplit $extdifftool] \
3002 [list $difffromfile $difftofile]]
3003 if {[catch {set fl [open $cmd r]} err]} {
3004 file delete -force $diffdir
3005 error_popup [mc "$extdifftool: command failed: $err"]
3006 } else {
3007 fconfigure $fl -blocking 0
3008 filerun $fl [list delete_at_eof $fl $diffdir]
3013 # delete $dir when we see eof on $f (presumably because the child has exited)
3014 proc delete_at_eof {f dir} {
3015 while {[gets $f line] >= 0} {}
3016 if {[eof $f]} {
3017 if {[catch {close $f} err]} {
3018 error_popup "External diff viewer failed: $err"
3020 file delete -force $dir
3021 return 0
3023 return 1
3026 # Functions for adding and removing shell-type quoting
3028 proc shellquote {str} {
3029 if {![string match "*\['\"\\ \t]*" $str]} {
3030 return $str
3032 if {![string match "*\['\"\\]*" $str]} {
3033 return "\"$str\""
3035 if {![string match "*'*" $str]} {
3036 return "'$str'"
3038 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3041 proc shellarglist {l} {
3042 set str {}
3043 foreach a $l {
3044 if {$str ne {}} {
3045 append str " "
3047 append str [shellquote $a]
3049 return $str
3052 proc shelldequote {str} {
3053 set ret {}
3054 set used -1
3055 while {1} {
3056 incr used
3057 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3058 append ret [string range $str $used end]
3059 set used [string length $str]
3060 break
3062 set first [lindex $first 0]
3063 set ch [string index $str $first]
3064 if {$first > $used} {
3065 append ret [string range $str $used [expr {$first - 1}]]
3066 set used $first
3068 if {$ch eq " " || $ch eq "\t"} break
3069 incr used
3070 if {$ch eq "'"} {
3071 set first [string first "'" $str $used]
3072 if {$first < 0} {
3073 error "unmatched single-quote"
3075 append ret [string range $str $used [expr {$first - 1}]]
3076 set used $first
3077 continue
3079 if {$ch eq "\\"} {
3080 if {$used >= [string length $str]} {
3081 error "trailing backslash"
3083 append ret [string index $str $used]
3084 continue
3086 # here ch == "\""
3087 while {1} {
3088 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3089 error "unmatched double-quote"
3091 set first [lindex $first 0]
3092 set ch [string index $str $first]
3093 if {$first > $used} {
3094 append ret [string range $str $used [expr {$first - 1}]]
3095 set used $first
3097 if {$ch eq "\""} break
3098 incr used
3099 append ret [string index $str $used]
3100 incr used
3103 return [list $used $ret]
3106 proc shellsplit {str} {
3107 set l {}
3108 while {1} {
3109 set str [string trimleft $str]
3110 if {$str eq {}} break
3111 set dq [shelldequote $str]
3112 set n [lindex $dq 0]
3113 set word [lindex $dq 1]
3114 set str [string range $str $n end]
3115 lappend l $word
3117 return $l
3120 # Code to implement multiple views
3122 proc newview {ishighlight} {
3123 global nextviewnum newviewname newviewperm newishighlight
3124 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3126 set newishighlight $ishighlight
3127 set top .gitkview
3128 if {[winfo exists $top]} {
3129 raise $top
3130 return
3132 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3133 set newviewperm($nextviewnum) 0
3134 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3135 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3136 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3139 proc editview {} {
3140 global curview
3141 global viewname viewperm newviewname newviewperm
3142 global viewargs newviewargs viewargscmd newviewargscmd
3144 set top .gitkvedit-$curview
3145 if {[winfo exists $top]} {
3146 raise $top
3147 return
3149 set newviewname($curview) $viewname($curview)
3150 set newviewperm($curview) $viewperm($curview)
3151 set newviewargs($curview) [shellarglist $viewargs($curview)]
3152 set newviewargscmd($curview) $viewargscmd($curview)
3153 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3156 proc vieweditor {top n title} {
3157 global newviewname newviewperm viewfiles bgcolor
3159 toplevel $top
3160 wm title $top $title
3161 label $top.nl -text [mc "Name"]
3162 entry $top.name -width 20 -textvariable newviewname($n)
3163 grid $top.nl $top.name -sticky w -pady 5
3164 checkbutton $top.perm -text [mc "Remember this view"] \
3165 -variable newviewperm($n)
3166 grid $top.perm - -pady 5 -sticky w
3167 message $top.al -aspect 1000 \
3168 -text [mc "Commits to include (arguments to git log):"]
3169 grid $top.al - -sticky w -pady 5
3170 entry $top.args -width 50 -textvariable newviewargs($n) \
3171 -background $bgcolor
3172 grid $top.args - -sticky ew -padx 5
3174 message $top.ac -aspect 1000 \
3175 -text [mc "Command to generate more commits to include:"]
3176 grid $top.ac - -sticky w -pady 5
3177 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3178 -background white
3179 grid $top.argscmd - -sticky ew -padx 5
3181 message $top.l -aspect 1000 \
3182 -text [mc "Enter files and directories to include, one per line:"]
3183 grid $top.l - -sticky w
3184 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3185 if {[info exists viewfiles($n)]} {
3186 foreach f $viewfiles($n) {
3187 $top.t insert end $f
3188 $top.t insert end "\n"
3190 $top.t delete {end - 1c} end
3191 $top.t mark set insert 0.0
3193 grid $top.t - -sticky ew -padx 5
3194 frame $top.buts
3195 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3196 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3197 grid $top.buts.ok $top.buts.can
3198 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3199 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3200 grid $top.buts - -pady 10 -sticky ew
3201 focus $top.t
3204 proc doviewmenu {m first cmd op argv} {
3205 set nmenu [$m index end]
3206 for {set i $first} {$i <= $nmenu} {incr i} {
3207 if {[$m entrycget $i -command] eq $cmd} {
3208 eval $m $op $i $argv
3209 break
3214 proc allviewmenus {n op args} {
3215 # global viewhlmenu
3217 doviewmenu .bar.view 5 [list showview $n] $op $args
3218 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3221 proc newviewok {top n} {
3222 global nextviewnum newviewperm newviewname newishighlight
3223 global viewname viewfiles viewperm selectedview curview
3224 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3226 if {[catch {
3227 set newargs [shellsplit $newviewargs($n)]
3228 } err]} {
3229 error_popup "[mc "Error in commit selection arguments:"] $err"
3230 wm raise $top
3231 focus $top
3232 return
3234 set files {}
3235 foreach f [split [$top.t get 0.0 end] "\n"] {
3236 set ft [string trim $f]
3237 if {$ft ne {}} {
3238 lappend files $ft
3241 if {![info exists viewfiles($n)]} {
3242 # creating a new view
3243 incr nextviewnum
3244 set viewname($n) $newviewname($n)
3245 set viewperm($n) $newviewperm($n)
3246 set viewfiles($n) $files
3247 set viewargs($n) $newargs
3248 set viewargscmd($n) $newviewargscmd($n)
3249 addviewmenu $n
3250 if {!$newishighlight} {
3251 run showview $n
3252 } else {
3253 run addvhighlight $n
3255 } else {
3256 # editing an existing view
3257 set viewperm($n) $newviewperm($n)
3258 if {$newviewname($n) ne $viewname($n)} {
3259 set viewname($n) $newviewname($n)
3260 doviewmenu .bar.view 5 [list showview $n] \
3261 entryconf [list -label $viewname($n)]
3262 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3263 # entryconf [list -label $viewname($n) -value $viewname($n)]
3265 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3266 $newviewargscmd($n) ne $viewargscmd($n)} {
3267 set viewfiles($n) $files
3268 set viewargs($n) $newargs
3269 set viewargscmd($n) $newviewargscmd($n)
3270 if {$curview == $n} {
3271 run reloadcommits
3275 catch {destroy $top}
3278 proc delview {} {
3279 global curview viewperm hlview selectedhlview
3281 if {$curview == 0} return
3282 if {[info exists hlview] && $hlview == $curview} {
3283 set selectedhlview [mc "None"]
3284 unset hlview
3286 allviewmenus $curview delete
3287 set viewperm($curview) 0
3288 showview 0
3291 proc addviewmenu {n} {
3292 global viewname viewhlmenu
3294 .bar.view add radiobutton -label $viewname($n) \
3295 -command [list showview $n] -variable selectedview -value $n
3296 #$viewhlmenu add radiobutton -label $viewname($n) \
3297 # -command [list addvhighlight $n] -variable selectedhlview
3300 proc showview {n} {
3301 global curview cached_commitrow ordertok
3302 global displayorder parentlist rowidlist rowisopt rowfinal
3303 global colormap rowtextx nextcolor canvxmax
3304 global numcommits viewcomplete
3305 global selectedline currentid canv canvy0
3306 global treediffs
3307 global pending_select mainheadid
3308 global commitidx
3309 global selectedview
3310 global hlview selectedhlview commitinterest
3312 if {$n == $curview} return
3313 set selid {}
3314 set ymax [lindex [$canv cget -scrollregion] 3]
3315 set span [$canv yview]
3316 set ytop [expr {[lindex $span 0] * $ymax}]
3317 set ybot [expr {[lindex $span 1] * $ymax}]
3318 set yscreen [expr {($ybot - $ytop) / 2}]
3319 if {$selectedline ne {}} {
3320 set selid $currentid
3321 set y [yc $selectedline]
3322 if {$ytop < $y && $y < $ybot} {
3323 set yscreen [expr {$y - $ytop}]
3325 } elseif {[info exists pending_select]} {
3326 set selid $pending_select
3327 unset pending_select
3329 unselectline
3330 normalline
3331 catch {unset treediffs}
3332 clear_display
3333 if {[info exists hlview] && $hlview == $n} {
3334 unset hlview
3335 set selectedhlview [mc "None"]
3337 catch {unset commitinterest}
3338 catch {unset cached_commitrow}
3339 catch {unset ordertok}
3341 set curview $n
3342 set selectedview $n
3343 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3344 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3346 run refill_reflist
3347 if {![info exists viewcomplete($n)]} {
3348 getcommits $selid
3349 return
3352 set displayorder {}
3353 set parentlist {}
3354 set rowidlist {}
3355 set rowisopt {}
3356 set rowfinal {}
3357 set numcommits $commitidx($n)
3359 catch {unset colormap}
3360 catch {unset rowtextx}
3361 set nextcolor 0
3362 set canvxmax [$canv cget -width]
3363 set curview $n
3364 set row 0
3365 setcanvscroll
3366 set yf 0
3367 set row {}
3368 if {$selid ne {} && [commitinview $selid $n]} {
3369 set row [rowofcommit $selid]
3370 # try to get the selected row in the same position on the screen
3371 set ymax [lindex [$canv cget -scrollregion] 3]
3372 set ytop [expr {[yc $row] - $yscreen}]
3373 if {$ytop < 0} {
3374 set ytop 0
3376 set yf [expr {$ytop * 1.0 / $ymax}]
3378 allcanvs yview moveto $yf
3379 drawvisible
3380 if {$row ne {}} {
3381 selectline $row 0
3382 } elseif {!$viewcomplete($n)} {
3383 reset_pending_select $selid
3384 } else {
3385 reset_pending_select {}
3387 if {[commitinview $pending_select $curview]} {
3388 selectline [rowofcommit $pending_select] 1
3389 } else {
3390 set row [first_real_row]
3391 if {$row < $numcommits} {
3392 selectline $row 0
3396 if {!$viewcomplete($n)} {
3397 if {$numcommits == 0} {
3398 show_status [mc "Reading commits..."]
3400 } elseif {$numcommits == 0} {
3401 show_status [mc "No commits selected"]
3405 # Stuff relating to the highlighting facility
3407 proc ishighlighted {id} {
3408 global vhighlights fhighlights nhighlights rhighlights
3410 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3411 return $nhighlights($id)
3413 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3414 return $vhighlights($id)
3416 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3417 return $fhighlights($id)
3419 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3420 return $rhighlights($id)
3422 return 0
3425 proc bolden {row font} {
3426 global canv linehtag selectedline boldrows
3428 lappend boldrows $row
3429 $canv itemconf $linehtag($row) -font $font
3430 if {$row == $selectedline} {
3431 $canv delete secsel
3432 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3433 -outline {{}} -tags secsel \
3434 -fill [$canv cget -selectbackground]]
3435 $canv lower $t
3439 proc bolden_name {row font} {
3440 global canv2 linentag selectedline boldnamerows
3442 lappend boldnamerows $row
3443 $canv2 itemconf $linentag($row) -font $font
3444 if {$row == $selectedline} {
3445 $canv2 delete secsel
3446 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3447 -outline {{}} -tags secsel \
3448 -fill [$canv2 cget -selectbackground]]
3449 $canv2 lower $t
3453 proc unbolden {} {
3454 global boldrows
3456 set stillbold {}
3457 foreach row $boldrows {
3458 if {![ishighlighted [commitonrow $row]]} {
3459 bolden $row mainfont
3460 } else {
3461 lappend stillbold $row
3464 set boldrows $stillbold
3467 proc addvhighlight {n} {
3468 global hlview viewcomplete curview vhl_done commitidx
3470 if {[info exists hlview]} {
3471 delvhighlight
3473 set hlview $n
3474 if {$n != $curview && ![info exists viewcomplete($n)]} {
3475 start_rev_list $n
3477 set vhl_done $commitidx($hlview)
3478 if {$vhl_done > 0} {
3479 drawvisible
3483 proc delvhighlight {} {
3484 global hlview vhighlights
3486 if {![info exists hlview]} return
3487 unset hlview
3488 catch {unset vhighlights}
3489 unbolden
3492 proc vhighlightmore {} {
3493 global hlview vhl_done commitidx vhighlights curview
3495 set max $commitidx($hlview)
3496 set vr [visiblerows]
3497 set r0 [lindex $vr 0]
3498 set r1 [lindex $vr 1]
3499 for {set i $vhl_done} {$i < $max} {incr i} {
3500 set id [commitonrow $i $hlview]
3501 if {[commitinview $id $curview]} {
3502 set row [rowofcommit $id]
3503 if {$r0 <= $row && $row <= $r1} {
3504 if {![highlighted $row]} {
3505 bolden $row mainfontbold
3507 set vhighlights($id) 1
3511 set vhl_done $max
3512 return 0
3515 proc askvhighlight {row id} {
3516 global hlview vhighlights iddrawn
3518 if {[commitinview $id $hlview]} {
3519 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3520 bolden $row mainfontbold
3522 set vhighlights($id) 1
3523 } else {
3524 set vhighlights($id) 0
3528 proc hfiles_change {} {
3529 global highlight_files filehighlight fhighlights fh_serial
3530 global highlight_paths gdttype
3532 if {[info exists filehighlight]} {
3533 # delete previous highlights
3534 catch {close $filehighlight}
3535 unset filehighlight
3536 catch {unset fhighlights}
3537 unbolden
3538 unhighlight_filelist
3540 set highlight_paths {}
3541 after cancel do_file_hl $fh_serial
3542 incr fh_serial
3543 if {$highlight_files ne {}} {
3544 after 300 do_file_hl $fh_serial
3548 proc gdttype_change {name ix op} {
3549 global gdttype highlight_files findstring findpattern
3551 stopfinding
3552 if {$findstring ne {}} {
3553 if {$gdttype eq [mc "containing:"]} {
3554 if {$highlight_files ne {}} {
3555 set highlight_files {}
3556 hfiles_change
3558 findcom_change
3559 } else {
3560 if {$findpattern ne {}} {
3561 set findpattern {}
3562 findcom_change
3564 set highlight_files $findstring
3565 hfiles_change
3567 drawvisible
3569 # enable/disable findtype/findloc menus too
3572 proc find_change {name ix op} {
3573 global gdttype findstring highlight_files
3575 stopfinding
3576 if {$gdttype eq [mc "containing:"]} {
3577 findcom_change
3578 } else {
3579 if {$highlight_files ne $findstring} {
3580 set highlight_files $findstring
3581 hfiles_change
3584 drawvisible
3587 proc findcom_change args {
3588 global nhighlights boldnamerows
3589 global findpattern findtype findstring gdttype
3591 stopfinding
3592 # delete previous highlights, if any
3593 foreach row $boldnamerows {
3594 bolden_name $row mainfont
3596 set boldnamerows {}
3597 catch {unset nhighlights}
3598 unbolden
3599 unmarkmatches
3600 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3601 set findpattern {}
3602 } elseif {$findtype eq [mc "Regexp"]} {
3603 set findpattern $findstring
3604 } else {
3605 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3606 $findstring]
3607 set findpattern "*$e*"
3611 proc makepatterns {l} {
3612 set ret {}
3613 foreach e $l {
3614 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3615 if {[string index $ee end] eq "/"} {
3616 lappend ret "$ee*"
3617 } else {
3618 lappend ret $ee
3619 lappend ret "$ee/*"
3622 return $ret
3625 proc do_file_hl {serial} {
3626 global highlight_files filehighlight highlight_paths gdttype fhl_list
3628 if {$gdttype eq [mc "touching paths:"]} {
3629 if {[catch {set paths [shellsplit $highlight_files]}]} return
3630 set highlight_paths [makepatterns $paths]
3631 highlight_filelist
3632 set gdtargs [concat -- $paths]
3633 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3634 set gdtargs [list "-S$highlight_files"]
3635 } else {
3636 # must be "containing:", i.e. we're searching commit info
3637 return
3639 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3640 set filehighlight [open $cmd r+]
3641 fconfigure $filehighlight -blocking 0
3642 filerun $filehighlight readfhighlight
3643 set fhl_list {}
3644 drawvisible
3645 flushhighlights
3648 proc flushhighlights {} {
3649 global filehighlight fhl_list
3651 if {[info exists filehighlight]} {
3652 lappend fhl_list {}
3653 puts $filehighlight ""
3654 flush $filehighlight
3658 proc askfilehighlight {row id} {
3659 global filehighlight fhighlights fhl_list
3661 lappend fhl_list $id
3662 set fhighlights($id) -1
3663 puts $filehighlight $id
3666 proc readfhighlight {} {
3667 global filehighlight fhighlights curview iddrawn
3668 global fhl_list find_dirn
3670 if {![info exists filehighlight]} {
3671 return 0
3673 set nr 0
3674 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3675 set line [string trim $line]
3676 set i [lsearch -exact $fhl_list $line]
3677 if {$i < 0} continue
3678 for {set j 0} {$j < $i} {incr j} {
3679 set id [lindex $fhl_list $j]
3680 set fhighlights($id) 0
3682 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3683 if {$line eq {}} continue
3684 if {![commitinview $line $curview]} continue
3685 set row [rowofcommit $line]
3686 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3687 bolden $row mainfontbold
3689 set fhighlights($line) 1
3691 if {[eof $filehighlight]} {
3692 # strange...
3693 puts "oops, git diff-tree died"
3694 catch {close $filehighlight}
3695 unset filehighlight
3696 return 0
3698 if {[info exists find_dirn]} {
3699 run findmore
3701 return 1
3704 proc doesmatch {f} {
3705 global findtype findpattern
3707 if {$findtype eq [mc "Regexp"]} {
3708 return [regexp $findpattern $f]
3709 } elseif {$findtype eq [mc "IgnCase"]} {
3710 return [string match -nocase $findpattern $f]
3711 } else {
3712 return [string match $findpattern $f]
3716 proc askfindhighlight {row id} {
3717 global nhighlights commitinfo iddrawn
3718 global findloc
3719 global markingmatches
3721 if {![info exists commitinfo($id)]} {
3722 getcommit $id
3724 set info $commitinfo($id)
3725 set isbold 0
3726 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3727 foreach f $info ty $fldtypes {
3728 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3729 [doesmatch $f]} {
3730 if {$ty eq [mc "Author"]} {
3731 set isbold 2
3732 break
3734 set isbold 1
3737 if {$isbold && [info exists iddrawn($id)]} {
3738 if {![ishighlighted $id]} {
3739 bolden $row mainfontbold
3740 if {$isbold > 1} {
3741 bolden_name $row mainfontbold
3744 if {$markingmatches} {
3745 markrowmatches $row $id
3748 set nhighlights($id) $isbold
3751 proc markrowmatches {row id} {
3752 global canv canv2 linehtag linentag commitinfo findloc
3754 set headline [lindex $commitinfo($id) 0]
3755 set author [lindex $commitinfo($id) 1]
3756 $canv delete match$row
3757 $canv2 delete match$row
3758 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3759 set m [findmatches $headline]
3760 if {$m ne {}} {
3761 markmatches $canv $row $headline $linehtag($row) $m \
3762 [$canv itemcget $linehtag($row) -font] $row
3765 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3766 set m [findmatches $author]
3767 if {$m ne {}} {
3768 markmatches $canv2 $row $author $linentag($row) $m \
3769 [$canv2 itemcget $linentag($row) -font] $row
3774 proc vrel_change {name ix op} {
3775 global highlight_related
3777 rhighlight_none
3778 if {$highlight_related ne [mc "None"]} {
3779 run drawvisible
3783 # prepare for testing whether commits are descendents or ancestors of a
3784 proc rhighlight_sel {a} {
3785 global descendent desc_todo ancestor anc_todo
3786 global highlight_related
3788 catch {unset descendent}
3789 set desc_todo [list $a]
3790 catch {unset ancestor}
3791 set anc_todo [list $a]
3792 if {$highlight_related ne [mc "None"]} {
3793 rhighlight_none
3794 run drawvisible
3798 proc rhighlight_none {} {
3799 global rhighlights
3801 catch {unset rhighlights}
3802 unbolden
3805 proc is_descendent {a} {
3806 global curview children descendent desc_todo
3808 set v $curview
3809 set la [rowofcommit $a]
3810 set todo $desc_todo
3811 set leftover {}
3812 set done 0
3813 for {set i 0} {$i < [llength $todo]} {incr i} {
3814 set do [lindex $todo $i]
3815 if {[rowofcommit $do] < $la} {
3816 lappend leftover $do
3817 continue
3819 foreach nk $children($v,$do) {
3820 if {![info exists descendent($nk)]} {
3821 set descendent($nk) 1
3822 lappend todo $nk
3823 if {$nk eq $a} {
3824 set done 1
3828 if {$done} {
3829 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3830 return
3833 set descendent($a) 0
3834 set desc_todo $leftover
3837 proc is_ancestor {a} {
3838 global curview parents ancestor anc_todo
3840 set v $curview
3841 set la [rowofcommit $a]
3842 set todo $anc_todo
3843 set leftover {}
3844 set done 0
3845 for {set i 0} {$i < [llength $todo]} {incr i} {
3846 set do [lindex $todo $i]
3847 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3848 lappend leftover $do
3849 continue
3851 foreach np $parents($v,$do) {
3852 if {![info exists ancestor($np)]} {
3853 set ancestor($np) 1
3854 lappend todo $np
3855 if {$np eq $a} {
3856 set done 1
3860 if {$done} {
3861 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3862 return
3865 set ancestor($a) 0
3866 set anc_todo $leftover
3869 proc askrelhighlight {row id} {
3870 global descendent highlight_related iddrawn rhighlights
3871 global selectedline ancestor
3873 if {$selectedline eq {}} return
3874 set isbold 0
3875 if {$highlight_related eq [mc "Descendant"] ||
3876 $highlight_related eq [mc "Not descendant"]} {
3877 if {![info exists descendent($id)]} {
3878 is_descendent $id
3880 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3881 set isbold 1
3883 } elseif {$highlight_related eq [mc "Ancestor"] ||
3884 $highlight_related eq [mc "Not ancestor"]} {
3885 if {![info exists ancestor($id)]} {
3886 is_ancestor $id
3888 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3889 set isbold 1
3892 if {[info exists iddrawn($id)]} {
3893 if {$isbold && ![ishighlighted $id]} {
3894 bolden $row mainfontbold
3897 set rhighlights($id) $isbold
3900 # Graph layout functions
3902 proc shortids {ids} {
3903 set res {}
3904 foreach id $ids {
3905 if {[llength $id] > 1} {
3906 lappend res [shortids $id]
3907 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3908 lappend res [string range $id 0 7]
3909 } else {
3910 lappend res $id
3913 return $res
3916 proc ntimes {n o} {
3917 set ret {}
3918 set o [list $o]
3919 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3920 if {($n & $mask) != 0} {
3921 set ret [concat $ret $o]
3923 set o [concat $o $o]
3925 return $ret
3928 proc ordertoken {id} {
3929 global ordertok curview varcid varcstart varctok curview parents children
3930 global nullid nullid2
3932 if {[info exists ordertok($id)]} {
3933 return $ordertok($id)
3935 set origid $id
3936 set todo {}
3937 while {1} {
3938 if {[info exists varcid($curview,$id)]} {
3939 set a $varcid($curview,$id)
3940 set p [lindex $varcstart($curview) $a]
3941 } else {
3942 set p [lindex $children($curview,$id) 0]
3944 if {[info exists ordertok($p)]} {
3945 set tok $ordertok($p)
3946 break
3948 set id [first_real_child $curview,$p]
3949 if {$id eq {}} {
3950 # it's a root
3951 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3952 break
3954 if {[llength $parents($curview,$id)] == 1} {
3955 lappend todo [list $p {}]
3956 } else {
3957 set j [lsearch -exact $parents($curview,$id) $p]
3958 if {$j < 0} {
3959 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3961 lappend todo [list $p [strrep $j]]
3964 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3965 set p [lindex $todo $i 0]
3966 append tok [lindex $todo $i 1]
3967 set ordertok($p) $tok
3969 set ordertok($origid) $tok
3970 return $tok
3973 # Work out where id should go in idlist so that order-token
3974 # values increase from left to right
3975 proc idcol {idlist id {i 0}} {
3976 set t [ordertoken $id]
3977 if {$i < 0} {
3978 set i 0
3980 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3981 if {$i > [llength $idlist]} {
3982 set i [llength $idlist]
3984 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3985 incr i
3986 } else {
3987 if {$t > [ordertoken [lindex $idlist $i]]} {
3988 while {[incr i] < [llength $idlist] &&
3989 $t >= [ordertoken [lindex $idlist $i]]} {}
3992 return $i
3995 proc initlayout {} {
3996 global rowidlist rowisopt rowfinal displayorder parentlist
3997 global numcommits canvxmax canv
3998 global nextcolor
3999 global colormap rowtextx
4001 set numcommits 0
4002 set displayorder {}
4003 set parentlist {}
4004 set nextcolor 0
4005 set rowidlist {}
4006 set rowisopt {}
4007 set rowfinal {}
4008 set canvxmax [$canv cget -width]
4009 catch {unset colormap}
4010 catch {unset rowtextx}
4011 setcanvscroll
4014 proc setcanvscroll {} {
4015 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4016 global lastscrollset lastscrollrows
4018 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4019 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4020 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4021 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4022 set lastscrollset [clock clicks -milliseconds]
4023 set lastscrollrows $numcommits
4026 proc visiblerows {} {
4027 global canv numcommits linespc
4029 set ymax [lindex [$canv cget -scrollregion] 3]
4030 if {$ymax eq {} || $ymax == 0} return
4031 set f [$canv yview]
4032 set y0 [expr {int([lindex $f 0] * $ymax)}]
4033 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4034 if {$r0 < 0} {
4035 set r0 0
4037 set y1 [expr {int([lindex $f 1] * $ymax)}]
4038 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4039 if {$r1 >= $numcommits} {
4040 set r1 [expr {$numcommits - 1}]
4042 return [list $r0 $r1]
4045 proc layoutmore {} {
4046 global commitidx viewcomplete curview
4047 global numcommits pending_select curview
4048 global lastscrollset lastscrollrows commitinterest
4050 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4051 [clock clicks -milliseconds] - $lastscrollset > 500} {
4052 setcanvscroll
4054 if {[info exists pending_select] &&
4055 [commitinview $pending_select $curview]} {
4056 update
4057 selectline [rowofcommit $pending_select] 1
4059 drawvisible
4062 proc doshowlocalchanges {} {
4063 global curview mainheadid
4065 if {$mainheadid eq {}} return
4066 if {[commitinview $mainheadid $curview]} {
4067 dodiffindex
4068 } else {
4069 lappend commitinterest($mainheadid) {dodiffindex}
4073 proc dohidelocalchanges {} {
4074 global nullid nullid2 lserial curview
4076 if {[commitinview $nullid $curview]} {
4077 removefakerow $nullid
4079 if {[commitinview $nullid2 $curview]} {
4080 removefakerow $nullid2
4082 incr lserial
4085 # spawn off a process to do git diff-index --cached HEAD
4086 proc dodiffindex {} {
4087 global lserial showlocalchanges
4088 global isworktree
4090 if {!$showlocalchanges || !$isworktree} return
4091 incr lserial
4092 set fd [open "|git diff-index --cached HEAD" r]
4093 fconfigure $fd -blocking 0
4094 set i [reg_instance $fd]
4095 filerun $fd [list readdiffindex $fd $lserial $i]
4098 proc readdiffindex {fd serial inst} {
4099 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4101 set isdiff 1
4102 if {[gets $fd line] < 0} {
4103 if {![eof $fd]} {
4104 return 1
4106 set isdiff 0
4108 # we only need to see one line and we don't really care what it says...
4109 stop_instance $inst
4111 if {$serial != $lserial} {
4112 return 0
4115 # now see if there are any local changes not checked in to the index
4116 set fd [open "|git diff-files" r]
4117 fconfigure $fd -blocking 0
4118 set i [reg_instance $fd]
4119 filerun $fd [list readdifffiles $fd $serial $i]
4121 if {$isdiff && ![commitinview $nullid2 $curview]} {
4122 # add the line for the changes in the index to the graph
4123 set hl [mc "Local changes checked in to index but not committed"]
4124 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4125 set commitdata($nullid2) "\n $hl\n"
4126 if {[commitinview $nullid $curview]} {
4127 removefakerow $nullid
4129 insertfakerow $nullid2 $mainheadid
4130 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4131 removefakerow $nullid2
4133 return 0
4136 proc readdifffiles {fd serial inst} {
4137 global mainheadid nullid nullid2 curview
4138 global commitinfo commitdata lserial
4140 set isdiff 1
4141 if {[gets $fd line] < 0} {
4142 if {![eof $fd]} {
4143 return 1
4145 set isdiff 0
4147 # we only need to see one line and we don't really care what it says...
4148 stop_instance $inst
4150 if {$serial != $lserial} {
4151 return 0
4154 if {$isdiff && ![commitinview $nullid $curview]} {
4155 # add the line for the local diff to the graph
4156 set hl [mc "Local uncommitted changes, not checked in to index"]
4157 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4158 set commitdata($nullid) "\n $hl\n"
4159 if {[commitinview $nullid2 $curview]} {
4160 set p $nullid2
4161 } else {
4162 set p $mainheadid
4164 insertfakerow $nullid $p
4165 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4166 removefakerow $nullid
4168 return 0
4171 proc nextuse {id row} {
4172 global curview children
4174 if {[info exists children($curview,$id)]} {
4175 foreach kid $children($curview,$id) {
4176 if {![commitinview $kid $curview]} {
4177 return -1
4179 if {[rowofcommit $kid] > $row} {
4180 return [rowofcommit $kid]
4184 if {[commitinview $id $curview]} {
4185 return [rowofcommit $id]
4187 return -1
4190 proc prevuse {id row} {
4191 global curview children
4193 set ret -1
4194 if {[info exists children($curview,$id)]} {
4195 foreach kid $children($curview,$id) {
4196 if {![commitinview $kid $curview]} break
4197 if {[rowofcommit $kid] < $row} {
4198 set ret [rowofcommit $kid]
4202 return $ret
4205 proc make_idlist {row} {
4206 global displayorder parentlist uparrowlen downarrowlen mingaplen
4207 global commitidx curview children
4209 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4210 if {$r < 0} {
4211 set r 0
4213 set ra [expr {$row - $downarrowlen}]
4214 if {$ra < 0} {
4215 set ra 0
4217 set rb [expr {$row + $uparrowlen}]
4218 if {$rb > $commitidx($curview)} {
4219 set rb $commitidx($curview)
4221 make_disporder $r [expr {$rb + 1}]
4222 set ids {}
4223 for {} {$r < $ra} {incr r} {
4224 set nextid [lindex $displayorder [expr {$r + 1}]]
4225 foreach p [lindex $parentlist $r] {
4226 if {$p eq $nextid} continue
4227 set rn [nextuse $p $r]
4228 if {$rn >= $row &&
4229 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4230 lappend ids [list [ordertoken $p] $p]
4234 for {} {$r < $row} {incr r} {
4235 set nextid [lindex $displayorder [expr {$r + 1}]]
4236 foreach p [lindex $parentlist $r] {
4237 if {$p eq $nextid} continue
4238 set rn [nextuse $p $r]
4239 if {$rn < 0 || $rn >= $row} {
4240 lappend ids [list [ordertoken $p] $p]
4244 set id [lindex $displayorder $row]
4245 lappend ids [list [ordertoken $id] $id]
4246 while {$r < $rb} {
4247 foreach p [lindex $parentlist $r] {
4248 set firstkid [lindex $children($curview,$p) 0]
4249 if {[rowofcommit $firstkid] < $row} {
4250 lappend ids [list [ordertoken $p] $p]
4253 incr r
4254 set id [lindex $displayorder $r]
4255 if {$id ne {}} {
4256 set firstkid [lindex $children($curview,$id) 0]
4257 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4258 lappend ids [list [ordertoken $id] $id]
4262 set idlist {}
4263 foreach idx [lsort -unique $ids] {
4264 lappend idlist [lindex $idx 1]
4266 return $idlist
4269 proc rowsequal {a b} {
4270 while {[set i [lsearch -exact $a {}]] >= 0} {
4271 set a [lreplace $a $i $i]
4273 while {[set i [lsearch -exact $b {}]] >= 0} {
4274 set b [lreplace $b $i $i]
4276 return [expr {$a eq $b}]
4279 proc makeupline {id row rend col} {
4280 global rowidlist uparrowlen downarrowlen mingaplen
4282 for {set r $rend} {1} {set r $rstart} {
4283 set rstart [prevuse $id $r]
4284 if {$rstart < 0} return
4285 if {$rstart < $row} break
4287 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4288 set rstart [expr {$rend - $uparrowlen - 1}]
4290 for {set r $rstart} {[incr r] <= $row} {} {
4291 set idlist [lindex $rowidlist $r]
4292 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4293 set col [idcol $idlist $id $col]
4294 lset rowidlist $r [linsert $idlist $col $id]
4295 changedrow $r
4300 proc layoutrows {row endrow} {
4301 global rowidlist rowisopt rowfinal displayorder
4302 global uparrowlen downarrowlen maxwidth mingaplen
4303 global children parentlist
4304 global commitidx viewcomplete curview
4306 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4307 set idlist {}
4308 if {$row > 0} {
4309 set rm1 [expr {$row - 1}]
4310 foreach id [lindex $rowidlist $rm1] {
4311 if {$id ne {}} {
4312 lappend idlist $id
4315 set final [lindex $rowfinal $rm1]
4317 for {} {$row < $endrow} {incr row} {
4318 set rm1 [expr {$row - 1}]
4319 if {$rm1 < 0 || $idlist eq {}} {
4320 set idlist [make_idlist $row]
4321 set final 1
4322 } else {
4323 set id [lindex $displayorder $rm1]
4324 set col [lsearch -exact $idlist $id]
4325 set idlist [lreplace $idlist $col $col]
4326 foreach p [lindex $parentlist $rm1] {
4327 if {[lsearch -exact $idlist $p] < 0} {
4328 set col [idcol $idlist $p $col]
4329 set idlist [linsert $idlist $col $p]
4330 # if not the first child, we have to insert a line going up
4331 if {$id ne [lindex $children($curview,$p) 0]} {
4332 makeupline $p $rm1 $row $col
4336 set id [lindex $displayorder $row]
4337 if {$row > $downarrowlen} {
4338 set termrow [expr {$row - $downarrowlen - 1}]
4339 foreach p [lindex $parentlist $termrow] {
4340 set i [lsearch -exact $idlist $p]
4341 if {$i < 0} continue
4342 set nr [nextuse $p $termrow]
4343 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4344 set idlist [lreplace $idlist $i $i]
4348 set col [lsearch -exact $idlist $id]
4349 if {$col < 0} {
4350 set col [idcol $idlist $id]
4351 set idlist [linsert $idlist $col $id]
4352 if {$children($curview,$id) ne {}} {
4353 makeupline $id $rm1 $row $col
4356 set r [expr {$row + $uparrowlen - 1}]
4357 if {$r < $commitidx($curview)} {
4358 set x $col
4359 foreach p [lindex $parentlist $r] {
4360 if {[lsearch -exact $idlist $p] >= 0} continue
4361 set fk [lindex $children($curview,$p) 0]
4362 if {[rowofcommit $fk] < $row} {
4363 set x [idcol $idlist $p $x]
4364 set idlist [linsert $idlist $x $p]
4367 if {[incr r] < $commitidx($curview)} {
4368 set p [lindex $displayorder $r]
4369 if {[lsearch -exact $idlist $p] < 0} {
4370 set fk [lindex $children($curview,$p) 0]
4371 if {$fk ne {} && [rowofcommit $fk] < $row} {
4372 set x [idcol $idlist $p $x]
4373 set idlist [linsert $idlist $x $p]
4379 if {$final && !$viewcomplete($curview) &&
4380 $row + $uparrowlen + $mingaplen + $downarrowlen
4381 >= $commitidx($curview)} {
4382 set final 0
4384 set l [llength $rowidlist]
4385 if {$row == $l} {
4386 lappend rowidlist $idlist
4387 lappend rowisopt 0
4388 lappend rowfinal $final
4389 } elseif {$row < $l} {
4390 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4391 lset rowidlist $row $idlist
4392 changedrow $row
4394 lset rowfinal $row $final
4395 } else {
4396 set pad [ntimes [expr {$row - $l}] {}]
4397 set rowidlist [concat $rowidlist $pad]
4398 lappend rowidlist $idlist
4399 set rowfinal [concat $rowfinal $pad]
4400 lappend rowfinal $final
4401 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4404 return $row
4407 proc changedrow {row} {
4408 global displayorder iddrawn rowisopt need_redisplay
4410 set l [llength $rowisopt]
4411 if {$row < $l} {
4412 lset rowisopt $row 0
4413 if {$row + 1 < $l} {
4414 lset rowisopt [expr {$row + 1}] 0
4415 if {$row + 2 < $l} {
4416 lset rowisopt [expr {$row + 2}] 0
4420 set id [lindex $displayorder $row]
4421 if {[info exists iddrawn($id)]} {
4422 set need_redisplay 1
4426 proc insert_pad {row col npad} {
4427 global rowidlist
4429 set pad [ntimes $npad {}]
4430 set idlist [lindex $rowidlist $row]
4431 set bef [lrange $idlist 0 [expr {$col - 1}]]
4432 set aft [lrange $idlist $col end]
4433 set i [lsearch -exact $aft {}]
4434 if {$i > 0} {
4435 set aft [lreplace $aft $i $i]
4437 lset rowidlist $row [concat $bef $pad $aft]
4438 changedrow $row
4441 proc optimize_rows {row col endrow} {
4442 global rowidlist rowisopt displayorder curview children
4444 if {$row < 1} {
4445 set row 1
4447 for {} {$row < $endrow} {incr row; set col 0} {
4448 if {[lindex $rowisopt $row]} continue
4449 set haspad 0
4450 set y0 [expr {$row - 1}]
4451 set ym [expr {$row - 2}]
4452 set idlist [lindex $rowidlist $row]
4453 set previdlist [lindex $rowidlist $y0]
4454 if {$idlist eq {} || $previdlist eq {}} continue
4455 if {$ym >= 0} {
4456 set pprevidlist [lindex $rowidlist $ym]
4457 if {$pprevidlist eq {}} continue
4458 } else {
4459 set pprevidlist {}
4461 set x0 -1
4462 set xm -1
4463 for {} {$col < [llength $idlist]} {incr col} {
4464 set id [lindex $idlist $col]
4465 if {[lindex $previdlist $col] eq $id} continue
4466 if {$id eq {}} {
4467 set haspad 1
4468 continue
4470 set x0 [lsearch -exact $previdlist $id]
4471 if {$x0 < 0} continue
4472 set z [expr {$x0 - $col}]
4473 set isarrow 0
4474 set z0 {}
4475 if {$ym >= 0} {
4476 set xm [lsearch -exact $pprevidlist $id]
4477 if {$xm >= 0} {
4478 set z0 [expr {$xm - $x0}]
4481 if {$z0 eq {}} {
4482 # if row y0 is the first child of $id then it's not an arrow
4483 if {[lindex $children($curview,$id) 0] ne
4484 [lindex $displayorder $y0]} {
4485 set isarrow 1
4488 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4489 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4490 set isarrow 1
4492 # Looking at lines from this row to the previous row,
4493 # make them go straight up if they end in an arrow on
4494 # the previous row; otherwise make them go straight up
4495 # or at 45 degrees.
4496 if {$z < -1 || ($z < 0 && $isarrow)} {
4497 # Line currently goes left too much;
4498 # insert pads in the previous row, then optimize it
4499 set npad [expr {-1 - $z + $isarrow}]
4500 insert_pad $y0 $x0 $npad
4501 if {$y0 > 0} {
4502 optimize_rows $y0 $x0 $row
4504 set previdlist [lindex $rowidlist $y0]
4505 set x0 [lsearch -exact $previdlist $id]
4506 set z [expr {$x0 - $col}]
4507 if {$z0 ne {}} {
4508 set pprevidlist [lindex $rowidlist $ym]
4509 set xm [lsearch -exact $pprevidlist $id]
4510 set z0 [expr {$xm - $x0}]
4512 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4513 # Line currently goes right too much;
4514 # insert pads in this line
4515 set npad [expr {$z - 1 + $isarrow}]
4516 insert_pad $row $col $npad
4517 set idlist [lindex $rowidlist $row]
4518 incr col $npad
4519 set z [expr {$x0 - $col}]
4520 set haspad 1
4522 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4523 # this line links to its first child on row $row-2
4524 set id [lindex $displayorder $ym]
4525 set xc [lsearch -exact $pprevidlist $id]
4526 if {$xc >= 0} {
4527 set z0 [expr {$xc - $x0}]
4530 # avoid lines jigging left then immediately right
4531 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4532 insert_pad $y0 $x0 1
4533 incr x0
4534 optimize_rows $y0 $x0 $row
4535 set previdlist [lindex $rowidlist $y0]
4538 if {!$haspad} {
4539 # Find the first column that doesn't have a line going right
4540 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4541 set id [lindex $idlist $col]
4542 if {$id eq {}} break
4543 set x0 [lsearch -exact $previdlist $id]
4544 if {$x0 < 0} {
4545 # check if this is the link to the first child
4546 set kid [lindex $displayorder $y0]
4547 if {[lindex $children($curview,$id) 0] eq $kid} {
4548 # it is, work out offset to child
4549 set x0 [lsearch -exact $previdlist $kid]
4552 if {$x0 <= $col} break
4554 # Insert a pad at that column as long as it has a line and
4555 # isn't the last column
4556 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4557 set idlist [linsert $idlist $col {}]
4558 lset rowidlist $row $idlist
4559 changedrow $row
4565 proc xc {row col} {
4566 global canvx0 linespc
4567 return [expr {$canvx0 + $col * $linespc}]
4570 proc yc {row} {
4571 global canvy0 linespc
4572 return [expr {$canvy0 + $row * $linespc}]
4575 proc linewidth {id} {
4576 global thickerline lthickness
4578 set wid $lthickness
4579 if {[info exists thickerline] && $id eq $thickerline} {
4580 set wid [expr {2 * $lthickness}]
4582 return $wid
4585 proc rowranges {id} {
4586 global curview children uparrowlen downarrowlen
4587 global rowidlist
4589 set kids $children($curview,$id)
4590 if {$kids eq {}} {
4591 return {}
4593 set ret {}
4594 lappend kids $id
4595 foreach child $kids {
4596 if {![commitinview $child $curview]} break
4597 set row [rowofcommit $child]
4598 if {![info exists prev]} {
4599 lappend ret [expr {$row + 1}]
4600 } else {
4601 if {$row <= $prevrow} {
4602 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4604 # see if the line extends the whole way from prevrow to row
4605 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4606 [lsearch -exact [lindex $rowidlist \
4607 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4608 # it doesn't, see where it ends
4609 set r [expr {$prevrow + $downarrowlen}]
4610 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4611 while {[incr r -1] > $prevrow &&
4612 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4613 } else {
4614 while {[incr r] <= $row &&
4615 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4616 incr r -1
4618 lappend ret $r
4619 # see where it starts up again
4620 set r [expr {$row - $uparrowlen}]
4621 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4622 while {[incr r] < $row &&
4623 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4624 } else {
4625 while {[incr r -1] >= $prevrow &&
4626 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4627 incr r
4629 lappend ret $r
4632 if {$child eq $id} {
4633 lappend ret $row
4635 set prev $child
4636 set prevrow $row
4638 return $ret
4641 proc drawlineseg {id row endrow arrowlow} {
4642 global rowidlist displayorder iddrawn linesegs
4643 global canv colormap linespc curview maxlinelen parentlist
4645 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4646 set le [expr {$row + 1}]
4647 set arrowhigh 1
4648 while {1} {
4649 set c [lsearch -exact [lindex $rowidlist $le] $id]
4650 if {$c < 0} {
4651 incr le -1
4652 break
4654 lappend cols $c
4655 set x [lindex $displayorder $le]
4656 if {$x eq $id} {
4657 set arrowhigh 0
4658 break
4660 if {[info exists iddrawn($x)] || $le == $endrow} {
4661 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4662 if {$c >= 0} {
4663 lappend cols $c
4664 set arrowhigh 0
4666 break
4668 incr le
4670 if {$le <= $row} {
4671 return $row
4674 set lines {}
4675 set i 0
4676 set joinhigh 0
4677 if {[info exists linesegs($id)]} {
4678 set lines $linesegs($id)
4679 foreach li $lines {
4680 set r0 [lindex $li 0]
4681 if {$r0 > $row} {
4682 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4683 set joinhigh 1
4685 break
4687 incr i
4690 set joinlow 0
4691 if {$i > 0} {
4692 set li [lindex $lines [expr {$i-1}]]
4693 set r1 [lindex $li 1]
4694 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4695 set joinlow 1
4699 set x [lindex $cols [expr {$le - $row}]]
4700 set xp [lindex $cols [expr {$le - 1 - $row}]]
4701 set dir [expr {$xp - $x}]
4702 if {$joinhigh} {
4703 set ith [lindex $lines $i 2]
4704 set coords [$canv coords $ith]
4705 set ah [$canv itemcget $ith -arrow]
4706 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4707 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4708 if {$x2 ne {} && $x - $x2 == $dir} {
4709 set coords [lrange $coords 0 end-2]
4711 } else {
4712 set coords [list [xc $le $x] [yc $le]]
4714 if {$joinlow} {
4715 set itl [lindex $lines [expr {$i-1}] 2]
4716 set al [$canv itemcget $itl -arrow]
4717 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4718 } elseif {$arrowlow} {
4719 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4720 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4721 set arrowlow 0
4724 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4725 for {set y $le} {[incr y -1] > $row} {} {
4726 set x $xp
4727 set xp [lindex $cols [expr {$y - 1 - $row}]]
4728 set ndir [expr {$xp - $x}]
4729 if {$dir != $ndir || $xp < 0} {
4730 lappend coords [xc $y $x] [yc $y]
4732 set dir $ndir
4734 if {!$joinlow} {
4735 if {$xp < 0} {
4736 # join parent line to first child
4737 set ch [lindex $displayorder $row]
4738 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4739 if {$xc < 0} {
4740 puts "oops: drawlineseg: child $ch not on row $row"
4741 } elseif {$xc != $x} {
4742 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4743 set d [expr {int(0.5 * $linespc)}]
4744 set x1 [xc $row $x]
4745 if {$xc < $x} {
4746 set x2 [expr {$x1 - $d}]
4747 } else {
4748 set x2 [expr {$x1 + $d}]
4750 set y2 [yc $row]
4751 set y1 [expr {$y2 + $d}]
4752 lappend coords $x1 $y1 $x2 $y2
4753 } elseif {$xc < $x - 1} {
4754 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4755 } elseif {$xc > $x + 1} {
4756 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4758 set x $xc
4760 lappend coords [xc $row $x] [yc $row]
4761 } else {
4762 set xn [xc $row $xp]
4763 set yn [yc $row]
4764 lappend coords $xn $yn
4766 if {!$joinhigh} {
4767 assigncolor $id
4768 set t [$canv create line $coords -width [linewidth $id] \
4769 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4770 $canv lower $t
4771 bindline $t $id
4772 set lines [linsert $lines $i [list $row $le $t]]
4773 } else {
4774 $canv coords $ith $coords
4775 if {$arrow ne $ah} {
4776 $canv itemconf $ith -arrow $arrow
4778 lset lines $i 0 $row
4780 } else {
4781 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4782 set ndir [expr {$xo - $xp}]
4783 set clow [$canv coords $itl]
4784 if {$dir == $ndir} {
4785 set clow [lrange $clow 2 end]
4787 set coords [concat $coords $clow]
4788 if {!$joinhigh} {
4789 lset lines [expr {$i-1}] 1 $le
4790 } else {
4791 # coalesce two pieces
4792 $canv delete $ith
4793 set b [lindex $lines [expr {$i-1}] 0]
4794 set e [lindex $lines $i 1]
4795 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4797 $canv coords $itl $coords
4798 if {$arrow ne $al} {
4799 $canv itemconf $itl -arrow $arrow
4803 set linesegs($id) $lines
4804 return $le
4807 proc drawparentlinks {id row} {
4808 global rowidlist canv colormap curview parentlist
4809 global idpos linespc
4811 set rowids [lindex $rowidlist $row]
4812 set col [lsearch -exact $rowids $id]
4813 if {$col < 0} return
4814 set olds [lindex $parentlist $row]
4815 set row2 [expr {$row + 1}]
4816 set x [xc $row $col]
4817 set y [yc $row]
4818 set y2 [yc $row2]
4819 set d [expr {int(0.5 * $linespc)}]
4820 set ymid [expr {$y + $d}]
4821 set ids [lindex $rowidlist $row2]
4822 # rmx = right-most X coord used
4823 set rmx 0
4824 foreach p $olds {
4825 set i [lsearch -exact $ids $p]
4826 if {$i < 0} {
4827 puts "oops, parent $p of $id not in list"
4828 continue
4830 set x2 [xc $row2 $i]
4831 if {$x2 > $rmx} {
4832 set rmx $x2
4834 set j [lsearch -exact $rowids $p]
4835 if {$j < 0} {
4836 # drawlineseg will do this one for us
4837 continue
4839 assigncolor $p
4840 # should handle duplicated parents here...
4841 set coords [list $x $y]
4842 if {$i != $col} {
4843 # if attaching to a vertical segment, draw a smaller
4844 # slant for visual distinctness
4845 if {$i == $j} {
4846 if {$i < $col} {
4847 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4848 } else {
4849 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4851 } elseif {$i < $col && $i < $j} {
4852 # segment slants towards us already
4853 lappend coords [xc $row $j] $y
4854 } else {
4855 if {$i < $col - 1} {
4856 lappend coords [expr {$x2 + $linespc}] $y
4857 } elseif {$i > $col + 1} {
4858 lappend coords [expr {$x2 - $linespc}] $y
4860 lappend coords $x2 $y2
4862 } else {
4863 lappend coords $x2 $y2
4865 set t [$canv create line $coords -width [linewidth $p] \
4866 -fill $colormap($p) -tags lines.$p]
4867 $canv lower $t
4868 bindline $t $p
4870 if {$rmx > [lindex $idpos($id) 1]} {
4871 lset idpos($id) 1 $rmx
4872 redrawtags $id
4876 proc drawlines {id} {
4877 global canv
4879 $canv itemconf lines.$id -width [linewidth $id]
4882 proc drawcmittext {id row col} {
4883 global linespc canv canv2 canv3 fgcolor curview
4884 global cmitlisted commitinfo rowidlist parentlist
4885 global rowtextx idpos idtags idheads idotherrefs
4886 global linehtag linentag linedtag selectedline
4887 global canvxmax boldrows boldnamerows fgcolor
4888 global mainheadid nullid nullid2 circleitem circlecolors
4890 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4891 set listed $cmitlisted($curview,$id)
4892 if {$id eq $nullid} {
4893 set ofill red
4894 } elseif {$id eq $nullid2} {
4895 set ofill green
4896 } elseif {$id eq $mainheadid} {
4897 set ofill yellow
4898 } else {
4899 set ofill [lindex $circlecolors $listed]
4901 set x [xc $row $col]
4902 set y [yc $row]
4903 set orad [expr {$linespc / 3}]
4904 if {$listed <= 2} {
4905 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4906 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4907 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4908 } elseif {$listed == 3} {
4909 # triangle pointing left for left-side commits
4910 set t [$canv create polygon \
4911 [expr {$x - $orad}] $y \
4912 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4913 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4914 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4915 } else {
4916 # triangle pointing right for right-side commits
4917 set t [$canv create polygon \
4918 [expr {$x + $orad - 1}] $y \
4919 [expr {$x - $orad}] [expr {$y - $orad}] \
4920 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4921 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4923 set circleitem($row) $t
4924 $canv raise $t
4925 $canv bind $t <1> {selcanvline {} %x %y}
4926 set rmx [llength [lindex $rowidlist $row]]
4927 set olds [lindex $parentlist $row]
4928 if {$olds ne {}} {
4929 set nextids [lindex $rowidlist [expr {$row + 1}]]
4930 foreach p $olds {
4931 set i [lsearch -exact $nextids $p]
4932 if {$i > $rmx} {
4933 set rmx $i
4937 set xt [xc $row $rmx]
4938 set rowtextx($row) $xt
4939 set idpos($id) [list $x $xt $y]
4940 if {[info exists idtags($id)] || [info exists idheads($id)]
4941 || [info exists idotherrefs($id)]} {
4942 set xt [drawtags $id $x $xt $y]
4944 set headline [lindex $commitinfo($id) 0]
4945 set name [lindex $commitinfo($id) 1]
4946 set date [lindex $commitinfo($id) 2]
4947 set date [formatdate $date]
4948 set font mainfont
4949 set nfont mainfont
4950 set isbold [ishighlighted $id]
4951 if {$isbold > 0} {
4952 lappend boldrows $row
4953 set font mainfontbold
4954 if {$isbold > 1} {
4955 lappend boldnamerows $row
4956 set nfont mainfontbold
4959 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4960 -text $headline -font $font -tags text]
4961 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4962 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4963 -text $name -font $nfont -tags text]
4964 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4965 -text $date -font mainfont -tags text]
4966 if {$selectedline == $row} {
4967 make_secsel $row
4969 set xr [expr {$xt + [font measure $font $headline]}]
4970 if {$xr > $canvxmax} {
4971 set canvxmax $xr
4972 setcanvscroll
4976 proc drawcmitrow {row} {
4977 global displayorder rowidlist nrows_drawn
4978 global iddrawn markingmatches
4979 global commitinfo numcommits
4980 global filehighlight fhighlights findpattern nhighlights
4981 global hlview vhighlights
4982 global highlight_related rhighlights
4984 if {$row >= $numcommits} return
4986 set id [lindex $displayorder $row]
4987 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4988 askvhighlight $row $id
4990 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4991 askfilehighlight $row $id
4993 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4994 askfindhighlight $row $id
4996 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4997 askrelhighlight $row $id
4999 if {![info exists iddrawn($id)]} {
5000 set col [lsearch -exact [lindex $rowidlist $row] $id]
5001 if {$col < 0} {
5002 puts "oops, row $row id $id not in list"
5003 return
5005 if {![info exists commitinfo($id)]} {
5006 getcommit $id
5008 assigncolor $id
5009 drawcmittext $id $row $col
5010 set iddrawn($id) 1
5011 incr nrows_drawn
5013 if {$markingmatches} {
5014 markrowmatches $row $id
5018 proc drawcommits {row {endrow {}}} {
5019 global numcommits iddrawn displayorder curview need_redisplay
5020 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5022 if {$row < 0} {
5023 set row 0
5025 if {$endrow eq {}} {
5026 set endrow $row
5028 if {$endrow >= $numcommits} {
5029 set endrow [expr {$numcommits - 1}]
5032 set rl1 [expr {$row - $downarrowlen - 3}]
5033 if {$rl1 < 0} {
5034 set rl1 0
5036 set ro1 [expr {$row - 3}]
5037 if {$ro1 < 0} {
5038 set ro1 0
5040 set r2 [expr {$endrow + $uparrowlen + 3}]
5041 if {$r2 > $numcommits} {
5042 set r2 $numcommits
5044 for {set r $rl1} {$r < $r2} {incr r} {
5045 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5046 if {$rl1 < $r} {
5047 layoutrows $rl1 $r
5049 set rl1 [expr {$r + 1}]
5052 if {$rl1 < $r} {
5053 layoutrows $rl1 $r
5055 optimize_rows $ro1 0 $r2
5056 if {$need_redisplay || $nrows_drawn > 2000} {
5057 clear_display
5058 drawvisible
5061 # make the lines join to already-drawn rows either side
5062 set r [expr {$row - 1}]
5063 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5064 set r $row
5066 set er [expr {$endrow + 1}]
5067 if {$er >= $numcommits ||
5068 ![info exists iddrawn([lindex $displayorder $er])]} {
5069 set er $endrow
5071 for {} {$r <= $er} {incr r} {
5072 set id [lindex $displayorder $r]
5073 set wasdrawn [info exists iddrawn($id)]
5074 drawcmitrow $r
5075 if {$r == $er} break
5076 set nextid [lindex $displayorder [expr {$r + 1}]]
5077 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5078 drawparentlinks $id $r
5080 set rowids [lindex $rowidlist $r]
5081 foreach lid $rowids {
5082 if {$lid eq {}} continue
5083 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5084 if {$lid eq $id} {
5085 # see if this is the first child of any of its parents
5086 foreach p [lindex $parentlist $r] {
5087 if {[lsearch -exact $rowids $p] < 0} {
5088 # make this line extend up to the child
5089 set lineend($p) [drawlineseg $p $r $er 0]
5092 } else {
5093 set lineend($lid) [drawlineseg $lid $r $er 1]
5099 proc undolayout {row} {
5100 global uparrowlen mingaplen downarrowlen
5101 global rowidlist rowisopt rowfinal need_redisplay
5103 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5104 if {$r < 0} {
5105 set r 0
5107 if {[llength $rowidlist] > $r} {
5108 incr r -1
5109 set rowidlist [lrange $rowidlist 0 $r]
5110 set rowfinal [lrange $rowfinal 0 $r]
5111 set rowisopt [lrange $rowisopt 0 $r]
5112 set need_redisplay 1
5113 run drawvisible
5117 proc drawvisible {} {
5118 global canv linespc curview vrowmod selectedline targetrow targetid
5119 global need_redisplay cscroll numcommits
5121 set fs [$canv yview]
5122 set ymax [lindex [$canv cget -scrollregion] 3]
5123 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5124 set f0 [lindex $fs 0]
5125 set f1 [lindex $fs 1]
5126 set y0 [expr {int($f0 * $ymax)}]
5127 set y1 [expr {int($f1 * $ymax)}]
5129 if {[info exists targetid]} {
5130 if {[commitinview $targetid $curview]} {
5131 set r [rowofcommit $targetid]
5132 if {$r != $targetrow} {
5133 # Fix up the scrollregion and change the scrolling position
5134 # now that our target row has moved.
5135 set diff [expr {($r - $targetrow) * $linespc}]
5136 set targetrow $r
5137 setcanvscroll
5138 set ymax [lindex [$canv cget -scrollregion] 3]
5139 incr y0 $diff
5140 incr y1 $diff
5141 set f0 [expr {$y0 / $ymax}]
5142 set f1 [expr {$y1 / $ymax}]
5143 allcanvs yview moveto $f0
5144 $cscroll set $f0 $f1
5145 set need_redisplay 1
5147 } else {
5148 unset targetid
5152 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5153 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5154 if {$endrow >= $vrowmod($curview)} {
5155 update_arcrows $curview
5157 if {$selectedline ne {} &&
5158 $row <= $selectedline && $selectedline <= $endrow} {
5159 set targetrow $selectedline
5160 } elseif {[info exists targetid]} {
5161 set targetrow [expr {int(($row + $endrow) / 2)}]
5163 if {[info exists targetrow]} {
5164 if {$targetrow >= $numcommits} {
5165 set targetrow [expr {$numcommits - 1}]
5167 set targetid [commitonrow $targetrow]
5169 drawcommits $row $endrow
5172 proc clear_display {} {
5173 global iddrawn linesegs need_redisplay nrows_drawn
5174 global vhighlights fhighlights nhighlights rhighlights
5175 global linehtag linentag linedtag boldrows boldnamerows
5177 allcanvs delete all
5178 catch {unset iddrawn}
5179 catch {unset linesegs}
5180 catch {unset linehtag}
5181 catch {unset linentag}
5182 catch {unset linedtag}
5183 set boldrows {}
5184 set boldnamerows {}
5185 catch {unset vhighlights}
5186 catch {unset fhighlights}
5187 catch {unset nhighlights}
5188 catch {unset rhighlights}
5189 set need_redisplay 0
5190 set nrows_drawn 0
5193 proc findcrossings {id} {
5194 global rowidlist parentlist numcommits displayorder
5196 set cross {}
5197 set ccross {}
5198 foreach {s e} [rowranges $id] {
5199 if {$e >= $numcommits} {
5200 set e [expr {$numcommits - 1}]
5202 if {$e <= $s} continue
5203 for {set row $e} {[incr row -1] >= $s} {} {
5204 set x [lsearch -exact [lindex $rowidlist $row] $id]
5205 if {$x < 0} break
5206 set olds [lindex $parentlist $row]
5207 set kid [lindex $displayorder $row]
5208 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5209 if {$kidx < 0} continue
5210 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5211 foreach p $olds {
5212 set px [lsearch -exact $nextrow $p]
5213 if {$px < 0} continue
5214 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5215 if {[lsearch -exact $ccross $p] >= 0} continue
5216 if {$x == $px + ($kidx < $px? -1: 1)} {
5217 lappend ccross $p
5218 } elseif {[lsearch -exact $cross $p] < 0} {
5219 lappend cross $p
5225 return [concat $ccross {{}} $cross]
5228 proc assigncolor {id} {
5229 global colormap colors nextcolor
5230 global parents children children curview
5232 if {[info exists colormap($id)]} return
5233 set ncolors [llength $colors]
5234 if {[info exists children($curview,$id)]} {
5235 set kids $children($curview,$id)
5236 } else {
5237 set kids {}
5239 if {[llength $kids] == 1} {
5240 set child [lindex $kids 0]
5241 if {[info exists colormap($child)]
5242 && [llength $parents($curview,$child)] == 1} {
5243 set colormap($id) $colormap($child)
5244 return
5247 set badcolors {}
5248 set origbad {}
5249 foreach x [findcrossings $id] {
5250 if {$x eq {}} {
5251 # delimiter between corner crossings and other crossings
5252 if {[llength $badcolors] >= $ncolors - 1} break
5253 set origbad $badcolors
5255 if {[info exists colormap($x)]
5256 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5257 lappend badcolors $colormap($x)
5260 if {[llength $badcolors] >= $ncolors} {
5261 set badcolors $origbad
5263 set origbad $badcolors
5264 if {[llength $badcolors] < $ncolors - 1} {
5265 foreach child $kids {
5266 if {[info exists colormap($child)]
5267 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5268 lappend badcolors $colormap($child)
5270 foreach p $parents($curview,$child) {
5271 if {[info exists colormap($p)]
5272 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5273 lappend badcolors $colormap($p)
5277 if {[llength $badcolors] >= $ncolors} {
5278 set badcolors $origbad
5281 for {set i 0} {$i <= $ncolors} {incr i} {
5282 set c [lindex $colors $nextcolor]
5283 if {[incr nextcolor] >= $ncolors} {
5284 set nextcolor 0
5286 if {[lsearch -exact $badcolors $c]} break
5288 set colormap($id) $c
5291 proc bindline {t id} {
5292 global canv
5294 $canv bind $t <Enter> "lineenter %x %y $id"
5295 $canv bind $t <Motion> "linemotion %x %y $id"
5296 $canv bind $t <Leave> "lineleave $id"
5297 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5300 proc drawtags {id x xt y1} {
5301 global idtags idheads idotherrefs mainhead
5302 global linespc lthickness
5303 global canv rowtextx curview fgcolor bgcolor
5305 set marks {}
5306 set ntags 0
5307 set nheads 0
5308 if {[info exists idtags($id)]} {
5309 set marks $idtags($id)
5310 set ntags [llength $marks]
5312 if {[info exists idheads($id)]} {
5313 set marks [concat $marks $idheads($id)]
5314 set nheads [llength $idheads($id)]
5316 if {[info exists idotherrefs($id)]} {
5317 set marks [concat $marks $idotherrefs($id)]
5319 if {$marks eq {}} {
5320 return $xt
5323 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5324 set yt [expr {$y1 - 0.5 * $linespc}]
5325 set yb [expr {$yt + $linespc - 1}]
5326 set xvals {}
5327 set wvals {}
5328 set i -1
5329 foreach tag $marks {
5330 incr i
5331 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5332 set wid [font measure mainfontbold $tag]
5333 } else {
5334 set wid [font measure mainfont $tag]
5336 lappend xvals $xt
5337 lappend wvals $wid
5338 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5340 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5341 -width $lthickness -fill black -tags tag.$id]
5342 $canv lower $t
5343 foreach tag $marks x $xvals wid $wvals {
5344 set xl [expr {$x + $delta}]
5345 set xr [expr {$x + $delta + $wid + $lthickness}]
5346 set font mainfont
5347 if {[incr ntags -1] >= 0} {
5348 # draw a tag
5349 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5350 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5351 -width 1 -outline black -fill yellow -tags tag.$id]
5352 $canv bind $t <1> [list showtag $tag 1]
5353 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5354 } else {
5355 # draw a head or other ref
5356 if {[incr nheads -1] >= 0} {
5357 set col green
5358 if {$tag eq $mainhead} {
5359 set font mainfontbold
5361 } else {
5362 set col "#ddddff"
5364 set xl [expr {$xl - $delta/2}]
5365 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5366 -width 1 -outline black -fill $col -tags tag.$id
5367 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5368 set rwid [font measure mainfont $remoteprefix]
5369 set xi [expr {$x + 1}]
5370 set yti [expr {$yt + 1}]
5371 set xri [expr {$x + $rwid}]
5372 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5373 -width 0 -fill "#ffddaa" -tags tag.$id
5376 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5377 -font $font -tags [list tag.$id text]]
5378 if {$ntags >= 0} {
5379 $canv bind $t <1> [list showtag $tag 1]
5380 } elseif {$nheads >= 0} {
5381 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5384 return $xt
5387 proc xcoord {i level ln} {
5388 global canvx0 xspc1 xspc2
5390 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5391 if {$i > 0 && $i == $level} {
5392 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5393 } elseif {$i > $level} {
5394 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5396 return $x
5399 proc show_status {msg} {
5400 global canv fgcolor
5402 clear_display
5403 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5404 -tags text -fill $fgcolor
5407 # Don't change the text pane cursor if it is currently the hand cursor,
5408 # showing that we are over a sha1 ID link.
5409 proc settextcursor {c} {
5410 global ctext curtextcursor
5412 if {[$ctext cget -cursor] == $curtextcursor} {
5413 $ctext config -cursor $c
5415 set curtextcursor $c
5418 proc nowbusy {what {name {}}} {
5419 global isbusy busyname statusw
5421 if {[array names isbusy] eq {}} {
5422 . config -cursor watch
5423 settextcursor watch
5425 set isbusy($what) 1
5426 set busyname($what) $name
5427 if {$name ne {}} {
5428 $statusw conf -text $name
5432 proc notbusy {what} {
5433 global isbusy maincursor textcursor busyname statusw
5435 catch {
5436 unset isbusy($what)
5437 if {$busyname($what) ne {} &&
5438 [$statusw cget -text] eq $busyname($what)} {
5439 $statusw conf -text {}
5442 if {[array names isbusy] eq {}} {
5443 . config -cursor $maincursor
5444 settextcursor $textcursor
5448 proc findmatches {f} {
5449 global findtype findstring
5450 if {$findtype == [mc "Regexp"]} {
5451 set matches [regexp -indices -all -inline $findstring $f]
5452 } else {
5453 set fs $findstring
5454 if {$findtype == [mc "IgnCase"]} {
5455 set f [string tolower $f]
5456 set fs [string tolower $fs]
5458 set matches {}
5459 set i 0
5460 set l [string length $fs]
5461 while {[set j [string first $fs $f $i]] >= 0} {
5462 lappend matches [list $j [expr {$j+$l-1}]]
5463 set i [expr {$j + $l}]
5466 return $matches
5469 proc dofind {{dirn 1} {wrap 1}} {
5470 global findstring findstartline findcurline selectedline numcommits
5471 global gdttype filehighlight fh_serial find_dirn findallowwrap
5473 if {[info exists find_dirn]} {
5474 if {$find_dirn == $dirn} return
5475 stopfinding
5477 focus .
5478 if {$findstring eq {} || $numcommits == 0} return
5479 if {$selectedline eq {}} {
5480 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5481 } else {
5482 set findstartline $selectedline
5484 set findcurline $findstartline
5485 nowbusy finding [mc "Searching"]
5486 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5487 after cancel do_file_hl $fh_serial
5488 do_file_hl $fh_serial
5490 set find_dirn $dirn
5491 set findallowwrap $wrap
5492 run findmore
5495 proc stopfinding {} {
5496 global find_dirn findcurline fprogcoord
5498 if {[info exists find_dirn]} {
5499 unset find_dirn
5500 unset findcurline
5501 notbusy finding
5502 set fprogcoord 0
5503 adjustprogress
5507 proc findmore {} {
5508 global commitdata commitinfo numcommits findpattern findloc
5509 global findstartline findcurline findallowwrap
5510 global find_dirn gdttype fhighlights fprogcoord
5511 global curview varcorder vrownum varccommits vrowmod
5513 if {![info exists find_dirn]} {
5514 return 0
5516 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5517 set l $findcurline
5518 set moretodo 0
5519 if {$find_dirn > 0} {
5520 incr l
5521 if {$l >= $numcommits} {
5522 set l 0
5524 if {$l <= $findstartline} {
5525 set lim [expr {$findstartline + 1}]
5526 } else {
5527 set lim $numcommits
5528 set moretodo $findallowwrap
5530 } else {
5531 if {$l == 0} {
5532 set l $numcommits
5534 incr l -1
5535 if {$l >= $findstartline} {
5536 set lim [expr {$findstartline - 1}]
5537 } else {
5538 set lim -1
5539 set moretodo $findallowwrap
5542 set n [expr {($lim - $l) * $find_dirn}]
5543 if {$n > 500} {
5544 set n 500
5545 set moretodo 1
5547 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5548 update_arcrows $curview
5550 set found 0
5551 set domore 1
5552 set ai [bsearch $vrownum($curview) $l]
5553 set a [lindex $varcorder($curview) $ai]
5554 set arow [lindex $vrownum($curview) $ai]
5555 set ids [lindex $varccommits($curview,$a)]
5556 set arowend [expr {$arow + [llength $ids]}]
5557 if {$gdttype eq [mc "containing:"]} {
5558 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5559 if {$l < $arow || $l >= $arowend} {
5560 incr ai $find_dirn
5561 set a [lindex $varcorder($curview) $ai]
5562 set arow [lindex $vrownum($curview) $ai]
5563 set ids [lindex $varccommits($curview,$a)]
5564 set arowend [expr {$arow + [llength $ids]}]
5566 set id [lindex $ids [expr {$l - $arow}]]
5567 # shouldn't happen unless git log doesn't give all the commits...
5568 if {![info exists commitdata($id)] ||
5569 ![doesmatch $commitdata($id)]} {
5570 continue
5572 if {![info exists commitinfo($id)]} {
5573 getcommit $id
5575 set info $commitinfo($id)
5576 foreach f $info ty $fldtypes {
5577 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5578 [doesmatch $f]} {
5579 set found 1
5580 break
5583 if {$found} break
5585 } else {
5586 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5587 if {$l < $arow || $l >= $arowend} {
5588 incr ai $find_dirn
5589 set a [lindex $varcorder($curview) $ai]
5590 set arow [lindex $vrownum($curview) $ai]
5591 set ids [lindex $varccommits($curview,$a)]
5592 set arowend [expr {$arow + [llength $ids]}]
5594 set id [lindex $ids [expr {$l - $arow}]]
5595 if {![info exists fhighlights($id)]} {
5596 # this sets fhighlights($id) to -1
5597 askfilehighlight $l $id
5599 if {$fhighlights($id) > 0} {
5600 set found $domore
5601 break
5603 if {$fhighlights($id) < 0} {
5604 if {$domore} {
5605 set domore 0
5606 set findcurline [expr {$l - $find_dirn}]
5611 if {$found || ($domore && !$moretodo)} {
5612 unset findcurline
5613 unset find_dirn
5614 notbusy finding
5615 set fprogcoord 0
5616 adjustprogress
5617 if {$found} {
5618 findselectline $l
5619 } else {
5620 bell
5622 return 0
5624 if {!$domore} {
5625 flushhighlights
5626 } else {
5627 set findcurline [expr {$l - $find_dirn}]
5629 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5630 if {$n < 0} {
5631 incr n $numcommits
5633 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5634 adjustprogress
5635 return $domore
5638 proc findselectline {l} {
5639 global findloc commentend ctext findcurline markingmatches gdttype
5641 set markingmatches 1
5642 set findcurline $l
5643 selectline $l 1
5644 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5645 # highlight the matches in the comments
5646 set f [$ctext get 1.0 $commentend]
5647 set matches [findmatches $f]
5648 foreach match $matches {
5649 set start [lindex $match 0]
5650 set end [expr {[lindex $match 1] + 1}]
5651 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5654 drawvisible
5657 # mark the bits of a headline or author that match a find string
5658 proc markmatches {canv l str tag matches font row} {
5659 global selectedline
5661 set bbox [$canv bbox $tag]
5662 set x0 [lindex $bbox 0]
5663 set y0 [lindex $bbox 1]
5664 set y1 [lindex $bbox 3]
5665 foreach match $matches {
5666 set start [lindex $match 0]
5667 set end [lindex $match 1]
5668 if {$start > $end} continue
5669 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5670 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5671 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5672 [expr {$x0+$xlen+2}] $y1 \
5673 -outline {} -tags [list match$l matches] -fill yellow]
5674 $canv lower $t
5675 if {$row == $selectedline} {
5676 $canv raise $t secsel
5681 proc unmarkmatches {} {
5682 global markingmatches
5684 allcanvs delete matches
5685 set markingmatches 0
5686 stopfinding
5689 proc selcanvline {w x y} {
5690 global canv canvy0 ctext linespc
5691 global rowtextx
5692 set ymax [lindex [$canv cget -scrollregion] 3]
5693 if {$ymax == {}} return
5694 set yfrac [lindex [$canv yview] 0]
5695 set y [expr {$y + $yfrac * $ymax}]
5696 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5697 if {$l < 0} {
5698 set l 0
5700 if {$w eq $canv} {
5701 set xmax [lindex [$canv cget -scrollregion] 2]
5702 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5703 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5705 unmarkmatches
5706 selectline $l 1
5709 proc commit_descriptor {p} {
5710 global commitinfo
5711 if {![info exists commitinfo($p)]} {
5712 getcommit $p
5714 set l "..."
5715 if {[llength $commitinfo($p)] > 1} {
5716 set l [lindex $commitinfo($p) 0]
5718 return "$p ($l)\n"
5721 # append some text to the ctext widget, and make any SHA1 ID
5722 # that we know about be a clickable link.
5723 proc appendwithlinks {text tags} {
5724 global ctext linknum curview pendinglinks
5726 set start [$ctext index "end - 1c"]
5727 $ctext insert end $text $tags
5728 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5729 foreach l $links {
5730 set s [lindex $l 0]
5731 set e [lindex $l 1]
5732 set linkid [string range $text $s $e]
5733 incr e
5734 $ctext tag delete link$linknum
5735 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5736 setlink $linkid link$linknum
5737 incr linknum
5741 proc setlink {id lk} {
5742 global curview ctext pendinglinks commitinterest
5744 if {[commitinview $id $curview]} {
5745 $ctext tag conf $lk -foreground blue -underline 1
5746 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5747 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5748 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5749 } else {
5750 lappend pendinglinks($id) $lk
5751 lappend commitinterest($id) {makelink %I}
5755 proc makelink {id} {
5756 global pendinglinks
5758 if {![info exists pendinglinks($id)]} return
5759 foreach lk $pendinglinks($id) {
5760 setlink $id $lk
5762 unset pendinglinks($id)
5765 proc linkcursor {w inc} {
5766 global linkentercount curtextcursor
5768 if {[incr linkentercount $inc] > 0} {
5769 $w configure -cursor hand2
5770 } else {
5771 $w configure -cursor $curtextcursor
5772 if {$linkentercount < 0} {
5773 set linkentercount 0
5778 proc viewnextline {dir} {
5779 global canv linespc
5781 $canv delete hover
5782 set ymax [lindex [$canv cget -scrollregion] 3]
5783 set wnow [$canv yview]
5784 set wtop [expr {[lindex $wnow 0] * $ymax}]
5785 set newtop [expr {$wtop + $dir * $linespc}]
5786 if {$newtop < 0} {
5787 set newtop 0
5788 } elseif {$newtop > $ymax} {
5789 set newtop $ymax
5791 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5794 # add a list of tag or branch names at position pos
5795 # returns the number of names inserted
5796 proc appendrefs {pos ids var} {
5797 global ctext linknum curview $var maxrefs
5799 if {[catch {$ctext index $pos}]} {
5800 return 0
5802 $ctext conf -state normal
5803 $ctext delete $pos "$pos lineend"
5804 set tags {}
5805 foreach id $ids {
5806 foreach tag [set $var\($id\)] {
5807 lappend tags [list $tag $id]
5810 if {[llength $tags] > $maxrefs} {
5811 $ctext insert $pos "many ([llength $tags])"
5812 } else {
5813 set tags [lsort -index 0 -decreasing $tags]
5814 set sep {}
5815 foreach ti $tags {
5816 set id [lindex $ti 1]
5817 set lk link$linknum
5818 incr linknum
5819 $ctext tag delete $lk
5820 $ctext insert $pos $sep
5821 $ctext insert $pos [lindex $ti 0] $lk
5822 setlink $id $lk
5823 set sep ", "
5826 $ctext conf -state disabled
5827 return [llength $tags]
5830 # called when we have finished computing the nearby tags
5831 proc dispneartags {delay} {
5832 global selectedline currentid showneartags tagphase
5834 if {$selectedline eq {} || !$showneartags} return
5835 after cancel dispnexttag
5836 if {$delay} {
5837 after 200 dispnexttag
5838 set tagphase -1
5839 } else {
5840 after idle dispnexttag
5841 set tagphase 0
5845 proc dispnexttag {} {
5846 global selectedline currentid showneartags tagphase ctext
5848 if {$selectedline eq {} || !$showneartags} return
5849 switch -- $tagphase {
5851 set dtags [desctags $currentid]
5852 if {$dtags ne {}} {
5853 appendrefs precedes $dtags idtags
5857 set atags [anctags $currentid]
5858 if {$atags ne {}} {
5859 appendrefs follows $atags idtags
5863 set dheads [descheads $currentid]
5864 if {$dheads ne {}} {
5865 if {[appendrefs branch $dheads idheads] > 1
5866 && [$ctext get "branch -3c"] eq "h"} {
5867 # turn "Branch" into "Branches"
5868 $ctext conf -state normal
5869 $ctext insert "branch -2c" "es"
5870 $ctext conf -state disabled
5875 if {[incr tagphase] <= 2} {
5876 after idle dispnexttag
5880 proc make_secsel {l} {
5881 global linehtag linentag linedtag canv canv2 canv3
5883 if {![info exists linehtag($l)]} return
5884 $canv delete secsel
5885 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5886 -tags secsel -fill [$canv cget -selectbackground]]
5887 $canv lower $t
5888 $canv2 delete secsel
5889 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5890 -tags secsel -fill [$canv2 cget -selectbackground]]
5891 $canv2 lower $t
5892 $canv3 delete secsel
5893 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5894 -tags secsel -fill [$canv3 cget -selectbackground]]
5895 $canv3 lower $t
5898 proc selectline {l isnew} {
5899 global canv ctext commitinfo selectedline
5900 global canvy0 linespc parents children curview
5901 global currentid sha1entry
5902 global commentend idtags linknum
5903 global mergemax numcommits pending_select
5904 global cmitmode showneartags allcommits
5905 global targetrow targetid lastscrollrows
5906 global autoselect
5908 catch {unset pending_select}
5909 $canv delete hover
5910 normalline
5911 unsel_reflist
5912 stopfinding
5913 if {$l < 0 || $l >= $numcommits} return
5914 set id [commitonrow $l]
5915 set targetid $id
5916 set targetrow $l
5917 set selectedline $l
5918 set currentid $id
5919 if {$lastscrollrows < $numcommits} {
5920 setcanvscroll
5923 set y [expr {$canvy0 + $l * $linespc}]
5924 set ymax [lindex [$canv cget -scrollregion] 3]
5925 set ytop [expr {$y - $linespc - 1}]
5926 set ybot [expr {$y + $linespc + 1}]
5927 set wnow [$canv yview]
5928 set wtop [expr {[lindex $wnow 0] * $ymax}]
5929 set wbot [expr {[lindex $wnow 1] * $ymax}]
5930 set wh [expr {$wbot - $wtop}]
5931 set newtop $wtop
5932 if {$ytop < $wtop} {
5933 if {$ybot < $wtop} {
5934 set newtop [expr {$y - $wh / 2.0}]
5935 } else {
5936 set newtop $ytop
5937 if {$newtop > $wtop - $linespc} {
5938 set newtop [expr {$wtop - $linespc}]
5941 } elseif {$ybot > $wbot} {
5942 if {$ytop > $wbot} {
5943 set newtop [expr {$y - $wh / 2.0}]
5944 } else {
5945 set newtop [expr {$ybot - $wh}]
5946 if {$newtop < $wtop + $linespc} {
5947 set newtop [expr {$wtop + $linespc}]
5951 if {$newtop != $wtop} {
5952 if {$newtop < 0} {
5953 set newtop 0
5955 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5956 drawvisible
5959 make_secsel $l
5961 if {$isnew} {
5962 addtohistory [list selbyid $id]
5965 $sha1entry delete 0 end
5966 $sha1entry insert 0 $id
5967 if {$autoselect} {
5968 $sha1entry selection from 0
5969 $sha1entry selection to end
5971 rhighlight_sel $id
5973 $ctext conf -state normal
5974 clear_ctext
5975 set linknum 0
5976 if {![info exists commitinfo($id)]} {
5977 getcommit $id
5979 set info $commitinfo($id)
5980 set date [formatdate [lindex $info 2]]
5981 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5982 set date [formatdate [lindex $info 4]]
5983 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5984 if {[info exists idtags($id)]} {
5985 $ctext insert end [mc "Tags:"]
5986 foreach tag $idtags($id) {
5987 $ctext insert end " $tag"
5989 $ctext insert end "\n"
5992 set headers {}
5993 set olds $parents($curview,$id)
5994 if {[llength $olds] > 1} {
5995 set np 0
5996 foreach p $olds {
5997 if {$np >= $mergemax} {
5998 set tag mmax
5999 } else {
6000 set tag m$np
6002 $ctext insert end "[mc "Parent"]: " $tag
6003 appendwithlinks [commit_descriptor $p] {}
6004 incr np
6006 } else {
6007 foreach p $olds {
6008 append headers "[mc "Parent"]: [commit_descriptor $p]"
6012 foreach c $children($curview,$id) {
6013 append headers "[mc "Child"]: [commit_descriptor $c]"
6016 # make anything that looks like a SHA1 ID be a clickable link
6017 appendwithlinks $headers {}
6018 if {$showneartags} {
6019 if {![info exists allcommits]} {
6020 getallcommits
6022 $ctext insert end "[mc "Branch"]: "
6023 $ctext mark set branch "end -1c"
6024 $ctext mark gravity branch left
6025 $ctext insert end "\n[mc "Follows"]: "
6026 $ctext mark set follows "end -1c"
6027 $ctext mark gravity follows left
6028 $ctext insert end "\n[mc "Precedes"]: "
6029 $ctext mark set precedes "end -1c"
6030 $ctext mark gravity precedes left
6031 $ctext insert end "\n"
6032 dispneartags 1
6034 $ctext insert end "\n"
6035 set comment [lindex $info 5]
6036 if {[string first "\r" $comment] >= 0} {
6037 set comment [string map {"\r" "\n "} $comment]
6039 appendwithlinks $comment {comment}
6041 $ctext tag remove found 1.0 end
6042 $ctext conf -state disabled
6043 set commentend [$ctext index "end - 1c"]
6045 init_flist [mc "Comments"]
6046 if {$cmitmode eq "tree"} {
6047 gettree $id
6048 } elseif {[llength $olds] <= 1} {
6049 startdiff $id
6050 } else {
6051 mergediff $id
6055 proc selfirstline {} {
6056 unmarkmatches
6057 selectline 0 1
6060 proc sellastline {} {
6061 global numcommits
6062 unmarkmatches
6063 set l [expr {$numcommits - 1}]
6064 selectline $l 1
6067 proc selnextline {dir} {
6068 global selectedline
6069 focus .
6070 if {$selectedline eq {}} return
6071 set l [expr {$selectedline + $dir}]
6072 unmarkmatches
6073 selectline $l 1
6076 proc selnextpage {dir} {
6077 global canv linespc selectedline numcommits
6079 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6080 if {$lpp < 1} {
6081 set lpp 1
6083 allcanvs yview scroll [expr {$dir * $lpp}] units
6084 drawvisible
6085 if {$selectedline eq {}} return
6086 set l [expr {$selectedline + $dir * $lpp}]
6087 if {$l < 0} {
6088 set l 0
6089 } elseif {$l >= $numcommits} {
6090 set l [expr $numcommits - 1]
6092 unmarkmatches
6093 selectline $l 1
6096 proc unselectline {} {
6097 global selectedline currentid
6099 set selectedline {}
6100 catch {unset currentid}
6101 allcanvs delete secsel
6102 rhighlight_none
6105 proc reselectline {} {
6106 global selectedline
6108 if {$selectedline ne {}} {
6109 selectline $selectedline 0
6113 proc addtohistory {cmd} {
6114 global history historyindex curview
6116 set elt [list $curview $cmd]
6117 if {$historyindex > 0
6118 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6119 return
6122 if {$historyindex < [llength $history]} {
6123 set history [lreplace $history $historyindex end $elt]
6124 } else {
6125 lappend history $elt
6127 incr historyindex
6128 if {$historyindex > 1} {
6129 .tf.bar.leftbut conf -state normal
6130 } else {
6131 .tf.bar.leftbut conf -state disabled
6133 .tf.bar.rightbut conf -state disabled
6136 proc godo {elt} {
6137 global curview
6139 set view [lindex $elt 0]
6140 set cmd [lindex $elt 1]
6141 if {$curview != $view} {
6142 showview $view
6144 eval $cmd
6147 proc goback {} {
6148 global history historyindex
6149 focus .
6151 if {$historyindex > 1} {
6152 incr historyindex -1
6153 godo [lindex $history [expr {$historyindex - 1}]]
6154 .tf.bar.rightbut conf -state normal
6156 if {$historyindex <= 1} {
6157 .tf.bar.leftbut conf -state disabled
6161 proc goforw {} {
6162 global history historyindex
6163 focus .
6165 if {$historyindex < [llength $history]} {
6166 set cmd [lindex $history $historyindex]
6167 incr historyindex
6168 godo $cmd
6169 .tf.bar.leftbut conf -state normal
6171 if {$historyindex >= [llength $history]} {
6172 .tf.bar.rightbut conf -state disabled
6176 proc gettree {id} {
6177 global treefilelist treeidlist diffids diffmergeid treepending
6178 global nullid nullid2
6180 set diffids $id
6181 catch {unset diffmergeid}
6182 if {![info exists treefilelist($id)]} {
6183 if {![info exists treepending]} {
6184 if {$id eq $nullid} {
6185 set cmd [list | git ls-files]
6186 } elseif {$id eq $nullid2} {
6187 set cmd [list | git ls-files --stage -t]
6188 } else {
6189 set cmd [list | git ls-tree -r $id]
6191 if {[catch {set gtf [open $cmd r]}]} {
6192 return
6194 set treepending $id
6195 set treefilelist($id) {}
6196 set treeidlist($id) {}
6197 fconfigure $gtf -blocking 0
6198 filerun $gtf [list gettreeline $gtf $id]
6200 } else {
6201 setfilelist $id
6205 proc gettreeline {gtf id} {
6206 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6208 set nl 0
6209 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6210 if {$diffids eq $nullid} {
6211 set fname $line
6212 } else {
6213 set i [string first "\t" $line]
6214 if {$i < 0} continue
6215 set fname [string range $line [expr {$i+1}] end]
6216 set line [string range $line 0 [expr {$i-1}]]
6217 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6218 set sha1 [lindex $line 2]
6219 if {[string index $fname 0] eq "\""} {
6220 set fname [lindex $fname 0]
6222 lappend treeidlist($id) $sha1
6224 lappend treefilelist($id) $fname
6226 if {![eof $gtf]} {
6227 return [expr {$nl >= 1000? 2: 1}]
6229 close $gtf
6230 unset treepending
6231 if {$cmitmode ne "tree"} {
6232 if {![info exists diffmergeid]} {
6233 gettreediffs $diffids
6235 } elseif {$id ne $diffids} {
6236 gettree $diffids
6237 } else {
6238 setfilelist $id
6240 return 0
6243 proc showfile {f} {
6244 global treefilelist treeidlist diffids nullid nullid2
6245 global ctext commentend
6247 set i [lsearch -exact $treefilelist($diffids) $f]
6248 if {$i < 0} {
6249 puts "oops, $f not in list for id $diffids"
6250 return
6252 if {$diffids eq $nullid} {
6253 if {[catch {set bf [open $f r]} err]} {
6254 puts "oops, can't read $f: $err"
6255 return
6257 } else {
6258 set blob [lindex $treeidlist($diffids) $i]
6259 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6260 puts "oops, error reading blob $blob: $err"
6261 return
6264 fconfigure $bf -blocking 0
6265 filerun $bf [list getblobline $bf $diffids]
6266 $ctext config -state normal
6267 clear_ctext $commentend
6268 $ctext insert end "\n"
6269 $ctext insert end "$f\n" filesep
6270 $ctext config -state disabled
6271 $ctext yview $commentend
6272 settabs 0
6275 proc getblobline {bf id} {
6276 global diffids cmitmode ctext
6278 if {$id ne $diffids || $cmitmode ne "tree"} {
6279 catch {close $bf}
6280 return 0
6282 $ctext config -state normal
6283 set nl 0
6284 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6285 $ctext insert end "$line\n"
6287 if {[eof $bf]} {
6288 # delete last newline
6289 $ctext delete "end - 2c" "end - 1c"
6290 close $bf
6291 return 0
6293 $ctext config -state disabled
6294 return [expr {$nl >= 1000? 2: 1}]
6297 proc mergediff {id} {
6298 global diffmergeid mdifffd
6299 global diffids
6300 global parents
6301 global diffcontext
6302 global limitdiffs vfilelimit curview
6304 set diffmergeid $id
6305 set diffids $id
6306 # this doesn't seem to actually affect anything...
6307 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6308 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6309 set cmd [concat $cmd -- $vfilelimit($curview)]
6311 if {[catch {set mdf [open $cmd r]} err]} {
6312 error_popup "[mc "Error getting merge diffs:"] $err"
6313 return
6315 fconfigure $mdf -blocking 0
6316 set mdifffd($id) $mdf
6317 set np [llength $parents($curview,$id)]
6318 settabs $np
6319 filerun $mdf [list getmergediffline $mdf $id $np]
6322 proc getmergediffline {mdf id np} {
6323 global diffmergeid ctext cflist mergemax
6324 global difffilestart mdifffd
6326 $ctext conf -state normal
6327 set nr 0
6328 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6329 if {![info exists diffmergeid] || $id != $diffmergeid
6330 || $mdf != $mdifffd($id)} {
6331 close $mdf
6332 return 0
6334 if {[regexp {^diff --cc (.*)} $line match fname]} {
6335 # start of a new file
6336 $ctext insert end "\n"
6337 set here [$ctext index "end - 1c"]
6338 lappend difffilestart $here
6339 add_flist [list $fname]
6340 set l [expr {(78 - [string length $fname]) / 2}]
6341 set pad [string range "----------------------------------------" 1 $l]
6342 $ctext insert end "$pad $fname $pad\n" filesep
6343 } elseif {[regexp {^@@} $line]} {
6344 $ctext insert end "$line\n" hunksep
6345 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6346 # do nothing
6347 } else {
6348 # parse the prefix - one ' ', '-' or '+' for each parent
6349 set spaces {}
6350 set minuses {}
6351 set pluses {}
6352 set isbad 0
6353 for {set j 0} {$j < $np} {incr j} {
6354 set c [string range $line $j $j]
6355 if {$c == " "} {
6356 lappend spaces $j
6357 } elseif {$c == "-"} {
6358 lappend minuses $j
6359 } elseif {$c == "+"} {
6360 lappend pluses $j
6361 } else {
6362 set isbad 1
6363 break
6366 set tags {}
6367 set num {}
6368 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6369 # line doesn't appear in result, parents in $minuses have the line
6370 set num [lindex $minuses 0]
6371 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6372 # line appears in result, parents in $pluses don't have the line
6373 lappend tags mresult
6374 set num [lindex $spaces 0]
6376 if {$num ne {}} {
6377 if {$num >= $mergemax} {
6378 set num "max"
6380 lappend tags m$num
6382 $ctext insert end "$line\n" $tags
6385 $ctext conf -state disabled
6386 if {[eof $mdf]} {
6387 close $mdf
6388 return 0
6390 return [expr {$nr >= 1000? 2: 1}]
6393 proc startdiff {ids} {
6394 global treediffs diffids treepending diffmergeid nullid nullid2
6396 settabs 1
6397 set diffids $ids
6398 catch {unset diffmergeid}
6399 if {![info exists treediffs($ids)] ||
6400 [lsearch -exact $ids $nullid] >= 0 ||
6401 [lsearch -exact $ids $nullid2] >= 0} {
6402 if {![info exists treepending]} {
6403 gettreediffs $ids
6405 } else {
6406 addtocflist $ids
6410 proc path_filter {filter name} {
6411 foreach p $filter {
6412 set l [string length $p]
6413 if {[string index $p end] eq "/"} {
6414 if {[string compare -length $l $p $name] == 0} {
6415 return 1
6417 } else {
6418 if {[string compare -length $l $p $name] == 0 &&
6419 ([string length $name] == $l ||
6420 [string index $name $l] eq "/")} {
6421 return 1
6425 return 0
6428 proc addtocflist {ids} {
6429 global treediffs
6431 add_flist $treediffs($ids)
6432 getblobdiffs $ids
6435 proc diffcmd {ids flags} {
6436 global nullid nullid2
6438 set i [lsearch -exact $ids $nullid]
6439 set j [lsearch -exact $ids $nullid2]
6440 if {$i >= 0} {
6441 if {[llength $ids] > 1 && $j < 0} {
6442 # comparing working directory with some specific revision
6443 set cmd [concat | git diff-index $flags]
6444 if {$i == 0} {
6445 lappend cmd -R [lindex $ids 1]
6446 } else {
6447 lappend cmd [lindex $ids 0]
6449 } else {
6450 # comparing working directory with index
6451 set cmd [concat | git diff-files $flags]
6452 if {$j == 1} {
6453 lappend cmd -R
6456 } elseif {$j >= 0} {
6457 set cmd [concat | git diff-index --cached $flags]
6458 if {[llength $ids] > 1} {
6459 # comparing index with specific revision
6460 if {$i == 0} {
6461 lappend cmd -R [lindex $ids 1]
6462 } else {
6463 lappend cmd [lindex $ids 0]
6465 } else {
6466 # comparing index with HEAD
6467 lappend cmd HEAD
6469 } else {
6470 set cmd [concat | git diff-tree -r $flags $ids]
6472 return $cmd
6475 proc gettreediffs {ids} {
6476 global treediff treepending
6478 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6480 set treepending $ids
6481 set treediff {}
6482 fconfigure $gdtf -blocking 0
6483 filerun $gdtf [list gettreediffline $gdtf $ids]
6486 proc gettreediffline {gdtf ids} {
6487 global treediff treediffs treepending diffids diffmergeid
6488 global cmitmode vfilelimit curview limitdiffs
6490 set nr 0
6491 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6492 set i [string first "\t" $line]
6493 if {$i >= 0} {
6494 set file [string range $line [expr {$i+1}] end]
6495 if {[string index $file 0] eq "\""} {
6496 set file [lindex $file 0]
6498 lappend treediff $file
6501 if {![eof $gdtf]} {
6502 return [expr {$nr >= 1000? 2: 1}]
6504 close $gdtf
6505 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6506 set flist {}
6507 foreach f $treediff {
6508 if {[path_filter $vfilelimit($curview) $f]} {
6509 lappend flist $f
6512 set treediffs($ids) $flist
6513 } else {
6514 set treediffs($ids) $treediff
6516 unset treepending
6517 if {$cmitmode eq "tree"} {
6518 gettree $diffids
6519 } elseif {$ids != $diffids} {
6520 if {![info exists diffmergeid]} {
6521 gettreediffs $diffids
6523 } else {
6524 addtocflist $ids
6526 return 0
6529 # empty string or positive integer
6530 proc diffcontextvalidate {v} {
6531 return [regexp {^(|[1-9][0-9]*)$} $v]
6534 proc diffcontextchange {n1 n2 op} {
6535 global diffcontextstring diffcontext
6537 if {[string is integer -strict $diffcontextstring]} {
6538 if {$diffcontextstring > 0} {
6539 set diffcontext $diffcontextstring
6540 reselectline
6545 proc changeignorespace {} {
6546 reselectline
6549 proc getblobdiffs {ids} {
6550 global blobdifffd diffids env
6551 global diffinhdr treediffs
6552 global diffcontext
6553 global ignorespace
6554 global limitdiffs vfilelimit curview
6556 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6557 if {$ignorespace} {
6558 append cmd " -w"
6560 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6561 set cmd [concat $cmd -- $vfilelimit($curview)]
6563 if {[catch {set bdf [open $cmd r]} err]} {
6564 puts "error getting diffs: $err"
6565 return
6567 set diffinhdr 0
6568 fconfigure $bdf -blocking 0
6569 set blobdifffd($ids) $bdf
6570 filerun $bdf [list getblobdiffline $bdf $diffids]
6573 proc setinlist {var i val} {
6574 global $var
6576 while {[llength [set $var]] < $i} {
6577 lappend $var {}
6579 if {[llength [set $var]] == $i} {
6580 lappend $var $val
6581 } else {
6582 lset $var $i $val
6586 proc makediffhdr {fname ids} {
6587 global ctext curdiffstart treediffs
6589 set i [lsearch -exact $treediffs($ids) $fname]
6590 if {$i >= 0} {
6591 setinlist difffilestart $i $curdiffstart
6593 set l [expr {(78 - [string length $fname]) / 2}]
6594 set pad [string range "----------------------------------------" 1 $l]
6595 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6598 proc getblobdiffline {bdf ids} {
6599 global diffids blobdifffd ctext curdiffstart
6600 global diffnexthead diffnextnote difffilestart
6601 global diffinhdr treediffs
6603 set nr 0
6604 $ctext conf -state normal
6605 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6606 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6607 close $bdf
6608 return 0
6610 if {![string compare -length 11 "diff --git " $line]} {
6611 # trim off "diff --git "
6612 set line [string range $line 11 end]
6613 set diffinhdr 1
6614 # start of a new file
6615 $ctext insert end "\n"
6616 set curdiffstart [$ctext index "end - 1c"]
6617 $ctext insert end "\n" filesep
6618 # If the name hasn't changed the length will be odd,
6619 # the middle char will be a space, and the two bits either
6620 # side will be a/name and b/name, or "a/name" and "b/name".
6621 # If the name has changed we'll get "rename from" and
6622 # "rename to" or "copy from" and "copy to" lines following this,
6623 # and we'll use them to get the filenames.
6624 # This complexity is necessary because spaces in the filename(s)
6625 # don't get escaped.
6626 set l [string length $line]
6627 set i [expr {$l / 2}]
6628 if {!(($l & 1) && [string index $line $i] eq " " &&
6629 [string range $line 2 [expr {$i - 1}]] eq \
6630 [string range $line [expr {$i + 3}] end])} {
6631 continue
6633 # unescape if quoted and chop off the a/ from the front
6634 if {[string index $line 0] eq "\""} {
6635 set fname [string range [lindex $line 0] 2 end]
6636 } else {
6637 set fname [string range $line 2 [expr {$i - 1}]]
6639 makediffhdr $fname $ids
6641 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6642 $line match f1l f1c f2l f2c rest]} {
6643 $ctext insert end "$line\n" hunksep
6644 set diffinhdr 0
6646 } elseif {$diffinhdr} {
6647 if {![string compare -length 12 "rename from " $line]} {
6648 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6649 if {[string index $fname 0] eq "\""} {
6650 set fname [lindex $fname 0]
6652 set i [lsearch -exact $treediffs($ids) $fname]
6653 if {$i >= 0} {
6654 setinlist difffilestart $i $curdiffstart
6656 } elseif {![string compare -length 10 $line "rename to "] ||
6657 ![string compare -length 8 $line "copy to "]} {
6658 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6659 if {[string index $fname 0] eq "\""} {
6660 set fname [lindex $fname 0]
6662 makediffhdr $fname $ids
6663 } elseif {[string compare -length 3 $line "---"] == 0} {
6664 # do nothing
6665 continue
6666 } elseif {[string compare -length 3 $line "+++"] == 0} {
6667 set diffinhdr 0
6668 continue
6670 $ctext insert end "$line\n" filesep
6672 } else {
6673 set x [string range $line 0 0]
6674 if {$x == "-" || $x == "+"} {
6675 set tag [expr {$x == "+"}]
6676 $ctext insert end "$line\n" d$tag
6677 } elseif {$x == " "} {
6678 $ctext insert end "$line\n"
6679 } else {
6680 # "\ No newline at end of file",
6681 # or something else we don't recognize
6682 $ctext insert end "$line\n" hunksep
6686 $ctext conf -state disabled
6687 if {[eof $bdf]} {
6688 close $bdf
6689 return 0
6691 return [expr {$nr >= 1000? 2: 1}]
6694 proc changediffdisp {} {
6695 global ctext diffelide
6697 $ctext tag conf d0 -elide [lindex $diffelide 0]
6698 $ctext tag conf d1 -elide [lindex $diffelide 1]
6701 proc highlightfile {loc cline} {
6702 global ctext cflist cflist_top
6704 $ctext yview $loc
6705 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6706 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6707 $cflist see $cline.0
6708 set cflist_top $cline
6711 proc prevfile {} {
6712 global difffilestart ctext cmitmode
6714 if {$cmitmode eq "tree"} return
6715 set prev 0.0
6716 set prevline 1
6717 set here [$ctext index @0,0]
6718 foreach loc $difffilestart {
6719 if {[$ctext compare $loc >= $here]} {
6720 highlightfile $prev $prevline
6721 return
6723 set prev $loc
6724 incr prevline
6726 highlightfile $prev $prevline
6729 proc nextfile {} {
6730 global difffilestart ctext cmitmode
6732 if {$cmitmode eq "tree"} return
6733 set here [$ctext index @0,0]
6734 set line 1
6735 foreach loc $difffilestart {
6736 incr line
6737 if {[$ctext compare $loc > $here]} {
6738 highlightfile $loc $line
6739 return
6744 proc clear_ctext {{first 1.0}} {
6745 global ctext smarktop smarkbot
6746 global pendinglinks
6748 set l [lindex [split $first .] 0]
6749 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6750 set smarktop $l
6752 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6753 set smarkbot $l
6755 $ctext delete $first end
6756 if {$first eq "1.0"} {
6757 catch {unset pendinglinks}
6761 proc settabs {{firstab {}}} {
6762 global firsttabstop tabstop ctext have_tk85
6764 if {$firstab ne {} && $have_tk85} {
6765 set firsttabstop $firstab
6767 set w [font measure textfont "0"]
6768 if {$firsttabstop != 0} {
6769 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6770 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6771 } elseif {$have_tk85 || $tabstop != 8} {
6772 $ctext conf -tabs [expr {$tabstop * $w}]
6773 } else {
6774 $ctext conf -tabs {}
6778 proc incrsearch {name ix op} {
6779 global ctext searchstring searchdirn
6781 $ctext tag remove found 1.0 end
6782 if {[catch {$ctext index anchor}]} {
6783 # no anchor set, use start of selection, or of visible area
6784 set sel [$ctext tag ranges sel]
6785 if {$sel ne {}} {
6786 $ctext mark set anchor [lindex $sel 0]
6787 } elseif {$searchdirn eq "-forwards"} {
6788 $ctext mark set anchor @0,0
6789 } else {
6790 $ctext mark set anchor @0,[winfo height $ctext]
6793 if {$searchstring ne {}} {
6794 set here [$ctext search $searchdirn -- $searchstring anchor]
6795 if {$here ne {}} {
6796 $ctext see $here
6798 searchmarkvisible 1
6802 proc dosearch {} {
6803 global sstring ctext searchstring searchdirn
6805 focus $sstring
6806 $sstring icursor end
6807 set searchdirn -forwards
6808 if {$searchstring ne {}} {
6809 set sel [$ctext tag ranges sel]
6810 if {$sel ne {}} {
6811 set start "[lindex $sel 0] + 1c"
6812 } elseif {[catch {set start [$ctext index anchor]}]} {
6813 set start "@0,0"
6815 set match [$ctext search -count mlen -- $searchstring $start]
6816 $ctext tag remove sel 1.0 end
6817 if {$match eq {}} {
6818 bell
6819 return
6821 $ctext see $match
6822 set mend "$match + $mlen c"
6823 $ctext tag add sel $match $mend
6824 $ctext mark unset anchor
6828 proc dosearchback {} {
6829 global sstring ctext searchstring searchdirn
6831 focus $sstring
6832 $sstring icursor end
6833 set searchdirn -backwards
6834 if {$searchstring ne {}} {
6835 set sel [$ctext tag ranges sel]
6836 if {$sel ne {}} {
6837 set start [lindex $sel 0]
6838 } elseif {[catch {set start [$ctext index anchor]}]} {
6839 set start @0,[winfo height $ctext]
6841 set match [$ctext search -backwards -count ml -- $searchstring $start]
6842 $ctext tag remove sel 1.0 end
6843 if {$match eq {}} {
6844 bell
6845 return
6847 $ctext see $match
6848 set mend "$match + $ml c"
6849 $ctext tag add sel $match $mend
6850 $ctext mark unset anchor
6854 proc searchmark {first last} {
6855 global ctext searchstring
6857 set mend $first.0
6858 while {1} {
6859 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6860 if {$match eq {}} break
6861 set mend "$match + $mlen c"
6862 $ctext tag add found $match $mend
6866 proc searchmarkvisible {doall} {
6867 global ctext smarktop smarkbot
6869 set topline [lindex [split [$ctext index @0,0] .] 0]
6870 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6871 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6872 # no overlap with previous
6873 searchmark $topline $botline
6874 set smarktop $topline
6875 set smarkbot $botline
6876 } else {
6877 if {$topline < $smarktop} {
6878 searchmark $topline [expr {$smarktop-1}]
6879 set smarktop $topline
6881 if {$botline > $smarkbot} {
6882 searchmark [expr {$smarkbot+1}] $botline
6883 set smarkbot $botline
6888 proc scrolltext {f0 f1} {
6889 global searchstring
6891 .bleft.bottom.sb set $f0 $f1
6892 if {$searchstring ne {}} {
6893 searchmarkvisible 0
6897 proc setcoords {} {
6898 global linespc charspc canvx0 canvy0
6899 global xspc1 xspc2 lthickness
6901 set linespc [font metrics mainfont -linespace]
6902 set charspc [font measure mainfont "m"]
6903 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6904 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6905 set lthickness [expr {int($linespc / 9) + 1}]
6906 set xspc1(0) $linespc
6907 set xspc2 $linespc
6910 proc redisplay {} {
6911 global canv
6912 global selectedline
6914 set ymax [lindex [$canv cget -scrollregion] 3]
6915 if {$ymax eq {} || $ymax == 0} return
6916 set span [$canv yview]
6917 clear_display
6918 setcanvscroll
6919 allcanvs yview moveto [lindex $span 0]
6920 drawvisible
6921 if {$selectedline ne {}} {
6922 selectline $selectedline 0
6923 allcanvs yview moveto [lindex $span 0]
6927 proc parsefont {f n} {
6928 global fontattr
6930 set fontattr($f,family) [lindex $n 0]
6931 set s [lindex $n 1]
6932 if {$s eq {} || $s == 0} {
6933 set s 10
6934 } elseif {$s < 0} {
6935 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6937 set fontattr($f,size) $s
6938 set fontattr($f,weight) normal
6939 set fontattr($f,slant) roman
6940 foreach style [lrange $n 2 end] {
6941 switch -- $style {
6942 "normal" -
6943 "bold" {set fontattr($f,weight) $style}
6944 "roman" -
6945 "italic" {set fontattr($f,slant) $style}
6950 proc fontflags {f {isbold 0}} {
6951 global fontattr
6953 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6954 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6955 -slant $fontattr($f,slant)]
6958 proc fontname {f} {
6959 global fontattr
6961 set n [list $fontattr($f,family) $fontattr($f,size)]
6962 if {$fontattr($f,weight) eq "bold"} {
6963 lappend n "bold"
6965 if {$fontattr($f,slant) eq "italic"} {
6966 lappend n "italic"
6968 return $n
6971 proc incrfont {inc} {
6972 global mainfont textfont ctext canv cflist showrefstop
6973 global stopped entries fontattr
6975 unmarkmatches
6976 set s $fontattr(mainfont,size)
6977 incr s $inc
6978 if {$s < 1} {
6979 set s 1
6981 set fontattr(mainfont,size) $s
6982 font config mainfont -size $s
6983 font config mainfontbold -size $s
6984 set mainfont [fontname mainfont]
6985 set s $fontattr(textfont,size)
6986 incr s $inc
6987 if {$s < 1} {
6988 set s 1
6990 set fontattr(textfont,size) $s
6991 font config textfont -size $s
6992 font config textfontbold -size $s
6993 set textfont [fontname textfont]
6994 setcoords
6995 settabs
6996 redisplay
6999 proc clearsha1 {} {
7000 global sha1entry sha1string
7001 if {[string length $sha1string] == 40} {
7002 $sha1entry delete 0 end
7006 proc sha1change {n1 n2 op} {
7007 global sha1string currentid sha1but
7008 if {$sha1string == {}
7009 || ([info exists currentid] && $sha1string == $currentid)} {
7010 set state disabled
7011 } else {
7012 set state normal
7014 if {[$sha1but cget -state] == $state} return
7015 if {$state == "normal"} {
7016 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7017 } else {
7018 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7022 proc gotocommit {} {
7023 global sha1string tagids headids curview varcid
7025 if {$sha1string == {}
7026 || ([info exists currentid] && $sha1string == $currentid)} return
7027 if {[info exists tagids($sha1string)]} {
7028 set id $tagids($sha1string)
7029 } elseif {[info exists headids($sha1string)]} {
7030 set id $headids($sha1string)
7031 } else {
7032 set id [string tolower $sha1string]
7033 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7034 set matches [array names varcid "$curview,$id*"]
7035 if {$matches ne {}} {
7036 if {[llength $matches] > 1} {
7037 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7038 return
7040 set id [lindex [split [lindex $matches 0] ","] 1]
7044 if {[commitinview $id $curview]} {
7045 selectline [rowofcommit $id] 1
7046 return
7048 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7049 set msg [mc "SHA1 id %s is not known" $sha1string]
7050 } else {
7051 set msg [mc "Tag/Head %s is not known" $sha1string]
7053 error_popup $msg
7056 proc lineenter {x y id} {
7057 global hoverx hovery hoverid hovertimer
7058 global commitinfo canv
7060 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7061 set hoverx $x
7062 set hovery $y
7063 set hoverid $id
7064 if {[info exists hovertimer]} {
7065 after cancel $hovertimer
7067 set hovertimer [after 500 linehover]
7068 $canv delete hover
7071 proc linemotion {x y id} {
7072 global hoverx hovery hoverid hovertimer
7074 if {[info exists hoverid] && $id == $hoverid} {
7075 set hoverx $x
7076 set hovery $y
7077 if {[info exists hovertimer]} {
7078 after cancel $hovertimer
7080 set hovertimer [after 500 linehover]
7084 proc lineleave {id} {
7085 global hoverid hovertimer canv
7087 if {[info exists hoverid] && $id == $hoverid} {
7088 $canv delete hover
7089 if {[info exists hovertimer]} {
7090 after cancel $hovertimer
7091 unset hovertimer
7093 unset hoverid
7097 proc linehover {} {
7098 global hoverx hovery hoverid hovertimer
7099 global canv linespc lthickness
7100 global commitinfo
7102 set text [lindex $commitinfo($hoverid) 0]
7103 set ymax [lindex [$canv cget -scrollregion] 3]
7104 if {$ymax == {}} return
7105 set yfrac [lindex [$canv yview] 0]
7106 set x [expr {$hoverx + 2 * $linespc}]
7107 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7108 set x0 [expr {$x - 2 * $lthickness}]
7109 set y0 [expr {$y - 2 * $lthickness}]
7110 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7111 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7112 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7113 -fill \#ffff80 -outline black -width 1 -tags hover]
7114 $canv raise $t
7115 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7116 -font mainfont]
7117 $canv raise $t
7120 proc clickisonarrow {id y} {
7121 global lthickness
7123 set ranges [rowranges $id]
7124 set thresh [expr {2 * $lthickness + 6}]
7125 set n [expr {[llength $ranges] - 1}]
7126 for {set i 1} {$i < $n} {incr i} {
7127 set row [lindex $ranges $i]
7128 if {abs([yc $row] - $y) < $thresh} {
7129 return $i
7132 return {}
7135 proc arrowjump {id n y} {
7136 global canv
7138 # 1 <-> 2, 3 <-> 4, etc...
7139 set n [expr {(($n - 1) ^ 1) + 1}]
7140 set row [lindex [rowranges $id] $n]
7141 set yt [yc $row]
7142 set ymax [lindex [$canv cget -scrollregion] 3]
7143 if {$ymax eq {} || $ymax <= 0} return
7144 set view [$canv yview]
7145 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7146 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7147 if {$yfrac < 0} {
7148 set yfrac 0
7150 allcanvs yview moveto $yfrac
7153 proc lineclick {x y id isnew} {
7154 global ctext commitinfo children canv thickerline curview
7156 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7157 unmarkmatches
7158 unselectline
7159 normalline
7160 $canv delete hover
7161 # draw this line thicker than normal
7162 set thickerline $id
7163 drawlines $id
7164 if {$isnew} {
7165 set ymax [lindex [$canv cget -scrollregion] 3]
7166 if {$ymax eq {}} return
7167 set yfrac [lindex [$canv yview] 0]
7168 set y [expr {$y + $yfrac * $ymax}]
7170 set dirn [clickisonarrow $id $y]
7171 if {$dirn ne {}} {
7172 arrowjump $id $dirn $y
7173 return
7176 if {$isnew} {
7177 addtohistory [list lineclick $x $y $id 0]
7179 # fill the details pane with info about this line
7180 $ctext conf -state normal
7181 clear_ctext
7182 settabs 0
7183 $ctext insert end "[mc "Parent"]:\t"
7184 $ctext insert end $id link0
7185 setlink $id link0
7186 set info $commitinfo($id)
7187 $ctext insert end "\n\t[lindex $info 0]\n"
7188 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7189 set date [formatdate [lindex $info 2]]
7190 $ctext insert end "\t[mc "Date"]:\t$date\n"
7191 set kids $children($curview,$id)
7192 if {$kids ne {}} {
7193 $ctext insert end "\n[mc "Children"]:"
7194 set i 0
7195 foreach child $kids {
7196 incr i
7197 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7198 set info $commitinfo($child)
7199 $ctext insert end "\n\t"
7200 $ctext insert end $child link$i
7201 setlink $child link$i
7202 $ctext insert end "\n\t[lindex $info 0]"
7203 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7204 set date [formatdate [lindex $info 2]]
7205 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7208 $ctext conf -state disabled
7209 init_flist {}
7212 proc normalline {} {
7213 global thickerline
7214 if {[info exists thickerline]} {
7215 set id $thickerline
7216 unset thickerline
7217 drawlines $id
7221 proc selbyid {id} {
7222 global curview
7223 if {[commitinview $id $curview]} {
7224 selectline [rowofcommit $id] 1
7228 proc mstime {} {
7229 global startmstime
7230 if {![info exists startmstime]} {
7231 set startmstime [clock clicks -milliseconds]
7233 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7236 proc rowmenu {x y id} {
7237 global rowctxmenu selectedline rowmenuid curview
7238 global nullid nullid2 fakerowmenu mainhead
7240 stopfinding
7241 set rowmenuid $id
7242 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7243 set state disabled
7244 } else {
7245 set state normal
7247 if {$id ne $nullid && $id ne $nullid2} {
7248 set menu $rowctxmenu
7249 if {$mainhead ne {}} {
7250 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7251 } else {
7252 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7254 } else {
7255 set menu $fakerowmenu
7257 $menu entryconfigure [mc "Diff this -> selected"] -state $state
7258 $menu entryconfigure [mc "Diff selected -> this"] -state $state
7259 $menu entryconfigure [mc "Make patch"] -state $state
7260 tk_popup $menu $x $y
7263 proc diffvssel {dirn} {
7264 global rowmenuid selectedline
7266 if {$selectedline eq {}} return
7267 if {$dirn} {
7268 set oldid [commitonrow $selectedline]
7269 set newid $rowmenuid
7270 } else {
7271 set oldid $rowmenuid
7272 set newid [commitonrow $selectedline]
7274 addtohistory [list doseldiff $oldid $newid]
7275 doseldiff $oldid $newid
7278 proc doseldiff {oldid newid} {
7279 global ctext
7280 global commitinfo
7282 $ctext conf -state normal
7283 clear_ctext
7284 init_flist [mc "Top"]
7285 $ctext insert end "[mc "From"] "
7286 $ctext insert end $oldid link0
7287 setlink $oldid link0
7288 $ctext insert end "\n "
7289 $ctext insert end [lindex $commitinfo($oldid) 0]
7290 $ctext insert end "\n\n[mc "To"] "
7291 $ctext insert end $newid link1
7292 setlink $newid link1
7293 $ctext insert end "\n "
7294 $ctext insert end [lindex $commitinfo($newid) 0]
7295 $ctext insert end "\n"
7296 $ctext conf -state disabled
7297 $ctext tag remove found 1.0 end
7298 startdiff [list $oldid $newid]
7301 proc mkpatch {} {
7302 global rowmenuid currentid commitinfo patchtop patchnum
7304 if {![info exists currentid]} return
7305 set oldid $currentid
7306 set oldhead [lindex $commitinfo($oldid) 0]
7307 set newid $rowmenuid
7308 set newhead [lindex $commitinfo($newid) 0]
7309 set top .patch
7310 set patchtop $top
7311 catch {destroy $top}
7312 toplevel $top
7313 label $top.title -text [mc "Generate patch"]
7314 grid $top.title - -pady 10
7315 label $top.from -text [mc "From:"]
7316 entry $top.fromsha1 -width 40 -relief flat
7317 $top.fromsha1 insert 0 $oldid
7318 $top.fromsha1 conf -state readonly
7319 grid $top.from $top.fromsha1 -sticky w
7320 entry $top.fromhead -width 60 -relief flat
7321 $top.fromhead insert 0 $oldhead
7322 $top.fromhead conf -state readonly
7323 grid x $top.fromhead -sticky w
7324 label $top.to -text [mc "To:"]
7325 entry $top.tosha1 -width 40 -relief flat
7326 $top.tosha1 insert 0 $newid
7327 $top.tosha1 conf -state readonly
7328 grid $top.to $top.tosha1 -sticky w
7329 entry $top.tohead -width 60 -relief flat
7330 $top.tohead insert 0 $newhead
7331 $top.tohead conf -state readonly
7332 grid x $top.tohead -sticky w
7333 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7334 grid $top.rev x -pady 10
7335 label $top.flab -text [mc "Output file:"]
7336 entry $top.fname -width 60
7337 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7338 incr patchnum
7339 grid $top.flab $top.fname -sticky w
7340 frame $top.buts
7341 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7342 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7343 grid $top.buts.gen $top.buts.can
7344 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7345 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7346 grid $top.buts - -pady 10 -sticky ew
7347 focus $top.fname
7350 proc mkpatchrev {} {
7351 global patchtop
7353 set oldid [$patchtop.fromsha1 get]
7354 set oldhead [$patchtop.fromhead get]
7355 set newid [$patchtop.tosha1 get]
7356 set newhead [$patchtop.tohead get]
7357 foreach e [list fromsha1 fromhead tosha1 tohead] \
7358 v [list $newid $newhead $oldid $oldhead] {
7359 $patchtop.$e conf -state normal
7360 $patchtop.$e delete 0 end
7361 $patchtop.$e insert 0 $v
7362 $patchtop.$e conf -state readonly
7366 proc mkpatchgo {} {
7367 global patchtop nullid nullid2
7369 set oldid [$patchtop.fromsha1 get]
7370 set newid [$patchtop.tosha1 get]
7371 set fname [$patchtop.fname get]
7372 set cmd [diffcmd [list $oldid $newid] -p]
7373 # trim off the initial "|"
7374 set cmd [lrange $cmd 1 end]
7375 lappend cmd >$fname &
7376 if {[catch {eval exec $cmd} err]} {
7377 error_popup "[mc "Error creating patch:"] $err"
7379 catch {destroy $patchtop}
7380 unset patchtop
7383 proc mkpatchcan {} {
7384 global patchtop
7386 catch {destroy $patchtop}
7387 unset patchtop
7390 proc mktag {} {
7391 global rowmenuid mktagtop commitinfo
7393 set top .maketag
7394 set mktagtop $top
7395 catch {destroy $top}
7396 toplevel $top
7397 label $top.title -text [mc "Create tag"]
7398 grid $top.title - -pady 10
7399 label $top.id -text [mc "ID:"]
7400 entry $top.sha1 -width 40 -relief flat
7401 $top.sha1 insert 0 $rowmenuid
7402 $top.sha1 conf -state readonly
7403 grid $top.id $top.sha1 -sticky w
7404 entry $top.head -width 60 -relief flat
7405 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7406 $top.head conf -state readonly
7407 grid x $top.head -sticky w
7408 label $top.tlab -text [mc "Tag name:"]
7409 entry $top.tag -width 60
7410 grid $top.tlab $top.tag -sticky w
7411 frame $top.buts
7412 button $top.buts.gen -text [mc "Create"] -command mktaggo
7413 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7414 grid $top.buts.gen $top.buts.can
7415 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7416 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7417 grid $top.buts - -pady 10 -sticky ew
7418 focus $top.tag
7421 proc domktag {} {
7422 global mktagtop env tagids idtags
7424 set id [$mktagtop.sha1 get]
7425 set tag [$mktagtop.tag get]
7426 if {$tag == {}} {
7427 error_popup [mc "No tag name specified"]
7428 return
7430 if {[info exists tagids($tag)]} {
7431 error_popup [mc "Tag \"%s\" already exists" $tag]
7432 return
7434 if {[catch {
7435 exec git tag $tag $id
7436 } err]} {
7437 error_popup "[mc "Error creating tag:"] $err"
7438 return
7441 set tagids($tag) $id
7442 lappend idtags($id) $tag
7443 redrawtags $id
7444 addedtag $id
7445 dispneartags 0
7446 run refill_reflist
7449 proc redrawtags {id} {
7450 global canv linehtag idpos currentid curview cmitlisted
7451 global canvxmax iddrawn circleitem mainheadid circlecolors
7453 if {![commitinview $id $curview]} return
7454 if {![info exists iddrawn($id)]} return
7455 set row [rowofcommit $id]
7456 if {$id eq $mainheadid} {
7457 set ofill yellow
7458 } else {
7459 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7461 $canv itemconf $circleitem($row) -fill $ofill
7462 $canv delete tag.$id
7463 set xt [eval drawtags $id $idpos($id)]
7464 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7465 set text [$canv itemcget $linehtag($row) -text]
7466 set font [$canv itemcget $linehtag($row) -font]
7467 set xr [expr {$xt + [font measure $font $text]}]
7468 if {$xr > $canvxmax} {
7469 set canvxmax $xr
7470 setcanvscroll
7472 if {[info exists currentid] && $currentid == $id} {
7473 make_secsel $row
7477 proc mktagcan {} {
7478 global mktagtop
7480 catch {destroy $mktagtop}
7481 unset mktagtop
7484 proc mktaggo {} {
7485 domktag
7486 mktagcan
7489 proc writecommit {} {
7490 global rowmenuid wrcomtop commitinfo wrcomcmd
7492 set top .writecommit
7493 set wrcomtop $top
7494 catch {destroy $top}
7495 toplevel $top
7496 label $top.title -text [mc "Write commit to file"]
7497 grid $top.title - -pady 10
7498 label $top.id -text [mc "ID:"]
7499 entry $top.sha1 -width 40 -relief flat
7500 $top.sha1 insert 0 $rowmenuid
7501 $top.sha1 conf -state readonly
7502 grid $top.id $top.sha1 -sticky w
7503 entry $top.head -width 60 -relief flat
7504 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7505 $top.head conf -state readonly
7506 grid x $top.head -sticky w
7507 label $top.clab -text [mc "Command:"]
7508 entry $top.cmd -width 60 -textvariable wrcomcmd
7509 grid $top.clab $top.cmd -sticky w -pady 10
7510 label $top.flab -text [mc "Output file:"]
7511 entry $top.fname -width 60
7512 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7513 grid $top.flab $top.fname -sticky w
7514 frame $top.buts
7515 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7516 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7517 grid $top.buts.gen $top.buts.can
7518 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7519 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7520 grid $top.buts - -pady 10 -sticky ew
7521 focus $top.fname
7524 proc wrcomgo {} {
7525 global wrcomtop
7527 set id [$wrcomtop.sha1 get]
7528 set cmd "echo $id | [$wrcomtop.cmd get]"
7529 set fname [$wrcomtop.fname get]
7530 if {[catch {exec sh -c $cmd >$fname &} err]} {
7531 error_popup "[mc "Error writing commit:"] $err"
7533 catch {destroy $wrcomtop}
7534 unset wrcomtop
7537 proc wrcomcan {} {
7538 global wrcomtop
7540 catch {destroy $wrcomtop}
7541 unset wrcomtop
7544 proc mkbranch {} {
7545 global rowmenuid mkbrtop
7547 set top .makebranch
7548 catch {destroy $top}
7549 toplevel $top
7550 label $top.title -text [mc "Create new branch"]
7551 grid $top.title - -pady 10
7552 label $top.id -text [mc "ID:"]
7553 entry $top.sha1 -width 40 -relief flat
7554 $top.sha1 insert 0 $rowmenuid
7555 $top.sha1 conf -state readonly
7556 grid $top.id $top.sha1 -sticky w
7557 label $top.nlab -text [mc "Name:"]
7558 entry $top.name -width 40
7559 grid $top.nlab $top.name -sticky w
7560 frame $top.buts
7561 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7562 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7563 grid $top.buts.go $top.buts.can
7564 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7565 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7566 grid $top.buts - -pady 10 -sticky ew
7567 focus $top.name
7570 proc mkbrgo {top} {
7571 global headids idheads
7573 set name [$top.name get]
7574 set id [$top.sha1 get]
7575 if {$name eq {}} {
7576 error_popup [mc "Please specify a name for the new branch"]
7577 return
7579 catch {destroy $top}
7580 nowbusy newbranch
7581 update
7582 if {[catch {
7583 exec git branch $name $id
7584 } err]} {
7585 notbusy newbranch
7586 error_popup $err
7587 } else {
7588 set headids($name) $id
7589 lappend idheads($id) $name
7590 addedhead $id $name
7591 notbusy newbranch
7592 redrawtags $id
7593 dispneartags 0
7594 run refill_reflist
7598 proc cherrypick {} {
7599 global rowmenuid curview
7600 global mainhead mainheadid
7602 set oldhead [exec git rev-parse HEAD]
7603 set dheads [descheads $rowmenuid]
7604 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7605 set ok [confirm_popup [mc "Commit %s is already\
7606 included in branch %s -- really re-apply it?" \
7607 [string range $rowmenuid 0 7] $mainhead]]
7608 if {!$ok} return
7610 nowbusy cherrypick [mc "Cherry-picking"]
7611 update
7612 # Unfortunately git-cherry-pick writes stuff to stderr even when
7613 # no error occurs, and exec takes that as an indication of error...
7614 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7615 notbusy cherrypick
7616 error_popup $err
7617 return
7619 set newhead [exec git rev-parse HEAD]
7620 if {$newhead eq $oldhead} {
7621 notbusy cherrypick
7622 error_popup [mc "No changes committed"]
7623 return
7625 addnewchild $newhead $oldhead
7626 if {[commitinview $oldhead $curview]} {
7627 insertrow $newhead $oldhead $curview
7628 if {$mainhead ne {}} {
7629 movehead $newhead $mainhead
7630 movedhead $newhead $mainhead
7632 set mainheadid $newhead
7633 redrawtags $oldhead
7634 redrawtags $newhead
7635 selbyid $newhead
7637 notbusy cherrypick
7640 proc resethead {} {
7641 global mainhead rowmenuid confirm_ok resettype
7643 set confirm_ok 0
7644 set w ".confirmreset"
7645 toplevel $w
7646 wm transient $w .
7647 wm title $w [mc "Confirm reset"]
7648 message $w.m -text \
7649 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7650 -justify center -aspect 1000
7651 pack $w.m -side top -fill x -padx 20 -pady 20
7652 frame $w.f -relief sunken -border 2
7653 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7654 grid $w.f.rt -sticky w
7655 set resettype mixed
7656 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7657 -text [mc "Soft: Leave working tree and index untouched"]
7658 grid $w.f.soft -sticky w
7659 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7660 -text [mc "Mixed: Leave working tree untouched, reset index"]
7661 grid $w.f.mixed -sticky w
7662 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7663 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7664 grid $w.f.hard -sticky w
7665 pack $w.f -side top -fill x
7666 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7667 pack $w.ok -side left -fill x -padx 20 -pady 20
7668 button $w.cancel -text [mc Cancel] -command "destroy $w"
7669 pack $w.cancel -side right -fill x -padx 20 -pady 20
7670 bind $w <Visibility> "grab $w; focus $w"
7671 tkwait window $w
7672 if {!$confirm_ok} return
7673 if {[catch {set fd [open \
7674 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7675 error_popup $err
7676 } else {
7677 dohidelocalchanges
7678 filerun $fd [list readresetstat $fd]
7679 nowbusy reset [mc "Resetting"]
7680 selbyid $rowmenuid
7684 proc readresetstat {fd} {
7685 global mainhead mainheadid showlocalchanges rprogcoord
7687 if {[gets $fd line] >= 0} {
7688 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7689 set rprogcoord [expr {1.0 * $m / $n}]
7690 adjustprogress
7692 return 1
7694 set rprogcoord 0
7695 adjustprogress
7696 notbusy reset
7697 if {[catch {close $fd} err]} {
7698 error_popup $err
7700 set oldhead $mainheadid
7701 set newhead [exec git rev-parse HEAD]
7702 if {$newhead ne $oldhead} {
7703 movehead $newhead $mainhead
7704 movedhead $newhead $mainhead
7705 set mainheadid $newhead
7706 redrawtags $oldhead
7707 redrawtags $newhead
7709 if {$showlocalchanges} {
7710 doshowlocalchanges
7712 return 0
7715 # context menu for a head
7716 proc headmenu {x y id head} {
7717 global headmenuid headmenuhead headctxmenu mainhead
7719 stopfinding
7720 set headmenuid $id
7721 set headmenuhead $head
7722 set state normal
7723 if {$head eq $mainhead} {
7724 set state disabled
7726 $headctxmenu entryconfigure 0 -state $state
7727 $headctxmenu entryconfigure 1 -state $state
7728 tk_popup $headctxmenu $x $y
7731 proc cobranch {} {
7732 global headmenuid headmenuhead headids
7733 global showlocalchanges mainheadid
7735 # check the tree is clean first??
7736 nowbusy checkout [mc "Checking out"]
7737 update
7738 dohidelocalchanges
7739 if {[catch {
7740 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7741 } err]} {
7742 notbusy checkout
7743 error_popup $err
7744 if {$showlocalchanges} {
7745 dodiffindex
7747 } else {
7748 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7752 proc readcheckoutstat {fd newhead newheadid} {
7753 global mainhead mainheadid headids showlocalchanges progresscoords
7755 if {[gets $fd line] >= 0} {
7756 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7757 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7758 adjustprogress
7760 return 1
7762 set progresscoords {0 0}
7763 adjustprogress
7764 notbusy checkout
7765 if {[catch {close $fd} err]} {
7766 error_popup $err
7768 set oldmainid $mainheadid
7769 set mainhead $newhead
7770 set mainheadid $newheadid
7771 redrawtags $oldmainid
7772 redrawtags $newheadid
7773 selbyid $newheadid
7774 if {$showlocalchanges} {
7775 dodiffindex
7779 proc rmbranch {} {
7780 global headmenuid headmenuhead mainhead
7781 global idheads
7783 set head $headmenuhead
7784 set id $headmenuid
7785 # this check shouldn't be needed any more...
7786 if {$head eq $mainhead} {
7787 error_popup [mc "Cannot delete the currently checked-out branch"]
7788 return
7790 set dheads [descheads $id]
7791 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7792 # the stuff on this branch isn't on any other branch
7793 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7794 branch.\nReally delete branch %s?" $head $head]]} return
7796 nowbusy rmbranch
7797 update
7798 if {[catch {exec git branch -D $head} err]} {
7799 notbusy rmbranch
7800 error_popup $err
7801 return
7803 removehead $id $head
7804 removedhead $id $head
7805 redrawtags $id
7806 notbusy rmbranch
7807 dispneartags 0
7808 run refill_reflist
7811 # Display a list of tags and heads
7812 proc showrefs {} {
7813 global showrefstop bgcolor fgcolor selectbgcolor
7814 global bglist fglist reflistfilter reflist maincursor
7816 set top .showrefs
7817 set showrefstop $top
7818 if {[winfo exists $top]} {
7819 raise $top
7820 refill_reflist
7821 return
7823 toplevel $top
7824 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7825 text $top.list -background $bgcolor -foreground $fgcolor \
7826 -selectbackground $selectbgcolor -font mainfont \
7827 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7828 -width 30 -height 20 -cursor $maincursor \
7829 -spacing1 1 -spacing3 1 -state disabled
7830 $top.list tag configure highlight -background $selectbgcolor
7831 lappend bglist $top.list
7832 lappend fglist $top.list
7833 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7834 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7835 grid $top.list $top.ysb -sticky nsew
7836 grid $top.xsb x -sticky ew
7837 frame $top.f
7838 label $top.f.l -text "[mc "Filter"]: "
7839 entry $top.f.e -width 20 -textvariable reflistfilter
7840 set reflistfilter "*"
7841 trace add variable reflistfilter write reflistfilter_change
7842 pack $top.f.e -side right -fill x -expand 1
7843 pack $top.f.l -side left
7844 grid $top.f - -sticky ew -pady 2
7845 button $top.close -command [list destroy $top] -text [mc "Close"]
7846 grid $top.close -
7847 grid columnconfigure $top 0 -weight 1
7848 grid rowconfigure $top 0 -weight 1
7849 bind $top.list <1> {break}
7850 bind $top.list <B1-Motion> {break}
7851 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7852 set reflist {}
7853 refill_reflist
7856 proc sel_reflist {w x y} {
7857 global showrefstop reflist headids tagids otherrefids
7859 if {![winfo exists $showrefstop]} return
7860 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7861 set ref [lindex $reflist [expr {$l-1}]]
7862 set n [lindex $ref 0]
7863 switch -- [lindex $ref 1] {
7864 "H" {selbyid $headids($n)}
7865 "T" {selbyid $tagids($n)}
7866 "o" {selbyid $otherrefids($n)}
7868 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7871 proc unsel_reflist {} {
7872 global showrefstop
7874 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7875 $showrefstop.list tag remove highlight 0.0 end
7878 proc reflistfilter_change {n1 n2 op} {
7879 global reflistfilter
7881 after cancel refill_reflist
7882 after 200 refill_reflist
7885 proc refill_reflist {} {
7886 global reflist reflistfilter showrefstop headids tagids otherrefids
7887 global curview commitinterest
7889 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7890 set refs {}
7891 foreach n [array names headids] {
7892 if {[string match $reflistfilter $n]} {
7893 if {[commitinview $headids($n) $curview]} {
7894 lappend refs [list $n H]
7895 } else {
7896 set commitinterest($headids($n)) {run refill_reflist}
7900 foreach n [array names tagids] {
7901 if {[string match $reflistfilter $n]} {
7902 if {[commitinview $tagids($n) $curview]} {
7903 lappend refs [list $n T]
7904 } else {
7905 set commitinterest($tagids($n)) {run refill_reflist}
7909 foreach n [array names otherrefids] {
7910 if {[string match $reflistfilter $n]} {
7911 if {[commitinview $otherrefids($n) $curview]} {
7912 lappend refs [list $n o]
7913 } else {
7914 set commitinterest($otherrefids($n)) {run refill_reflist}
7918 set refs [lsort -index 0 $refs]
7919 if {$refs eq $reflist} return
7921 # Update the contents of $showrefstop.list according to the
7922 # differences between $reflist (old) and $refs (new)
7923 $showrefstop.list conf -state normal
7924 $showrefstop.list insert end "\n"
7925 set i 0
7926 set j 0
7927 while {$i < [llength $reflist] || $j < [llength $refs]} {
7928 if {$i < [llength $reflist]} {
7929 if {$j < [llength $refs]} {
7930 set cmp [string compare [lindex $reflist $i 0] \
7931 [lindex $refs $j 0]]
7932 if {$cmp == 0} {
7933 set cmp [string compare [lindex $reflist $i 1] \
7934 [lindex $refs $j 1]]
7936 } else {
7937 set cmp -1
7939 } else {
7940 set cmp 1
7942 switch -- $cmp {
7943 -1 {
7944 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7945 incr i
7948 incr i
7949 incr j
7952 set l [expr {$j + 1}]
7953 $showrefstop.list image create $l.0 -align baseline \
7954 -image reficon-[lindex $refs $j 1] -padx 2
7955 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7956 incr j
7960 set reflist $refs
7961 # delete last newline
7962 $showrefstop.list delete end-2c end-1c
7963 $showrefstop.list conf -state disabled
7966 # Stuff for finding nearby tags
7967 proc getallcommits {} {
7968 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7969 global idheads idtags idotherrefs allparents tagobjid
7971 if {![info exists allcommits]} {
7972 set nextarc 0
7973 set allcommits 0
7974 set seeds {}
7975 set allcwait 0
7976 set cachedarcs 0
7977 set allccache [file join [gitdir] "gitk.cache"]
7978 if {![catch {
7979 set f [open $allccache r]
7980 set allcwait 1
7981 getcache $f
7982 }]} return
7985 if {$allcwait} {
7986 return
7988 set cmd [list | git rev-list --parents]
7989 set allcupdate [expr {$seeds ne {}}]
7990 if {!$allcupdate} {
7991 set ids "--all"
7992 } else {
7993 set refs [concat [array names idheads] [array names idtags] \
7994 [array names idotherrefs]]
7995 set ids {}
7996 set tagobjs {}
7997 foreach name [array names tagobjid] {
7998 lappend tagobjs $tagobjid($name)
8000 foreach id [lsort -unique $refs] {
8001 if {![info exists allparents($id)] &&
8002 [lsearch -exact $tagobjs $id] < 0} {
8003 lappend ids $id
8006 if {$ids ne {}} {
8007 foreach id $seeds {
8008 lappend ids "^$id"
8012 if {$ids ne {}} {
8013 set fd [open [concat $cmd $ids] r]
8014 fconfigure $fd -blocking 0
8015 incr allcommits
8016 nowbusy allcommits
8017 filerun $fd [list getallclines $fd]
8018 } else {
8019 dispneartags 0
8023 # Since most commits have 1 parent and 1 child, we group strings of
8024 # such commits into "arcs" joining branch/merge points (BMPs), which
8025 # are commits that either don't have 1 parent or don't have 1 child.
8027 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8028 # arcout(id) - outgoing arcs for BMP
8029 # arcids(a) - list of IDs on arc including end but not start
8030 # arcstart(a) - BMP ID at start of arc
8031 # arcend(a) - BMP ID at end of arc
8032 # growing(a) - arc a is still growing
8033 # arctags(a) - IDs out of arcids (excluding end) that have tags
8034 # archeads(a) - IDs out of arcids (excluding end) that have heads
8035 # The start of an arc is at the descendent end, so "incoming" means
8036 # coming from descendents, and "outgoing" means going towards ancestors.
8038 proc getallclines {fd} {
8039 global allparents allchildren idtags idheads nextarc
8040 global arcnos arcids arctags arcout arcend arcstart archeads growing
8041 global seeds allcommits cachedarcs allcupdate
8043 set nid 0
8044 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8045 set id [lindex $line 0]
8046 if {[info exists allparents($id)]} {
8047 # seen it already
8048 continue
8050 set cachedarcs 0
8051 set olds [lrange $line 1 end]
8052 set allparents($id) $olds
8053 if {![info exists allchildren($id)]} {
8054 set allchildren($id) {}
8055 set arcnos($id) {}
8056 lappend seeds $id
8057 } else {
8058 set a $arcnos($id)
8059 if {[llength $olds] == 1 && [llength $a] == 1} {
8060 lappend arcids($a) $id
8061 if {[info exists idtags($id)]} {
8062 lappend arctags($a) $id
8064 if {[info exists idheads($id)]} {
8065 lappend archeads($a) $id
8067 if {[info exists allparents($olds)]} {
8068 # seen parent already
8069 if {![info exists arcout($olds)]} {
8070 splitarc $olds
8072 lappend arcids($a) $olds
8073 set arcend($a) $olds
8074 unset growing($a)
8076 lappend allchildren($olds) $id
8077 lappend arcnos($olds) $a
8078 continue
8081 foreach a $arcnos($id) {
8082 lappend arcids($a) $id
8083 set arcend($a) $id
8084 unset growing($a)
8087 set ao {}
8088 foreach p $olds {
8089 lappend allchildren($p) $id
8090 set a [incr nextarc]
8091 set arcstart($a) $id
8092 set archeads($a) {}
8093 set arctags($a) {}
8094 set archeads($a) {}
8095 set arcids($a) {}
8096 lappend ao $a
8097 set growing($a) 1
8098 if {[info exists allparents($p)]} {
8099 # seen it already, may need to make a new branch
8100 if {![info exists arcout($p)]} {
8101 splitarc $p
8103 lappend arcids($a) $p
8104 set arcend($a) $p
8105 unset growing($a)
8107 lappend arcnos($p) $a
8109 set arcout($id) $ao
8111 if {$nid > 0} {
8112 global cached_dheads cached_dtags cached_atags
8113 catch {unset cached_dheads}
8114 catch {unset cached_dtags}
8115 catch {unset cached_atags}
8117 if {![eof $fd]} {
8118 return [expr {$nid >= 1000? 2: 1}]
8120 set cacheok 1
8121 if {[catch {
8122 fconfigure $fd -blocking 1
8123 close $fd
8124 } err]} {
8125 # got an error reading the list of commits
8126 # if we were updating, try rereading the whole thing again
8127 if {$allcupdate} {
8128 incr allcommits -1
8129 dropcache $err
8130 return
8132 error_popup "[mc "Error reading commit topology information;\
8133 branch and preceding/following tag information\
8134 will be incomplete."]\n($err)"
8135 set cacheok 0
8137 if {[incr allcommits -1] == 0} {
8138 notbusy allcommits
8139 if {$cacheok} {
8140 run savecache
8143 dispneartags 0
8144 return 0
8147 proc recalcarc {a} {
8148 global arctags archeads arcids idtags idheads
8150 set at {}
8151 set ah {}
8152 foreach id [lrange $arcids($a) 0 end-1] {
8153 if {[info exists idtags($id)]} {
8154 lappend at $id
8156 if {[info exists idheads($id)]} {
8157 lappend ah $id
8160 set arctags($a) $at
8161 set archeads($a) $ah
8164 proc splitarc {p} {
8165 global arcnos arcids nextarc arctags archeads idtags idheads
8166 global arcstart arcend arcout allparents growing
8168 set a $arcnos($p)
8169 if {[llength $a] != 1} {
8170 puts "oops splitarc called but [llength $a] arcs already"
8171 return
8173 set a [lindex $a 0]
8174 set i [lsearch -exact $arcids($a) $p]
8175 if {$i < 0} {
8176 puts "oops splitarc $p not in arc $a"
8177 return
8179 set na [incr nextarc]
8180 if {[info exists arcend($a)]} {
8181 set arcend($na) $arcend($a)
8182 } else {
8183 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8184 set j [lsearch -exact $arcnos($l) $a]
8185 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8187 set tail [lrange $arcids($a) [expr {$i+1}] end]
8188 set arcids($a) [lrange $arcids($a) 0 $i]
8189 set arcend($a) $p
8190 set arcstart($na) $p
8191 set arcout($p) $na
8192 set arcids($na) $tail
8193 if {[info exists growing($a)]} {
8194 set growing($na) 1
8195 unset growing($a)
8198 foreach id $tail {
8199 if {[llength $arcnos($id)] == 1} {
8200 set arcnos($id) $na
8201 } else {
8202 set j [lsearch -exact $arcnos($id) $a]
8203 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8207 # reconstruct tags and heads lists
8208 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8209 recalcarc $a
8210 recalcarc $na
8211 } else {
8212 set arctags($na) {}
8213 set archeads($na) {}
8217 # Update things for a new commit added that is a child of one
8218 # existing commit. Used when cherry-picking.
8219 proc addnewchild {id p} {
8220 global allparents allchildren idtags nextarc
8221 global arcnos arcids arctags arcout arcend arcstart archeads growing
8222 global seeds allcommits
8224 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8225 set allparents($id) [list $p]
8226 set allchildren($id) {}
8227 set arcnos($id) {}
8228 lappend seeds $id
8229 lappend allchildren($p) $id
8230 set a [incr nextarc]
8231 set arcstart($a) $id
8232 set archeads($a) {}
8233 set arctags($a) {}
8234 set arcids($a) [list $p]
8235 set arcend($a) $p
8236 if {![info exists arcout($p)]} {
8237 splitarc $p
8239 lappend arcnos($p) $a
8240 set arcout($id) [list $a]
8243 # This implements a cache for the topology information.
8244 # The cache saves, for each arc, the start and end of the arc,
8245 # the ids on the arc, and the outgoing arcs from the end.
8246 proc readcache {f} {
8247 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8248 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8249 global allcwait
8251 set a $nextarc
8252 set lim $cachedarcs
8253 if {$lim - $a > 500} {
8254 set lim [expr {$a + 500}]
8256 if {[catch {
8257 if {$a == $lim} {
8258 # finish reading the cache and setting up arctags, etc.
8259 set line [gets $f]
8260 if {$line ne "1"} {error "bad final version"}
8261 close $f
8262 foreach id [array names idtags] {
8263 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8264 [llength $allparents($id)] == 1} {
8265 set a [lindex $arcnos($id) 0]
8266 if {$arctags($a) eq {}} {
8267 recalcarc $a
8271 foreach id [array names idheads] {
8272 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8273 [llength $allparents($id)] == 1} {
8274 set a [lindex $arcnos($id) 0]
8275 if {$archeads($a) eq {}} {
8276 recalcarc $a
8280 foreach id [lsort -unique $possible_seeds] {
8281 if {$arcnos($id) eq {}} {
8282 lappend seeds $id
8285 set allcwait 0
8286 } else {
8287 while {[incr a] <= $lim} {
8288 set line [gets $f]
8289 if {[llength $line] != 3} {error "bad line"}
8290 set s [lindex $line 0]
8291 set arcstart($a) $s
8292 lappend arcout($s) $a
8293 if {![info exists arcnos($s)]} {
8294 lappend possible_seeds $s
8295 set arcnos($s) {}
8297 set e [lindex $line 1]
8298 if {$e eq {}} {
8299 set growing($a) 1
8300 } else {
8301 set arcend($a) $e
8302 if {![info exists arcout($e)]} {
8303 set arcout($e) {}
8306 set arcids($a) [lindex $line 2]
8307 foreach id $arcids($a) {
8308 lappend allparents($s) $id
8309 set s $id
8310 lappend arcnos($id) $a
8312 if {![info exists allparents($s)]} {
8313 set allparents($s) {}
8315 set arctags($a) {}
8316 set archeads($a) {}
8318 set nextarc [expr {$a - 1}]
8320 } err]} {
8321 dropcache $err
8322 return 0
8324 if {!$allcwait} {
8325 getallcommits
8327 return $allcwait
8330 proc getcache {f} {
8331 global nextarc cachedarcs possible_seeds
8333 if {[catch {
8334 set line [gets $f]
8335 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8336 # make sure it's an integer
8337 set cachedarcs [expr {int([lindex $line 1])}]
8338 if {$cachedarcs < 0} {error "bad number of arcs"}
8339 set nextarc 0
8340 set possible_seeds {}
8341 run readcache $f
8342 } err]} {
8343 dropcache $err
8345 return 0
8348 proc dropcache {err} {
8349 global allcwait nextarc cachedarcs seeds
8351 #puts "dropping cache ($err)"
8352 foreach v {arcnos arcout arcids arcstart arcend growing \
8353 arctags archeads allparents allchildren} {
8354 global $v
8355 catch {unset $v}
8357 set allcwait 0
8358 set nextarc 0
8359 set cachedarcs 0
8360 set seeds {}
8361 getallcommits
8364 proc writecache {f} {
8365 global cachearc cachedarcs allccache
8366 global arcstart arcend arcnos arcids arcout
8368 set a $cachearc
8369 set lim $cachedarcs
8370 if {$lim - $a > 1000} {
8371 set lim [expr {$a + 1000}]
8373 if {[catch {
8374 while {[incr a] <= $lim} {
8375 if {[info exists arcend($a)]} {
8376 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8377 } else {
8378 puts $f [list $arcstart($a) {} $arcids($a)]
8381 } err]} {
8382 catch {close $f}
8383 catch {file delete $allccache}
8384 #puts "writing cache failed ($err)"
8385 return 0
8387 set cachearc [expr {$a - 1}]
8388 if {$a > $cachedarcs} {
8389 puts $f "1"
8390 close $f
8391 return 0
8393 return 1
8396 proc savecache {} {
8397 global nextarc cachedarcs cachearc allccache
8399 if {$nextarc == $cachedarcs} return
8400 set cachearc 0
8401 set cachedarcs $nextarc
8402 catch {
8403 set f [open $allccache w]
8404 puts $f [list 1 $cachedarcs]
8405 run writecache $f
8409 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8410 # or 0 if neither is true.
8411 proc anc_or_desc {a b} {
8412 global arcout arcstart arcend arcnos cached_isanc
8414 if {$arcnos($a) eq $arcnos($b)} {
8415 # Both are on the same arc(s); either both are the same BMP,
8416 # or if one is not a BMP, the other is also not a BMP or is
8417 # the BMP at end of the arc (and it only has 1 incoming arc).
8418 # Or both can be BMPs with no incoming arcs.
8419 if {$a eq $b || $arcnos($a) eq {}} {
8420 return 0
8422 # assert {[llength $arcnos($a)] == 1}
8423 set arc [lindex $arcnos($a) 0]
8424 set i [lsearch -exact $arcids($arc) $a]
8425 set j [lsearch -exact $arcids($arc) $b]
8426 if {$i < 0 || $i > $j} {
8427 return 1
8428 } else {
8429 return -1
8433 if {![info exists arcout($a)]} {
8434 set arc [lindex $arcnos($a) 0]
8435 if {[info exists arcend($arc)]} {
8436 set aend $arcend($arc)
8437 } else {
8438 set aend {}
8440 set a $arcstart($arc)
8441 } else {
8442 set aend $a
8444 if {![info exists arcout($b)]} {
8445 set arc [lindex $arcnos($b) 0]
8446 if {[info exists arcend($arc)]} {
8447 set bend $arcend($arc)
8448 } else {
8449 set bend {}
8451 set b $arcstart($arc)
8452 } else {
8453 set bend $b
8455 if {$a eq $bend} {
8456 return 1
8458 if {$b eq $aend} {
8459 return -1
8461 if {[info exists cached_isanc($a,$bend)]} {
8462 if {$cached_isanc($a,$bend)} {
8463 return 1
8466 if {[info exists cached_isanc($b,$aend)]} {
8467 if {$cached_isanc($b,$aend)} {
8468 return -1
8470 if {[info exists cached_isanc($a,$bend)]} {
8471 return 0
8475 set todo [list $a $b]
8476 set anc($a) a
8477 set anc($b) b
8478 for {set i 0} {$i < [llength $todo]} {incr i} {
8479 set x [lindex $todo $i]
8480 if {$anc($x) eq {}} {
8481 continue
8483 foreach arc $arcnos($x) {
8484 set xd $arcstart($arc)
8485 if {$xd eq $bend} {
8486 set cached_isanc($a,$bend) 1
8487 set cached_isanc($b,$aend) 0
8488 return 1
8489 } elseif {$xd eq $aend} {
8490 set cached_isanc($b,$aend) 1
8491 set cached_isanc($a,$bend) 0
8492 return -1
8494 if {![info exists anc($xd)]} {
8495 set anc($xd) $anc($x)
8496 lappend todo $xd
8497 } elseif {$anc($xd) ne $anc($x)} {
8498 set anc($xd) {}
8502 set cached_isanc($a,$bend) 0
8503 set cached_isanc($b,$aend) 0
8504 return 0
8507 # This identifies whether $desc has an ancestor that is
8508 # a growing tip of the graph and which is not an ancestor of $anc
8509 # and returns 0 if so and 1 if not.
8510 # If we subsequently discover a tag on such a growing tip, and that
8511 # turns out to be a descendent of $anc (which it could, since we
8512 # don't necessarily see children before parents), then $desc
8513 # isn't a good choice to display as a descendent tag of
8514 # $anc (since it is the descendent of another tag which is
8515 # a descendent of $anc). Similarly, $anc isn't a good choice to
8516 # display as a ancestor tag of $desc.
8518 proc is_certain {desc anc} {
8519 global arcnos arcout arcstart arcend growing problems
8521 set certain {}
8522 if {[llength $arcnos($anc)] == 1} {
8523 # tags on the same arc are certain
8524 if {$arcnos($desc) eq $arcnos($anc)} {
8525 return 1
8527 if {![info exists arcout($anc)]} {
8528 # if $anc is partway along an arc, use the start of the arc instead
8529 set a [lindex $arcnos($anc) 0]
8530 set anc $arcstart($a)
8533 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8534 set x $desc
8535 } else {
8536 set a [lindex $arcnos($desc) 0]
8537 set x $arcend($a)
8539 if {$x == $anc} {
8540 return 1
8542 set anclist [list $x]
8543 set dl($x) 1
8544 set nnh 1
8545 set ngrowanc 0
8546 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8547 set x [lindex $anclist $i]
8548 if {$dl($x)} {
8549 incr nnh -1
8551 set done($x) 1
8552 foreach a $arcout($x) {
8553 if {[info exists growing($a)]} {
8554 if {![info exists growanc($x)] && $dl($x)} {
8555 set growanc($x) 1
8556 incr ngrowanc
8558 } else {
8559 set y $arcend($a)
8560 if {[info exists dl($y)]} {
8561 if {$dl($y)} {
8562 if {!$dl($x)} {
8563 set dl($y) 0
8564 if {![info exists done($y)]} {
8565 incr nnh -1
8567 if {[info exists growanc($x)]} {
8568 incr ngrowanc -1
8570 set xl [list $y]
8571 for {set k 0} {$k < [llength $xl]} {incr k} {
8572 set z [lindex $xl $k]
8573 foreach c $arcout($z) {
8574 if {[info exists arcend($c)]} {
8575 set v $arcend($c)
8576 if {[info exists dl($v)] && $dl($v)} {
8577 set dl($v) 0
8578 if {![info exists done($v)]} {
8579 incr nnh -1
8581 if {[info exists growanc($v)]} {
8582 incr ngrowanc -1
8584 lappend xl $v
8591 } elseif {$y eq $anc || !$dl($x)} {
8592 set dl($y) 0
8593 lappend anclist $y
8594 } else {
8595 set dl($y) 1
8596 lappend anclist $y
8597 incr nnh
8602 foreach x [array names growanc] {
8603 if {$dl($x)} {
8604 return 0
8606 return 0
8608 return 1
8611 proc validate_arctags {a} {
8612 global arctags idtags
8614 set i -1
8615 set na $arctags($a)
8616 foreach id $arctags($a) {
8617 incr i
8618 if {![info exists idtags($id)]} {
8619 set na [lreplace $na $i $i]
8620 incr i -1
8623 set arctags($a) $na
8626 proc validate_archeads {a} {
8627 global archeads idheads
8629 set i -1
8630 set na $archeads($a)
8631 foreach id $archeads($a) {
8632 incr i
8633 if {![info exists idheads($id)]} {
8634 set na [lreplace $na $i $i]
8635 incr i -1
8638 set archeads($a) $na
8641 # Return the list of IDs that have tags that are descendents of id,
8642 # ignoring IDs that are descendents of IDs already reported.
8643 proc desctags {id} {
8644 global arcnos arcstart arcids arctags idtags allparents
8645 global growing cached_dtags
8647 if {![info exists allparents($id)]} {
8648 return {}
8650 set t1 [clock clicks -milliseconds]
8651 set argid $id
8652 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8653 # part-way along an arc; check that arc first
8654 set a [lindex $arcnos($id) 0]
8655 if {$arctags($a) ne {}} {
8656 validate_arctags $a
8657 set i [lsearch -exact $arcids($a) $id]
8658 set tid {}
8659 foreach t $arctags($a) {
8660 set j [lsearch -exact $arcids($a) $t]
8661 if {$j >= $i} break
8662 set tid $t
8664 if {$tid ne {}} {
8665 return $tid
8668 set id $arcstart($a)
8669 if {[info exists idtags($id)]} {
8670 return $id
8673 if {[info exists cached_dtags($id)]} {
8674 return $cached_dtags($id)
8677 set origid $id
8678 set todo [list $id]
8679 set queued($id) 1
8680 set nc 1
8681 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8682 set id [lindex $todo $i]
8683 set done($id) 1
8684 set ta [info exists hastaggedancestor($id)]
8685 if {!$ta} {
8686 incr nc -1
8688 # ignore tags on starting node
8689 if {!$ta && $i > 0} {
8690 if {[info exists idtags($id)]} {
8691 set tagloc($id) $id
8692 set ta 1
8693 } elseif {[info exists cached_dtags($id)]} {
8694 set tagloc($id) $cached_dtags($id)
8695 set ta 1
8698 foreach a $arcnos($id) {
8699 set d $arcstart($a)
8700 if {!$ta && $arctags($a) ne {}} {
8701 validate_arctags $a
8702 if {$arctags($a) ne {}} {
8703 lappend tagloc($id) [lindex $arctags($a) end]
8706 if {$ta || $arctags($a) ne {}} {
8707 set tomark [list $d]
8708 for {set j 0} {$j < [llength $tomark]} {incr j} {
8709 set dd [lindex $tomark $j]
8710 if {![info exists hastaggedancestor($dd)]} {
8711 if {[info exists done($dd)]} {
8712 foreach b $arcnos($dd) {
8713 lappend tomark $arcstart($b)
8715 if {[info exists tagloc($dd)]} {
8716 unset tagloc($dd)
8718 } elseif {[info exists queued($dd)]} {
8719 incr nc -1
8721 set hastaggedancestor($dd) 1
8725 if {![info exists queued($d)]} {
8726 lappend todo $d
8727 set queued($d) 1
8728 if {![info exists hastaggedancestor($d)]} {
8729 incr nc
8734 set tags {}
8735 foreach id [array names tagloc] {
8736 if {![info exists hastaggedancestor($id)]} {
8737 foreach t $tagloc($id) {
8738 if {[lsearch -exact $tags $t] < 0} {
8739 lappend tags $t
8744 set t2 [clock clicks -milliseconds]
8745 set loopix $i
8747 # remove tags that are descendents of other tags
8748 for {set i 0} {$i < [llength $tags]} {incr i} {
8749 set a [lindex $tags $i]
8750 for {set j 0} {$j < $i} {incr j} {
8751 set b [lindex $tags $j]
8752 set r [anc_or_desc $a $b]
8753 if {$r == 1} {
8754 set tags [lreplace $tags $j $j]
8755 incr j -1
8756 incr i -1
8757 } elseif {$r == -1} {
8758 set tags [lreplace $tags $i $i]
8759 incr i -1
8760 break
8765 if {[array names growing] ne {}} {
8766 # graph isn't finished, need to check if any tag could get
8767 # eclipsed by another tag coming later. Simply ignore any
8768 # tags that could later get eclipsed.
8769 set ctags {}
8770 foreach t $tags {
8771 if {[is_certain $t $origid]} {
8772 lappend ctags $t
8775 if {$tags eq $ctags} {
8776 set cached_dtags($origid) $tags
8777 } else {
8778 set tags $ctags
8780 } else {
8781 set cached_dtags($origid) $tags
8783 set t3 [clock clicks -milliseconds]
8784 if {0 && $t3 - $t1 >= 100} {
8785 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8786 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8788 return $tags
8791 proc anctags {id} {
8792 global arcnos arcids arcout arcend arctags idtags allparents
8793 global growing cached_atags
8795 if {![info exists allparents($id)]} {
8796 return {}
8798 set t1 [clock clicks -milliseconds]
8799 set argid $id
8800 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8801 # part-way along an arc; check that arc first
8802 set a [lindex $arcnos($id) 0]
8803 if {$arctags($a) ne {}} {
8804 validate_arctags $a
8805 set i [lsearch -exact $arcids($a) $id]
8806 foreach t $arctags($a) {
8807 set j [lsearch -exact $arcids($a) $t]
8808 if {$j > $i} {
8809 return $t
8813 if {![info exists arcend($a)]} {
8814 return {}
8816 set id $arcend($a)
8817 if {[info exists idtags($id)]} {
8818 return $id
8821 if {[info exists cached_atags($id)]} {
8822 return $cached_atags($id)
8825 set origid $id
8826 set todo [list $id]
8827 set queued($id) 1
8828 set taglist {}
8829 set nc 1
8830 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8831 set id [lindex $todo $i]
8832 set done($id) 1
8833 set td [info exists hastaggeddescendent($id)]
8834 if {!$td} {
8835 incr nc -1
8837 # ignore tags on starting node
8838 if {!$td && $i > 0} {
8839 if {[info exists idtags($id)]} {
8840 set tagloc($id) $id
8841 set td 1
8842 } elseif {[info exists cached_atags($id)]} {
8843 set tagloc($id) $cached_atags($id)
8844 set td 1
8847 foreach a $arcout($id) {
8848 if {!$td && $arctags($a) ne {}} {
8849 validate_arctags $a
8850 if {$arctags($a) ne {}} {
8851 lappend tagloc($id) [lindex $arctags($a) 0]
8854 if {![info exists arcend($a)]} continue
8855 set d $arcend($a)
8856 if {$td || $arctags($a) ne {}} {
8857 set tomark [list $d]
8858 for {set j 0} {$j < [llength $tomark]} {incr j} {
8859 set dd [lindex $tomark $j]
8860 if {![info exists hastaggeddescendent($dd)]} {
8861 if {[info exists done($dd)]} {
8862 foreach b $arcout($dd) {
8863 if {[info exists arcend($b)]} {
8864 lappend tomark $arcend($b)
8867 if {[info exists tagloc($dd)]} {
8868 unset tagloc($dd)
8870 } elseif {[info exists queued($dd)]} {
8871 incr nc -1
8873 set hastaggeddescendent($dd) 1
8877 if {![info exists queued($d)]} {
8878 lappend todo $d
8879 set queued($d) 1
8880 if {![info exists hastaggeddescendent($d)]} {
8881 incr nc
8886 set t2 [clock clicks -milliseconds]
8887 set loopix $i
8888 set tags {}
8889 foreach id [array names tagloc] {
8890 if {![info exists hastaggeddescendent($id)]} {
8891 foreach t $tagloc($id) {
8892 if {[lsearch -exact $tags $t] < 0} {
8893 lappend tags $t
8899 # remove tags that are ancestors of other tags
8900 for {set i 0} {$i < [llength $tags]} {incr i} {
8901 set a [lindex $tags $i]
8902 for {set j 0} {$j < $i} {incr j} {
8903 set b [lindex $tags $j]
8904 set r [anc_or_desc $a $b]
8905 if {$r == -1} {
8906 set tags [lreplace $tags $j $j]
8907 incr j -1
8908 incr i -1
8909 } elseif {$r == 1} {
8910 set tags [lreplace $tags $i $i]
8911 incr i -1
8912 break
8917 if {[array names growing] ne {}} {
8918 # graph isn't finished, need to check if any tag could get
8919 # eclipsed by another tag coming later. Simply ignore any
8920 # tags that could later get eclipsed.
8921 set ctags {}
8922 foreach t $tags {
8923 if {[is_certain $origid $t]} {
8924 lappend ctags $t
8927 if {$tags eq $ctags} {
8928 set cached_atags($origid) $tags
8929 } else {
8930 set tags $ctags
8932 } else {
8933 set cached_atags($origid) $tags
8935 set t3 [clock clicks -milliseconds]
8936 if {0 && $t3 - $t1 >= 100} {
8937 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8938 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8940 return $tags
8943 # Return the list of IDs that have heads that are descendents of id,
8944 # including id itself if it has a head.
8945 proc descheads {id} {
8946 global arcnos arcstart arcids archeads idheads cached_dheads
8947 global allparents
8949 if {![info exists allparents($id)]} {
8950 return {}
8952 set aret {}
8953 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8954 # part-way along an arc; check it first
8955 set a [lindex $arcnos($id) 0]
8956 if {$archeads($a) ne {}} {
8957 validate_archeads $a
8958 set i [lsearch -exact $arcids($a) $id]
8959 foreach t $archeads($a) {
8960 set j [lsearch -exact $arcids($a) $t]
8961 if {$j > $i} break
8962 lappend aret $t
8965 set id $arcstart($a)
8967 set origid $id
8968 set todo [list $id]
8969 set seen($id) 1
8970 set ret {}
8971 for {set i 0} {$i < [llength $todo]} {incr i} {
8972 set id [lindex $todo $i]
8973 if {[info exists cached_dheads($id)]} {
8974 set ret [concat $ret $cached_dheads($id)]
8975 } else {
8976 if {[info exists idheads($id)]} {
8977 lappend ret $id
8979 foreach a $arcnos($id) {
8980 if {$archeads($a) ne {}} {
8981 validate_archeads $a
8982 if {$archeads($a) ne {}} {
8983 set ret [concat $ret $archeads($a)]
8986 set d $arcstart($a)
8987 if {![info exists seen($d)]} {
8988 lappend todo $d
8989 set seen($d) 1
8994 set ret [lsort -unique $ret]
8995 set cached_dheads($origid) $ret
8996 return [concat $ret $aret]
8999 proc addedtag {id} {
9000 global arcnos arcout cached_dtags cached_atags
9002 if {![info exists arcnos($id)]} return
9003 if {![info exists arcout($id)]} {
9004 recalcarc [lindex $arcnos($id) 0]
9006 catch {unset cached_dtags}
9007 catch {unset cached_atags}
9010 proc addedhead {hid head} {
9011 global arcnos arcout cached_dheads
9013 if {![info exists arcnos($hid)]} return
9014 if {![info exists arcout($hid)]} {
9015 recalcarc [lindex $arcnos($hid) 0]
9017 catch {unset cached_dheads}
9020 proc removedhead {hid head} {
9021 global cached_dheads
9023 catch {unset cached_dheads}
9026 proc movedhead {hid head} {
9027 global arcnos arcout cached_dheads
9029 if {![info exists arcnos($hid)]} return
9030 if {![info exists arcout($hid)]} {
9031 recalcarc [lindex $arcnos($hid) 0]
9033 catch {unset cached_dheads}
9036 proc changedrefs {} {
9037 global cached_dheads cached_dtags cached_atags
9038 global arctags archeads arcnos arcout idheads idtags
9040 foreach id [concat [array names idheads] [array names idtags]] {
9041 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9042 set a [lindex $arcnos($id) 0]
9043 if {![info exists donearc($a)]} {
9044 recalcarc $a
9045 set donearc($a) 1
9049 catch {unset cached_dtags}
9050 catch {unset cached_atags}
9051 catch {unset cached_dheads}
9054 proc rereadrefs {} {
9055 global idtags idheads idotherrefs mainheadid
9057 set refids [concat [array names idtags] \
9058 [array names idheads] [array names idotherrefs]]
9059 foreach id $refids {
9060 if {![info exists ref($id)]} {
9061 set ref($id) [listrefs $id]
9064 set oldmainhead $mainheadid
9065 readrefs
9066 changedrefs
9067 set refids [lsort -unique [concat $refids [array names idtags] \
9068 [array names idheads] [array names idotherrefs]]]
9069 foreach id $refids {
9070 set v [listrefs $id]
9071 if {![info exists ref($id)] || $ref($id) != $v} {
9072 redrawtags $id
9075 if {$oldmainhead ne $mainheadid} {
9076 redrawtags $oldmainhead
9077 redrawtags $mainheadid
9079 run refill_reflist
9082 proc listrefs {id} {
9083 global idtags idheads idotherrefs
9085 set x {}
9086 if {[info exists idtags($id)]} {
9087 set x $idtags($id)
9089 set y {}
9090 if {[info exists idheads($id)]} {
9091 set y $idheads($id)
9093 set z {}
9094 if {[info exists idotherrefs($id)]} {
9095 set z $idotherrefs($id)
9097 return [list $x $y $z]
9100 proc showtag {tag isnew} {
9101 global ctext tagcontents tagids linknum tagobjid
9103 if {$isnew} {
9104 addtohistory [list showtag $tag 0]
9106 $ctext conf -state normal
9107 clear_ctext
9108 settabs 0
9109 set linknum 0
9110 if {![info exists tagcontents($tag)]} {
9111 catch {
9112 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9115 if {[info exists tagcontents($tag)]} {
9116 set text $tagcontents($tag)
9117 } else {
9118 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9120 appendwithlinks $text {}
9121 $ctext conf -state disabled
9122 init_flist {}
9125 proc doquit {} {
9126 global stopped
9127 global gitktmpdir
9129 set stopped 100
9130 savestuff .
9131 destroy .
9133 if {[info exists gitktmpdir]} {
9134 catch {file delete -force $gitktmpdir}
9138 proc mkfontdisp {font top which} {
9139 global fontattr fontpref $font
9141 set fontpref($font) [set $font]
9142 button $top.${font}but -text $which -font optionfont \
9143 -command [list choosefont $font $which]
9144 label $top.$font -relief flat -font $font \
9145 -text $fontattr($font,family) -justify left
9146 grid x $top.${font}but $top.$font -sticky w
9149 proc choosefont {font which} {
9150 global fontparam fontlist fonttop fontattr
9152 set fontparam(which) $which
9153 set fontparam(font) $font
9154 set fontparam(family) [font actual $font -family]
9155 set fontparam(size) $fontattr($font,size)
9156 set fontparam(weight) $fontattr($font,weight)
9157 set fontparam(slant) $fontattr($font,slant)
9158 set top .gitkfont
9159 set fonttop $top
9160 if {![winfo exists $top]} {
9161 font create sample
9162 eval font config sample [font actual $font]
9163 toplevel $top
9164 wm title $top [mc "Gitk font chooser"]
9165 label $top.l -textvariable fontparam(which)
9166 pack $top.l -side top
9167 set fontlist [lsort [font families]]
9168 frame $top.f
9169 listbox $top.f.fam -listvariable fontlist \
9170 -yscrollcommand [list $top.f.sb set]
9171 bind $top.f.fam <<ListboxSelect>> selfontfam
9172 scrollbar $top.f.sb -command [list $top.f.fam yview]
9173 pack $top.f.sb -side right -fill y
9174 pack $top.f.fam -side left -fill both -expand 1
9175 pack $top.f -side top -fill both -expand 1
9176 frame $top.g
9177 spinbox $top.g.size -from 4 -to 40 -width 4 \
9178 -textvariable fontparam(size) \
9179 -validatecommand {string is integer -strict %s}
9180 checkbutton $top.g.bold -padx 5 \
9181 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9182 -variable fontparam(weight) -onvalue bold -offvalue normal
9183 checkbutton $top.g.ital -padx 5 \
9184 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9185 -variable fontparam(slant) -onvalue italic -offvalue roman
9186 pack $top.g.size $top.g.bold $top.g.ital -side left
9187 pack $top.g -side top
9188 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9189 -background white
9190 $top.c create text 100 25 -anchor center -text $which -font sample \
9191 -fill black -tags text
9192 bind $top.c <Configure> [list centertext $top.c]
9193 pack $top.c -side top -fill x
9194 frame $top.buts
9195 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9196 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9197 grid $top.buts.ok $top.buts.can
9198 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9199 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9200 pack $top.buts -side bottom -fill x
9201 trace add variable fontparam write chg_fontparam
9202 } else {
9203 raise $top
9204 $top.c itemconf text -text $which
9206 set i [lsearch -exact $fontlist $fontparam(family)]
9207 if {$i >= 0} {
9208 $top.f.fam selection set $i
9209 $top.f.fam see $i
9213 proc centertext {w} {
9214 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9217 proc fontok {} {
9218 global fontparam fontpref prefstop
9220 set f $fontparam(font)
9221 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9222 if {$fontparam(weight) eq "bold"} {
9223 lappend fontpref($f) "bold"
9225 if {$fontparam(slant) eq "italic"} {
9226 lappend fontpref($f) "italic"
9228 set w $prefstop.$f
9229 $w conf -text $fontparam(family) -font $fontpref($f)
9231 fontcan
9234 proc fontcan {} {
9235 global fonttop fontparam
9237 if {[info exists fonttop]} {
9238 catch {destroy $fonttop}
9239 catch {font delete sample}
9240 unset fonttop
9241 unset fontparam
9245 proc selfontfam {} {
9246 global fonttop fontparam
9248 set i [$fonttop.f.fam curselection]
9249 if {$i ne {}} {
9250 set fontparam(family) [$fonttop.f.fam get $i]
9254 proc chg_fontparam {v sub op} {
9255 global fontparam
9257 font config sample -$sub $fontparam($sub)
9260 proc doprefs {} {
9261 global maxwidth maxgraphpct
9262 global oldprefs prefstop showneartags showlocalchanges
9263 global bgcolor fgcolor ctext diffcolors selectbgcolor
9264 global tabstop limitdiffs autoselect extdifftool
9266 set top .gitkprefs
9267 set prefstop $top
9268 if {[winfo exists $top]} {
9269 raise $top
9270 return
9272 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9273 limitdiffs tabstop} {
9274 set oldprefs($v) [set $v]
9276 toplevel $top
9277 wm title $top [mc "Gitk preferences"]
9278 label $top.ldisp -text [mc "Commit list display options"]
9279 grid $top.ldisp - -sticky w -pady 10
9280 label $top.spacer -text " "
9281 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9282 -font optionfont
9283 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9284 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9285 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9286 -font optionfont
9287 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9288 grid x $top.maxpctl $top.maxpct -sticky w
9289 frame $top.showlocal
9290 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9291 checkbutton $top.showlocal.b -variable showlocalchanges
9292 pack $top.showlocal.b $top.showlocal.l -side left
9293 grid x $top.showlocal -sticky w
9294 frame $top.autoselect
9295 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9296 checkbutton $top.autoselect.b -variable autoselect
9297 pack $top.autoselect.b $top.autoselect.l -side left
9298 grid x $top.autoselect -sticky w
9300 label $top.ddisp -text [mc "Diff display options"]
9301 grid $top.ddisp - -sticky w -pady 10
9302 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9303 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9304 grid x $top.tabstopl $top.tabstop -sticky w
9305 frame $top.ntag
9306 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9307 checkbutton $top.ntag.b -variable showneartags
9308 pack $top.ntag.b $top.ntag.l -side left
9309 grid x $top.ntag -sticky w
9310 frame $top.ldiff
9311 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9312 checkbutton $top.ldiff.b -variable limitdiffs
9313 pack $top.ldiff.b $top.ldiff.l -side left
9314 grid x $top.ldiff -sticky w
9316 entry $top.extdifft -textvariable extdifftool
9317 frame $top.extdifff
9318 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9319 -padx 10
9320 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9321 -command choose_extdiff
9322 pack $top.extdifff.l $top.extdifff.b -side left
9323 grid x $top.extdifff $top.extdifft -sticky w
9325 label $top.cdisp -text [mc "Colors: press to choose"]
9326 grid $top.cdisp - -sticky w -pady 10
9327 label $top.bg -padx 40 -relief sunk -background $bgcolor
9328 button $top.bgbut -text [mc "Background"] -font optionfont \
9329 -command [list choosecolor bgcolor {} $top.bg background setbg]
9330 grid x $top.bgbut $top.bg -sticky w
9331 label $top.fg -padx 40 -relief sunk -background $fgcolor
9332 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9333 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9334 grid x $top.fgbut $top.fg -sticky w
9335 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9336 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9337 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9338 [list $ctext tag conf d0 -foreground]]
9339 grid x $top.diffoldbut $top.diffold -sticky w
9340 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9341 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9342 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9343 [list $ctext tag conf d1 -foreground]]
9344 grid x $top.diffnewbut $top.diffnew -sticky w
9345 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9346 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9347 -command [list choosecolor diffcolors 2 $top.hunksep \
9348 "diff hunk header" \
9349 [list $ctext tag conf hunksep -foreground]]
9350 grid x $top.hunksepbut $top.hunksep -sticky w
9351 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9352 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9353 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9354 grid x $top.selbgbut $top.selbgsep -sticky w
9356 label $top.cfont -text [mc "Fonts: press to choose"]
9357 grid $top.cfont - -sticky w -pady 10
9358 mkfontdisp mainfont $top [mc "Main font"]
9359 mkfontdisp textfont $top [mc "Diff display font"]
9360 mkfontdisp uifont $top [mc "User interface font"]
9362 frame $top.buts
9363 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9364 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9365 grid $top.buts.ok $top.buts.can
9366 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9367 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9368 grid $top.buts - - -pady 10 -sticky ew
9369 bind $top <Visibility> "focus $top.buts.ok"
9372 proc choose_extdiff {} {
9373 global extdifftool
9375 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9376 if {$prog ne {}} {
9377 set extdifftool $prog
9381 proc choosecolor {v vi w x cmd} {
9382 global $v
9384 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9385 -title [mc "Gitk: choose color for %s" $x]]
9386 if {$c eq {}} return
9387 $w conf -background $c
9388 lset $v $vi $c
9389 eval $cmd $c
9392 proc setselbg {c} {
9393 global bglist cflist
9394 foreach w $bglist {
9395 $w configure -selectbackground $c
9397 $cflist tag configure highlight \
9398 -background [$cflist cget -selectbackground]
9399 allcanvs itemconf secsel -fill $c
9402 proc setbg {c} {
9403 global bglist
9405 foreach w $bglist {
9406 $w conf -background $c
9410 proc setfg {c} {
9411 global fglist canv
9413 foreach w $fglist {
9414 $w conf -foreground $c
9416 allcanvs itemconf text -fill $c
9417 $canv itemconf circle -outline $c
9420 proc prefscan {} {
9421 global oldprefs prefstop
9423 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9424 limitdiffs tabstop} {
9425 global $v
9426 set $v $oldprefs($v)
9428 catch {destroy $prefstop}
9429 unset prefstop
9430 fontcan
9433 proc prefsok {} {
9434 global maxwidth maxgraphpct
9435 global oldprefs prefstop showneartags showlocalchanges
9436 global fontpref mainfont textfont uifont
9437 global limitdiffs treediffs
9439 catch {destroy $prefstop}
9440 unset prefstop
9441 fontcan
9442 set fontchanged 0
9443 if {$mainfont ne $fontpref(mainfont)} {
9444 set mainfont $fontpref(mainfont)
9445 parsefont mainfont $mainfont
9446 eval font configure mainfont [fontflags mainfont]
9447 eval font configure mainfontbold [fontflags mainfont 1]
9448 setcoords
9449 set fontchanged 1
9451 if {$textfont ne $fontpref(textfont)} {
9452 set textfont $fontpref(textfont)
9453 parsefont textfont $textfont
9454 eval font configure textfont [fontflags textfont]
9455 eval font configure textfontbold [fontflags textfont 1]
9457 if {$uifont ne $fontpref(uifont)} {
9458 set uifont $fontpref(uifont)
9459 parsefont uifont $uifont
9460 eval font configure uifont [fontflags uifont]
9462 settabs
9463 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9464 if {$showlocalchanges} {
9465 doshowlocalchanges
9466 } else {
9467 dohidelocalchanges
9470 if {$limitdiffs != $oldprefs(limitdiffs)} {
9471 # treediffs elements are limited by path
9472 catch {unset treediffs}
9474 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9475 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9476 redisplay
9477 } elseif {$showneartags != $oldprefs(showneartags) ||
9478 $limitdiffs != $oldprefs(limitdiffs)} {
9479 reselectline
9483 proc formatdate {d} {
9484 global datetimeformat
9485 if {$d ne {}} {
9486 set d [clock format $d -format $datetimeformat]
9488 return $d
9491 # This list of encoding names and aliases is distilled from
9492 # http://www.iana.org/assignments/character-sets.
9493 # Not all of them are supported by Tcl.
9494 set encoding_aliases {
9495 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9496 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9497 { ISO-10646-UTF-1 csISO10646UTF1 }
9498 { ISO_646.basic:1983 ref csISO646basic1983 }
9499 { INVARIANT csINVARIANT }
9500 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9501 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9502 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9503 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9504 { NATS-DANO iso-ir-9-1 csNATSDANO }
9505 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9506 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9507 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9508 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9509 { ISO-2022-KR csISO2022KR }
9510 { EUC-KR csEUCKR }
9511 { ISO-2022-JP csISO2022JP }
9512 { ISO-2022-JP-2 csISO2022JP2 }
9513 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9514 csISO13JISC6220jp }
9515 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9516 { IT iso-ir-15 ISO646-IT csISO15Italian }
9517 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9518 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9519 { greek7-old iso-ir-18 csISO18Greek7Old }
9520 { latin-greek iso-ir-19 csISO19LatinGreek }
9521 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9522 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9523 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9524 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9525 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9526 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9527 { INIS iso-ir-49 csISO49INIS }
9528 { INIS-8 iso-ir-50 csISO50INIS8 }
9529 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9530 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9531 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9532 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9533 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9534 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9535 csISO60Norwegian1 }
9536 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9537 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9538 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9539 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9540 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9541 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9542 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9543 { greek7 iso-ir-88 csISO88Greek7 }
9544 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9545 { iso-ir-90 csISO90 }
9546 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9547 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9548 csISO92JISC62991984b }
9549 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9550 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9551 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9552 csISO95JIS62291984handadd }
9553 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9554 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9555 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9556 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9557 CP819 csISOLatin1 }
9558 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9559 { T.61-7bit iso-ir-102 csISO102T617bit }
9560 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9561 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9562 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9563 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9564 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9565 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9566 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9567 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9568 arabic csISOLatinArabic }
9569 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9570 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9571 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9572 greek greek8 csISOLatinGreek }
9573 { T.101-G2 iso-ir-128 csISO128T101G2 }
9574 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9575 csISOLatinHebrew }
9576 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9577 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9578 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9579 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9580 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9581 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9582 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9583 csISOLatinCyrillic }
9584 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9585 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9586 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9587 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9588 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9589 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9590 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9591 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9592 { ISO_10367-box iso-ir-155 csISO10367Box }
9593 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9594 { latin-lap lap iso-ir-158 csISO158Lap }
9595 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9596 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9597 { us-dk csUSDK }
9598 { dk-us csDKUS }
9599 { JIS_X0201 X0201 csHalfWidthKatakana }
9600 { KSC5636 ISO646-KR csKSC5636 }
9601 { ISO-10646-UCS-2 csUnicode }
9602 { ISO-10646-UCS-4 csUCS4 }
9603 { DEC-MCS dec csDECMCS }
9604 { hp-roman8 roman8 r8 csHPRoman8 }
9605 { macintosh mac csMacintosh }
9606 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9607 csIBM037 }
9608 { IBM038 EBCDIC-INT cp038 csIBM038 }
9609 { IBM273 CP273 csIBM273 }
9610 { IBM274 EBCDIC-BE CP274 csIBM274 }
9611 { IBM275 EBCDIC-BR cp275 csIBM275 }
9612 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9613 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9614 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9615 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9616 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9617 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9618 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9619 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9620 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9621 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9622 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9623 { IBM437 cp437 437 csPC8CodePage437 }
9624 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9625 { IBM775 cp775 csPC775Baltic }
9626 { IBM850 cp850 850 csPC850Multilingual }
9627 { IBM851 cp851 851 csIBM851 }
9628 { IBM852 cp852 852 csPCp852 }
9629 { IBM855 cp855 855 csIBM855 }
9630 { IBM857 cp857 857 csIBM857 }
9631 { IBM860 cp860 860 csIBM860 }
9632 { IBM861 cp861 861 cp-is csIBM861 }
9633 { IBM862 cp862 862 csPC862LatinHebrew }
9634 { IBM863 cp863 863 csIBM863 }
9635 { IBM864 cp864 csIBM864 }
9636 { IBM865 cp865 865 csIBM865 }
9637 { IBM866 cp866 866 csIBM866 }
9638 { IBM868 CP868 cp-ar csIBM868 }
9639 { IBM869 cp869 869 cp-gr csIBM869 }
9640 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9641 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9642 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9643 { IBM891 cp891 csIBM891 }
9644 { IBM903 cp903 csIBM903 }
9645 { IBM904 cp904 904 csIBBM904 }
9646 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9647 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9648 { IBM1026 CP1026 csIBM1026 }
9649 { EBCDIC-AT-DE csIBMEBCDICATDE }
9650 { EBCDIC-AT-DE-A csEBCDICATDEA }
9651 { EBCDIC-CA-FR csEBCDICCAFR }
9652 { EBCDIC-DK-NO csEBCDICDKNO }
9653 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9654 { EBCDIC-FI-SE csEBCDICFISE }
9655 { EBCDIC-FI-SE-A csEBCDICFISEA }
9656 { EBCDIC-FR csEBCDICFR }
9657 { EBCDIC-IT csEBCDICIT }
9658 { EBCDIC-PT csEBCDICPT }
9659 { EBCDIC-ES csEBCDICES }
9660 { EBCDIC-ES-A csEBCDICESA }
9661 { EBCDIC-ES-S csEBCDICESS }
9662 { EBCDIC-UK csEBCDICUK }
9663 { EBCDIC-US csEBCDICUS }
9664 { UNKNOWN-8BIT csUnknown8BiT }
9665 { MNEMONIC csMnemonic }
9666 { MNEM csMnem }
9667 { VISCII csVISCII }
9668 { VIQR csVIQR }
9669 { KOI8-R csKOI8R }
9670 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9671 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9672 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9673 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9674 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9675 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9676 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9677 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9678 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9679 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9680 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9681 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9682 { IBM1047 IBM-1047 }
9683 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9684 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9685 { UNICODE-1-1 csUnicode11 }
9686 { CESU-8 csCESU-8 }
9687 { BOCU-1 csBOCU-1 }
9688 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9689 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9690 l8 }
9691 { ISO-8859-15 ISO_8859-15 Latin-9 }
9692 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9693 { GBK CP936 MS936 windows-936 }
9694 { JIS_Encoding csJISEncoding }
9695 { Shift_JIS MS_Kanji csShiftJIS }
9696 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9697 EUC-JP }
9698 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9699 { ISO-10646-UCS-Basic csUnicodeASCII }
9700 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9701 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9702 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9703 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9704 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9705 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9706 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9707 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9708 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9709 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9710 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9711 { Ventura-US csVenturaUS }
9712 { Ventura-International csVenturaInternational }
9713 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9714 { PC8-Turkish csPC8Turkish }
9715 { IBM-Symbols csIBMSymbols }
9716 { IBM-Thai csIBMThai }
9717 { HP-Legal csHPLegal }
9718 { HP-Pi-font csHPPiFont }
9719 { HP-Math8 csHPMath8 }
9720 { Adobe-Symbol-Encoding csHPPSMath }
9721 { HP-DeskTop csHPDesktop }
9722 { Ventura-Math csVenturaMath }
9723 { Microsoft-Publishing csMicrosoftPublishing }
9724 { Windows-31J csWindows31J }
9725 { GB2312 csGB2312 }
9726 { Big5 csBig5 }
9729 proc tcl_encoding {enc} {
9730 global encoding_aliases
9731 set names [encoding names]
9732 set lcnames [string tolower $names]
9733 set enc [string tolower $enc]
9734 set i [lsearch -exact $lcnames $enc]
9735 if {$i < 0} {
9736 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9737 if {[regsub {^iso[-_]} $enc iso encx]} {
9738 set i [lsearch -exact $lcnames $encx]
9741 if {$i < 0} {
9742 foreach l $encoding_aliases {
9743 set ll [string tolower $l]
9744 if {[lsearch -exact $ll $enc] < 0} continue
9745 # look through the aliases for one that tcl knows about
9746 foreach e $ll {
9747 set i [lsearch -exact $lcnames $e]
9748 if {$i < 0} {
9749 if {[regsub {^iso[-_]} $e iso ex]} {
9750 set i [lsearch -exact $lcnames $ex]
9753 if {$i >= 0} break
9755 break
9758 if {$i >= 0} {
9759 return [lindex $names $i]
9761 return {}
9764 # First check that Tcl/Tk is recent enough
9765 if {[catch {package require Tk 8.4} err]} {
9766 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9767 Gitk requires at least Tcl/Tk 8.4."]
9768 exit 1
9771 # defaults...
9772 set wrcomcmd "git diff-tree --stdin -p --pretty"
9774 set gitencoding {}
9775 catch {
9776 set gitencoding [exec git config --get i18n.commitencoding]
9778 if {$gitencoding == ""} {
9779 set gitencoding "utf-8"
9781 set tclencoding [tcl_encoding $gitencoding]
9782 if {$tclencoding == {}} {
9783 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9786 set mainfont {Helvetica 9}
9787 set textfont {Courier 9}
9788 set uifont {Helvetica 9 bold}
9789 set tabstop 8
9790 set findmergefiles 0
9791 set maxgraphpct 50
9792 set maxwidth 16
9793 set revlistorder 0
9794 set fastdate 0
9795 set uparrowlen 5
9796 set downarrowlen 5
9797 set mingaplen 100
9798 set cmitmode "patch"
9799 set wrapcomment "none"
9800 set showneartags 1
9801 set maxrefs 20
9802 set maxlinelen 200
9803 set showlocalchanges 1
9804 set limitdiffs 1
9805 set datetimeformat "%Y-%m-%d %H:%M:%S"
9806 set autoselect 1
9808 set extdifftool "meld"
9810 set colors {green red blue magenta darkgrey brown orange}
9811 set bgcolor white
9812 set fgcolor black
9813 set diffcolors {red "#00a000" blue}
9814 set diffcontext 3
9815 set ignorespace 0
9816 set selectbgcolor gray85
9818 set circlecolors {white blue gray blue blue}
9820 ## For msgcat loading, first locate the installation location.
9821 if { [info exists ::env(GITK_MSGSDIR)] } {
9822 ## Msgsdir was manually set in the environment.
9823 set gitk_msgsdir $::env(GITK_MSGSDIR)
9824 } else {
9825 ## Let's guess the prefix from argv0.
9826 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9827 set gitk_libdir [file join $gitk_prefix share gitk lib]
9828 set gitk_msgsdir [file join $gitk_libdir msgs]
9829 unset gitk_prefix
9832 ## Internationalization (i18n) through msgcat and gettext. See
9833 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9834 package require msgcat
9835 namespace import ::msgcat::mc
9836 ## And eventually load the actual message catalog
9837 ::msgcat::mcload $gitk_msgsdir
9839 catch {source ~/.gitk}
9841 font create optionfont -family sans-serif -size -12
9843 parsefont mainfont $mainfont
9844 eval font create mainfont [fontflags mainfont]
9845 eval font create mainfontbold [fontflags mainfont 1]
9847 parsefont textfont $textfont
9848 eval font create textfont [fontflags textfont]
9849 eval font create textfontbold [fontflags textfont 1]
9851 parsefont uifont $uifont
9852 eval font create uifont [fontflags uifont]
9854 setoptions
9856 # check that we can find a .git directory somewhere...
9857 if {[catch {set gitdir [gitdir]}]} {
9858 show_error {} . [mc "Cannot find a git repository here."]
9859 exit 1
9861 if {![file isdirectory $gitdir]} {
9862 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9863 exit 1
9866 set revtreeargs {}
9867 set cmdline_files {}
9868 set i 0
9869 set revtreeargscmd {}
9870 foreach arg $argv {
9871 switch -glob -- $arg {
9872 "" { }
9873 "--" {
9874 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9875 break
9877 "--argscmd=*" {
9878 set revtreeargscmd [string range $arg 10 end]
9880 default {
9881 lappend revtreeargs $arg
9884 incr i
9887 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9888 # no -- on command line, but some arguments (other than --argscmd)
9889 if {[catch {
9890 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9891 set cmdline_files [split $f "\n"]
9892 set n [llength $cmdline_files]
9893 set revtreeargs [lrange $revtreeargs 0 end-$n]
9894 # Unfortunately git rev-parse doesn't produce an error when
9895 # something is both a revision and a filename. To be consistent
9896 # with git log and git rev-list, check revtreeargs for filenames.
9897 foreach arg $revtreeargs {
9898 if {[file exists $arg]} {
9899 show_error {} . [mc "Ambiguous argument '%s': both revision\
9900 and filename" $arg]
9901 exit 1
9904 } err]} {
9905 # unfortunately we get both stdout and stderr in $err,
9906 # so look for "fatal:".
9907 set i [string first "fatal:" $err]
9908 if {$i > 0} {
9909 set err [string range $err [expr {$i + 6}] end]
9911 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9912 exit 1
9916 set nullid "0000000000000000000000000000000000000000"
9917 set nullid2 "0000000000000000000000000000000000000001"
9918 set nullfile "/dev/null"
9920 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9922 set runq {}
9923 set history {}
9924 set historyindex 0
9925 set fh_serial 0
9926 set nhl_names {}
9927 set highlight_paths {}
9928 set findpattern {}
9929 set searchdirn -forwards
9930 set boldrows {}
9931 set boldnamerows {}
9932 set diffelide {0 0}
9933 set markingmatches 0
9934 set linkentercount 0
9935 set need_redisplay 0
9936 set nrows_drawn 0
9937 set firsttabstop 0
9939 set nextviewnum 1
9940 set curview 0
9941 set selectedview 0
9942 set selectedhlview [mc "None"]
9943 set highlight_related [mc "None"]
9944 set highlight_files {}
9945 set viewfiles(0) {}
9946 set viewperm(0) 0
9947 set viewargs(0) {}
9948 set viewargscmd(0) {}
9950 set selectedline {}
9951 set numcommits 0
9952 set loginstance 0
9953 set cmdlineok 0
9954 set stopped 0
9955 set stuffsaved 0
9956 set patchnum 0
9957 set lserial 0
9958 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9959 setcoords
9960 makewindow
9961 # wait for the window to become visible
9962 tkwait visibility .
9963 wm title . "[file tail $argv0]: [file tail [pwd]]"
9964 readrefs
9966 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9967 # create a view for the files/dirs specified on the command line
9968 set curview 1
9969 set selectedview 1
9970 set nextviewnum 2
9971 set viewname(1) [mc "Command line"]
9972 set viewfiles(1) $cmdline_files
9973 set viewargs(1) $revtreeargs
9974 set viewargscmd(1) $revtreeargscmd
9975 set viewperm(1) 0
9976 set vdatemode(1) 0
9977 addviewmenu 1
9978 .bar.view entryconf [mc "Edit view..."] -state normal
9979 .bar.view entryconf [mc "Delete view"] -state normal
9982 if {[info exists permviews]} {
9983 foreach v $permviews {
9984 set n $nextviewnum
9985 incr nextviewnum
9986 set viewname($n) [lindex $v 0]
9987 set viewfiles($n) [lindex $v 1]
9988 set viewargs($n) [lindex $v 2]
9989 set viewargscmd($n) [lindex $v 3]
9990 set viewperm($n) 1
9991 addviewmenu $n
9994 getcommits {}