gitk: On Windows, use a Cygwin-specific flag for kill
[git/debian.git] / gitk
blobd7fea265f3e48a32c11c208749d59f86a8f5bdda
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 pending_select mainheadid
311 global vcanopt vflags vrevs vorigargs
313 set startmsecs [clock clicks -milliseconds]
314 set commitidx($view) 0
315 # these are set this way for the error exits
316 set viewcomplete($view) 1
317 set viewactive($view) 0
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 if {$view == $curview} {
378 set pending_select $mainheadid
380 set viewcomplete($view) 0
381 set viewactive($view) 1
382 return 1
385 proc stop_instance {inst} {
386 global commfd leftover
388 set fd $commfd($inst)
389 catch {
390 set pid [pid $fd]
392 if {$::tcl_platform(platform) eq {windows}} {
393 exec kill -f $pid
394 } else {
395 exec kill $pid
398 catch {close $fd}
399 nukefile $fd
400 unset commfd($inst)
401 unset leftover($inst)
404 proc stop_backends {} {
405 global commfd
407 foreach inst [array names commfd] {
408 stop_instance $inst
412 proc stop_rev_list {view} {
413 global viewinstances
415 foreach inst $viewinstances($view) {
416 stop_instance $inst
418 set viewinstances($view) {}
421 proc getcommits {} {
422 global canv curview need_redisplay viewactive
424 initlayout
425 if {[start_rev_list $curview]} {
426 show_status [mc "Reading commits..."]
427 set need_redisplay 1
428 } else {
429 show_status [mc "No commits selected"]
433 proc updatecommits {} {
434 global curview vcanopt vorigargs vfilelimit viewinstances
435 global viewactive viewcomplete tclencoding
436 global startmsecs showneartags showlocalchanges
437 global mainheadid pending_select
438 global isworktree
439 global varcid vposids vnegids vflags vrevs
441 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
442 set oldmainid $mainheadid
443 rereadrefs
444 if {$showlocalchanges} {
445 if {$mainheadid ne $oldmainid} {
446 dohidelocalchanges
448 if {[commitinview $mainheadid $curview]} {
449 dodiffindex
452 set view $curview
453 if {$vcanopt($view)} {
454 set oldpos $vposids($view)
455 set oldneg $vnegids($view)
456 set revs [parseviewrevs $view $vrevs($view)]
457 if {$revs eq {}} {
458 return
460 # note: getting the delta when negative refs change is hard,
461 # and could require multiple git log invocations, so in that
462 # case we ask git log for all the commits (not just the delta)
463 if {$oldneg eq $vnegids($view)} {
464 set newrevs {}
465 set npos 0
466 # take out positive refs that we asked for before or
467 # that we have already seen
468 foreach rev $revs {
469 if {[string length $rev] == 40} {
470 if {[lsearch -exact $oldpos $rev] < 0
471 && ![info exists varcid($view,$rev)]} {
472 lappend newrevs $rev
473 incr npos
475 } else {
476 lappend $newrevs $rev
479 if {$npos == 0} return
480 set revs $newrevs
481 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
483 set args [concat $vflags($view) $revs --not $oldpos]
484 } else {
485 set args $vorigargs($view)
487 if {[catch {
488 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
489 --boundary $args "--" $vfilelimit($view)] r]
490 } err]} {
491 error_popup "Error executing git log: $err"
492 return
494 if {$viewactive($view) == 0} {
495 set startmsecs [clock clicks -milliseconds]
497 set i [reg_instance $fd]
498 lappend viewinstances($view) $i
499 fconfigure $fd -blocking 0 -translation lf -eofchar {}
500 if {$tclencoding != {}} {
501 fconfigure $fd -encoding $tclencoding
503 filerun $fd [list getcommitlines $fd $i $view 1]
504 incr viewactive($view)
505 set viewcomplete($view) 0
506 set pending_select $mainheadid
507 nowbusy $view "Reading"
508 if {$showneartags} {
509 getallcommits
513 proc reloadcommits {} {
514 global curview viewcomplete selectedline currentid thickerline
515 global showneartags treediffs commitinterest cached_commitrow
516 global targetid
518 if {!$viewcomplete($curview)} {
519 stop_rev_list $curview
521 resetvarcs $curview
522 set selectedline {}
523 catch {unset currentid}
524 catch {unset thickerline}
525 catch {unset treediffs}
526 readrefs
527 changedrefs
528 if {$showneartags} {
529 getallcommits
531 clear_display
532 catch {unset commitinterest}
533 catch {unset cached_commitrow}
534 catch {unset targetid}
535 setcanvscroll
536 getcommits
537 return 0
540 # This makes a string representation of a positive integer which
541 # sorts as a string in numerical order
542 proc strrep {n} {
543 if {$n < 16} {
544 return [format "%x" $n]
545 } elseif {$n < 256} {
546 return [format "x%.2x" $n]
547 } elseif {$n < 65536} {
548 return [format "y%.4x" $n]
550 return [format "z%.8x" $n]
553 # Procedures used in reordering commits from git log (without
554 # --topo-order) into the order for display.
556 proc varcinit {view} {
557 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
558 global vtokmod varcmod vrowmod varcix vlastins
560 set varcstart($view) {{}}
561 set vupptr($view) {0}
562 set vdownptr($view) {0}
563 set vleftptr($view) {0}
564 set vbackptr($view) {0}
565 set varctok($view) {{}}
566 set varcrow($view) {{}}
567 set vtokmod($view) {}
568 set varcmod($view) 0
569 set vrowmod($view) 0
570 set varcix($view) {{}}
571 set vlastins($view) {0}
574 proc resetvarcs {view} {
575 global varcid varccommits parents children vseedcount ordertok
577 foreach vid [array names varcid $view,*] {
578 unset varcid($vid)
579 unset children($vid)
580 unset parents($vid)
582 # some commits might have children but haven't been seen yet
583 foreach vid [array names children $view,*] {
584 unset children($vid)
586 foreach va [array names varccommits $view,*] {
587 unset varccommits($va)
589 foreach vd [array names vseedcount $view,*] {
590 unset vseedcount($vd)
592 catch {unset ordertok}
595 # returns a list of the commits with no children
596 proc seeds {v} {
597 global vdownptr vleftptr varcstart
599 set ret {}
600 set a [lindex $vdownptr($v) 0]
601 while {$a != 0} {
602 lappend ret [lindex $varcstart($v) $a]
603 set a [lindex $vleftptr($v) $a]
605 return $ret
608 proc newvarc {view id} {
609 global varcid varctok parents children vdatemode
610 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
611 global commitdata commitinfo vseedcount varccommits vlastins
613 set a [llength $varctok($view)]
614 set vid $view,$id
615 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
616 if {![info exists commitinfo($id)]} {
617 parsecommit $id $commitdata($id) 1
619 set cdate [lindex $commitinfo($id) 4]
620 if {![string is integer -strict $cdate]} {
621 set cdate 0
623 if {![info exists vseedcount($view,$cdate)]} {
624 set vseedcount($view,$cdate) -1
626 set c [incr vseedcount($view,$cdate)]
627 set cdate [expr {$cdate ^ 0xffffffff}]
628 set tok "s[strrep $cdate][strrep $c]"
629 } else {
630 set tok {}
632 set ka 0
633 if {[llength $children($vid)] > 0} {
634 set kid [lindex $children($vid) end]
635 set k $varcid($view,$kid)
636 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
637 set ki $kid
638 set ka $k
639 set tok [lindex $varctok($view) $k]
642 if {$ka != 0} {
643 set i [lsearch -exact $parents($view,$ki) $id]
644 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
645 append tok [strrep $j]
647 set c [lindex $vlastins($view) $ka]
648 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
649 set c $ka
650 set b [lindex $vdownptr($view) $ka]
651 } else {
652 set b [lindex $vleftptr($view) $c]
654 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
655 set c $b
656 set b [lindex $vleftptr($view) $c]
658 if {$c == $ka} {
659 lset vdownptr($view) $ka $a
660 lappend vbackptr($view) 0
661 } else {
662 lset vleftptr($view) $c $a
663 lappend vbackptr($view) $c
665 lset vlastins($view) $ka $a
666 lappend vupptr($view) $ka
667 lappend vleftptr($view) $b
668 if {$b != 0} {
669 lset vbackptr($view) $b $a
671 lappend varctok($view) $tok
672 lappend varcstart($view) $id
673 lappend vdownptr($view) 0
674 lappend varcrow($view) {}
675 lappend varcix($view) {}
676 set varccommits($view,$a) {}
677 lappend vlastins($view) 0
678 return $a
681 proc splitvarc {p v} {
682 global varcid varcstart varccommits varctok
683 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
685 set oa $varcid($v,$p)
686 set ac $varccommits($v,$oa)
687 set i [lsearch -exact $varccommits($v,$oa) $p]
688 if {$i <= 0} return
689 set na [llength $varctok($v)]
690 # "%" sorts before "0"...
691 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
692 lappend varctok($v) $tok
693 lappend varcrow($v) {}
694 lappend varcix($v) {}
695 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
696 set varccommits($v,$na) [lrange $ac $i end]
697 lappend varcstart($v) $p
698 foreach id $varccommits($v,$na) {
699 set varcid($v,$id) $na
701 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
702 lappend vlastins($v) [lindex $vlastins($v) $oa]
703 lset vdownptr($v) $oa $na
704 lset vlastins($v) $oa 0
705 lappend vupptr($v) $oa
706 lappend vleftptr($v) 0
707 lappend vbackptr($v) 0
708 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
709 lset vupptr($v) $b $na
713 proc renumbervarc {a v} {
714 global parents children varctok varcstart varccommits
715 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
717 set t1 [clock clicks -milliseconds]
718 set todo {}
719 set isrelated($a) 1
720 set kidchanged($a) 1
721 set ntot 0
722 while {$a != 0} {
723 if {[info exists isrelated($a)]} {
724 lappend todo $a
725 set id [lindex $varccommits($v,$a) end]
726 foreach p $parents($v,$id) {
727 if {[info exists varcid($v,$p)]} {
728 set isrelated($varcid($v,$p)) 1
732 incr ntot
733 set b [lindex $vdownptr($v) $a]
734 if {$b == 0} {
735 while {$a != 0} {
736 set b [lindex $vleftptr($v) $a]
737 if {$b != 0} break
738 set a [lindex $vupptr($v) $a]
741 set a $b
743 foreach a $todo {
744 if {![info exists kidchanged($a)]} continue
745 set id [lindex $varcstart($v) $a]
746 if {[llength $children($v,$id)] > 1} {
747 set children($v,$id) [lsort -command [list vtokcmp $v] \
748 $children($v,$id)]
750 set oldtok [lindex $varctok($v) $a]
751 if {!$vdatemode($v)} {
752 set tok {}
753 } else {
754 set tok $oldtok
756 set ka 0
757 set kid [last_real_child $v,$id]
758 if {$kid ne {}} {
759 set k $varcid($v,$kid)
760 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
761 set ki $kid
762 set ka $k
763 set tok [lindex $varctok($v) $k]
766 if {$ka != 0} {
767 set i [lsearch -exact $parents($v,$ki) $id]
768 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
769 append tok [strrep $j]
771 if {$tok eq $oldtok} {
772 continue
774 set id [lindex $varccommits($v,$a) end]
775 foreach p $parents($v,$id) {
776 if {[info exists varcid($v,$p)]} {
777 set kidchanged($varcid($v,$p)) 1
778 } else {
779 set sortkids($p) 1
782 lset varctok($v) $a $tok
783 set b [lindex $vupptr($v) $a]
784 if {$b != $ka} {
785 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
786 modify_arc $v $ka
788 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
789 modify_arc $v $b
791 set c [lindex $vbackptr($v) $a]
792 set d [lindex $vleftptr($v) $a]
793 if {$c == 0} {
794 lset vdownptr($v) $b $d
795 } else {
796 lset vleftptr($v) $c $d
798 if {$d != 0} {
799 lset vbackptr($v) $d $c
801 if {[lindex $vlastins($v) $b] == $a} {
802 lset vlastins($v) $b $c
804 lset vupptr($v) $a $ka
805 set c [lindex $vlastins($v) $ka]
806 if {$c == 0 || \
807 [string compare $tok [lindex $varctok($v) $c]] < 0} {
808 set c $ka
809 set b [lindex $vdownptr($v) $ka]
810 } else {
811 set b [lindex $vleftptr($v) $c]
813 while {$b != 0 && \
814 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
815 set c $b
816 set b [lindex $vleftptr($v) $c]
818 if {$c == $ka} {
819 lset vdownptr($v) $ka $a
820 lset vbackptr($v) $a 0
821 } else {
822 lset vleftptr($v) $c $a
823 lset vbackptr($v) $a $c
825 lset vleftptr($v) $a $b
826 if {$b != 0} {
827 lset vbackptr($v) $b $a
829 lset vlastins($v) $ka $a
832 foreach id [array names sortkids] {
833 if {[llength $children($v,$id)] > 1} {
834 set children($v,$id) [lsort -command [list vtokcmp $v] \
835 $children($v,$id)]
838 set t2 [clock clicks -milliseconds]
839 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
842 # Fix up the graph after we have found out that in view $v,
843 # $p (a commit that we have already seen) is actually the parent
844 # of the last commit in arc $a.
845 proc fix_reversal {p a v} {
846 global varcid varcstart varctok vupptr
848 set pa $varcid($v,$p)
849 if {$p ne [lindex $varcstart($v) $pa]} {
850 splitvarc $p $v
851 set pa $varcid($v,$p)
853 # seeds always need to be renumbered
854 if {[lindex $vupptr($v) $pa] == 0 ||
855 [string compare [lindex $varctok($v) $a] \
856 [lindex $varctok($v) $pa]] > 0} {
857 renumbervarc $pa $v
861 proc insertrow {id p v} {
862 global cmitlisted children parents varcid varctok vtokmod
863 global varccommits ordertok commitidx numcommits curview
864 global targetid targetrow
866 readcommit $id
867 set vid $v,$id
868 set cmitlisted($vid) 1
869 set children($vid) {}
870 set parents($vid) [list $p]
871 set a [newvarc $v $id]
872 set varcid($vid) $a
873 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
874 modify_arc $v $a
876 lappend varccommits($v,$a) $id
877 set vp $v,$p
878 if {[llength [lappend children($vp) $id]] > 1} {
879 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
880 catch {unset ordertok}
882 fix_reversal $p $a $v
883 incr commitidx($v)
884 if {$v == $curview} {
885 set numcommits $commitidx($v)
886 setcanvscroll
887 if {[info exists targetid]} {
888 if {![comes_before $targetid $p]} {
889 incr targetrow
895 proc insertfakerow {id p} {
896 global varcid varccommits parents children cmitlisted
897 global commitidx varctok vtokmod targetid targetrow curview numcommits
899 set v $curview
900 set a $varcid($v,$p)
901 set i [lsearch -exact $varccommits($v,$a) $p]
902 if {$i < 0} {
903 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
904 return
906 set children($v,$id) {}
907 set parents($v,$id) [list $p]
908 set varcid($v,$id) $a
909 lappend children($v,$p) $id
910 set cmitlisted($v,$id) 1
911 set numcommits [incr commitidx($v)]
912 # note we deliberately don't update varcstart($v) even if $i == 0
913 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
914 modify_arc $v $a $i
915 if {[info exists targetid]} {
916 if {![comes_before $targetid $p]} {
917 incr targetrow
920 setcanvscroll
921 drawvisible
924 proc removefakerow {id} {
925 global varcid varccommits parents children commitidx
926 global varctok vtokmod cmitlisted currentid selectedline
927 global targetid curview numcommits
929 set v $curview
930 if {[llength $parents($v,$id)] != 1} {
931 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
932 return
934 set p [lindex $parents($v,$id) 0]
935 set a $varcid($v,$id)
936 set i [lsearch -exact $varccommits($v,$a) $id]
937 if {$i < 0} {
938 puts "oops: removefakerow can't find [shortids $id] on arc $a"
939 return
941 unset varcid($v,$id)
942 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
943 unset parents($v,$id)
944 unset children($v,$id)
945 unset cmitlisted($v,$id)
946 set numcommits [incr commitidx($v) -1]
947 set j [lsearch -exact $children($v,$p) $id]
948 if {$j >= 0} {
949 set children($v,$p) [lreplace $children($v,$p) $j $j]
951 modify_arc $v $a $i
952 if {[info exist currentid] && $id eq $currentid} {
953 unset currentid
954 set selectedline {}
956 if {[info exists targetid] && $targetid eq $id} {
957 set targetid $p
959 setcanvscroll
960 drawvisible
963 proc first_real_child {vp} {
964 global children nullid nullid2
966 foreach id $children($vp) {
967 if {$id ne $nullid && $id ne $nullid2} {
968 return $id
971 return {}
974 proc last_real_child {vp} {
975 global children nullid nullid2
977 set kids $children($vp)
978 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
979 set id [lindex $kids $i]
980 if {$id ne $nullid && $id ne $nullid2} {
981 return $id
984 return {}
987 proc vtokcmp {v a b} {
988 global varctok varcid
990 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
991 [lindex $varctok($v) $varcid($v,$b)]]
994 # This assumes that if lim is not given, the caller has checked that
995 # arc a's token is less than $vtokmod($v)
996 proc modify_arc {v a {lim {}}} {
997 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
999 if {$lim ne {}} {
1000 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1001 if {$c > 0} return
1002 if {$c == 0} {
1003 set r [lindex $varcrow($v) $a]
1004 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1007 set vtokmod($v) [lindex $varctok($v) $a]
1008 set varcmod($v) $a
1009 if {$v == $curview} {
1010 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1011 set a [lindex $vupptr($v) $a]
1012 set lim {}
1014 set r 0
1015 if {$a != 0} {
1016 if {$lim eq {}} {
1017 set lim [llength $varccommits($v,$a)]
1019 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1021 set vrowmod($v) $r
1022 undolayout $r
1026 proc update_arcrows {v} {
1027 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1028 global varcid vrownum varcorder varcix varccommits
1029 global vupptr vdownptr vleftptr varctok
1030 global displayorder parentlist curview cached_commitrow
1032 if {$vrowmod($v) == $commitidx($v)} return
1033 if {$v == $curview} {
1034 if {[llength $displayorder] > $vrowmod($v)} {
1035 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1036 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1038 catch {unset cached_commitrow}
1040 set narctot [expr {[llength $varctok($v)] - 1}]
1041 set a $varcmod($v)
1042 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1043 # go up the tree until we find something that has a row number,
1044 # or we get to a seed
1045 set a [lindex $vupptr($v) $a]
1047 if {$a == 0} {
1048 set a [lindex $vdownptr($v) 0]
1049 if {$a == 0} return
1050 set vrownum($v) {0}
1051 set varcorder($v) [list $a]
1052 lset varcix($v) $a 0
1053 lset varcrow($v) $a 0
1054 set arcn 0
1055 set row 0
1056 } else {
1057 set arcn [lindex $varcix($v) $a]
1058 if {[llength $vrownum($v)] > $arcn + 1} {
1059 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1060 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1062 set row [lindex $varcrow($v) $a]
1064 while {1} {
1065 set p $a
1066 incr row [llength $varccommits($v,$a)]
1067 # go down if possible
1068 set b [lindex $vdownptr($v) $a]
1069 if {$b == 0} {
1070 # if not, go left, or go up until we can go left
1071 while {$a != 0} {
1072 set b [lindex $vleftptr($v) $a]
1073 if {$b != 0} break
1074 set a [lindex $vupptr($v) $a]
1076 if {$a == 0} break
1078 set a $b
1079 incr arcn
1080 lappend vrownum($v) $row
1081 lappend varcorder($v) $a
1082 lset varcix($v) $a $arcn
1083 lset varcrow($v) $a $row
1085 set vtokmod($v) [lindex $varctok($v) $p]
1086 set varcmod($v) $p
1087 set vrowmod($v) $row
1088 if {[info exists currentid]} {
1089 set selectedline [rowofcommit $currentid]
1093 # Test whether view $v contains commit $id
1094 proc commitinview {id v} {
1095 global varcid
1097 return [info exists varcid($v,$id)]
1100 # Return the row number for commit $id in the current view
1101 proc rowofcommit {id} {
1102 global varcid varccommits varcrow curview cached_commitrow
1103 global varctok vtokmod
1105 set v $curview
1106 if {![info exists varcid($v,$id)]} {
1107 puts "oops rowofcommit no arc for [shortids $id]"
1108 return {}
1110 set a $varcid($v,$id)
1111 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1112 update_arcrows $v
1114 if {[info exists cached_commitrow($id)]} {
1115 return $cached_commitrow($id)
1117 set i [lsearch -exact $varccommits($v,$a) $id]
1118 if {$i < 0} {
1119 puts "oops didn't find commit [shortids $id] in arc $a"
1120 return {}
1122 incr i [lindex $varcrow($v) $a]
1123 set cached_commitrow($id) $i
1124 return $i
1127 # Returns 1 if a is on an earlier row than b, otherwise 0
1128 proc comes_before {a b} {
1129 global varcid varctok curview
1131 set v $curview
1132 if {$a eq $b || ![info exists varcid($v,$a)] || \
1133 ![info exists varcid($v,$b)]} {
1134 return 0
1136 if {$varcid($v,$a) != $varcid($v,$b)} {
1137 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1138 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1140 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1143 proc bsearch {l elt} {
1144 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1145 return 0
1147 set lo 0
1148 set hi [llength $l]
1149 while {$hi - $lo > 1} {
1150 set mid [expr {int(($lo + $hi) / 2)}]
1151 set t [lindex $l $mid]
1152 if {$elt < $t} {
1153 set hi $mid
1154 } elseif {$elt > $t} {
1155 set lo $mid
1156 } else {
1157 return $mid
1160 return $lo
1163 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1164 proc make_disporder {start end} {
1165 global vrownum curview commitidx displayorder parentlist
1166 global varccommits varcorder parents vrowmod varcrow
1167 global d_valid_start d_valid_end
1169 if {$end > $vrowmod($curview)} {
1170 update_arcrows $curview
1172 set ai [bsearch $vrownum($curview) $start]
1173 set start [lindex $vrownum($curview) $ai]
1174 set narc [llength $vrownum($curview)]
1175 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1176 set a [lindex $varcorder($curview) $ai]
1177 set l [llength $displayorder]
1178 set al [llength $varccommits($curview,$a)]
1179 if {$l < $r + $al} {
1180 if {$l < $r} {
1181 set pad [ntimes [expr {$r - $l}] {}]
1182 set displayorder [concat $displayorder $pad]
1183 set parentlist [concat $parentlist $pad]
1184 } elseif {$l > $r} {
1185 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1186 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1188 foreach id $varccommits($curview,$a) {
1189 lappend displayorder $id
1190 lappend parentlist $parents($curview,$id)
1192 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1193 set i $r
1194 foreach id $varccommits($curview,$a) {
1195 lset displayorder $i $id
1196 lset parentlist $i $parents($curview,$id)
1197 incr i
1200 incr r $al
1204 proc commitonrow {row} {
1205 global displayorder
1207 set id [lindex $displayorder $row]
1208 if {$id eq {}} {
1209 make_disporder $row [expr {$row + 1}]
1210 set id [lindex $displayorder $row]
1212 return $id
1215 proc closevarcs {v} {
1216 global varctok varccommits varcid parents children
1217 global cmitlisted commitidx commitinterest vtokmod
1219 set missing_parents 0
1220 set scripts {}
1221 set narcs [llength $varctok($v)]
1222 for {set a 1} {$a < $narcs} {incr a} {
1223 set id [lindex $varccommits($v,$a) end]
1224 foreach p $parents($v,$id) {
1225 if {[info exists varcid($v,$p)]} continue
1226 # add p as a new commit
1227 incr missing_parents
1228 set cmitlisted($v,$p) 0
1229 set parents($v,$p) {}
1230 if {[llength $children($v,$p)] == 1 &&
1231 [llength $parents($v,$id)] == 1} {
1232 set b $a
1233 } else {
1234 set b [newvarc $v $p]
1236 set varcid($v,$p) $b
1237 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1238 modify_arc $v $b
1240 lappend varccommits($v,$b) $p
1241 incr commitidx($v)
1242 if {[info exists commitinterest($p)]} {
1243 foreach script $commitinterest($p) {
1244 lappend scripts [string map [list "%I" $p] $script]
1246 unset commitinterest($id)
1250 if {$missing_parents > 0} {
1251 foreach s $scripts {
1252 eval $s
1257 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1258 # Assumes we already have an arc for $rwid.
1259 proc rewrite_commit {v id rwid} {
1260 global children parents varcid varctok vtokmod varccommits
1262 foreach ch $children($v,$id) {
1263 # make $rwid be $ch's parent in place of $id
1264 set i [lsearch -exact $parents($v,$ch) $id]
1265 if {$i < 0} {
1266 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1268 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1269 # add $ch to $rwid's children and sort the list if necessary
1270 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1271 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1272 $children($v,$rwid)]
1274 # fix the graph after joining $id to $rwid
1275 set a $varcid($v,$ch)
1276 fix_reversal $rwid $a $v
1277 # parentlist is wrong for the last element of arc $a
1278 # even if displayorder is right, hence the 3rd arg here
1279 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1283 proc getcommitlines {fd inst view updating} {
1284 global cmitlisted commitinterest leftover
1285 global commitidx commitdata vdatemode
1286 global parents children curview hlview
1287 global idpending ordertok
1288 global varccommits varcid varctok vtokmod vfilelimit
1290 set stuff [read $fd 500000]
1291 # git log doesn't terminate the last commit with a null...
1292 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1293 set stuff "\0"
1295 if {$stuff == {}} {
1296 if {![eof $fd]} {
1297 return 1
1299 global commfd viewcomplete viewactive viewname
1300 global viewinstances
1301 unset commfd($inst)
1302 set i [lsearch -exact $viewinstances($view) $inst]
1303 if {$i >= 0} {
1304 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1306 # set it blocking so we wait for the process to terminate
1307 fconfigure $fd -blocking 1
1308 if {[catch {close $fd} err]} {
1309 set fv {}
1310 if {$view != $curview} {
1311 set fv " for the \"$viewname($view)\" view"
1313 if {[string range $err 0 4] == "usage"} {
1314 set err "Gitk: error reading commits$fv:\
1315 bad arguments to git log."
1316 if {$viewname($view) eq "Command line"} {
1317 append err \
1318 " (Note: arguments to gitk are passed to git log\
1319 to allow selection of commits to be displayed.)"
1321 } else {
1322 set err "Error reading commits$fv: $err"
1324 error_popup $err
1326 if {[incr viewactive($view) -1] <= 0} {
1327 set viewcomplete($view) 1
1328 # Check if we have seen any ids listed as parents that haven't
1329 # appeared in the list
1330 closevarcs $view
1331 notbusy $view
1333 if {$view == $curview} {
1334 run chewcommits
1336 return 0
1338 set start 0
1339 set gotsome 0
1340 set scripts {}
1341 while 1 {
1342 set i [string first "\0" $stuff $start]
1343 if {$i < 0} {
1344 append leftover($inst) [string range $stuff $start end]
1345 break
1347 if {$start == 0} {
1348 set cmit $leftover($inst)
1349 append cmit [string range $stuff 0 [expr {$i - 1}]]
1350 set leftover($inst) {}
1351 } else {
1352 set cmit [string range $stuff $start [expr {$i - 1}]]
1354 set start [expr {$i + 1}]
1355 set j [string first "\n" $cmit]
1356 set ok 0
1357 set listed 1
1358 if {$j >= 0 && [string match "commit *" $cmit]} {
1359 set ids [string range $cmit 7 [expr {$j - 1}]]
1360 if {[string match {[-^<>]*} $ids]} {
1361 switch -- [string index $ids 0] {
1362 "-" {set listed 0}
1363 "^" {set listed 2}
1364 "<" {set listed 3}
1365 ">" {set listed 4}
1367 set ids [string range $ids 1 end]
1369 set ok 1
1370 foreach id $ids {
1371 if {[string length $id] != 40} {
1372 set ok 0
1373 break
1377 if {!$ok} {
1378 set shortcmit $cmit
1379 if {[string length $shortcmit] > 80} {
1380 set shortcmit "[string range $shortcmit 0 80]..."
1382 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1383 exit 1
1385 set id [lindex $ids 0]
1386 set vid $view,$id
1388 if {!$listed && $updating && ![info exists varcid($vid)] &&
1389 $vfilelimit($view) ne {}} {
1390 # git log doesn't rewrite parents for unlisted commits
1391 # when doing path limiting, so work around that here
1392 # by working out the rewritten parent with git rev-list
1393 # and if we already know about it, using the rewritten
1394 # parent as a substitute parent for $id's children.
1395 if {![catch {
1396 set rwid [exec git rev-list --first-parent --max-count=1 \
1397 $id -- $vfilelimit($view)]
1398 }]} {
1399 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1400 # use $rwid in place of $id
1401 rewrite_commit $view $id $rwid
1402 continue
1407 set a 0
1408 if {[info exists varcid($vid)]} {
1409 if {$cmitlisted($vid) || !$listed} continue
1410 set a $varcid($vid)
1412 if {$listed} {
1413 set olds [lrange $ids 1 end]
1414 } else {
1415 set olds {}
1417 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1418 set cmitlisted($vid) $listed
1419 set parents($vid) $olds
1420 if {![info exists children($vid)]} {
1421 set children($vid) {}
1422 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1423 set k [lindex $children($vid) 0]
1424 if {[llength $parents($view,$k)] == 1 &&
1425 (!$vdatemode($view) ||
1426 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1427 set a $varcid($view,$k)
1430 if {$a == 0} {
1431 # new arc
1432 set a [newvarc $view $id]
1434 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1435 modify_arc $view $a
1437 if {![info exists varcid($vid)]} {
1438 set varcid($vid) $a
1439 lappend varccommits($view,$a) $id
1440 incr commitidx($view)
1443 set i 0
1444 foreach p $olds {
1445 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1446 set vp $view,$p
1447 if {[llength [lappend children($vp) $id]] > 1 &&
1448 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1449 set children($vp) [lsort -command [list vtokcmp $view] \
1450 $children($vp)]
1451 catch {unset ordertok}
1453 if {[info exists varcid($view,$p)]} {
1454 fix_reversal $p $a $view
1457 incr i
1460 if {[info exists commitinterest($id)]} {
1461 foreach script $commitinterest($id) {
1462 lappend scripts [string map [list "%I" $id] $script]
1464 unset commitinterest($id)
1466 set gotsome 1
1468 if {$gotsome} {
1469 global numcommits hlview
1471 if {$view == $curview} {
1472 set numcommits $commitidx($view)
1473 run chewcommits
1475 if {[info exists hlview] && $view == $hlview} {
1476 # we never actually get here...
1477 run vhighlightmore
1479 foreach s $scripts {
1480 eval $s
1483 return 2
1486 proc chewcommits {} {
1487 global curview hlview viewcomplete
1488 global pending_select
1490 layoutmore
1491 if {$viewcomplete($curview)} {
1492 global commitidx varctok
1493 global numcommits startmsecs
1495 if {[info exists pending_select]} {
1496 set row [first_real_row]
1497 selectline $row 1
1499 if {$commitidx($curview) > 0} {
1500 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1501 #puts "overall $ms ms for $numcommits commits"
1502 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1503 } else {
1504 show_status [mc "No commits selected"]
1506 notbusy layout
1508 return 0
1511 proc readcommit {id} {
1512 if {[catch {set contents [exec git cat-file commit $id]}]} return
1513 parsecommit $id $contents 0
1516 proc parsecommit {id contents listed} {
1517 global commitinfo cdate
1519 set inhdr 1
1520 set comment {}
1521 set headline {}
1522 set auname {}
1523 set audate {}
1524 set comname {}
1525 set comdate {}
1526 set hdrend [string first "\n\n" $contents]
1527 if {$hdrend < 0} {
1528 # should never happen...
1529 set hdrend [string length $contents]
1531 set header [string range $contents 0 [expr {$hdrend - 1}]]
1532 set comment [string range $contents [expr {$hdrend + 2}] end]
1533 foreach line [split $header "\n"] {
1534 set tag [lindex $line 0]
1535 if {$tag == "author"} {
1536 set audate [lindex $line end-1]
1537 set auname [lrange $line 1 end-2]
1538 } elseif {$tag == "committer"} {
1539 set comdate [lindex $line end-1]
1540 set comname [lrange $line 1 end-2]
1543 set headline {}
1544 # take the first non-blank line of the comment as the headline
1545 set headline [string trimleft $comment]
1546 set i [string first "\n" $headline]
1547 if {$i >= 0} {
1548 set headline [string range $headline 0 $i]
1550 set headline [string trimright $headline]
1551 set i [string first "\r" $headline]
1552 if {$i >= 0} {
1553 set headline [string trimright [string range $headline 0 $i]]
1555 if {!$listed} {
1556 # git log indents the comment by 4 spaces;
1557 # if we got this via git cat-file, add the indentation
1558 set newcomment {}
1559 foreach line [split $comment "\n"] {
1560 append newcomment " "
1561 append newcomment $line
1562 append newcomment "\n"
1564 set comment $newcomment
1566 if {$comdate != {}} {
1567 set cdate($id) $comdate
1569 set commitinfo($id) [list $headline $auname $audate \
1570 $comname $comdate $comment]
1573 proc getcommit {id} {
1574 global commitdata commitinfo
1576 if {[info exists commitdata($id)]} {
1577 parsecommit $id $commitdata($id) 1
1578 } else {
1579 readcommit $id
1580 if {![info exists commitinfo($id)]} {
1581 set commitinfo($id) [list [mc "No commit information available"]]
1584 return 1
1587 proc readrefs {} {
1588 global tagids idtags headids idheads tagobjid
1589 global otherrefids idotherrefs mainhead mainheadid
1591 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1592 catch {unset $v}
1594 set refd [open [list | git show-ref -d] r]
1595 while {[gets $refd line] >= 0} {
1596 if {[string index $line 40] ne " "} continue
1597 set id [string range $line 0 39]
1598 set ref [string range $line 41 end]
1599 if {![string match "refs/*" $ref]} continue
1600 set name [string range $ref 5 end]
1601 if {[string match "remotes/*" $name]} {
1602 if {![string match "*/HEAD" $name]} {
1603 set headids($name) $id
1604 lappend idheads($id) $name
1606 } elseif {[string match "heads/*" $name]} {
1607 set name [string range $name 6 end]
1608 set headids($name) $id
1609 lappend idheads($id) $name
1610 } elseif {[string match "tags/*" $name]} {
1611 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1612 # which is what we want since the former is the commit ID
1613 set name [string range $name 5 end]
1614 if {[string match "*^{}" $name]} {
1615 set name [string range $name 0 end-3]
1616 } else {
1617 set tagobjid($name) $id
1619 set tagids($name) $id
1620 lappend idtags($id) $name
1621 } else {
1622 set otherrefids($name) $id
1623 lappend idotherrefs($id) $name
1626 catch {close $refd}
1627 set mainhead {}
1628 set mainheadid {}
1629 catch {
1630 set mainheadid [exec git rev-parse HEAD]
1631 set thehead [exec git symbolic-ref HEAD]
1632 if {[string match "refs/heads/*" $thehead]} {
1633 set mainhead [string range $thehead 11 end]
1638 # skip over fake commits
1639 proc first_real_row {} {
1640 global nullid nullid2 numcommits
1642 for {set row 0} {$row < $numcommits} {incr row} {
1643 set id [commitonrow $row]
1644 if {$id ne $nullid && $id ne $nullid2} {
1645 break
1648 return $row
1651 # update things for a head moved to a child of its previous location
1652 proc movehead {id name} {
1653 global headids idheads
1655 removehead $headids($name) $name
1656 set headids($name) $id
1657 lappend idheads($id) $name
1660 # update things when a head has been removed
1661 proc removehead {id name} {
1662 global headids idheads
1664 if {$idheads($id) eq $name} {
1665 unset idheads($id)
1666 } else {
1667 set i [lsearch -exact $idheads($id) $name]
1668 if {$i >= 0} {
1669 set idheads($id) [lreplace $idheads($id) $i $i]
1672 unset headids($name)
1675 proc show_error {w top msg} {
1676 message $w.m -text $msg -justify center -aspect 400
1677 pack $w.m -side top -fill x -padx 20 -pady 20
1678 button $w.ok -text [mc OK] -command "destroy $top"
1679 pack $w.ok -side bottom -fill x
1680 bind $top <Visibility> "grab $top; focus $top"
1681 bind $top <Key-Return> "destroy $top"
1682 tkwait window $top
1685 proc error_popup msg {
1686 set w .error
1687 toplevel $w
1688 wm transient $w .
1689 show_error $w $w $msg
1692 proc confirm_popup msg {
1693 global confirm_ok
1694 set confirm_ok 0
1695 set w .confirm
1696 toplevel $w
1697 wm transient $w .
1698 message $w.m -text $msg -justify center -aspect 400
1699 pack $w.m -side top -fill x -padx 20 -pady 20
1700 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1701 pack $w.ok -side left -fill x
1702 button $w.cancel -text [mc Cancel] -command "destroy $w"
1703 pack $w.cancel -side right -fill x
1704 bind $w <Visibility> "grab $w; focus $w"
1705 tkwait window $w
1706 return $confirm_ok
1709 proc setoptions {} {
1710 option add *Panedwindow.showHandle 1 startupFile
1711 option add *Panedwindow.sashRelief raised startupFile
1712 option add *Button.font uifont startupFile
1713 option add *Checkbutton.font uifont startupFile
1714 option add *Radiobutton.font uifont startupFile
1715 option add *Menu.font uifont startupFile
1716 option add *Menubutton.font uifont startupFile
1717 option add *Label.font uifont startupFile
1718 option add *Message.font uifont startupFile
1719 option add *Entry.font uifont startupFile
1722 proc makewindow {} {
1723 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1724 global tabstop
1725 global findtype findtypemenu findloc findstring fstring geometry
1726 global entries sha1entry sha1string sha1but
1727 global diffcontextstring diffcontext
1728 global ignorespace
1729 global maincursor textcursor curtextcursor
1730 global rowctxmenu fakerowmenu mergemax wrapcomment
1731 global highlight_files gdttype
1732 global searchstring sstring
1733 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1734 global headctxmenu progresscanv progressitem progresscoords statusw
1735 global fprogitem fprogcoord lastprogupdate progupdatepending
1736 global rprogitem rprogcoord rownumsel numcommits
1737 global have_tk85
1739 menu .bar
1740 .bar add cascade -label [mc "File"] -menu .bar.file
1741 menu .bar.file
1742 .bar.file add command -label [mc "Update"] -command updatecommits
1743 .bar.file add command -label [mc "Reload"] -command reloadcommits
1744 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1745 .bar.file add command -label [mc "List references"] -command showrefs
1746 .bar.file add command -label [mc "Quit"] -command doquit
1747 menu .bar.edit
1748 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1749 .bar.edit add command -label [mc "Preferences"] -command doprefs
1751 menu .bar.view
1752 .bar add cascade -label [mc "View"] -menu .bar.view
1753 .bar.view add command -label [mc "New view..."] -command {newview 0}
1754 .bar.view add command -label [mc "Edit view..."] -command editview \
1755 -state disabled
1756 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1757 .bar.view add separator
1758 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1759 -variable selectedview -value 0
1761 menu .bar.help
1762 .bar add cascade -label [mc "Help"] -menu .bar.help
1763 .bar.help add command -label [mc "About gitk"] -command about
1764 .bar.help add command -label [mc "Key bindings"] -command keys
1765 .bar.help configure
1766 . configure -menu .bar
1768 # the gui has upper and lower half, parts of a paned window.
1769 panedwindow .ctop -orient vertical
1771 # possibly use assumed geometry
1772 if {![info exists geometry(pwsash0)]} {
1773 set geometry(topheight) [expr {15 * $linespc}]
1774 set geometry(topwidth) [expr {80 * $charspc}]
1775 set geometry(botheight) [expr {15 * $linespc}]
1776 set geometry(botwidth) [expr {50 * $charspc}]
1777 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1778 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1781 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1782 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1783 frame .tf.histframe
1784 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1786 # create three canvases
1787 set cscroll .tf.histframe.csb
1788 set canv .tf.histframe.pwclist.canv
1789 canvas $canv \
1790 -selectbackground $selectbgcolor \
1791 -background $bgcolor -bd 0 \
1792 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1793 .tf.histframe.pwclist add $canv
1794 set canv2 .tf.histframe.pwclist.canv2
1795 canvas $canv2 \
1796 -selectbackground $selectbgcolor \
1797 -background $bgcolor -bd 0 -yscrollincr $linespc
1798 .tf.histframe.pwclist add $canv2
1799 set canv3 .tf.histframe.pwclist.canv3
1800 canvas $canv3 \
1801 -selectbackground $selectbgcolor \
1802 -background $bgcolor -bd 0 -yscrollincr $linespc
1803 .tf.histframe.pwclist add $canv3
1804 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1805 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1807 # a scroll bar to rule them
1808 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1809 pack $cscroll -side right -fill y
1810 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1811 lappend bglist $canv $canv2 $canv3
1812 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1814 # we have two button bars at bottom of top frame. Bar 1
1815 frame .tf.bar
1816 frame .tf.lbar -height 15
1818 set sha1entry .tf.bar.sha1
1819 set entries $sha1entry
1820 set sha1but .tf.bar.sha1label
1821 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1822 -command gotocommit -width 8
1823 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1824 pack .tf.bar.sha1label -side left
1825 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1826 trace add variable sha1string write sha1change
1827 pack $sha1entry -side left -pady 2
1829 image create bitmap bm-left -data {
1830 #define left_width 16
1831 #define left_height 16
1832 static unsigned char left_bits[] = {
1833 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1834 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1835 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1837 image create bitmap bm-right -data {
1838 #define right_width 16
1839 #define right_height 16
1840 static unsigned char right_bits[] = {
1841 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1842 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1843 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1845 button .tf.bar.leftbut -image bm-left -command goback \
1846 -state disabled -width 26
1847 pack .tf.bar.leftbut -side left -fill y
1848 button .tf.bar.rightbut -image bm-right -command goforw \
1849 -state disabled -width 26
1850 pack .tf.bar.rightbut -side left -fill y
1852 label .tf.bar.rowlabel -text [mc "Row"]
1853 set rownumsel {}
1854 label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1855 -relief sunken -anchor e
1856 label .tf.bar.rowlabel2 -text "/"
1857 label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1858 -relief sunken -anchor e
1859 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1860 -side left
1861 global selectedline
1862 trace add variable selectedline write selectedline_change
1864 # Status label and progress bar
1865 set statusw .tf.bar.status
1866 label $statusw -width 15 -relief sunken
1867 pack $statusw -side left -padx 5
1868 set h [expr {[font metrics uifont -linespace] + 2}]
1869 set progresscanv .tf.bar.progress
1870 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1871 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1872 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1873 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1874 pack $progresscanv -side right -expand 1 -fill x
1875 set progresscoords {0 0}
1876 set fprogcoord 0
1877 set rprogcoord 0
1878 bind $progresscanv <Configure> adjustprogress
1879 set lastprogupdate [clock clicks -milliseconds]
1880 set progupdatepending 0
1882 # build up the bottom bar of upper window
1883 label .tf.lbar.flabel -text "[mc "Find"] "
1884 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1885 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1886 label .tf.lbar.flab2 -text " [mc "commit"] "
1887 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1888 -side left -fill y
1889 set gdttype [mc "containing:"]
1890 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1891 [mc "containing:"] \
1892 [mc "touching paths:"] \
1893 [mc "adding/removing string:"]]
1894 trace add variable gdttype write gdttype_change
1895 pack .tf.lbar.gdttype -side left -fill y
1897 set findstring {}
1898 set fstring .tf.lbar.findstring
1899 lappend entries $fstring
1900 entry $fstring -width 30 -font textfont -textvariable findstring
1901 trace add variable findstring write find_change
1902 set findtype [mc "Exact"]
1903 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1904 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1905 trace add variable findtype write findcom_change
1906 set findloc [mc "All fields"]
1907 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1908 [mc "Comments"] [mc "Author"] [mc "Committer"]
1909 trace add variable findloc write find_change
1910 pack .tf.lbar.findloc -side right
1911 pack .tf.lbar.findtype -side right
1912 pack $fstring -side left -expand 1 -fill x
1914 # Finish putting the upper half of the viewer together
1915 pack .tf.lbar -in .tf -side bottom -fill x
1916 pack .tf.bar -in .tf -side bottom -fill x
1917 pack .tf.histframe -fill both -side top -expand 1
1918 .ctop add .tf
1919 .ctop paneconfigure .tf -height $geometry(topheight)
1920 .ctop paneconfigure .tf -width $geometry(topwidth)
1922 # now build up the bottom
1923 panedwindow .pwbottom -orient horizontal
1925 # lower left, a text box over search bar, scroll bar to the right
1926 # if we know window height, then that will set the lower text height, otherwise
1927 # we set lower text height which will drive window height
1928 if {[info exists geometry(main)]} {
1929 frame .bleft -width $geometry(botwidth)
1930 } else {
1931 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1933 frame .bleft.top
1934 frame .bleft.mid
1935 frame .bleft.bottom
1937 button .bleft.top.search -text [mc "Search"] -command dosearch
1938 pack .bleft.top.search -side left -padx 5
1939 set sstring .bleft.top.sstring
1940 entry $sstring -width 20 -font textfont -textvariable searchstring
1941 lappend entries $sstring
1942 trace add variable searchstring write incrsearch
1943 pack $sstring -side left -expand 1 -fill x
1944 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1945 -command changediffdisp -variable diffelide -value {0 0}
1946 radiobutton .bleft.mid.old -text [mc "Old version"] \
1947 -command changediffdisp -variable diffelide -value {0 1}
1948 radiobutton .bleft.mid.new -text [mc "New version"] \
1949 -command changediffdisp -variable diffelide -value {1 0}
1950 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1951 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1952 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1953 -from 1 -increment 1 -to 10000000 \
1954 -validate all -validatecommand "diffcontextvalidate %P" \
1955 -textvariable diffcontextstring
1956 .bleft.mid.diffcontext set $diffcontext
1957 trace add variable diffcontextstring write diffcontextchange
1958 lappend entries .bleft.mid.diffcontext
1959 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1960 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1961 -command changeignorespace -variable ignorespace
1962 pack .bleft.mid.ignspace -side left -padx 5
1963 set ctext .bleft.bottom.ctext
1964 text $ctext -background $bgcolor -foreground $fgcolor \
1965 -state disabled -font textfont \
1966 -yscrollcommand scrolltext -wrap none \
1967 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1968 if {$have_tk85} {
1969 $ctext conf -tabstyle wordprocessor
1971 scrollbar .bleft.bottom.sb -command "$ctext yview"
1972 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
1973 -width 10
1974 pack .bleft.top -side top -fill x
1975 pack .bleft.mid -side top -fill x
1976 grid $ctext .bleft.bottom.sb -sticky nsew
1977 grid .bleft.bottom.sbhorizontal -sticky ew
1978 grid columnconfigure .bleft.bottom 0 -weight 1
1979 grid rowconfigure .bleft.bottom 0 -weight 1
1980 grid rowconfigure .bleft.bottom 1 -weight 0
1981 pack .bleft.bottom -side top -fill both -expand 1
1982 lappend bglist $ctext
1983 lappend fglist $ctext
1985 $ctext tag conf comment -wrap $wrapcomment
1986 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1987 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1988 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1989 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1990 $ctext tag conf m0 -fore red
1991 $ctext tag conf m1 -fore blue
1992 $ctext tag conf m2 -fore green
1993 $ctext tag conf m3 -fore purple
1994 $ctext tag conf m4 -fore brown
1995 $ctext tag conf m5 -fore "#009090"
1996 $ctext tag conf m6 -fore magenta
1997 $ctext tag conf m7 -fore "#808000"
1998 $ctext tag conf m8 -fore "#009000"
1999 $ctext tag conf m9 -fore "#ff0080"
2000 $ctext tag conf m10 -fore cyan
2001 $ctext tag conf m11 -fore "#b07070"
2002 $ctext tag conf m12 -fore "#70b0f0"
2003 $ctext tag conf m13 -fore "#70f0b0"
2004 $ctext tag conf m14 -fore "#f0b070"
2005 $ctext tag conf m15 -fore "#ff70b0"
2006 $ctext tag conf mmax -fore darkgrey
2007 set mergemax 16
2008 $ctext tag conf mresult -font textfontbold
2009 $ctext tag conf msep -font textfontbold
2010 $ctext tag conf found -back yellow
2012 .pwbottom add .bleft
2013 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2015 # lower right
2016 frame .bright
2017 frame .bright.mode
2018 radiobutton .bright.mode.patch -text [mc "Patch"] \
2019 -command reselectline -variable cmitmode -value "patch"
2020 radiobutton .bright.mode.tree -text [mc "Tree"] \
2021 -command reselectline -variable cmitmode -value "tree"
2022 grid .bright.mode.patch .bright.mode.tree -sticky ew
2023 pack .bright.mode -side top -fill x
2024 set cflist .bright.cfiles
2025 set indent [font measure mainfont "nn"]
2026 text $cflist \
2027 -selectbackground $selectbgcolor \
2028 -background $bgcolor -foreground $fgcolor \
2029 -font mainfont \
2030 -tabs [list $indent [expr {2 * $indent}]] \
2031 -yscrollcommand ".bright.sb set" \
2032 -cursor [. cget -cursor] \
2033 -spacing1 1 -spacing3 1
2034 lappend bglist $cflist
2035 lappend fglist $cflist
2036 scrollbar .bright.sb -command "$cflist yview"
2037 pack .bright.sb -side right -fill y
2038 pack $cflist -side left -fill both -expand 1
2039 $cflist tag configure highlight \
2040 -background [$cflist cget -selectbackground]
2041 $cflist tag configure bold -font mainfontbold
2043 .pwbottom add .bright
2044 .ctop add .pwbottom
2046 # restore window width & height if known
2047 if {[info exists geometry(main)]} {
2048 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2049 if {$w > [winfo screenwidth .]} {
2050 set w [winfo screenwidth .]
2052 if {$h > [winfo screenheight .]} {
2053 set h [winfo screenheight .]
2055 wm geometry . "${w}x$h"
2059 if {[tk windowingsystem] eq {aqua}} {
2060 set M1B M1
2061 } else {
2062 set M1B Control
2065 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2066 pack .ctop -fill both -expand 1
2067 bindall <1> {selcanvline %W %x %y}
2068 #bindall <B1-Motion> {selcanvline %W %x %y}
2069 if {[tk windowingsystem] == "win32"} {
2070 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2071 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2072 } else {
2073 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2074 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2075 if {[tk windowingsystem] eq "aqua"} {
2076 bindall <MouseWheel> {
2077 set delta [expr {- (%D)}]
2078 allcanvs yview scroll $delta units
2082 bindall <2> "canvscan mark %W %x %y"
2083 bindall <B2-Motion> "canvscan dragto %W %x %y"
2084 bindkey <Home> selfirstline
2085 bindkey <End> sellastline
2086 bind . <Key-Up> "selnextline -1"
2087 bind . <Key-Down> "selnextline 1"
2088 bind . <Shift-Key-Up> "dofind -1 0"
2089 bind . <Shift-Key-Down> "dofind 1 0"
2090 bindkey <Key-Right> "goforw"
2091 bindkey <Key-Left> "goback"
2092 bind . <Key-Prior> "selnextpage -1"
2093 bind . <Key-Next> "selnextpage 1"
2094 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2095 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2096 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2097 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2098 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2099 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2100 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2101 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2102 bindkey <Key-space> "$ctext yview scroll 1 pages"
2103 bindkey p "selnextline -1"
2104 bindkey n "selnextline 1"
2105 bindkey z "goback"
2106 bindkey x "goforw"
2107 bindkey i "selnextline -1"
2108 bindkey k "selnextline 1"
2109 bindkey j "goback"
2110 bindkey l "goforw"
2111 bindkey b prevfile
2112 bindkey d "$ctext yview scroll 18 units"
2113 bindkey u "$ctext yview scroll -18 units"
2114 bindkey / {dofind 1 1}
2115 bindkey <Key-Return> {dofind 1 1}
2116 bindkey ? {dofind -1 1}
2117 bindkey f nextfile
2118 bindkey <F5> updatecommits
2119 bind . <$M1B-q> doquit
2120 bind . <$M1B-f> {dofind 1 1}
2121 bind . <$M1B-g> {dofind 1 0}
2122 bind . <$M1B-r> dosearchback
2123 bind . <$M1B-s> dosearch
2124 bind . <$M1B-equal> {incrfont 1}
2125 bind . <$M1B-plus> {incrfont 1}
2126 bind . <$M1B-KP_Add> {incrfont 1}
2127 bind . <$M1B-minus> {incrfont -1}
2128 bind . <$M1B-KP_Subtract> {incrfont -1}
2129 wm protocol . WM_DELETE_WINDOW doquit
2130 bind . <Destroy> {stop_backends}
2131 bind . <Button-1> "click %W"
2132 bind $fstring <Key-Return> {dofind 1 1}
2133 bind $sha1entry <Key-Return> gotocommit
2134 bind $sha1entry <<PasteSelection>> clearsha1
2135 bind $cflist <1> {sel_flist %W %x %y; break}
2136 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2137 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2138 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
2140 set maincursor [. cget -cursor]
2141 set textcursor [$ctext cget -cursor]
2142 set curtextcursor $textcursor
2144 set rowctxmenu .rowctxmenu
2145 menu $rowctxmenu -tearoff 0
2146 $rowctxmenu add command -label [mc "Diff this -> selected"] \
2147 -command {diffvssel 0}
2148 $rowctxmenu add command -label [mc "Diff selected -> this"] \
2149 -command {diffvssel 1}
2150 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2151 $rowctxmenu add command -label [mc "Create tag"] -command mktag
2152 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2153 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2154 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2155 -command cherrypick
2156 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2157 -command resethead
2159 set fakerowmenu .fakerowmenu
2160 menu $fakerowmenu -tearoff 0
2161 $fakerowmenu add command -label [mc "Diff this -> selected"] \
2162 -command {diffvssel 0}
2163 $fakerowmenu add command -label [mc "Diff selected -> this"] \
2164 -command {diffvssel 1}
2165 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2166 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2167 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2168 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2170 set headctxmenu .headctxmenu
2171 menu $headctxmenu -tearoff 0
2172 $headctxmenu add command -label [mc "Check out this branch"] \
2173 -command cobranch
2174 $headctxmenu add command -label [mc "Remove this branch"] \
2175 -command rmbranch
2177 global flist_menu
2178 set flist_menu .flistctxmenu
2179 menu $flist_menu -tearoff 0
2180 $flist_menu add command -label [mc "Highlight this too"] \
2181 -command {flist_hl 0}
2182 $flist_menu add command -label [mc "Highlight this only"] \
2183 -command {flist_hl 1}
2184 $flist_menu add command -label [mc "External diff"] \
2185 -command {external_diff}
2188 # Windows sends all mouse wheel events to the current focused window, not
2189 # the one where the mouse hovers, so bind those events here and redirect
2190 # to the correct window
2191 proc windows_mousewheel_redirector {W X Y D} {
2192 global canv canv2 canv3
2193 set w [winfo containing -displayof $W $X $Y]
2194 if {$w ne ""} {
2195 set u [expr {$D < 0 ? 5 : -5}]
2196 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2197 allcanvs yview scroll $u units
2198 } else {
2199 catch {
2200 $w yview scroll $u units
2206 # Update row number label when selectedline changes
2207 proc selectedline_change {n1 n2 op} {
2208 global selectedline rownumsel
2210 if {$selectedline eq {}} {
2211 set rownumsel {}
2212 } else {
2213 set rownumsel [expr {$selectedline + 1}]
2217 # mouse-2 makes all windows scan vertically, but only the one
2218 # the cursor is in scans horizontally
2219 proc canvscan {op w x y} {
2220 global canv canv2 canv3
2221 foreach c [list $canv $canv2 $canv3] {
2222 if {$c == $w} {
2223 $c scan $op $x $y
2224 } else {
2225 $c scan $op 0 $y
2230 proc scrollcanv {cscroll f0 f1} {
2231 $cscroll set $f0 $f1
2232 drawvisible
2233 flushhighlights
2236 # when we make a key binding for the toplevel, make sure
2237 # it doesn't get triggered when that key is pressed in the
2238 # find string entry widget.
2239 proc bindkey {ev script} {
2240 global entries
2241 bind . $ev $script
2242 set escript [bind Entry $ev]
2243 if {$escript == {}} {
2244 set escript [bind Entry <Key>]
2246 foreach e $entries {
2247 bind $e $ev "$escript; break"
2251 # set the focus back to the toplevel for any click outside
2252 # the entry widgets
2253 proc click {w} {
2254 global ctext entries
2255 foreach e [concat $entries $ctext] {
2256 if {$w == $e} return
2258 focus .
2261 # Adjust the progress bar for a change in requested extent or canvas size
2262 proc adjustprogress {} {
2263 global progresscanv progressitem progresscoords
2264 global fprogitem fprogcoord lastprogupdate progupdatepending
2265 global rprogitem rprogcoord
2267 set w [expr {[winfo width $progresscanv] - 4}]
2268 set x0 [expr {$w * [lindex $progresscoords 0]}]
2269 set x1 [expr {$w * [lindex $progresscoords 1]}]
2270 set h [winfo height $progresscanv]
2271 $progresscanv coords $progressitem $x0 0 $x1 $h
2272 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2273 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2274 set now [clock clicks -milliseconds]
2275 if {$now >= $lastprogupdate + 100} {
2276 set progupdatepending 0
2277 update
2278 } elseif {!$progupdatepending} {
2279 set progupdatepending 1
2280 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2284 proc doprogupdate {} {
2285 global lastprogupdate progupdatepending
2287 if {$progupdatepending} {
2288 set progupdatepending 0
2289 set lastprogupdate [clock clicks -milliseconds]
2290 update
2294 proc savestuff {w} {
2295 global canv canv2 canv3 mainfont textfont uifont tabstop
2296 global stuffsaved findmergefiles maxgraphpct
2297 global maxwidth showneartags showlocalchanges
2298 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2299 global cmitmode wrapcomment datetimeformat limitdiffs
2300 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2301 global autoselect extdifftool
2303 if {$stuffsaved} return
2304 if {![winfo viewable .]} return
2305 catch {
2306 set f [open "~/.gitk-new" w]
2307 puts $f [list set mainfont $mainfont]
2308 puts $f [list set textfont $textfont]
2309 puts $f [list set uifont $uifont]
2310 puts $f [list set tabstop $tabstop]
2311 puts $f [list set findmergefiles $findmergefiles]
2312 puts $f [list set maxgraphpct $maxgraphpct]
2313 puts $f [list set maxwidth $maxwidth]
2314 puts $f [list set cmitmode $cmitmode]
2315 puts $f [list set wrapcomment $wrapcomment]
2316 puts $f [list set autoselect $autoselect]
2317 puts $f [list set showneartags $showneartags]
2318 puts $f [list set showlocalchanges $showlocalchanges]
2319 puts $f [list set datetimeformat $datetimeformat]
2320 puts $f [list set limitdiffs $limitdiffs]
2321 puts $f [list set bgcolor $bgcolor]
2322 puts $f [list set fgcolor $fgcolor]
2323 puts $f [list set colors $colors]
2324 puts $f [list set diffcolors $diffcolors]
2325 puts $f [list set diffcontext $diffcontext]
2326 puts $f [list set selectbgcolor $selectbgcolor]
2327 puts $f [list set extdifftool $extdifftool]
2329 puts $f "set geometry(main) [wm geometry .]"
2330 puts $f "set geometry(topwidth) [winfo width .tf]"
2331 puts $f "set geometry(topheight) [winfo height .tf]"
2332 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2333 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2334 puts $f "set geometry(botwidth) [winfo width .bleft]"
2335 puts $f "set geometry(botheight) [winfo height .bleft]"
2337 puts -nonewline $f "set permviews {"
2338 for {set v 0} {$v < $nextviewnum} {incr v} {
2339 if {$viewperm($v)} {
2340 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2343 puts $f "}"
2344 close $f
2345 file rename -force "~/.gitk-new" "~/.gitk"
2347 set stuffsaved 1
2350 proc resizeclistpanes {win w} {
2351 global oldwidth
2352 if {[info exists oldwidth($win)]} {
2353 set s0 [$win sash coord 0]
2354 set s1 [$win sash coord 1]
2355 if {$w < 60} {
2356 set sash0 [expr {int($w/2 - 2)}]
2357 set sash1 [expr {int($w*5/6 - 2)}]
2358 } else {
2359 set factor [expr {1.0 * $w / $oldwidth($win)}]
2360 set sash0 [expr {int($factor * [lindex $s0 0])}]
2361 set sash1 [expr {int($factor * [lindex $s1 0])}]
2362 if {$sash0 < 30} {
2363 set sash0 30
2365 if {$sash1 < $sash0 + 20} {
2366 set sash1 [expr {$sash0 + 20}]
2368 if {$sash1 > $w - 10} {
2369 set sash1 [expr {$w - 10}]
2370 if {$sash0 > $sash1 - 20} {
2371 set sash0 [expr {$sash1 - 20}]
2375 $win sash place 0 $sash0 [lindex $s0 1]
2376 $win sash place 1 $sash1 [lindex $s1 1]
2378 set oldwidth($win) $w
2381 proc resizecdetpanes {win w} {
2382 global oldwidth
2383 if {[info exists oldwidth($win)]} {
2384 set s0 [$win sash coord 0]
2385 if {$w < 60} {
2386 set sash0 [expr {int($w*3/4 - 2)}]
2387 } else {
2388 set factor [expr {1.0 * $w / $oldwidth($win)}]
2389 set sash0 [expr {int($factor * [lindex $s0 0])}]
2390 if {$sash0 < 45} {
2391 set sash0 45
2393 if {$sash0 > $w - 15} {
2394 set sash0 [expr {$w - 15}]
2397 $win sash place 0 $sash0 [lindex $s0 1]
2399 set oldwidth($win) $w
2402 proc allcanvs args {
2403 global canv canv2 canv3
2404 eval $canv $args
2405 eval $canv2 $args
2406 eval $canv3 $args
2409 proc bindall {event action} {
2410 global canv canv2 canv3
2411 bind $canv $event $action
2412 bind $canv2 $event $action
2413 bind $canv3 $event $action
2416 proc about {} {
2417 global uifont
2418 set w .about
2419 if {[winfo exists $w]} {
2420 raise $w
2421 return
2423 toplevel $w
2424 wm title $w [mc "About gitk"]
2425 message $w.m -text [mc "
2426 Gitk - a commit viewer for git
2428 Copyright © 2005-2008 Paul Mackerras
2430 Use and redistribute under the terms of the GNU General Public License"] \
2431 -justify center -aspect 400 -border 2 -bg white -relief groove
2432 pack $w.m -side top -fill x -padx 2 -pady 2
2433 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2434 pack $w.ok -side bottom
2435 bind $w <Visibility> "focus $w.ok"
2436 bind $w <Key-Escape> "destroy $w"
2437 bind $w <Key-Return> "destroy $w"
2440 proc keys {} {
2441 set w .keys
2442 if {[winfo exists $w]} {
2443 raise $w
2444 return
2446 if {[tk windowingsystem] eq {aqua}} {
2447 set M1T Cmd
2448 } else {
2449 set M1T Ctrl
2451 toplevel $w
2452 wm title $w [mc "Gitk key bindings"]
2453 message $w.m -text "
2454 [mc "Gitk key bindings:"]
2456 [mc "<%s-Q> Quit" $M1T]
2457 [mc "<Home> Move to first commit"]
2458 [mc "<End> Move to last commit"]
2459 [mc "<Up>, p, i Move up one commit"]
2460 [mc "<Down>, n, k Move down one commit"]
2461 [mc "<Left>, z, j Go back in history list"]
2462 [mc "<Right>, x, l Go forward in history list"]
2463 [mc "<PageUp> Move up one page in commit list"]
2464 [mc "<PageDown> Move down one page in commit list"]
2465 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2466 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2467 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2468 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2469 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2470 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2471 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2472 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2473 [mc "<Delete>, b Scroll diff view up one page"]
2474 [mc "<Backspace> Scroll diff view up one page"]
2475 [mc "<Space> Scroll diff view down one page"]
2476 [mc "u Scroll diff view up 18 lines"]
2477 [mc "d Scroll diff view down 18 lines"]
2478 [mc "<%s-F> Find" $M1T]
2479 [mc "<%s-G> Move to next find hit" $M1T]
2480 [mc "<Return> Move to next find hit"]
2481 [mc "/ Move to next find hit, or redo find"]
2482 [mc "? Move to previous find hit"]
2483 [mc "f Scroll diff view to next file"]
2484 [mc "<%s-S> Search for next hit in diff view" $M1T]
2485 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2486 [mc "<%s-KP+> Increase font size" $M1T]
2487 [mc "<%s-plus> Increase font size" $M1T]
2488 [mc "<%s-KP-> Decrease font size" $M1T]
2489 [mc "<%s-minus> Decrease font size" $M1T]
2490 [mc "<F5> Update"]
2492 -justify left -bg white -border 2 -relief groove
2493 pack $w.m -side top -fill both -padx 2 -pady 2
2494 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2495 pack $w.ok -side bottom
2496 bind $w <Visibility> "focus $w.ok"
2497 bind $w <Key-Escape> "destroy $w"
2498 bind $w <Key-Return> "destroy $w"
2501 # Procedures for manipulating the file list window at the
2502 # bottom right of the overall window.
2504 proc treeview {w l openlevs} {
2505 global treecontents treediropen treeheight treeparent treeindex
2507 set ix 0
2508 set treeindex() 0
2509 set lev 0
2510 set prefix {}
2511 set prefixend -1
2512 set prefendstack {}
2513 set htstack {}
2514 set ht 0
2515 set treecontents() {}
2516 $w conf -state normal
2517 foreach f $l {
2518 while {[string range $f 0 $prefixend] ne $prefix} {
2519 if {$lev <= $openlevs} {
2520 $w mark set e:$treeindex($prefix) "end -1c"
2521 $w mark gravity e:$treeindex($prefix) left
2523 set treeheight($prefix) $ht
2524 incr ht [lindex $htstack end]
2525 set htstack [lreplace $htstack end end]
2526 set prefixend [lindex $prefendstack end]
2527 set prefendstack [lreplace $prefendstack end end]
2528 set prefix [string range $prefix 0 $prefixend]
2529 incr lev -1
2531 set tail [string range $f [expr {$prefixend+1}] end]
2532 while {[set slash [string first "/" $tail]] >= 0} {
2533 lappend htstack $ht
2534 set ht 0
2535 lappend prefendstack $prefixend
2536 incr prefixend [expr {$slash + 1}]
2537 set d [string range $tail 0 $slash]
2538 lappend treecontents($prefix) $d
2539 set oldprefix $prefix
2540 append prefix $d
2541 set treecontents($prefix) {}
2542 set treeindex($prefix) [incr ix]
2543 set treeparent($prefix) $oldprefix
2544 set tail [string range $tail [expr {$slash+1}] end]
2545 if {$lev <= $openlevs} {
2546 set ht 1
2547 set treediropen($prefix) [expr {$lev < $openlevs}]
2548 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2549 $w mark set d:$ix "end -1c"
2550 $w mark gravity d:$ix left
2551 set str "\n"
2552 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2553 $w insert end $str
2554 $w image create end -align center -image $bm -padx 1 \
2555 -name a:$ix
2556 $w insert end $d [highlight_tag $prefix]
2557 $w mark set s:$ix "end -1c"
2558 $w mark gravity s:$ix left
2560 incr lev
2562 if {$tail ne {}} {
2563 if {$lev <= $openlevs} {
2564 incr ht
2565 set str "\n"
2566 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2567 $w insert end $str
2568 $w insert end $tail [highlight_tag $f]
2570 lappend treecontents($prefix) $tail
2573 while {$htstack ne {}} {
2574 set treeheight($prefix) $ht
2575 incr ht [lindex $htstack end]
2576 set htstack [lreplace $htstack end end]
2577 set prefixend [lindex $prefendstack end]
2578 set prefendstack [lreplace $prefendstack end end]
2579 set prefix [string range $prefix 0 $prefixend]
2581 $w conf -state disabled
2584 proc linetoelt {l} {
2585 global treeheight treecontents
2587 set y 2
2588 set prefix {}
2589 while {1} {
2590 foreach e $treecontents($prefix) {
2591 if {$y == $l} {
2592 return "$prefix$e"
2594 set n 1
2595 if {[string index $e end] eq "/"} {
2596 set n $treeheight($prefix$e)
2597 if {$y + $n > $l} {
2598 append prefix $e
2599 incr y
2600 break
2603 incr y $n
2608 proc highlight_tree {y prefix} {
2609 global treeheight treecontents cflist
2611 foreach e $treecontents($prefix) {
2612 set path $prefix$e
2613 if {[highlight_tag $path] ne {}} {
2614 $cflist tag add bold $y.0 "$y.0 lineend"
2616 incr y
2617 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2618 set y [highlight_tree $y $path]
2621 return $y
2624 proc treeclosedir {w dir} {
2625 global treediropen treeheight treeparent treeindex
2627 set ix $treeindex($dir)
2628 $w conf -state normal
2629 $w delete s:$ix e:$ix
2630 set treediropen($dir) 0
2631 $w image configure a:$ix -image tri-rt
2632 $w conf -state disabled
2633 set n [expr {1 - $treeheight($dir)}]
2634 while {$dir ne {}} {
2635 incr treeheight($dir) $n
2636 set dir $treeparent($dir)
2640 proc treeopendir {w dir} {
2641 global treediropen treeheight treeparent treecontents treeindex
2643 set ix $treeindex($dir)
2644 $w conf -state normal
2645 $w image configure a:$ix -image tri-dn
2646 $w mark set e:$ix s:$ix
2647 $w mark gravity e:$ix right
2648 set lev 0
2649 set str "\n"
2650 set n [llength $treecontents($dir)]
2651 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2652 incr lev
2653 append str "\t"
2654 incr treeheight($x) $n
2656 foreach e $treecontents($dir) {
2657 set de $dir$e
2658 if {[string index $e end] eq "/"} {
2659 set iy $treeindex($de)
2660 $w mark set d:$iy e:$ix
2661 $w mark gravity d:$iy left
2662 $w insert e:$ix $str
2663 set treediropen($de) 0
2664 $w image create e:$ix -align center -image tri-rt -padx 1 \
2665 -name a:$iy
2666 $w insert e:$ix $e [highlight_tag $de]
2667 $w mark set s:$iy e:$ix
2668 $w mark gravity s:$iy left
2669 set treeheight($de) 1
2670 } else {
2671 $w insert e:$ix $str
2672 $w insert e:$ix $e [highlight_tag $de]
2675 $w mark gravity e:$ix left
2676 $w conf -state disabled
2677 set treediropen($dir) 1
2678 set top [lindex [split [$w index @0,0] .] 0]
2679 set ht [$w cget -height]
2680 set l [lindex [split [$w index s:$ix] .] 0]
2681 if {$l < $top} {
2682 $w yview $l.0
2683 } elseif {$l + $n + 1 > $top + $ht} {
2684 set top [expr {$l + $n + 2 - $ht}]
2685 if {$l < $top} {
2686 set top $l
2688 $w yview $top.0
2692 proc treeclick {w x y} {
2693 global treediropen cmitmode ctext cflist cflist_top
2695 if {$cmitmode ne "tree"} return
2696 if {![info exists cflist_top]} return
2697 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2698 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2699 $cflist tag add highlight $l.0 "$l.0 lineend"
2700 set cflist_top $l
2701 if {$l == 1} {
2702 $ctext yview 1.0
2703 return
2705 set e [linetoelt $l]
2706 if {[string index $e end] ne "/"} {
2707 showfile $e
2708 } elseif {$treediropen($e)} {
2709 treeclosedir $w $e
2710 } else {
2711 treeopendir $w $e
2715 proc setfilelist {id} {
2716 global treefilelist cflist
2718 treeview $cflist $treefilelist($id) 0
2721 image create bitmap tri-rt -background black -foreground blue -data {
2722 #define tri-rt_width 13
2723 #define tri-rt_height 13
2724 static unsigned char tri-rt_bits[] = {
2725 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2726 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2727 0x00, 0x00};
2728 } -maskdata {
2729 #define tri-rt-mask_width 13
2730 #define tri-rt-mask_height 13
2731 static unsigned char tri-rt-mask_bits[] = {
2732 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2733 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2734 0x08, 0x00};
2736 image create bitmap tri-dn -background black -foreground blue -data {
2737 #define tri-dn_width 13
2738 #define tri-dn_height 13
2739 static unsigned char tri-dn_bits[] = {
2740 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2741 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2742 0x00, 0x00};
2743 } -maskdata {
2744 #define tri-dn-mask_width 13
2745 #define tri-dn-mask_height 13
2746 static unsigned char tri-dn-mask_bits[] = {
2747 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2748 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2749 0x00, 0x00};
2752 image create bitmap reficon-T -background black -foreground yellow -data {
2753 #define tagicon_width 13
2754 #define tagicon_height 9
2755 static unsigned char tagicon_bits[] = {
2756 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2757 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2758 } -maskdata {
2759 #define tagicon-mask_width 13
2760 #define tagicon-mask_height 9
2761 static unsigned char tagicon-mask_bits[] = {
2762 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2763 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2765 set rectdata {
2766 #define headicon_width 13
2767 #define headicon_height 9
2768 static unsigned char headicon_bits[] = {
2769 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2770 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2772 set rectmask {
2773 #define headicon-mask_width 13
2774 #define headicon-mask_height 9
2775 static unsigned char headicon-mask_bits[] = {
2776 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2777 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2779 image create bitmap reficon-H -background black -foreground green \
2780 -data $rectdata -maskdata $rectmask
2781 image create bitmap reficon-o -background black -foreground "#ddddff" \
2782 -data $rectdata -maskdata $rectmask
2784 proc init_flist {first} {
2785 global cflist cflist_top difffilestart
2787 $cflist conf -state normal
2788 $cflist delete 0.0 end
2789 if {$first ne {}} {
2790 $cflist insert end $first
2791 set cflist_top 1
2792 $cflist tag add highlight 1.0 "1.0 lineend"
2793 } else {
2794 catch {unset cflist_top}
2796 $cflist conf -state disabled
2797 set difffilestart {}
2800 proc highlight_tag {f} {
2801 global highlight_paths
2803 foreach p $highlight_paths {
2804 if {[string match $p $f]} {
2805 return "bold"
2808 return {}
2811 proc highlight_filelist {} {
2812 global cmitmode cflist
2814 $cflist conf -state normal
2815 if {$cmitmode ne "tree"} {
2816 set end [lindex [split [$cflist index end] .] 0]
2817 for {set l 2} {$l < $end} {incr l} {
2818 set line [$cflist get $l.0 "$l.0 lineend"]
2819 if {[highlight_tag $line] ne {}} {
2820 $cflist tag add bold $l.0 "$l.0 lineend"
2823 } else {
2824 highlight_tree 2 {}
2826 $cflist conf -state disabled
2829 proc unhighlight_filelist {} {
2830 global cflist
2832 $cflist conf -state normal
2833 $cflist tag remove bold 1.0 end
2834 $cflist conf -state disabled
2837 proc add_flist {fl} {
2838 global cflist
2840 $cflist conf -state normal
2841 foreach f $fl {
2842 $cflist insert end "\n"
2843 $cflist insert end $f [highlight_tag $f]
2845 $cflist conf -state disabled
2848 proc sel_flist {w x y} {
2849 global ctext difffilestart cflist cflist_top cmitmode
2851 if {$cmitmode eq "tree"} return
2852 if {![info exists cflist_top]} return
2853 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2854 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2855 $cflist tag add highlight $l.0 "$l.0 lineend"
2856 set cflist_top $l
2857 if {$l == 1} {
2858 $ctext yview 1.0
2859 } else {
2860 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2864 proc pop_flist_menu {w X Y x y} {
2865 global ctext cflist cmitmode flist_menu flist_menu_file
2866 global treediffs diffids
2868 stopfinding
2869 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2870 if {$l <= 1} return
2871 if {$cmitmode eq "tree"} {
2872 set e [linetoelt $l]
2873 if {[string index $e end] eq "/"} return
2874 } else {
2875 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2877 set flist_menu_file $e
2878 set xdiffstate "normal"
2879 if {$cmitmode eq "tree"} {
2880 set xdiffstate "disabled"
2882 # Disable "External diff" item in tree mode
2883 $flist_menu entryconf 2 -state $xdiffstate
2884 tk_popup $flist_menu $X $Y
2887 proc flist_hl {only} {
2888 global flist_menu_file findstring gdttype
2890 set x [shellquote $flist_menu_file]
2891 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2892 set findstring $x
2893 } else {
2894 append findstring " " $x
2896 set gdttype [mc "touching paths:"]
2899 proc save_file_from_commit {filename output what} {
2900 global nullfile
2902 if {[catch {exec git show $filename -- > $output} err]} {
2903 if {[string match "fatal: bad revision *" $err]} {
2904 return $nullfile
2906 error_popup "Error getting \"$filename\" from $what: $err"
2907 return {}
2909 return $output
2912 proc external_diff_get_one_file {diffid filename diffdir} {
2913 global nullid nullid2 nullfile
2914 global gitdir
2916 if {$diffid == $nullid} {
2917 set difffile [file join [file dirname $gitdir] $filename]
2918 if {[file exists $difffile]} {
2919 return $difffile
2921 return $nullfile
2923 if {$diffid == $nullid2} {
2924 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2925 return [save_file_from_commit :$filename $difffile index]
2927 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2928 return [save_file_from_commit $diffid:$filename $difffile \
2929 "revision $diffid"]
2932 proc external_diff {} {
2933 global gitktmpdir nullid nullid2
2934 global flist_menu_file
2935 global diffids
2936 global diffnum
2937 global gitdir extdifftool
2939 if {[llength $diffids] == 1} {
2940 # no reference commit given
2941 set diffidto [lindex $diffids 0]
2942 if {$diffidto eq $nullid} {
2943 # diffing working copy with index
2944 set diffidfrom $nullid2
2945 } elseif {$diffidto eq $nullid2} {
2946 # diffing index with HEAD
2947 set diffidfrom "HEAD"
2948 } else {
2949 # use first parent commit
2950 global parentlist selectedline
2951 set diffidfrom [lindex $parentlist $selectedline 0]
2953 } else {
2954 set diffidfrom [lindex $diffids 0]
2955 set diffidto [lindex $diffids 1]
2958 # make sure that several diffs wont collide
2959 if {![info exists gitktmpdir]} {
2960 set gitktmpdir [file join [file dirname $gitdir] \
2961 [format ".gitk-tmp.%s" [pid]]]
2962 if {[catch {file mkdir $gitktmpdir} err]} {
2963 error_popup "Error creating temporary directory $gitktmpdir: $err"
2964 unset gitktmpdir
2965 return
2967 set diffnum 0
2969 incr diffnum
2970 set diffdir [file join $gitktmpdir $diffnum]
2971 if {[catch {file mkdir $diffdir} err]} {
2972 error_popup "Error creating temporary directory $diffdir: $err"
2973 return
2976 # gather files to diff
2977 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
2978 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
2980 if {$difffromfile ne {} && $difftofile ne {}} {
2981 set cmd [concat | [shellsplit $extdifftool] \
2982 [list $difffromfile $difftofile]]
2983 if {[catch {set fl [open $cmd r]} err]} {
2984 file delete -force $diffdir
2985 error_popup [mc "$extdifftool: command failed: $err"]
2986 } else {
2987 fconfigure $fl -blocking 0
2988 filerun $fl [list delete_at_eof $fl $diffdir]
2993 # delete $dir when we see eof on $f (presumably because the child has exited)
2994 proc delete_at_eof {f dir} {
2995 while {[gets $f line] >= 0} {}
2996 if {[eof $f]} {
2997 if {[catch {close $f} err]} {
2998 error_popup "External diff viewer failed: $err"
3000 file delete -force $dir
3001 return 0
3003 return 1
3006 # Functions for adding and removing shell-type quoting
3008 proc shellquote {str} {
3009 if {![string match "*\['\"\\ \t]*" $str]} {
3010 return $str
3012 if {![string match "*\['\"\\]*" $str]} {
3013 return "\"$str\""
3015 if {![string match "*'*" $str]} {
3016 return "'$str'"
3018 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3021 proc shellarglist {l} {
3022 set str {}
3023 foreach a $l {
3024 if {$str ne {}} {
3025 append str " "
3027 append str [shellquote $a]
3029 return $str
3032 proc shelldequote {str} {
3033 set ret {}
3034 set used -1
3035 while {1} {
3036 incr used
3037 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3038 append ret [string range $str $used end]
3039 set used [string length $str]
3040 break
3042 set first [lindex $first 0]
3043 set ch [string index $str $first]
3044 if {$first > $used} {
3045 append ret [string range $str $used [expr {$first - 1}]]
3046 set used $first
3048 if {$ch eq " " || $ch eq "\t"} break
3049 incr used
3050 if {$ch eq "'"} {
3051 set first [string first "'" $str $used]
3052 if {$first < 0} {
3053 error "unmatched single-quote"
3055 append ret [string range $str $used [expr {$first - 1}]]
3056 set used $first
3057 continue
3059 if {$ch eq "\\"} {
3060 if {$used >= [string length $str]} {
3061 error "trailing backslash"
3063 append ret [string index $str $used]
3064 continue
3066 # here ch == "\""
3067 while {1} {
3068 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3069 error "unmatched double-quote"
3071 set first [lindex $first 0]
3072 set ch [string index $str $first]
3073 if {$first > $used} {
3074 append ret [string range $str $used [expr {$first - 1}]]
3075 set used $first
3077 if {$ch eq "\""} break
3078 incr used
3079 append ret [string index $str $used]
3080 incr used
3083 return [list $used $ret]
3086 proc shellsplit {str} {
3087 set l {}
3088 while {1} {
3089 set str [string trimleft $str]
3090 if {$str eq {}} break
3091 set dq [shelldequote $str]
3092 set n [lindex $dq 0]
3093 set word [lindex $dq 1]
3094 set str [string range $str $n end]
3095 lappend l $word
3097 return $l
3100 # Code to implement multiple views
3102 proc newview {ishighlight} {
3103 global nextviewnum newviewname newviewperm newishighlight
3104 global newviewargs revtreeargs viewargscmd newviewargscmd curview
3106 set newishighlight $ishighlight
3107 set top .gitkview
3108 if {[winfo exists $top]} {
3109 raise $top
3110 return
3112 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3113 set newviewperm($nextviewnum) 0
3114 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3115 set newviewargscmd($nextviewnum) $viewargscmd($curview)
3116 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3119 proc editview {} {
3120 global curview
3121 global viewname viewperm newviewname newviewperm
3122 global viewargs newviewargs viewargscmd newviewargscmd
3124 set top .gitkvedit-$curview
3125 if {[winfo exists $top]} {
3126 raise $top
3127 return
3129 set newviewname($curview) $viewname($curview)
3130 set newviewperm($curview) $viewperm($curview)
3131 set newviewargs($curview) [shellarglist $viewargs($curview)]
3132 set newviewargscmd($curview) $viewargscmd($curview)
3133 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3136 proc vieweditor {top n title} {
3137 global newviewname newviewperm viewfiles bgcolor
3139 toplevel $top
3140 wm title $top $title
3141 label $top.nl -text [mc "Name"]
3142 entry $top.name -width 20 -textvariable newviewname($n)
3143 grid $top.nl $top.name -sticky w -pady 5
3144 checkbutton $top.perm -text [mc "Remember this view"] \
3145 -variable newviewperm($n)
3146 grid $top.perm - -pady 5 -sticky w
3147 message $top.al -aspect 1000 \
3148 -text [mc "Commits to include (arguments to git log):"]
3149 grid $top.al - -sticky w -pady 5
3150 entry $top.args -width 50 -textvariable newviewargs($n) \
3151 -background $bgcolor
3152 grid $top.args - -sticky ew -padx 5
3154 message $top.ac -aspect 1000 \
3155 -text [mc "Command to generate more commits to include:"]
3156 grid $top.ac - -sticky w -pady 5
3157 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3158 -background white
3159 grid $top.argscmd - -sticky ew -padx 5
3161 message $top.l -aspect 1000 \
3162 -text [mc "Enter files and directories to include, one per line:"]
3163 grid $top.l - -sticky w
3164 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3165 if {[info exists viewfiles($n)]} {
3166 foreach f $viewfiles($n) {
3167 $top.t insert end $f
3168 $top.t insert end "\n"
3170 $top.t delete {end - 1c} end
3171 $top.t mark set insert 0.0
3173 grid $top.t - -sticky ew -padx 5
3174 frame $top.buts
3175 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3176 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3177 grid $top.buts.ok $top.buts.can
3178 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3179 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3180 grid $top.buts - -pady 10 -sticky ew
3181 focus $top.t
3184 proc doviewmenu {m first cmd op argv} {
3185 set nmenu [$m index end]
3186 for {set i $first} {$i <= $nmenu} {incr i} {
3187 if {[$m entrycget $i -command] eq $cmd} {
3188 eval $m $op $i $argv
3189 break
3194 proc allviewmenus {n op args} {
3195 # global viewhlmenu
3197 doviewmenu .bar.view 5 [list showview $n] $op $args
3198 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3201 proc newviewok {top n} {
3202 global nextviewnum newviewperm newviewname newishighlight
3203 global viewname viewfiles viewperm selectedview curview
3204 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3206 if {[catch {
3207 set newargs [shellsplit $newviewargs($n)]
3208 } err]} {
3209 error_popup "[mc "Error in commit selection arguments:"] $err"
3210 wm raise $top
3211 focus $top
3212 return
3214 set files {}
3215 foreach f [split [$top.t get 0.0 end] "\n"] {
3216 set ft [string trim $f]
3217 if {$ft ne {}} {
3218 lappend files $ft
3221 if {![info exists viewfiles($n)]} {
3222 # creating a new view
3223 incr nextviewnum
3224 set viewname($n) $newviewname($n)
3225 set viewperm($n) $newviewperm($n)
3226 set viewfiles($n) $files
3227 set viewargs($n) $newargs
3228 set viewargscmd($n) $newviewargscmd($n)
3229 addviewmenu $n
3230 if {!$newishighlight} {
3231 run showview $n
3232 } else {
3233 run addvhighlight $n
3235 } else {
3236 # editing an existing view
3237 set viewperm($n) $newviewperm($n)
3238 if {$newviewname($n) ne $viewname($n)} {
3239 set viewname($n) $newviewname($n)
3240 doviewmenu .bar.view 5 [list showview $n] \
3241 entryconf [list -label $viewname($n)]
3242 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3243 # entryconf [list -label $viewname($n) -value $viewname($n)]
3245 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3246 $newviewargscmd($n) ne $viewargscmd($n)} {
3247 set viewfiles($n) $files
3248 set viewargs($n) $newargs
3249 set viewargscmd($n) $newviewargscmd($n)
3250 if {$curview == $n} {
3251 run reloadcommits
3255 catch {destroy $top}
3258 proc delview {} {
3259 global curview viewperm hlview selectedhlview
3261 if {$curview == 0} return
3262 if {[info exists hlview] && $hlview == $curview} {
3263 set selectedhlview [mc "None"]
3264 unset hlview
3266 allviewmenus $curview delete
3267 set viewperm($curview) 0
3268 showview 0
3271 proc addviewmenu {n} {
3272 global viewname viewhlmenu
3274 .bar.view add radiobutton -label $viewname($n) \
3275 -command [list showview $n] -variable selectedview -value $n
3276 #$viewhlmenu add radiobutton -label $viewname($n) \
3277 # -command [list addvhighlight $n] -variable selectedhlview
3280 proc showview {n} {
3281 global curview cached_commitrow ordertok
3282 global displayorder parentlist rowidlist rowisopt rowfinal
3283 global colormap rowtextx nextcolor canvxmax
3284 global numcommits viewcomplete
3285 global selectedline currentid canv canvy0
3286 global treediffs
3287 global pending_select mainheadid
3288 global commitidx
3289 global selectedview
3290 global hlview selectedhlview commitinterest
3292 if {$n == $curview} return
3293 set selid {}
3294 set ymax [lindex [$canv cget -scrollregion] 3]
3295 set span [$canv yview]
3296 set ytop [expr {[lindex $span 0] * $ymax}]
3297 set ybot [expr {[lindex $span 1] * $ymax}]
3298 set yscreen [expr {($ybot - $ytop) / 2}]
3299 if {$selectedline ne {}} {
3300 set selid $currentid
3301 set y [yc $selectedline]
3302 if {$ytop < $y && $y < $ybot} {
3303 set yscreen [expr {$y - $ytop}]
3305 } elseif {[info exists pending_select]} {
3306 set selid $pending_select
3307 unset pending_select
3309 unselectline
3310 normalline
3311 catch {unset treediffs}
3312 clear_display
3313 if {[info exists hlview] && $hlview == $n} {
3314 unset hlview
3315 set selectedhlview [mc "None"]
3317 catch {unset commitinterest}
3318 catch {unset cached_commitrow}
3319 catch {unset ordertok}
3321 set curview $n
3322 set selectedview $n
3323 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3324 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3326 run refill_reflist
3327 if {![info exists viewcomplete($n)]} {
3328 if {$selid ne {}} {
3329 set pending_select $selid
3331 getcommits
3332 return
3335 set displayorder {}
3336 set parentlist {}
3337 set rowidlist {}
3338 set rowisopt {}
3339 set rowfinal {}
3340 set numcommits $commitidx($n)
3342 catch {unset colormap}
3343 catch {unset rowtextx}
3344 set nextcolor 0
3345 set canvxmax [$canv cget -width]
3346 set curview $n
3347 set row 0
3348 setcanvscroll
3349 set yf 0
3350 set row {}
3351 if {$selid ne {} && [commitinview $selid $n]} {
3352 set row [rowofcommit $selid]
3353 # try to get the selected row in the same position on the screen
3354 set ymax [lindex [$canv cget -scrollregion] 3]
3355 set ytop [expr {[yc $row] - $yscreen}]
3356 if {$ytop < 0} {
3357 set ytop 0
3359 set yf [expr {$ytop * 1.0 / $ymax}]
3361 allcanvs yview moveto $yf
3362 drawvisible
3363 if {$row ne {}} {
3364 selectline $row 0
3365 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
3366 selectline [rowofcommit $mainheadid] 1
3367 } elseif {!$viewcomplete($n)} {
3368 if {$selid ne {}} {
3369 set pending_select $selid
3370 } else {
3371 set pending_select $mainheadid
3373 } else {
3374 set row [first_real_row]
3375 if {$row < $numcommits} {
3376 selectline $row 0
3379 if {!$viewcomplete($n)} {
3380 if {$numcommits == 0} {
3381 show_status [mc "Reading commits..."]
3383 } elseif {$numcommits == 0} {
3384 show_status [mc "No commits selected"]
3388 # Stuff relating to the highlighting facility
3390 proc ishighlighted {id} {
3391 global vhighlights fhighlights nhighlights rhighlights
3393 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3394 return $nhighlights($id)
3396 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3397 return $vhighlights($id)
3399 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3400 return $fhighlights($id)
3402 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3403 return $rhighlights($id)
3405 return 0
3408 proc bolden {row font} {
3409 global canv linehtag selectedline boldrows
3411 lappend boldrows $row
3412 $canv itemconf $linehtag($row) -font $font
3413 if {$row == $selectedline} {
3414 $canv delete secsel
3415 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3416 -outline {{}} -tags secsel \
3417 -fill [$canv cget -selectbackground]]
3418 $canv lower $t
3422 proc bolden_name {row font} {
3423 global canv2 linentag selectedline boldnamerows
3425 lappend boldnamerows $row
3426 $canv2 itemconf $linentag($row) -font $font
3427 if {$row == $selectedline} {
3428 $canv2 delete secsel
3429 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3430 -outline {{}} -tags secsel \
3431 -fill [$canv2 cget -selectbackground]]
3432 $canv2 lower $t
3436 proc unbolden {} {
3437 global boldrows
3439 set stillbold {}
3440 foreach row $boldrows {
3441 if {![ishighlighted [commitonrow $row]]} {
3442 bolden $row mainfont
3443 } else {
3444 lappend stillbold $row
3447 set boldrows $stillbold
3450 proc addvhighlight {n} {
3451 global hlview viewcomplete curview vhl_done commitidx
3453 if {[info exists hlview]} {
3454 delvhighlight
3456 set hlview $n
3457 if {$n != $curview && ![info exists viewcomplete($n)]} {
3458 start_rev_list $n
3460 set vhl_done $commitidx($hlview)
3461 if {$vhl_done > 0} {
3462 drawvisible
3466 proc delvhighlight {} {
3467 global hlview vhighlights
3469 if {![info exists hlview]} return
3470 unset hlview
3471 catch {unset vhighlights}
3472 unbolden
3475 proc vhighlightmore {} {
3476 global hlview vhl_done commitidx vhighlights curview
3478 set max $commitidx($hlview)
3479 set vr [visiblerows]
3480 set r0 [lindex $vr 0]
3481 set r1 [lindex $vr 1]
3482 for {set i $vhl_done} {$i < $max} {incr i} {
3483 set id [commitonrow $i $hlview]
3484 if {[commitinview $id $curview]} {
3485 set row [rowofcommit $id]
3486 if {$r0 <= $row && $row <= $r1} {
3487 if {![highlighted $row]} {
3488 bolden $row mainfontbold
3490 set vhighlights($id) 1
3494 set vhl_done $max
3495 return 0
3498 proc askvhighlight {row id} {
3499 global hlview vhighlights iddrawn
3501 if {[commitinview $id $hlview]} {
3502 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3503 bolden $row mainfontbold
3505 set vhighlights($id) 1
3506 } else {
3507 set vhighlights($id) 0
3511 proc hfiles_change {} {
3512 global highlight_files filehighlight fhighlights fh_serial
3513 global highlight_paths gdttype
3515 if {[info exists filehighlight]} {
3516 # delete previous highlights
3517 catch {close $filehighlight}
3518 unset filehighlight
3519 catch {unset fhighlights}
3520 unbolden
3521 unhighlight_filelist
3523 set highlight_paths {}
3524 after cancel do_file_hl $fh_serial
3525 incr fh_serial
3526 if {$highlight_files ne {}} {
3527 after 300 do_file_hl $fh_serial
3531 proc gdttype_change {name ix op} {
3532 global gdttype highlight_files findstring findpattern
3534 stopfinding
3535 if {$findstring ne {}} {
3536 if {$gdttype eq [mc "containing:"]} {
3537 if {$highlight_files ne {}} {
3538 set highlight_files {}
3539 hfiles_change
3541 findcom_change
3542 } else {
3543 if {$findpattern ne {}} {
3544 set findpattern {}
3545 findcom_change
3547 set highlight_files $findstring
3548 hfiles_change
3550 drawvisible
3552 # enable/disable findtype/findloc menus too
3555 proc find_change {name ix op} {
3556 global gdttype findstring highlight_files
3558 stopfinding
3559 if {$gdttype eq [mc "containing:"]} {
3560 findcom_change
3561 } else {
3562 if {$highlight_files ne $findstring} {
3563 set highlight_files $findstring
3564 hfiles_change
3567 drawvisible
3570 proc findcom_change args {
3571 global nhighlights boldnamerows
3572 global findpattern findtype findstring gdttype
3574 stopfinding
3575 # delete previous highlights, if any
3576 foreach row $boldnamerows {
3577 bolden_name $row mainfont
3579 set boldnamerows {}
3580 catch {unset nhighlights}
3581 unbolden
3582 unmarkmatches
3583 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3584 set findpattern {}
3585 } elseif {$findtype eq [mc "Regexp"]} {
3586 set findpattern $findstring
3587 } else {
3588 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3589 $findstring]
3590 set findpattern "*$e*"
3594 proc makepatterns {l} {
3595 set ret {}
3596 foreach e $l {
3597 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3598 if {[string index $ee end] eq "/"} {
3599 lappend ret "$ee*"
3600 } else {
3601 lappend ret $ee
3602 lappend ret "$ee/*"
3605 return $ret
3608 proc do_file_hl {serial} {
3609 global highlight_files filehighlight highlight_paths gdttype fhl_list
3611 if {$gdttype eq [mc "touching paths:"]} {
3612 if {[catch {set paths [shellsplit $highlight_files]}]} return
3613 set highlight_paths [makepatterns $paths]
3614 highlight_filelist
3615 set gdtargs [concat -- $paths]
3616 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3617 set gdtargs [list "-S$highlight_files"]
3618 } else {
3619 # must be "containing:", i.e. we're searching commit info
3620 return
3622 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3623 set filehighlight [open $cmd r+]
3624 fconfigure $filehighlight -blocking 0
3625 filerun $filehighlight readfhighlight
3626 set fhl_list {}
3627 drawvisible
3628 flushhighlights
3631 proc flushhighlights {} {
3632 global filehighlight fhl_list
3634 if {[info exists filehighlight]} {
3635 lappend fhl_list {}
3636 puts $filehighlight ""
3637 flush $filehighlight
3641 proc askfilehighlight {row id} {
3642 global filehighlight fhighlights fhl_list
3644 lappend fhl_list $id
3645 set fhighlights($id) -1
3646 puts $filehighlight $id
3649 proc readfhighlight {} {
3650 global filehighlight fhighlights curview iddrawn
3651 global fhl_list find_dirn
3653 if {![info exists filehighlight]} {
3654 return 0
3656 set nr 0
3657 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3658 set line [string trim $line]
3659 set i [lsearch -exact $fhl_list $line]
3660 if {$i < 0} continue
3661 for {set j 0} {$j < $i} {incr j} {
3662 set id [lindex $fhl_list $j]
3663 set fhighlights($id) 0
3665 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3666 if {$line eq {}} continue
3667 if {![commitinview $line $curview]} continue
3668 set row [rowofcommit $line]
3669 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3670 bolden $row mainfontbold
3672 set fhighlights($line) 1
3674 if {[eof $filehighlight]} {
3675 # strange...
3676 puts "oops, git diff-tree died"
3677 catch {close $filehighlight}
3678 unset filehighlight
3679 return 0
3681 if {[info exists find_dirn]} {
3682 run findmore
3684 return 1
3687 proc doesmatch {f} {
3688 global findtype findpattern
3690 if {$findtype eq [mc "Regexp"]} {
3691 return [regexp $findpattern $f]
3692 } elseif {$findtype eq [mc "IgnCase"]} {
3693 return [string match -nocase $findpattern $f]
3694 } else {
3695 return [string match $findpattern $f]
3699 proc askfindhighlight {row id} {
3700 global nhighlights commitinfo iddrawn
3701 global findloc
3702 global markingmatches
3704 if {![info exists commitinfo($id)]} {
3705 getcommit $id
3707 set info $commitinfo($id)
3708 set isbold 0
3709 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3710 foreach f $info ty $fldtypes {
3711 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3712 [doesmatch $f]} {
3713 if {$ty eq [mc "Author"]} {
3714 set isbold 2
3715 break
3717 set isbold 1
3720 if {$isbold && [info exists iddrawn($id)]} {
3721 if {![ishighlighted $id]} {
3722 bolden $row mainfontbold
3723 if {$isbold > 1} {
3724 bolden_name $row mainfontbold
3727 if {$markingmatches} {
3728 markrowmatches $row $id
3731 set nhighlights($id) $isbold
3734 proc markrowmatches {row id} {
3735 global canv canv2 linehtag linentag commitinfo findloc
3737 set headline [lindex $commitinfo($id) 0]
3738 set author [lindex $commitinfo($id) 1]
3739 $canv delete match$row
3740 $canv2 delete match$row
3741 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3742 set m [findmatches $headline]
3743 if {$m ne {}} {
3744 markmatches $canv $row $headline $linehtag($row) $m \
3745 [$canv itemcget $linehtag($row) -font] $row
3748 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3749 set m [findmatches $author]
3750 if {$m ne {}} {
3751 markmatches $canv2 $row $author $linentag($row) $m \
3752 [$canv2 itemcget $linentag($row) -font] $row
3757 proc vrel_change {name ix op} {
3758 global highlight_related
3760 rhighlight_none
3761 if {$highlight_related ne [mc "None"]} {
3762 run drawvisible
3766 # prepare for testing whether commits are descendents or ancestors of a
3767 proc rhighlight_sel {a} {
3768 global descendent desc_todo ancestor anc_todo
3769 global highlight_related
3771 catch {unset descendent}
3772 set desc_todo [list $a]
3773 catch {unset ancestor}
3774 set anc_todo [list $a]
3775 if {$highlight_related ne [mc "None"]} {
3776 rhighlight_none
3777 run drawvisible
3781 proc rhighlight_none {} {
3782 global rhighlights
3784 catch {unset rhighlights}
3785 unbolden
3788 proc is_descendent {a} {
3789 global curview children descendent desc_todo
3791 set v $curview
3792 set la [rowofcommit $a]
3793 set todo $desc_todo
3794 set leftover {}
3795 set done 0
3796 for {set i 0} {$i < [llength $todo]} {incr i} {
3797 set do [lindex $todo $i]
3798 if {[rowofcommit $do] < $la} {
3799 lappend leftover $do
3800 continue
3802 foreach nk $children($v,$do) {
3803 if {![info exists descendent($nk)]} {
3804 set descendent($nk) 1
3805 lappend todo $nk
3806 if {$nk eq $a} {
3807 set done 1
3811 if {$done} {
3812 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3813 return
3816 set descendent($a) 0
3817 set desc_todo $leftover
3820 proc is_ancestor {a} {
3821 global curview parents ancestor anc_todo
3823 set v $curview
3824 set la [rowofcommit $a]
3825 set todo $anc_todo
3826 set leftover {}
3827 set done 0
3828 for {set i 0} {$i < [llength $todo]} {incr i} {
3829 set do [lindex $todo $i]
3830 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3831 lappend leftover $do
3832 continue
3834 foreach np $parents($v,$do) {
3835 if {![info exists ancestor($np)]} {
3836 set ancestor($np) 1
3837 lappend todo $np
3838 if {$np eq $a} {
3839 set done 1
3843 if {$done} {
3844 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3845 return
3848 set ancestor($a) 0
3849 set anc_todo $leftover
3852 proc askrelhighlight {row id} {
3853 global descendent highlight_related iddrawn rhighlights
3854 global selectedline ancestor
3856 if {$selectedline eq {}} return
3857 set isbold 0
3858 if {$highlight_related eq [mc "Descendant"] ||
3859 $highlight_related eq [mc "Not descendant"]} {
3860 if {![info exists descendent($id)]} {
3861 is_descendent $id
3863 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3864 set isbold 1
3866 } elseif {$highlight_related eq [mc "Ancestor"] ||
3867 $highlight_related eq [mc "Not ancestor"]} {
3868 if {![info exists ancestor($id)]} {
3869 is_ancestor $id
3871 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3872 set isbold 1
3875 if {[info exists iddrawn($id)]} {
3876 if {$isbold && ![ishighlighted $id]} {
3877 bolden $row mainfontbold
3880 set rhighlights($id) $isbold
3883 # Graph layout functions
3885 proc shortids {ids} {
3886 set res {}
3887 foreach id $ids {
3888 if {[llength $id] > 1} {
3889 lappend res [shortids $id]
3890 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3891 lappend res [string range $id 0 7]
3892 } else {
3893 lappend res $id
3896 return $res
3899 proc ntimes {n o} {
3900 set ret {}
3901 set o [list $o]
3902 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3903 if {($n & $mask) != 0} {
3904 set ret [concat $ret $o]
3906 set o [concat $o $o]
3908 return $ret
3911 proc ordertoken {id} {
3912 global ordertok curview varcid varcstart varctok curview parents children
3913 global nullid nullid2
3915 if {[info exists ordertok($id)]} {
3916 return $ordertok($id)
3918 set origid $id
3919 set todo {}
3920 while {1} {
3921 if {[info exists varcid($curview,$id)]} {
3922 set a $varcid($curview,$id)
3923 set p [lindex $varcstart($curview) $a]
3924 } else {
3925 set p [lindex $children($curview,$id) 0]
3927 if {[info exists ordertok($p)]} {
3928 set tok $ordertok($p)
3929 break
3931 set id [first_real_child $curview,$p]
3932 if {$id eq {}} {
3933 # it's a root
3934 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3935 break
3937 if {[llength $parents($curview,$id)] == 1} {
3938 lappend todo [list $p {}]
3939 } else {
3940 set j [lsearch -exact $parents($curview,$id) $p]
3941 if {$j < 0} {
3942 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3944 lappend todo [list $p [strrep $j]]
3947 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3948 set p [lindex $todo $i 0]
3949 append tok [lindex $todo $i 1]
3950 set ordertok($p) $tok
3952 set ordertok($origid) $tok
3953 return $tok
3956 # Work out where id should go in idlist so that order-token
3957 # values increase from left to right
3958 proc idcol {idlist id {i 0}} {
3959 set t [ordertoken $id]
3960 if {$i < 0} {
3961 set i 0
3963 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3964 if {$i > [llength $idlist]} {
3965 set i [llength $idlist]
3967 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3968 incr i
3969 } else {
3970 if {$t > [ordertoken [lindex $idlist $i]]} {
3971 while {[incr i] < [llength $idlist] &&
3972 $t >= [ordertoken [lindex $idlist $i]]} {}
3975 return $i
3978 proc initlayout {} {
3979 global rowidlist rowisopt rowfinal displayorder parentlist
3980 global numcommits canvxmax canv
3981 global nextcolor
3982 global colormap rowtextx
3984 set numcommits 0
3985 set displayorder {}
3986 set parentlist {}
3987 set nextcolor 0
3988 set rowidlist {}
3989 set rowisopt {}
3990 set rowfinal {}
3991 set canvxmax [$canv cget -width]
3992 catch {unset colormap}
3993 catch {unset rowtextx}
3994 setcanvscroll
3997 proc setcanvscroll {} {
3998 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3999 global lastscrollset lastscrollrows
4001 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4002 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4003 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4004 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4005 set lastscrollset [clock clicks -milliseconds]
4006 set lastscrollrows $numcommits
4009 proc visiblerows {} {
4010 global canv numcommits linespc
4012 set ymax [lindex [$canv cget -scrollregion] 3]
4013 if {$ymax eq {} || $ymax == 0} return
4014 set f [$canv yview]
4015 set y0 [expr {int([lindex $f 0] * $ymax)}]
4016 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4017 if {$r0 < 0} {
4018 set r0 0
4020 set y1 [expr {int([lindex $f 1] * $ymax)}]
4021 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4022 if {$r1 >= $numcommits} {
4023 set r1 [expr {$numcommits - 1}]
4025 return [list $r0 $r1]
4028 proc layoutmore {} {
4029 global commitidx viewcomplete curview
4030 global numcommits pending_select curview
4031 global lastscrollset lastscrollrows commitinterest
4033 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4034 [clock clicks -milliseconds] - $lastscrollset > 500} {
4035 setcanvscroll
4037 if {[info exists pending_select] &&
4038 [commitinview $pending_select $curview]} {
4039 selectline [rowofcommit $pending_select] 1
4041 drawvisible
4044 proc doshowlocalchanges {} {
4045 global curview mainheadid
4047 if {$mainheadid eq {}} return
4048 if {[commitinview $mainheadid $curview]} {
4049 dodiffindex
4050 } else {
4051 lappend commitinterest($mainheadid) {dodiffindex}
4055 proc dohidelocalchanges {} {
4056 global nullid nullid2 lserial curview
4058 if {[commitinview $nullid $curview]} {
4059 removefakerow $nullid
4061 if {[commitinview $nullid2 $curview]} {
4062 removefakerow $nullid2
4064 incr lserial
4067 # spawn off a process to do git diff-index --cached HEAD
4068 proc dodiffindex {} {
4069 global lserial showlocalchanges
4070 global isworktree
4072 if {!$showlocalchanges || !$isworktree} return
4073 incr lserial
4074 set fd [open "|git diff-index --cached HEAD" r]
4075 fconfigure $fd -blocking 0
4076 set i [reg_instance $fd]
4077 filerun $fd [list readdiffindex $fd $lserial $i]
4080 proc readdiffindex {fd serial inst} {
4081 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4083 set isdiff 1
4084 if {[gets $fd line] < 0} {
4085 if {![eof $fd]} {
4086 return 1
4088 set isdiff 0
4090 # we only need to see one line and we don't really care what it says...
4091 stop_instance $inst
4093 if {$serial != $lserial} {
4094 return 0
4097 # now see if there are any local changes not checked in to the index
4098 set fd [open "|git diff-files" r]
4099 fconfigure $fd -blocking 0
4100 set i [reg_instance $fd]
4101 filerun $fd [list readdifffiles $fd $serial $i]
4103 if {$isdiff && ![commitinview $nullid2 $curview]} {
4104 # add the line for the changes in the index to the graph
4105 set hl [mc "Local changes checked in to index but not committed"]
4106 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4107 set commitdata($nullid2) "\n $hl\n"
4108 if {[commitinview $nullid $curview]} {
4109 removefakerow $nullid
4111 insertfakerow $nullid2 $mainheadid
4112 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4113 removefakerow $nullid2
4115 return 0
4118 proc readdifffiles {fd serial inst} {
4119 global mainheadid nullid nullid2 curview
4120 global commitinfo commitdata lserial
4122 set isdiff 1
4123 if {[gets $fd line] < 0} {
4124 if {![eof $fd]} {
4125 return 1
4127 set isdiff 0
4129 # we only need to see one line and we don't really care what it says...
4130 stop_instance $inst
4132 if {$serial != $lserial} {
4133 return 0
4136 if {$isdiff && ![commitinview $nullid $curview]} {
4137 # add the line for the local diff to the graph
4138 set hl [mc "Local uncommitted changes, not checked in to index"]
4139 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4140 set commitdata($nullid) "\n $hl\n"
4141 if {[commitinview $nullid2 $curview]} {
4142 set p $nullid2
4143 } else {
4144 set p $mainheadid
4146 insertfakerow $nullid $p
4147 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4148 removefakerow $nullid
4150 return 0
4153 proc nextuse {id row} {
4154 global curview children
4156 if {[info exists children($curview,$id)]} {
4157 foreach kid $children($curview,$id) {
4158 if {![commitinview $kid $curview]} {
4159 return -1
4161 if {[rowofcommit $kid] > $row} {
4162 return [rowofcommit $kid]
4166 if {[commitinview $id $curview]} {
4167 return [rowofcommit $id]
4169 return -1
4172 proc prevuse {id row} {
4173 global curview children
4175 set ret -1
4176 if {[info exists children($curview,$id)]} {
4177 foreach kid $children($curview,$id) {
4178 if {![commitinview $kid $curview]} break
4179 if {[rowofcommit $kid] < $row} {
4180 set ret [rowofcommit $kid]
4184 return $ret
4187 proc make_idlist {row} {
4188 global displayorder parentlist uparrowlen downarrowlen mingaplen
4189 global commitidx curview children
4191 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4192 if {$r < 0} {
4193 set r 0
4195 set ra [expr {$row - $downarrowlen}]
4196 if {$ra < 0} {
4197 set ra 0
4199 set rb [expr {$row + $uparrowlen}]
4200 if {$rb > $commitidx($curview)} {
4201 set rb $commitidx($curview)
4203 make_disporder $r [expr {$rb + 1}]
4204 set ids {}
4205 for {} {$r < $ra} {incr r} {
4206 set nextid [lindex $displayorder [expr {$r + 1}]]
4207 foreach p [lindex $parentlist $r] {
4208 if {$p eq $nextid} continue
4209 set rn [nextuse $p $r]
4210 if {$rn >= $row &&
4211 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4212 lappend ids [list [ordertoken $p] $p]
4216 for {} {$r < $row} {incr r} {
4217 set nextid [lindex $displayorder [expr {$r + 1}]]
4218 foreach p [lindex $parentlist $r] {
4219 if {$p eq $nextid} continue
4220 set rn [nextuse $p $r]
4221 if {$rn < 0 || $rn >= $row} {
4222 lappend ids [list [ordertoken $p] $p]
4226 set id [lindex $displayorder $row]
4227 lappend ids [list [ordertoken $id] $id]
4228 while {$r < $rb} {
4229 foreach p [lindex $parentlist $r] {
4230 set firstkid [lindex $children($curview,$p) 0]
4231 if {[rowofcommit $firstkid] < $row} {
4232 lappend ids [list [ordertoken $p] $p]
4235 incr r
4236 set id [lindex $displayorder $r]
4237 if {$id ne {}} {
4238 set firstkid [lindex $children($curview,$id) 0]
4239 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4240 lappend ids [list [ordertoken $id] $id]
4244 set idlist {}
4245 foreach idx [lsort -unique $ids] {
4246 lappend idlist [lindex $idx 1]
4248 return $idlist
4251 proc rowsequal {a b} {
4252 while {[set i [lsearch -exact $a {}]] >= 0} {
4253 set a [lreplace $a $i $i]
4255 while {[set i [lsearch -exact $b {}]] >= 0} {
4256 set b [lreplace $b $i $i]
4258 return [expr {$a eq $b}]
4261 proc makeupline {id row rend col} {
4262 global rowidlist uparrowlen downarrowlen mingaplen
4264 for {set r $rend} {1} {set r $rstart} {
4265 set rstart [prevuse $id $r]
4266 if {$rstart < 0} return
4267 if {$rstart < $row} break
4269 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4270 set rstart [expr {$rend - $uparrowlen - 1}]
4272 for {set r $rstart} {[incr r] <= $row} {} {
4273 set idlist [lindex $rowidlist $r]
4274 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4275 set col [idcol $idlist $id $col]
4276 lset rowidlist $r [linsert $idlist $col $id]
4277 changedrow $r
4282 proc layoutrows {row endrow} {
4283 global rowidlist rowisopt rowfinal displayorder
4284 global uparrowlen downarrowlen maxwidth mingaplen
4285 global children parentlist
4286 global commitidx viewcomplete curview
4288 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4289 set idlist {}
4290 if {$row > 0} {
4291 set rm1 [expr {$row - 1}]
4292 foreach id [lindex $rowidlist $rm1] {
4293 if {$id ne {}} {
4294 lappend idlist $id
4297 set final [lindex $rowfinal $rm1]
4299 for {} {$row < $endrow} {incr row} {
4300 set rm1 [expr {$row - 1}]
4301 if {$rm1 < 0 || $idlist eq {}} {
4302 set idlist [make_idlist $row]
4303 set final 1
4304 } else {
4305 set id [lindex $displayorder $rm1]
4306 set col [lsearch -exact $idlist $id]
4307 set idlist [lreplace $idlist $col $col]
4308 foreach p [lindex $parentlist $rm1] {
4309 if {[lsearch -exact $idlist $p] < 0} {
4310 set col [idcol $idlist $p $col]
4311 set idlist [linsert $idlist $col $p]
4312 # if not the first child, we have to insert a line going up
4313 if {$id ne [lindex $children($curview,$p) 0]} {
4314 makeupline $p $rm1 $row $col
4318 set id [lindex $displayorder $row]
4319 if {$row > $downarrowlen} {
4320 set termrow [expr {$row - $downarrowlen - 1}]
4321 foreach p [lindex $parentlist $termrow] {
4322 set i [lsearch -exact $idlist $p]
4323 if {$i < 0} continue
4324 set nr [nextuse $p $termrow]
4325 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4326 set idlist [lreplace $idlist $i $i]
4330 set col [lsearch -exact $idlist $id]
4331 if {$col < 0} {
4332 set col [idcol $idlist $id]
4333 set idlist [linsert $idlist $col $id]
4334 if {$children($curview,$id) ne {}} {
4335 makeupline $id $rm1 $row $col
4338 set r [expr {$row + $uparrowlen - 1}]
4339 if {$r < $commitidx($curview)} {
4340 set x $col
4341 foreach p [lindex $parentlist $r] {
4342 if {[lsearch -exact $idlist $p] >= 0} continue
4343 set fk [lindex $children($curview,$p) 0]
4344 if {[rowofcommit $fk] < $row} {
4345 set x [idcol $idlist $p $x]
4346 set idlist [linsert $idlist $x $p]
4349 if {[incr r] < $commitidx($curview)} {
4350 set p [lindex $displayorder $r]
4351 if {[lsearch -exact $idlist $p] < 0} {
4352 set fk [lindex $children($curview,$p) 0]
4353 if {$fk ne {} && [rowofcommit $fk] < $row} {
4354 set x [idcol $idlist $p $x]
4355 set idlist [linsert $idlist $x $p]
4361 if {$final && !$viewcomplete($curview) &&
4362 $row + $uparrowlen + $mingaplen + $downarrowlen
4363 >= $commitidx($curview)} {
4364 set final 0
4366 set l [llength $rowidlist]
4367 if {$row == $l} {
4368 lappend rowidlist $idlist
4369 lappend rowisopt 0
4370 lappend rowfinal $final
4371 } elseif {$row < $l} {
4372 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4373 lset rowidlist $row $idlist
4374 changedrow $row
4376 lset rowfinal $row $final
4377 } else {
4378 set pad [ntimes [expr {$row - $l}] {}]
4379 set rowidlist [concat $rowidlist $pad]
4380 lappend rowidlist $idlist
4381 set rowfinal [concat $rowfinal $pad]
4382 lappend rowfinal $final
4383 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4386 return $row
4389 proc changedrow {row} {
4390 global displayorder iddrawn rowisopt need_redisplay
4392 set l [llength $rowisopt]
4393 if {$row < $l} {
4394 lset rowisopt $row 0
4395 if {$row + 1 < $l} {
4396 lset rowisopt [expr {$row + 1}] 0
4397 if {$row + 2 < $l} {
4398 lset rowisopt [expr {$row + 2}] 0
4402 set id [lindex $displayorder $row]
4403 if {[info exists iddrawn($id)]} {
4404 set need_redisplay 1
4408 proc insert_pad {row col npad} {
4409 global rowidlist
4411 set pad [ntimes $npad {}]
4412 set idlist [lindex $rowidlist $row]
4413 set bef [lrange $idlist 0 [expr {$col - 1}]]
4414 set aft [lrange $idlist $col end]
4415 set i [lsearch -exact $aft {}]
4416 if {$i > 0} {
4417 set aft [lreplace $aft $i $i]
4419 lset rowidlist $row [concat $bef $pad $aft]
4420 changedrow $row
4423 proc optimize_rows {row col endrow} {
4424 global rowidlist rowisopt displayorder curview children
4426 if {$row < 1} {
4427 set row 1
4429 for {} {$row < $endrow} {incr row; set col 0} {
4430 if {[lindex $rowisopt $row]} continue
4431 set haspad 0
4432 set y0 [expr {$row - 1}]
4433 set ym [expr {$row - 2}]
4434 set idlist [lindex $rowidlist $row]
4435 set previdlist [lindex $rowidlist $y0]
4436 if {$idlist eq {} || $previdlist eq {}} continue
4437 if {$ym >= 0} {
4438 set pprevidlist [lindex $rowidlist $ym]
4439 if {$pprevidlist eq {}} continue
4440 } else {
4441 set pprevidlist {}
4443 set x0 -1
4444 set xm -1
4445 for {} {$col < [llength $idlist]} {incr col} {
4446 set id [lindex $idlist $col]
4447 if {[lindex $previdlist $col] eq $id} continue
4448 if {$id eq {}} {
4449 set haspad 1
4450 continue
4452 set x0 [lsearch -exact $previdlist $id]
4453 if {$x0 < 0} continue
4454 set z [expr {$x0 - $col}]
4455 set isarrow 0
4456 set z0 {}
4457 if {$ym >= 0} {
4458 set xm [lsearch -exact $pprevidlist $id]
4459 if {$xm >= 0} {
4460 set z0 [expr {$xm - $x0}]
4463 if {$z0 eq {}} {
4464 # if row y0 is the first child of $id then it's not an arrow
4465 if {[lindex $children($curview,$id) 0] ne
4466 [lindex $displayorder $y0]} {
4467 set isarrow 1
4470 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4471 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4472 set isarrow 1
4474 # Looking at lines from this row to the previous row,
4475 # make them go straight up if they end in an arrow on
4476 # the previous row; otherwise make them go straight up
4477 # or at 45 degrees.
4478 if {$z < -1 || ($z < 0 && $isarrow)} {
4479 # Line currently goes left too much;
4480 # insert pads in the previous row, then optimize it
4481 set npad [expr {-1 - $z + $isarrow}]
4482 insert_pad $y0 $x0 $npad
4483 if {$y0 > 0} {
4484 optimize_rows $y0 $x0 $row
4486 set previdlist [lindex $rowidlist $y0]
4487 set x0 [lsearch -exact $previdlist $id]
4488 set z [expr {$x0 - $col}]
4489 if {$z0 ne {}} {
4490 set pprevidlist [lindex $rowidlist $ym]
4491 set xm [lsearch -exact $pprevidlist $id]
4492 set z0 [expr {$xm - $x0}]
4494 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4495 # Line currently goes right too much;
4496 # insert pads in this line
4497 set npad [expr {$z - 1 + $isarrow}]
4498 insert_pad $row $col $npad
4499 set idlist [lindex $rowidlist $row]
4500 incr col $npad
4501 set z [expr {$x0 - $col}]
4502 set haspad 1
4504 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4505 # this line links to its first child on row $row-2
4506 set id [lindex $displayorder $ym]
4507 set xc [lsearch -exact $pprevidlist $id]
4508 if {$xc >= 0} {
4509 set z0 [expr {$xc - $x0}]
4512 # avoid lines jigging left then immediately right
4513 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4514 insert_pad $y0 $x0 1
4515 incr x0
4516 optimize_rows $y0 $x0 $row
4517 set previdlist [lindex $rowidlist $y0]
4520 if {!$haspad} {
4521 # Find the first column that doesn't have a line going right
4522 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4523 set id [lindex $idlist $col]
4524 if {$id eq {}} break
4525 set x0 [lsearch -exact $previdlist $id]
4526 if {$x0 < 0} {
4527 # check if this is the link to the first child
4528 set kid [lindex $displayorder $y0]
4529 if {[lindex $children($curview,$id) 0] eq $kid} {
4530 # it is, work out offset to child
4531 set x0 [lsearch -exact $previdlist $kid]
4534 if {$x0 <= $col} break
4536 # Insert a pad at that column as long as it has a line and
4537 # isn't the last column
4538 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4539 set idlist [linsert $idlist $col {}]
4540 lset rowidlist $row $idlist
4541 changedrow $row
4547 proc xc {row col} {
4548 global canvx0 linespc
4549 return [expr {$canvx0 + $col * $linespc}]
4552 proc yc {row} {
4553 global canvy0 linespc
4554 return [expr {$canvy0 + $row * $linespc}]
4557 proc linewidth {id} {
4558 global thickerline lthickness
4560 set wid $lthickness
4561 if {[info exists thickerline] && $id eq $thickerline} {
4562 set wid [expr {2 * $lthickness}]
4564 return $wid
4567 proc rowranges {id} {
4568 global curview children uparrowlen downarrowlen
4569 global rowidlist
4571 set kids $children($curview,$id)
4572 if {$kids eq {}} {
4573 return {}
4575 set ret {}
4576 lappend kids $id
4577 foreach child $kids {
4578 if {![commitinview $child $curview]} break
4579 set row [rowofcommit $child]
4580 if {![info exists prev]} {
4581 lappend ret [expr {$row + 1}]
4582 } else {
4583 if {$row <= $prevrow} {
4584 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4586 # see if the line extends the whole way from prevrow to row
4587 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4588 [lsearch -exact [lindex $rowidlist \
4589 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4590 # it doesn't, see where it ends
4591 set r [expr {$prevrow + $downarrowlen}]
4592 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4593 while {[incr r -1] > $prevrow &&
4594 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4595 } else {
4596 while {[incr r] <= $row &&
4597 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4598 incr r -1
4600 lappend ret $r
4601 # see where it starts up again
4602 set r [expr {$row - $uparrowlen}]
4603 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4604 while {[incr r] < $row &&
4605 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4606 } else {
4607 while {[incr r -1] >= $prevrow &&
4608 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4609 incr r
4611 lappend ret $r
4614 if {$child eq $id} {
4615 lappend ret $row
4617 set prev $child
4618 set prevrow $row
4620 return $ret
4623 proc drawlineseg {id row endrow arrowlow} {
4624 global rowidlist displayorder iddrawn linesegs
4625 global canv colormap linespc curview maxlinelen parentlist
4627 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4628 set le [expr {$row + 1}]
4629 set arrowhigh 1
4630 while {1} {
4631 set c [lsearch -exact [lindex $rowidlist $le] $id]
4632 if {$c < 0} {
4633 incr le -1
4634 break
4636 lappend cols $c
4637 set x [lindex $displayorder $le]
4638 if {$x eq $id} {
4639 set arrowhigh 0
4640 break
4642 if {[info exists iddrawn($x)] || $le == $endrow} {
4643 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4644 if {$c >= 0} {
4645 lappend cols $c
4646 set arrowhigh 0
4648 break
4650 incr le
4652 if {$le <= $row} {
4653 return $row
4656 set lines {}
4657 set i 0
4658 set joinhigh 0
4659 if {[info exists linesegs($id)]} {
4660 set lines $linesegs($id)
4661 foreach li $lines {
4662 set r0 [lindex $li 0]
4663 if {$r0 > $row} {
4664 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4665 set joinhigh 1
4667 break
4669 incr i
4672 set joinlow 0
4673 if {$i > 0} {
4674 set li [lindex $lines [expr {$i-1}]]
4675 set r1 [lindex $li 1]
4676 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4677 set joinlow 1
4681 set x [lindex $cols [expr {$le - $row}]]
4682 set xp [lindex $cols [expr {$le - 1 - $row}]]
4683 set dir [expr {$xp - $x}]
4684 if {$joinhigh} {
4685 set ith [lindex $lines $i 2]
4686 set coords [$canv coords $ith]
4687 set ah [$canv itemcget $ith -arrow]
4688 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4689 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4690 if {$x2 ne {} && $x - $x2 == $dir} {
4691 set coords [lrange $coords 0 end-2]
4693 } else {
4694 set coords [list [xc $le $x] [yc $le]]
4696 if {$joinlow} {
4697 set itl [lindex $lines [expr {$i-1}] 2]
4698 set al [$canv itemcget $itl -arrow]
4699 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4700 } elseif {$arrowlow} {
4701 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4702 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4703 set arrowlow 0
4706 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4707 for {set y $le} {[incr y -1] > $row} {} {
4708 set x $xp
4709 set xp [lindex $cols [expr {$y - 1 - $row}]]
4710 set ndir [expr {$xp - $x}]
4711 if {$dir != $ndir || $xp < 0} {
4712 lappend coords [xc $y $x] [yc $y]
4714 set dir $ndir
4716 if {!$joinlow} {
4717 if {$xp < 0} {
4718 # join parent line to first child
4719 set ch [lindex $displayorder $row]
4720 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4721 if {$xc < 0} {
4722 puts "oops: drawlineseg: child $ch not on row $row"
4723 } elseif {$xc != $x} {
4724 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4725 set d [expr {int(0.5 * $linespc)}]
4726 set x1 [xc $row $x]
4727 if {$xc < $x} {
4728 set x2 [expr {$x1 - $d}]
4729 } else {
4730 set x2 [expr {$x1 + $d}]
4732 set y2 [yc $row]
4733 set y1 [expr {$y2 + $d}]
4734 lappend coords $x1 $y1 $x2 $y2
4735 } elseif {$xc < $x - 1} {
4736 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4737 } elseif {$xc > $x + 1} {
4738 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4740 set x $xc
4742 lappend coords [xc $row $x] [yc $row]
4743 } else {
4744 set xn [xc $row $xp]
4745 set yn [yc $row]
4746 lappend coords $xn $yn
4748 if {!$joinhigh} {
4749 assigncolor $id
4750 set t [$canv create line $coords -width [linewidth $id] \
4751 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4752 $canv lower $t
4753 bindline $t $id
4754 set lines [linsert $lines $i [list $row $le $t]]
4755 } else {
4756 $canv coords $ith $coords
4757 if {$arrow ne $ah} {
4758 $canv itemconf $ith -arrow $arrow
4760 lset lines $i 0 $row
4762 } else {
4763 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4764 set ndir [expr {$xo - $xp}]
4765 set clow [$canv coords $itl]
4766 if {$dir == $ndir} {
4767 set clow [lrange $clow 2 end]
4769 set coords [concat $coords $clow]
4770 if {!$joinhigh} {
4771 lset lines [expr {$i-1}] 1 $le
4772 } else {
4773 # coalesce two pieces
4774 $canv delete $ith
4775 set b [lindex $lines [expr {$i-1}] 0]
4776 set e [lindex $lines $i 1]
4777 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4779 $canv coords $itl $coords
4780 if {$arrow ne $al} {
4781 $canv itemconf $itl -arrow $arrow
4785 set linesegs($id) $lines
4786 return $le
4789 proc drawparentlinks {id row} {
4790 global rowidlist canv colormap curview parentlist
4791 global idpos linespc
4793 set rowids [lindex $rowidlist $row]
4794 set col [lsearch -exact $rowids $id]
4795 if {$col < 0} return
4796 set olds [lindex $parentlist $row]
4797 set row2 [expr {$row + 1}]
4798 set x [xc $row $col]
4799 set y [yc $row]
4800 set y2 [yc $row2]
4801 set d [expr {int(0.5 * $linespc)}]
4802 set ymid [expr {$y + $d}]
4803 set ids [lindex $rowidlist $row2]
4804 # rmx = right-most X coord used
4805 set rmx 0
4806 foreach p $olds {
4807 set i [lsearch -exact $ids $p]
4808 if {$i < 0} {
4809 puts "oops, parent $p of $id not in list"
4810 continue
4812 set x2 [xc $row2 $i]
4813 if {$x2 > $rmx} {
4814 set rmx $x2
4816 set j [lsearch -exact $rowids $p]
4817 if {$j < 0} {
4818 # drawlineseg will do this one for us
4819 continue
4821 assigncolor $p
4822 # should handle duplicated parents here...
4823 set coords [list $x $y]
4824 if {$i != $col} {
4825 # if attaching to a vertical segment, draw a smaller
4826 # slant for visual distinctness
4827 if {$i == $j} {
4828 if {$i < $col} {
4829 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4830 } else {
4831 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4833 } elseif {$i < $col && $i < $j} {
4834 # segment slants towards us already
4835 lappend coords [xc $row $j] $y
4836 } else {
4837 if {$i < $col - 1} {
4838 lappend coords [expr {$x2 + $linespc}] $y
4839 } elseif {$i > $col + 1} {
4840 lappend coords [expr {$x2 - $linespc}] $y
4842 lappend coords $x2 $y2
4844 } else {
4845 lappend coords $x2 $y2
4847 set t [$canv create line $coords -width [linewidth $p] \
4848 -fill $colormap($p) -tags lines.$p]
4849 $canv lower $t
4850 bindline $t $p
4852 if {$rmx > [lindex $idpos($id) 1]} {
4853 lset idpos($id) 1 $rmx
4854 redrawtags $id
4858 proc drawlines {id} {
4859 global canv
4861 $canv itemconf lines.$id -width [linewidth $id]
4864 proc drawcmittext {id row col} {
4865 global linespc canv canv2 canv3 fgcolor curview
4866 global cmitlisted commitinfo rowidlist parentlist
4867 global rowtextx idpos idtags idheads idotherrefs
4868 global linehtag linentag linedtag selectedline
4869 global canvxmax boldrows boldnamerows fgcolor
4870 global mainheadid nullid nullid2 circleitem circlecolors
4872 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4873 set listed $cmitlisted($curview,$id)
4874 if {$id eq $nullid} {
4875 set ofill red
4876 } elseif {$id eq $nullid2} {
4877 set ofill green
4878 } elseif {$id eq $mainheadid} {
4879 set ofill yellow
4880 } else {
4881 set ofill [lindex $circlecolors $listed]
4883 set x [xc $row $col]
4884 set y [yc $row]
4885 set orad [expr {$linespc / 3}]
4886 if {$listed <= 2} {
4887 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4888 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4889 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4890 } elseif {$listed == 3} {
4891 # triangle pointing left for left-side commits
4892 set t [$canv create polygon \
4893 [expr {$x - $orad}] $y \
4894 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4895 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4896 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4897 } else {
4898 # triangle pointing right for right-side commits
4899 set t [$canv create polygon \
4900 [expr {$x + $orad - 1}] $y \
4901 [expr {$x - $orad}] [expr {$y - $orad}] \
4902 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4903 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4905 set circleitem($row) $t
4906 $canv raise $t
4907 $canv bind $t <1> {selcanvline {} %x %y}
4908 set rmx [llength [lindex $rowidlist $row]]
4909 set olds [lindex $parentlist $row]
4910 if {$olds ne {}} {
4911 set nextids [lindex $rowidlist [expr {$row + 1}]]
4912 foreach p $olds {
4913 set i [lsearch -exact $nextids $p]
4914 if {$i > $rmx} {
4915 set rmx $i
4919 set xt [xc $row $rmx]
4920 set rowtextx($row) $xt
4921 set idpos($id) [list $x $xt $y]
4922 if {[info exists idtags($id)] || [info exists idheads($id)]
4923 || [info exists idotherrefs($id)]} {
4924 set xt [drawtags $id $x $xt $y]
4926 set headline [lindex $commitinfo($id) 0]
4927 set name [lindex $commitinfo($id) 1]
4928 set date [lindex $commitinfo($id) 2]
4929 set date [formatdate $date]
4930 set font mainfont
4931 set nfont mainfont
4932 set isbold [ishighlighted $id]
4933 if {$isbold > 0} {
4934 lappend boldrows $row
4935 set font mainfontbold
4936 if {$isbold > 1} {
4937 lappend boldnamerows $row
4938 set nfont mainfontbold
4941 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4942 -text $headline -font $font -tags text]
4943 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4944 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4945 -text $name -font $nfont -tags text]
4946 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4947 -text $date -font mainfont -tags text]
4948 if {$selectedline == $row} {
4949 make_secsel $row
4951 set xr [expr {$xt + [font measure $font $headline]}]
4952 if {$xr > $canvxmax} {
4953 set canvxmax $xr
4954 setcanvscroll
4958 proc drawcmitrow {row} {
4959 global displayorder rowidlist nrows_drawn
4960 global iddrawn markingmatches
4961 global commitinfo numcommits
4962 global filehighlight fhighlights findpattern nhighlights
4963 global hlview vhighlights
4964 global highlight_related rhighlights
4966 if {$row >= $numcommits} return
4968 set id [lindex $displayorder $row]
4969 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4970 askvhighlight $row $id
4972 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4973 askfilehighlight $row $id
4975 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4976 askfindhighlight $row $id
4978 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4979 askrelhighlight $row $id
4981 if {![info exists iddrawn($id)]} {
4982 set col [lsearch -exact [lindex $rowidlist $row] $id]
4983 if {$col < 0} {
4984 puts "oops, row $row id $id not in list"
4985 return
4987 if {![info exists commitinfo($id)]} {
4988 getcommit $id
4990 assigncolor $id
4991 drawcmittext $id $row $col
4992 set iddrawn($id) 1
4993 incr nrows_drawn
4995 if {$markingmatches} {
4996 markrowmatches $row $id
5000 proc drawcommits {row {endrow {}}} {
5001 global numcommits iddrawn displayorder curview need_redisplay
5002 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5004 if {$row < 0} {
5005 set row 0
5007 if {$endrow eq {}} {
5008 set endrow $row
5010 if {$endrow >= $numcommits} {
5011 set endrow [expr {$numcommits - 1}]
5014 set rl1 [expr {$row - $downarrowlen - 3}]
5015 if {$rl1 < 0} {
5016 set rl1 0
5018 set ro1 [expr {$row - 3}]
5019 if {$ro1 < 0} {
5020 set ro1 0
5022 set r2 [expr {$endrow + $uparrowlen + 3}]
5023 if {$r2 > $numcommits} {
5024 set r2 $numcommits
5026 for {set r $rl1} {$r < $r2} {incr r} {
5027 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5028 if {$rl1 < $r} {
5029 layoutrows $rl1 $r
5031 set rl1 [expr {$r + 1}]
5034 if {$rl1 < $r} {
5035 layoutrows $rl1 $r
5037 optimize_rows $ro1 0 $r2
5038 if {$need_redisplay || $nrows_drawn > 2000} {
5039 clear_display
5040 drawvisible
5043 # make the lines join to already-drawn rows either side
5044 set r [expr {$row - 1}]
5045 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5046 set r $row
5048 set er [expr {$endrow + 1}]
5049 if {$er >= $numcommits ||
5050 ![info exists iddrawn([lindex $displayorder $er])]} {
5051 set er $endrow
5053 for {} {$r <= $er} {incr r} {
5054 set id [lindex $displayorder $r]
5055 set wasdrawn [info exists iddrawn($id)]
5056 drawcmitrow $r
5057 if {$r == $er} break
5058 set nextid [lindex $displayorder [expr {$r + 1}]]
5059 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5060 drawparentlinks $id $r
5062 set rowids [lindex $rowidlist $r]
5063 foreach lid $rowids {
5064 if {$lid eq {}} continue
5065 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5066 if {$lid eq $id} {
5067 # see if this is the first child of any of its parents
5068 foreach p [lindex $parentlist $r] {
5069 if {[lsearch -exact $rowids $p] < 0} {
5070 # make this line extend up to the child
5071 set lineend($p) [drawlineseg $p $r $er 0]
5074 } else {
5075 set lineend($lid) [drawlineseg $lid $r $er 1]
5081 proc undolayout {row} {
5082 global uparrowlen mingaplen downarrowlen
5083 global rowidlist rowisopt rowfinal need_redisplay
5085 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5086 if {$r < 0} {
5087 set r 0
5089 if {[llength $rowidlist] > $r} {
5090 incr r -1
5091 set rowidlist [lrange $rowidlist 0 $r]
5092 set rowfinal [lrange $rowfinal 0 $r]
5093 set rowisopt [lrange $rowisopt 0 $r]
5094 set need_redisplay 1
5095 run drawvisible
5099 proc drawvisible {} {
5100 global canv linespc curview vrowmod selectedline targetrow targetid
5101 global need_redisplay cscroll numcommits
5103 set fs [$canv yview]
5104 set ymax [lindex [$canv cget -scrollregion] 3]
5105 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5106 set f0 [lindex $fs 0]
5107 set f1 [lindex $fs 1]
5108 set y0 [expr {int($f0 * $ymax)}]
5109 set y1 [expr {int($f1 * $ymax)}]
5111 if {[info exists targetid]} {
5112 if {[commitinview $targetid $curview]} {
5113 set r [rowofcommit $targetid]
5114 if {$r != $targetrow} {
5115 # Fix up the scrollregion and change the scrolling position
5116 # now that our target row has moved.
5117 set diff [expr {($r - $targetrow) * $linespc}]
5118 set targetrow $r
5119 setcanvscroll
5120 set ymax [lindex [$canv cget -scrollregion] 3]
5121 incr y0 $diff
5122 incr y1 $diff
5123 set f0 [expr {$y0 / $ymax}]
5124 set f1 [expr {$y1 / $ymax}]
5125 allcanvs yview moveto $f0
5126 $cscroll set $f0 $f1
5127 set need_redisplay 1
5129 } else {
5130 unset targetid
5134 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5135 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5136 if {$endrow >= $vrowmod($curview)} {
5137 update_arcrows $curview
5139 if {$selectedline ne {} &&
5140 $row <= $selectedline && $selectedline <= $endrow} {
5141 set targetrow $selectedline
5142 } elseif {[info exists targetid]} {
5143 set targetrow [expr {int(($row + $endrow) / 2)}]
5145 if {[info exists targetrow]} {
5146 if {$targetrow >= $numcommits} {
5147 set targetrow [expr {$numcommits - 1}]
5149 set targetid [commitonrow $targetrow]
5151 drawcommits $row $endrow
5154 proc clear_display {} {
5155 global iddrawn linesegs need_redisplay nrows_drawn
5156 global vhighlights fhighlights nhighlights rhighlights
5157 global linehtag linentag linedtag boldrows boldnamerows
5159 allcanvs delete all
5160 catch {unset iddrawn}
5161 catch {unset linesegs}
5162 catch {unset linehtag}
5163 catch {unset linentag}
5164 catch {unset linedtag}
5165 set boldrows {}
5166 set boldnamerows {}
5167 catch {unset vhighlights}
5168 catch {unset fhighlights}
5169 catch {unset nhighlights}
5170 catch {unset rhighlights}
5171 set need_redisplay 0
5172 set nrows_drawn 0
5175 proc findcrossings {id} {
5176 global rowidlist parentlist numcommits displayorder
5178 set cross {}
5179 set ccross {}
5180 foreach {s e} [rowranges $id] {
5181 if {$e >= $numcommits} {
5182 set e [expr {$numcommits - 1}]
5184 if {$e <= $s} continue
5185 for {set row $e} {[incr row -1] >= $s} {} {
5186 set x [lsearch -exact [lindex $rowidlist $row] $id]
5187 if {$x < 0} break
5188 set olds [lindex $parentlist $row]
5189 set kid [lindex $displayorder $row]
5190 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5191 if {$kidx < 0} continue
5192 set nextrow [lindex $rowidlist [expr {$row + 1}]]
5193 foreach p $olds {
5194 set px [lsearch -exact $nextrow $p]
5195 if {$px < 0} continue
5196 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5197 if {[lsearch -exact $ccross $p] >= 0} continue
5198 if {$x == $px + ($kidx < $px? -1: 1)} {
5199 lappend ccross $p
5200 } elseif {[lsearch -exact $cross $p] < 0} {
5201 lappend cross $p
5207 return [concat $ccross {{}} $cross]
5210 proc assigncolor {id} {
5211 global colormap colors nextcolor
5212 global parents children children curview
5214 if {[info exists colormap($id)]} return
5215 set ncolors [llength $colors]
5216 if {[info exists children($curview,$id)]} {
5217 set kids $children($curview,$id)
5218 } else {
5219 set kids {}
5221 if {[llength $kids] == 1} {
5222 set child [lindex $kids 0]
5223 if {[info exists colormap($child)]
5224 && [llength $parents($curview,$child)] == 1} {
5225 set colormap($id) $colormap($child)
5226 return
5229 set badcolors {}
5230 set origbad {}
5231 foreach x [findcrossings $id] {
5232 if {$x eq {}} {
5233 # delimiter between corner crossings and other crossings
5234 if {[llength $badcolors] >= $ncolors - 1} break
5235 set origbad $badcolors
5237 if {[info exists colormap($x)]
5238 && [lsearch -exact $badcolors $colormap($x)] < 0} {
5239 lappend badcolors $colormap($x)
5242 if {[llength $badcolors] >= $ncolors} {
5243 set badcolors $origbad
5245 set origbad $badcolors
5246 if {[llength $badcolors] < $ncolors - 1} {
5247 foreach child $kids {
5248 if {[info exists colormap($child)]
5249 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5250 lappend badcolors $colormap($child)
5252 foreach p $parents($curview,$child) {
5253 if {[info exists colormap($p)]
5254 && [lsearch -exact $badcolors $colormap($p)] < 0} {
5255 lappend badcolors $colormap($p)
5259 if {[llength $badcolors] >= $ncolors} {
5260 set badcolors $origbad
5263 for {set i 0} {$i <= $ncolors} {incr i} {
5264 set c [lindex $colors $nextcolor]
5265 if {[incr nextcolor] >= $ncolors} {
5266 set nextcolor 0
5268 if {[lsearch -exact $badcolors $c]} break
5270 set colormap($id) $c
5273 proc bindline {t id} {
5274 global canv
5276 $canv bind $t <Enter> "lineenter %x %y $id"
5277 $canv bind $t <Motion> "linemotion %x %y $id"
5278 $canv bind $t <Leave> "lineleave $id"
5279 $canv bind $t <Button-1> "lineclick %x %y $id 1"
5282 proc drawtags {id x xt y1} {
5283 global idtags idheads idotherrefs mainhead
5284 global linespc lthickness
5285 global canv rowtextx curview fgcolor bgcolor
5287 set marks {}
5288 set ntags 0
5289 set nheads 0
5290 if {[info exists idtags($id)]} {
5291 set marks $idtags($id)
5292 set ntags [llength $marks]
5294 if {[info exists idheads($id)]} {
5295 set marks [concat $marks $idheads($id)]
5296 set nheads [llength $idheads($id)]
5298 if {[info exists idotherrefs($id)]} {
5299 set marks [concat $marks $idotherrefs($id)]
5301 if {$marks eq {}} {
5302 return $xt
5305 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5306 set yt [expr {$y1 - 0.5 * $linespc}]
5307 set yb [expr {$yt + $linespc - 1}]
5308 set xvals {}
5309 set wvals {}
5310 set i -1
5311 foreach tag $marks {
5312 incr i
5313 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5314 set wid [font measure mainfontbold $tag]
5315 } else {
5316 set wid [font measure mainfont $tag]
5318 lappend xvals $xt
5319 lappend wvals $wid
5320 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5322 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5323 -width $lthickness -fill black -tags tag.$id]
5324 $canv lower $t
5325 foreach tag $marks x $xvals wid $wvals {
5326 set xl [expr {$x + $delta}]
5327 set xr [expr {$x + $delta + $wid + $lthickness}]
5328 set font mainfont
5329 if {[incr ntags -1] >= 0} {
5330 # draw a tag
5331 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5332 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5333 -width 1 -outline black -fill yellow -tags tag.$id]
5334 $canv bind $t <1> [list showtag $tag 1]
5335 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5336 } else {
5337 # draw a head or other ref
5338 if {[incr nheads -1] >= 0} {
5339 set col green
5340 if {$tag eq $mainhead} {
5341 set font mainfontbold
5343 } else {
5344 set col "#ddddff"
5346 set xl [expr {$xl - $delta/2}]
5347 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5348 -width 1 -outline black -fill $col -tags tag.$id
5349 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5350 set rwid [font measure mainfont $remoteprefix]
5351 set xi [expr {$x + 1}]
5352 set yti [expr {$yt + 1}]
5353 set xri [expr {$x + $rwid}]
5354 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5355 -width 0 -fill "#ffddaa" -tags tag.$id
5358 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5359 -font $font -tags [list tag.$id text]]
5360 if {$ntags >= 0} {
5361 $canv bind $t <1> [list showtag $tag 1]
5362 } elseif {$nheads >= 0} {
5363 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
5366 return $xt
5369 proc xcoord {i level ln} {
5370 global canvx0 xspc1 xspc2
5372 set x [expr {$canvx0 + $i * $xspc1($ln)}]
5373 if {$i > 0 && $i == $level} {
5374 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5375 } elseif {$i > $level} {
5376 set x [expr {$x + $xspc2 - $xspc1($ln)}]
5378 return $x
5381 proc show_status {msg} {
5382 global canv fgcolor
5384 clear_display
5385 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5386 -tags text -fill $fgcolor
5389 # Don't change the text pane cursor if it is currently the hand cursor,
5390 # showing that we are over a sha1 ID link.
5391 proc settextcursor {c} {
5392 global ctext curtextcursor
5394 if {[$ctext cget -cursor] == $curtextcursor} {
5395 $ctext config -cursor $c
5397 set curtextcursor $c
5400 proc nowbusy {what {name {}}} {
5401 global isbusy busyname statusw
5403 if {[array names isbusy] eq {}} {
5404 . config -cursor watch
5405 settextcursor watch
5407 set isbusy($what) 1
5408 set busyname($what) $name
5409 if {$name ne {}} {
5410 $statusw conf -text $name
5414 proc notbusy {what} {
5415 global isbusy maincursor textcursor busyname statusw
5417 catch {
5418 unset isbusy($what)
5419 if {$busyname($what) ne {} &&
5420 [$statusw cget -text] eq $busyname($what)} {
5421 $statusw conf -text {}
5424 if {[array names isbusy] eq {}} {
5425 . config -cursor $maincursor
5426 settextcursor $textcursor
5430 proc findmatches {f} {
5431 global findtype findstring
5432 if {$findtype == [mc "Regexp"]} {
5433 set matches [regexp -indices -all -inline $findstring $f]
5434 } else {
5435 set fs $findstring
5436 if {$findtype == [mc "IgnCase"]} {
5437 set f [string tolower $f]
5438 set fs [string tolower $fs]
5440 set matches {}
5441 set i 0
5442 set l [string length $fs]
5443 while {[set j [string first $fs $f $i]] >= 0} {
5444 lappend matches [list $j [expr {$j+$l-1}]]
5445 set i [expr {$j + $l}]
5448 return $matches
5451 proc dofind {{dirn 1} {wrap 1}} {
5452 global findstring findstartline findcurline selectedline numcommits
5453 global gdttype filehighlight fh_serial find_dirn findallowwrap
5455 if {[info exists find_dirn]} {
5456 if {$find_dirn == $dirn} return
5457 stopfinding
5459 focus .
5460 if {$findstring eq {} || $numcommits == 0} return
5461 if {$selectedline eq {}} {
5462 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5463 } else {
5464 set findstartline $selectedline
5466 set findcurline $findstartline
5467 nowbusy finding [mc "Searching"]
5468 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5469 after cancel do_file_hl $fh_serial
5470 do_file_hl $fh_serial
5472 set find_dirn $dirn
5473 set findallowwrap $wrap
5474 run findmore
5477 proc stopfinding {} {
5478 global find_dirn findcurline fprogcoord
5480 if {[info exists find_dirn]} {
5481 unset find_dirn
5482 unset findcurline
5483 notbusy finding
5484 set fprogcoord 0
5485 adjustprogress
5489 proc findmore {} {
5490 global commitdata commitinfo numcommits findpattern findloc
5491 global findstartline findcurline findallowwrap
5492 global find_dirn gdttype fhighlights fprogcoord
5493 global curview varcorder vrownum varccommits vrowmod
5495 if {![info exists find_dirn]} {
5496 return 0
5498 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5499 set l $findcurline
5500 set moretodo 0
5501 if {$find_dirn > 0} {
5502 incr l
5503 if {$l >= $numcommits} {
5504 set l 0
5506 if {$l <= $findstartline} {
5507 set lim [expr {$findstartline + 1}]
5508 } else {
5509 set lim $numcommits
5510 set moretodo $findallowwrap
5512 } else {
5513 if {$l == 0} {
5514 set l $numcommits
5516 incr l -1
5517 if {$l >= $findstartline} {
5518 set lim [expr {$findstartline - 1}]
5519 } else {
5520 set lim -1
5521 set moretodo $findallowwrap
5524 set n [expr {($lim - $l) * $find_dirn}]
5525 if {$n > 500} {
5526 set n 500
5527 set moretodo 1
5529 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5530 update_arcrows $curview
5532 set found 0
5533 set domore 1
5534 set ai [bsearch $vrownum($curview) $l]
5535 set a [lindex $varcorder($curview) $ai]
5536 set arow [lindex $vrownum($curview) $ai]
5537 set ids [lindex $varccommits($curview,$a)]
5538 set arowend [expr {$arow + [llength $ids]}]
5539 if {$gdttype eq [mc "containing:"]} {
5540 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5541 if {$l < $arow || $l >= $arowend} {
5542 incr ai $find_dirn
5543 set a [lindex $varcorder($curview) $ai]
5544 set arow [lindex $vrownum($curview) $ai]
5545 set ids [lindex $varccommits($curview,$a)]
5546 set arowend [expr {$arow + [llength $ids]}]
5548 set id [lindex $ids [expr {$l - $arow}]]
5549 # shouldn't happen unless git log doesn't give all the commits...
5550 if {![info exists commitdata($id)] ||
5551 ![doesmatch $commitdata($id)]} {
5552 continue
5554 if {![info exists commitinfo($id)]} {
5555 getcommit $id
5557 set info $commitinfo($id)
5558 foreach f $info ty $fldtypes {
5559 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5560 [doesmatch $f]} {
5561 set found 1
5562 break
5565 if {$found} break
5567 } else {
5568 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5569 if {$l < $arow || $l >= $arowend} {
5570 incr ai $find_dirn
5571 set a [lindex $varcorder($curview) $ai]
5572 set arow [lindex $vrownum($curview) $ai]
5573 set ids [lindex $varccommits($curview,$a)]
5574 set arowend [expr {$arow + [llength $ids]}]
5576 set id [lindex $ids [expr {$l - $arow}]]
5577 if {![info exists fhighlights($id)]} {
5578 # this sets fhighlights($id) to -1
5579 askfilehighlight $l $id
5581 if {$fhighlights($id) > 0} {
5582 set found $domore
5583 break
5585 if {$fhighlights($id) < 0} {
5586 if {$domore} {
5587 set domore 0
5588 set findcurline [expr {$l - $find_dirn}]
5593 if {$found || ($domore && !$moretodo)} {
5594 unset findcurline
5595 unset find_dirn
5596 notbusy finding
5597 set fprogcoord 0
5598 adjustprogress
5599 if {$found} {
5600 findselectline $l
5601 } else {
5602 bell
5604 return 0
5606 if {!$domore} {
5607 flushhighlights
5608 } else {
5609 set findcurline [expr {$l - $find_dirn}]
5611 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5612 if {$n < 0} {
5613 incr n $numcommits
5615 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5616 adjustprogress
5617 return $domore
5620 proc findselectline {l} {
5621 global findloc commentend ctext findcurline markingmatches gdttype
5623 set markingmatches 1
5624 set findcurline $l
5625 selectline $l 1
5626 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5627 # highlight the matches in the comments
5628 set f [$ctext get 1.0 $commentend]
5629 set matches [findmatches $f]
5630 foreach match $matches {
5631 set start [lindex $match 0]
5632 set end [expr {[lindex $match 1] + 1}]
5633 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5636 drawvisible
5639 # mark the bits of a headline or author that match a find string
5640 proc markmatches {canv l str tag matches font row} {
5641 global selectedline
5643 set bbox [$canv bbox $tag]
5644 set x0 [lindex $bbox 0]
5645 set y0 [lindex $bbox 1]
5646 set y1 [lindex $bbox 3]
5647 foreach match $matches {
5648 set start [lindex $match 0]
5649 set end [lindex $match 1]
5650 if {$start > $end} continue
5651 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5652 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5653 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5654 [expr {$x0+$xlen+2}] $y1 \
5655 -outline {} -tags [list match$l matches] -fill yellow]
5656 $canv lower $t
5657 if {$row == $selectedline} {
5658 $canv raise $t secsel
5663 proc unmarkmatches {} {
5664 global markingmatches
5666 allcanvs delete matches
5667 set markingmatches 0
5668 stopfinding
5671 proc selcanvline {w x y} {
5672 global canv canvy0 ctext linespc
5673 global rowtextx
5674 set ymax [lindex [$canv cget -scrollregion] 3]
5675 if {$ymax == {}} return
5676 set yfrac [lindex [$canv yview] 0]
5677 set y [expr {$y + $yfrac * $ymax}]
5678 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5679 if {$l < 0} {
5680 set l 0
5682 if {$w eq $canv} {
5683 set xmax [lindex [$canv cget -scrollregion] 2]
5684 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5685 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5687 unmarkmatches
5688 selectline $l 1
5691 proc commit_descriptor {p} {
5692 global commitinfo
5693 if {![info exists commitinfo($p)]} {
5694 getcommit $p
5696 set l "..."
5697 if {[llength $commitinfo($p)] > 1} {
5698 set l [lindex $commitinfo($p) 0]
5700 return "$p ($l)\n"
5703 # append some text to the ctext widget, and make any SHA1 ID
5704 # that we know about be a clickable link.
5705 proc appendwithlinks {text tags} {
5706 global ctext linknum curview pendinglinks
5708 set start [$ctext index "end - 1c"]
5709 $ctext insert end $text $tags
5710 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5711 foreach l $links {
5712 set s [lindex $l 0]
5713 set e [lindex $l 1]
5714 set linkid [string range $text $s $e]
5715 incr e
5716 $ctext tag delete link$linknum
5717 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5718 setlink $linkid link$linknum
5719 incr linknum
5723 proc setlink {id lk} {
5724 global curview ctext pendinglinks commitinterest
5726 if {[commitinview $id $curview]} {
5727 $ctext tag conf $lk -foreground blue -underline 1
5728 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5729 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5730 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5731 } else {
5732 lappend pendinglinks($id) $lk
5733 lappend commitinterest($id) {makelink %I}
5737 proc makelink {id} {
5738 global pendinglinks
5740 if {![info exists pendinglinks($id)]} return
5741 foreach lk $pendinglinks($id) {
5742 setlink $id $lk
5744 unset pendinglinks($id)
5747 proc linkcursor {w inc} {
5748 global linkentercount curtextcursor
5750 if {[incr linkentercount $inc] > 0} {
5751 $w configure -cursor hand2
5752 } else {
5753 $w configure -cursor $curtextcursor
5754 if {$linkentercount < 0} {
5755 set linkentercount 0
5760 proc viewnextline {dir} {
5761 global canv linespc
5763 $canv delete hover
5764 set ymax [lindex [$canv cget -scrollregion] 3]
5765 set wnow [$canv yview]
5766 set wtop [expr {[lindex $wnow 0] * $ymax}]
5767 set newtop [expr {$wtop + $dir * $linespc}]
5768 if {$newtop < 0} {
5769 set newtop 0
5770 } elseif {$newtop > $ymax} {
5771 set newtop $ymax
5773 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5776 # add a list of tag or branch names at position pos
5777 # returns the number of names inserted
5778 proc appendrefs {pos ids var} {
5779 global ctext linknum curview $var maxrefs
5781 if {[catch {$ctext index $pos}]} {
5782 return 0
5784 $ctext conf -state normal
5785 $ctext delete $pos "$pos lineend"
5786 set tags {}
5787 foreach id $ids {
5788 foreach tag [set $var\($id\)] {
5789 lappend tags [list $tag $id]
5792 if {[llength $tags] > $maxrefs} {
5793 $ctext insert $pos "many ([llength $tags])"
5794 } else {
5795 set tags [lsort -index 0 -decreasing $tags]
5796 set sep {}
5797 foreach ti $tags {
5798 set id [lindex $ti 1]
5799 set lk link$linknum
5800 incr linknum
5801 $ctext tag delete $lk
5802 $ctext insert $pos $sep
5803 $ctext insert $pos [lindex $ti 0] $lk
5804 setlink $id $lk
5805 set sep ", "
5808 $ctext conf -state disabled
5809 return [llength $tags]
5812 # called when we have finished computing the nearby tags
5813 proc dispneartags {delay} {
5814 global selectedline currentid showneartags tagphase
5816 if {$selectedline eq {} || !$showneartags} return
5817 after cancel dispnexttag
5818 if {$delay} {
5819 after 200 dispnexttag
5820 set tagphase -1
5821 } else {
5822 after idle dispnexttag
5823 set tagphase 0
5827 proc dispnexttag {} {
5828 global selectedline currentid showneartags tagphase ctext
5830 if {$selectedline eq {} || !$showneartags} return
5831 switch -- $tagphase {
5833 set dtags [desctags $currentid]
5834 if {$dtags ne {}} {
5835 appendrefs precedes $dtags idtags
5839 set atags [anctags $currentid]
5840 if {$atags ne {}} {
5841 appendrefs follows $atags idtags
5845 set dheads [descheads $currentid]
5846 if {$dheads ne {}} {
5847 if {[appendrefs branch $dheads idheads] > 1
5848 && [$ctext get "branch -3c"] eq "h"} {
5849 # turn "Branch" into "Branches"
5850 $ctext conf -state normal
5851 $ctext insert "branch -2c" "es"
5852 $ctext conf -state disabled
5857 if {[incr tagphase] <= 2} {
5858 after idle dispnexttag
5862 proc make_secsel {l} {
5863 global linehtag linentag linedtag canv canv2 canv3
5865 if {![info exists linehtag($l)]} return
5866 $canv delete secsel
5867 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5868 -tags secsel -fill [$canv cget -selectbackground]]
5869 $canv lower $t
5870 $canv2 delete secsel
5871 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5872 -tags secsel -fill [$canv2 cget -selectbackground]]
5873 $canv2 lower $t
5874 $canv3 delete secsel
5875 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5876 -tags secsel -fill [$canv3 cget -selectbackground]]
5877 $canv3 lower $t
5880 proc selectline {l isnew} {
5881 global canv ctext commitinfo selectedline
5882 global canvy0 linespc parents children curview
5883 global currentid sha1entry
5884 global commentend idtags linknum
5885 global mergemax numcommits pending_select
5886 global cmitmode showneartags allcommits
5887 global targetrow targetid lastscrollrows
5888 global autoselect
5890 catch {unset pending_select}
5891 $canv delete hover
5892 normalline
5893 unsel_reflist
5894 stopfinding
5895 if {$l < 0 || $l >= $numcommits} return
5896 set id [commitonrow $l]
5897 set targetid $id
5898 set targetrow $l
5899 set selectedline $l
5900 set currentid $id
5901 if {$lastscrollrows < $numcommits} {
5902 setcanvscroll
5905 set y [expr {$canvy0 + $l * $linespc}]
5906 set ymax [lindex [$canv cget -scrollregion] 3]
5907 set ytop [expr {$y - $linespc - 1}]
5908 set ybot [expr {$y + $linespc + 1}]
5909 set wnow [$canv yview]
5910 set wtop [expr {[lindex $wnow 0] * $ymax}]
5911 set wbot [expr {[lindex $wnow 1] * $ymax}]
5912 set wh [expr {$wbot - $wtop}]
5913 set newtop $wtop
5914 if {$ytop < $wtop} {
5915 if {$ybot < $wtop} {
5916 set newtop [expr {$y - $wh / 2.0}]
5917 } else {
5918 set newtop $ytop
5919 if {$newtop > $wtop - $linespc} {
5920 set newtop [expr {$wtop - $linespc}]
5923 } elseif {$ybot > $wbot} {
5924 if {$ytop > $wbot} {
5925 set newtop [expr {$y - $wh / 2.0}]
5926 } else {
5927 set newtop [expr {$ybot - $wh}]
5928 if {$newtop < $wtop + $linespc} {
5929 set newtop [expr {$wtop + $linespc}]
5933 if {$newtop != $wtop} {
5934 if {$newtop < 0} {
5935 set newtop 0
5937 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5938 drawvisible
5941 make_secsel $l
5943 if {$isnew} {
5944 addtohistory [list selbyid $id]
5947 $sha1entry delete 0 end
5948 $sha1entry insert 0 $id
5949 if {$autoselect} {
5950 $sha1entry selection from 0
5951 $sha1entry selection to end
5953 rhighlight_sel $id
5955 $ctext conf -state normal
5956 clear_ctext
5957 set linknum 0
5958 if {![info exists commitinfo($id)]} {
5959 getcommit $id
5961 set info $commitinfo($id)
5962 set date [formatdate [lindex $info 2]]
5963 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5964 set date [formatdate [lindex $info 4]]
5965 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5966 if {[info exists idtags($id)]} {
5967 $ctext insert end [mc "Tags:"]
5968 foreach tag $idtags($id) {
5969 $ctext insert end " $tag"
5971 $ctext insert end "\n"
5974 set headers {}
5975 set olds $parents($curview,$id)
5976 if {[llength $olds] > 1} {
5977 set np 0
5978 foreach p $olds {
5979 if {$np >= $mergemax} {
5980 set tag mmax
5981 } else {
5982 set tag m$np
5984 $ctext insert end "[mc "Parent"]: " $tag
5985 appendwithlinks [commit_descriptor $p] {}
5986 incr np
5988 } else {
5989 foreach p $olds {
5990 append headers "[mc "Parent"]: [commit_descriptor $p]"
5994 foreach c $children($curview,$id) {
5995 append headers "[mc "Child"]: [commit_descriptor $c]"
5998 # make anything that looks like a SHA1 ID be a clickable link
5999 appendwithlinks $headers {}
6000 if {$showneartags} {
6001 if {![info exists allcommits]} {
6002 getallcommits
6004 $ctext insert end "[mc "Branch"]: "
6005 $ctext mark set branch "end -1c"
6006 $ctext mark gravity branch left
6007 $ctext insert end "\n[mc "Follows"]: "
6008 $ctext mark set follows "end -1c"
6009 $ctext mark gravity follows left
6010 $ctext insert end "\n[mc "Precedes"]: "
6011 $ctext mark set precedes "end -1c"
6012 $ctext mark gravity precedes left
6013 $ctext insert end "\n"
6014 dispneartags 1
6016 $ctext insert end "\n"
6017 set comment [lindex $info 5]
6018 if {[string first "\r" $comment] >= 0} {
6019 set comment [string map {"\r" "\n "} $comment]
6021 appendwithlinks $comment {comment}
6023 $ctext tag remove found 1.0 end
6024 $ctext conf -state disabled
6025 set commentend [$ctext index "end - 1c"]
6027 init_flist [mc "Comments"]
6028 if {$cmitmode eq "tree"} {
6029 gettree $id
6030 } elseif {[llength $olds] <= 1} {
6031 startdiff $id
6032 } else {
6033 mergediff $id
6037 proc selfirstline {} {
6038 unmarkmatches
6039 selectline 0 1
6042 proc sellastline {} {
6043 global numcommits
6044 unmarkmatches
6045 set l [expr {$numcommits - 1}]
6046 selectline $l 1
6049 proc selnextline {dir} {
6050 global selectedline
6051 focus .
6052 if {$selectedline eq {}} return
6053 set l [expr {$selectedline + $dir}]
6054 unmarkmatches
6055 selectline $l 1
6058 proc selnextpage {dir} {
6059 global canv linespc selectedline numcommits
6061 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6062 if {$lpp < 1} {
6063 set lpp 1
6065 allcanvs yview scroll [expr {$dir * $lpp}] units
6066 drawvisible
6067 if {$selectedline eq {}} return
6068 set l [expr {$selectedline + $dir * $lpp}]
6069 if {$l < 0} {
6070 set l 0
6071 } elseif {$l >= $numcommits} {
6072 set l [expr $numcommits - 1]
6074 unmarkmatches
6075 selectline $l 1
6078 proc unselectline {} {
6079 global selectedline currentid
6081 set selectedline {}
6082 catch {unset currentid}
6083 allcanvs delete secsel
6084 rhighlight_none
6087 proc reselectline {} {
6088 global selectedline
6090 if {$selectedline ne {}} {
6091 selectline $selectedline 0
6095 proc addtohistory {cmd} {
6096 global history historyindex curview
6098 set elt [list $curview $cmd]
6099 if {$historyindex > 0
6100 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6101 return
6104 if {$historyindex < [llength $history]} {
6105 set history [lreplace $history $historyindex end $elt]
6106 } else {
6107 lappend history $elt
6109 incr historyindex
6110 if {$historyindex > 1} {
6111 .tf.bar.leftbut conf -state normal
6112 } else {
6113 .tf.bar.leftbut conf -state disabled
6115 .tf.bar.rightbut conf -state disabled
6118 proc godo {elt} {
6119 global curview
6121 set view [lindex $elt 0]
6122 set cmd [lindex $elt 1]
6123 if {$curview != $view} {
6124 showview $view
6126 eval $cmd
6129 proc goback {} {
6130 global history historyindex
6131 focus .
6133 if {$historyindex > 1} {
6134 incr historyindex -1
6135 godo [lindex $history [expr {$historyindex - 1}]]
6136 .tf.bar.rightbut conf -state normal
6138 if {$historyindex <= 1} {
6139 .tf.bar.leftbut conf -state disabled
6143 proc goforw {} {
6144 global history historyindex
6145 focus .
6147 if {$historyindex < [llength $history]} {
6148 set cmd [lindex $history $historyindex]
6149 incr historyindex
6150 godo $cmd
6151 .tf.bar.leftbut conf -state normal
6153 if {$historyindex >= [llength $history]} {
6154 .tf.bar.rightbut conf -state disabled
6158 proc gettree {id} {
6159 global treefilelist treeidlist diffids diffmergeid treepending
6160 global nullid nullid2
6162 set diffids $id
6163 catch {unset diffmergeid}
6164 if {![info exists treefilelist($id)]} {
6165 if {![info exists treepending]} {
6166 if {$id eq $nullid} {
6167 set cmd [list | git ls-files]
6168 } elseif {$id eq $nullid2} {
6169 set cmd [list | git ls-files --stage -t]
6170 } else {
6171 set cmd [list | git ls-tree -r $id]
6173 if {[catch {set gtf [open $cmd r]}]} {
6174 return
6176 set treepending $id
6177 set treefilelist($id) {}
6178 set treeidlist($id) {}
6179 fconfigure $gtf -blocking 0
6180 filerun $gtf [list gettreeline $gtf $id]
6182 } else {
6183 setfilelist $id
6187 proc gettreeline {gtf id} {
6188 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6190 set nl 0
6191 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6192 if {$diffids eq $nullid} {
6193 set fname $line
6194 } else {
6195 set i [string first "\t" $line]
6196 if {$i < 0} continue
6197 set fname [string range $line [expr {$i+1}] end]
6198 set line [string range $line 0 [expr {$i-1}]]
6199 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6200 set sha1 [lindex $line 2]
6201 if {[string index $fname 0] eq "\""} {
6202 set fname [lindex $fname 0]
6204 lappend treeidlist($id) $sha1
6206 lappend treefilelist($id) $fname
6208 if {![eof $gtf]} {
6209 return [expr {$nl >= 1000? 2: 1}]
6211 close $gtf
6212 unset treepending
6213 if {$cmitmode ne "tree"} {
6214 if {![info exists diffmergeid]} {
6215 gettreediffs $diffids
6217 } elseif {$id ne $diffids} {
6218 gettree $diffids
6219 } else {
6220 setfilelist $id
6222 return 0
6225 proc showfile {f} {
6226 global treefilelist treeidlist diffids nullid nullid2
6227 global ctext commentend
6229 set i [lsearch -exact $treefilelist($diffids) $f]
6230 if {$i < 0} {
6231 puts "oops, $f not in list for id $diffids"
6232 return
6234 if {$diffids eq $nullid} {
6235 if {[catch {set bf [open $f r]} err]} {
6236 puts "oops, can't read $f: $err"
6237 return
6239 } else {
6240 set blob [lindex $treeidlist($diffids) $i]
6241 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6242 puts "oops, error reading blob $blob: $err"
6243 return
6246 fconfigure $bf -blocking 0
6247 filerun $bf [list getblobline $bf $diffids]
6248 $ctext config -state normal
6249 clear_ctext $commentend
6250 $ctext insert end "\n"
6251 $ctext insert end "$f\n" filesep
6252 $ctext config -state disabled
6253 $ctext yview $commentend
6254 settabs 0
6257 proc getblobline {bf id} {
6258 global diffids cmitmode ctext
6260 if {$id ne $diffids || $cmitmode ne "tree"} {
6261 catch {close $bf}
6262 return 0
6264 $ctext config -state normal
6265 set nl 0
6266 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6267 $ctext insert end "$line\n"
6269 if {[eof $bf]} {
6270 # delete last newline
6271 $ctext delete "end - 2c" "end - 1c"
6272 close $bf
6273 return 0
6275 $ctext config -state disabled
6276 return [expr {$nl >= 1000? 2: 1}]
6279 proc mergediff {id} {
6280 global diffmergeid mdifffd
6281 global diffids
6282 global parents
6283 global diffcontext
6284 global limitdiffs vfilelimit curview
6286 set diffmergeid $id
6287 set diffids $id
6288 # this doesn't seem to actually affect anything...
6289 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6290 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6291 set cmd [concat $cmd -- $vfilelimit($curview)]
6293 if {[catch {set mdf [open $cmd r]} err]} {
6294 error_popup "[mc "Error getting merge diffs:"] $err"
6295 return
6297 fconfigure $mdf -blocking 0
6298 set mdifffd($id) $mdf
6299 set np [llength $parents($curview,$id)]
6300 settabs $np
6301 filerun $mdf [list getmergediffline $mdf $id $np]
6304 proc getmergediffline {mdf id np} {
6305 global diffmergeid ctext cflist mergemax
6306 global difffilestart mdifffd
6308 $ctext conf -state normal
6309 set nr 0
6310 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6311 if {![info exists diffmergeid] || $id != $diffmergeid
6312 || $mdf != $mdifffd($id)} {
6313 close $mdf
6314 return 0
6316 if {[regexp {^diff --cc (.*)} $line match fname]} {
6317 # start of a new file
6318 $ctext insert end "\n"
6319 set here [$ctext index "end - 1c"]
6320 lappend difffilestart $here
6321 add_flist [list $fname]
6322 set l [expr {(78 - [string length $fname]) / 2}]
6323 set pad [string range "----------------------------------------" 1 $l]
6324 $ctext insert end "$pad $fname $pad\n" filesep
6325 } elseif {[regexp {^@@} $line]} {
6326 $ctext insert end "$line\n" hunksep
6327 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6328 # do nothing
6329 } else {
6330 # parse the prefix - one ' ', '-' or '+' for each parent
6331 set spaces {}
6332 set minuses {}
6333 set pluses {}
6334 set isbad 0
6335 for {set j 0} {$j < $np} {incr j} {
6336 set c [string range $line $j $j]
6337 if {$c == " "} {
6338 lappend spaces $j
6339 } elseif {$c == "-"} {
6340 lappend minuses $j
6341 } elseif {$c == "+"} {
6342 lappend pluses $j
6343 } else {
6344 set isbad 1
6345 break
6348 set tags {}
6349 set num {}
6350 if {!$isbad && $minuses ne {} && $pluses eq {}} {
6351 # line doesn't appear in result, parents in $minuses have the line
6352 set num [lindex $minuses 0]
6353 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6354 # line appears in result, parents in $pluses don't have the line
6355 lappend tags mresult
6356 set num [lindex $spaces 0]
6358 if {$num ne {}} {
6359 if {$num >= $mergemax} {
6360 set num "max"
6362 lappend tags m$num
6364 $ctext insert end "$line\n" $tags
6367 $ctext conf -state disabled
6368 if {[eof $mdf]} {
6369 close $mdf
6370 return 0
6372 return [expr {$nr >= 1000? 2: 1}]
6375 proc startdiff {ids} {
6376 global treediffs diffids treepending diffmergeid nullid nullid2
6378 settabs 1
6379 set diffids $ids
6380 catch {unset diffmergeid}
6381 if {![info exists treediffs($ids)] ||
6382 [lsearch -exact $ids $nullid] >= 0 ||
6383 [lsearch -exact $ids $nullid2] >= 0} {
6384 if {![info exists treepending]} {
6385 gettreediffs $ids
6387 } else {
6388 addtocflist $ids
6392 proc path_filter {filter name} {
6393 foreach p $filter {
6394 set l [string length $p]
6395 if {[string index $p end] eq "/"} {
6396 if {[string compare -length $l $p $name] == 0} {
6397 return 1
6399 } else {
6400 if {[string compare -length $l $p $name] == 0 &&
6401 ([string length $name] == $l ||
6402 [string index $name $l] eq "/")} {
6403 return 1
6407 return 0
6410 proc addtocflist {ids} {
6411 global treediffs
6413 add_flist $treediffs($ids)
6414 getblobdiffs $ids
6417 proc diffcmd {ids flags} {
6418 global nullid nullid2
6420 set i [lsearch -exact $ids $nullid]
6421 set j [lsearch -exact $ids $nullid2]
6422 if {$i >= 0} {
6423 if {[llength $ids] > 1 && $j < 0} {
6424 # comparing working directory with some specific revision
6425 set cmd [concat | git diff-index $flags]
6426 if {$i == 0} {
6427 lappend cmd -R [lindex $ids 1]
6428 } else {
6429 lappend cmd [lindex $ids 0]
6431 } else {
6432 # comparing working directory with index
6433 set cmd [concat | git diff-files $flags]
6434 if {$j == 1} {
6435 lappend cmd -R
6438 } elseif {$j >= 0} {
6439 set cmd [concat | git diff-index --cached $flags]
6440 if {[llength $ids] > 1} {
6441 # comparing index with specific revision
6442 if {$i == 0} {
6443 lappend cmd -R [lindex $ids 1]
6444 } else {
6445 lappend cmd [lindex $ids 0]
6447 } else {
6448 # comparing index with HEAD
6449 lappend cmd HEAD
6451 } else {
6452 set cmd [concat | git diff-tree -r $flags $ids]
6454 return $cmd
6457 proc gettreediffs {ids} {
6458 global treediff treepending
6460 set treepending $ids
6461 set treediff {}
6462 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6463 fconfigure $gdtf -blocking 0
6464 filerun $gdtf [list gettreediffline $gdtf $ids]
6467 proc gettreediffline {gdtf ids} {
6468 global treediff treediffs treepending diffids diffmergeid
6469 global cmitmode vfilelimit curview limitdiffs
6471 set nr 0
6472 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6473 set i [string first "\t" $line]
6474 if {$i >= 0} {
6475 set file [string range $line [expr {$i+1}] end]
6476 if {[string index $file 0] eq "\""} {
6477 set file [lindex $file 0]
6479 lappend treediff $file
6482 if {![eof $gdtf]} {
6483 return [expr {$nr >= 1000? 2: 1}]
6485 close $gdtf
6486 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6487 set flist {}
6488 foreach f $treediff {
6489 if {[path_filter $vfilelimit($curview) $f]} {
6490 lappend flist $f
6493 set treediffs($ids) $flist
6494 } else {
6495 set treediffs($ids) $treediff
6497 unset treepending
6498 if {$cmitmode eq "tree"} {
6499 gettree $diffids
6500 } elseif {$ids != $diffids} {
6501 if {![info exists diffmergeid]} {
6502 gettreediffs $diffids
6504 } else {
6505 addtocflist $ids
6507 return 0
6510 # empty string or positive integer
6511 proc diffcontextvalidate {v} {
6512 return [regexp {^(|[1-9][0-9]*)$} $v]
6515 proc diffcontextchange {n1 n2 op} {
6516 global diffcontextstring diffcontext
6518 if {[string is integer -strict $diffcontextstring]} {
6519 if {$diffcontextstring > 0} {
6520 set diffcontext $diffcontextstring
6521 reselectline
6526 proc changeignorespace {} {
6527 reselectline
6530 proc getblobdiffs {ids} {
6531 global blobdifffd diffids env
6532 global diffinhdr treediffs
6533 global diffcontext
6534 global ignorespace
6535 global limitdiffs vfilelimit curview
6537 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6538 if {$ignorespace} {
6539 append cmd " -w"
6541 if {$limitdiffs && $vfilelimit($curview) ne {}} {
6542 set cmd [concat $cmd -- $vfilelimit($curview)]
6544 if {[catch {set bdf [open $cmd r]} err]} {
6545 puts "error getting diffs: $err"
6546 return
6548 set diffinhdr 0
6549 fconfigure $bdf -blocking 0
6550 set blobdifffd($ids) $bdf
6551 filerun $bdf [list getblobdiffline $bdf $diffids]
6554 proc setinlist {var i val} {
6555 global $var
6557 while {[llength [set $var]] < $i} {
6558 lappend $var {}
6560 if {[llength [set $var]] == $i} {
6561 lappend $var $val
6562 } else {
6563 lset $var $i $val
6567 proc makediffhdr {fname ids} {
6568 global ctext curdiffstart treediffs
6570 set i [lsearch -exact $treediffs($ids) $fname]
6571 if {$i >= 0} {
6572 setinlist difffilestart $i $curdiffstart
6574 set l [expr {(78 - [string length $fname]) / 2}]
6575 set pad [string range "----------------------------------------" 1 $l]
6576 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6579 proc getblobdiffline {bdf ids} {
6580 global diffids blobdifffd ctext curdiffstart
6581 global diffnexthead diffnextnote difffilestart
6582 global diffinhdr treediffs
6584 set nr 0
6585 $ctext conf -state normal
6586 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6587 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6588 close $bdf
6589 return 0
6591 if {![string compare -length 11 "diff --git " $line]} {
6592 # trim off "diff --git "
6593 set line [string range $line 11 end]
6594 set diffinhdr 1
6595 # start of a new file
6596 $ctext insert end "\n"
6597 set curdiffstart [$ctext index "end - 1c"]
6598 $ctext insert end "\n" filesep
6599 # If the name hasn't changed the length will be odd,
6600 # the middle char will be a space, and the two bits either
6601 # side will be a/name and b/name, or "a/name" and "b/name".
6602 # If the name has changed we'll get "rename from" and
6603 # "rename to" or "copy from" and "copy to" lines following this,
6604 # and we'll use them to get the filenames.
6605 # This complexity is necessary because spaces in the filename(s)
6606 # don't get escaped.
6607 set l [string length $line]
6608 set i [expr {$l / 2}]
6609 if {!(($l & 1) && [string index $line $i] eq " " &&
6610 [string range $line 2 [expr {$i - 1}]] eq \
6611 [string range $line [expr {$i + 3}] end])} {
6612 continue
6614 # unescape if quoted and chop off the a/ from the front
6615 if {[string index $line 0] eq "\""} {
6616 set fname [string range [lindex $line 0] 2 end]
6617 } else {
6618 set fname [string range $line 2 [expr {$i - 1}]]
6620 makediffhdr $fname $ids
6622 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6623 $line match f1l f1c f2l f2c rest]} {
6624 $ctext insert end "$line\n" hunksep
6625 set diffinhdr 0
6627 } elseif {$diffinhdr} {
6628 if {![string compare -length 12 "rename from " $line]} {
6629 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6630 if {[string index $fname 0] eq "\""} {
6631 set fname [lindex $fname 0]
6633 set i [lsearch -exact $treediffs($ids) $fname]
6634 if {$i >= 0} {
6635 setinlist difffilestart $i $curdiffstart
6637 } elseif {![string compare -length 10 $line "rename to "] ||
6638 ![string compare -length 8 $line "copy to "]} {
6639 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6640 if {[string index $fname 0] eq "\""} {
6641 set fname [lindex $fname 0]
6643 makediffhdr $fname $ids
6644 } elseif {[string compare -length 3 $line "---"] == 0} {
6645 # do nothing
6646 continue
6647 } elseif {[string compare -length 3 $line "+++"] == 0} {
6648 set diffinhdr 0
6649 continue
6651 $ctext insert end "$line\n" filesep
6653 } else {
6654 set x [string range $line 0 0]
6655 if {$x == "-" || $x == "+"} {
6656 set tag [expr {$x == "+"}]
6657 $ctext insert end "$line\n" d$tag
6658 } elseif {$x == " "} {
6659 $ctext insert end "$line\n"
6660 } else {
6661 # "\ No newline at end of file",
6662 # or something else we don't recognize
6663 $ctext insert end "$line\n" hunksep
6667 $ctext conf -state disabled
6668 if {[eof $bdf]} {
6669 close $bdf
6670 return 0
6672 return [expr {$nr >= 1000? 2: 1}]
6675 proc changediffdisp {} {
6676 global ctext diffelide
6678 $ctext tag conf d0 -elide [lindex $diffelide 0]
6679 $ctext tag conf d1 -elide [lindex $diffelide 1]
6682 proc highlightfile {loc cline} {
6683 global ctext cflist cflist_top
6685 $ctext yview $loc
6686 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6687 $cflist tag add highlight $cline.0 "$cline.0 lineend"
6688 $cflist see $cline.0
6689 set cflist_top $cline
6692 proc prevfile {} {
6693 global difffilestart ctext cmitmode
6695 if {$cmitmode eq "tree"} return
6696 set prev 0.0
6697 set prevline 1
6698 set here [$ctext index @0,0]
6699 foreach loc $difffilestart {
6700 if {[$ctext compare $loc >= $here]} {
6701 highlightfile $prev $prevline
6702 return
6704 set prev $loc
6705 incr prevline
6707 highlightfile $prev $prevline
6710 proc nextfile {} {
6711 global difffilestart ctext cmitmode
6713 if {$cmitmode eq "tree"} return
6714 set here [$ctext index @0,0]
6715 set line 1
6716 foreach loc $difffilestart {
6717 incr line
6718 if {[$ctext compare $loc > $here]} {
6719 highlightfile $loc $line
6720 return
6725 proc clear_ctext {{first 1.0}} {
6726 global ctext smarktop smarkbot
6727 global pendinglinks
6729 set l [lindex [split $first .] 0]
6730 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6731 set smarktop $l
6733 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6734 set smarkbot $l
6736 $ctext delete $first end
6737 if {$first eq "1.0"} {
6738 catch {unset pendinglinks}
6742 proc settabs {{firstab {}}} {
6743 global firsttabstop tabstop ctext have_tk85
6745 if {$firstab ne {} && $have_tk85} {
6746 set firsttabstop $firstab
6748 set w [font measure textfont "0"]
6749 if {$firsttabstop != 0} {
6750 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6751 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6752 } elseif {$have_tk85 || $tabstop != 8} {
6753 $ctext conf -tabs [expr {$tabstop * $w}]
6754 } else {
6755 $ctext conf -tabs {}
6759 proc incrsearch {name ix op} {
6760 global ctext searchstring searchdirn
6762 $ctext tag remove found 1.0 end
6763 if {[catch {$ctext index anchor}]} {
6764 # no anchor set, use start of selection, or of visible area
6765 set sel [$ctext tag ranges sel]
6766 if {$sel ne {}} {
6767 $ctext mark set anchor [lindex $sel 0]
6768 } elseif {$searchdirn eq "-forwards"} {
6769 $ctext mark set anchor @0,0
6770 } else {
6771 $ctext mark set anchor @0,[winfo height $ctext]
6774 if {$searchstring ne {}} {
6775 set here [$ctext search $searchdirn -- $searchstring anchor]
6776 if {$here ne {}} {
6777 $ctext see $here
6779 searchmarkvisible 1
6783 proc dosearch {} {
6784 global sstring ctext searchstring searchdirn
6786 focus $sstring
6787 $sstring icursor end
6788 set searchdirn -forwards
6789 if {$searchstring ne {}} {
6790 set sel [$ctext tag ranges sel]
6791 if {$sel ne {}} {
6792 set start "[lindex $sel 0] + 1c"
6793 } elseif {[catch {set start [$ctext index anchor]}]} {
6794 set start "@0,0"
6796 set match [$ctext search -count mlen -- $searchstring $start]
6797 $ctext tag remove sel 1.0 end
6798 if {$match eq {}} {
6799 bell
6800 return
6802 $ctext see $match
6803 set mend "$match + $mlen c"
6804 $ctext tag add sel $match $mend
6805 $ctext mark unset anchor
6809 proc dosearchback {} {
6810 global sstring ctext searchstring searchdirn
6812 focus $sstring
6813 $sstring icursor end
6814 set searchdirn -backwards
6815 if {$searchstring ne {}} {
6816 set sel [$ctext tag ranges sel]
6817 if {$sel ne {}} {
6818 set start [lindex $sel 0]
6819 } elseif {[catch {set start [$ctext index anchor]}]} {
6820 set start @0,[winfo height $ctext]
6822 set match [$ctext search -backwards -count ml -- $searchstring $start]
6823 $ctext tag remove sel 1.0 end
6824 if {$match eq {}} {
6825 bell
6826 return
6828 $ctext see $match
6829 set mend "$match + $ml c"
6830 $ctext tag add sel $match $mend
6831 $ctext mark unset anchor
6835 proc searchmark {first last} {
6836 global ctext searchstring
6838 set mend $first.0
6839 while {1} {
6840 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6841 if {$match eq {}} break
6842 set mend "$match + $mlen c"
6843 $ctext tag add found $match $mend
6847 proc searchmarkvisible {doall} {
6848 global ctext smarktop smarkbot
6850 set topline [lindex [split [$ctext index @0,0] .] 0]
6851 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6852 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6853 # no overlap with previous
6854 searchmark $topline $botline
6855 set smarktop $topline
6856 set smarkbot $botline
6857 } else {
6858 if {$topline < $smarktop} {
6859 searchmark $topline [expr {$smarktop-1}]
6860 set smarktop $topline
6862 if {$botline > $smarkbot} {
6863 searchmark [expr {$smarkbot+1}] $botline
6864 set smarkbot $botline
6869 proc scrolltext {f0 f1} {
6870 global searchstring
6872 .bleft.bottom.sb set $f0 $f1
6873 if {$searchstring ne {}} {
6874 searchmarkvisible 0
6878 proc setcoords {} {
6879 global linespc charspc canvx0 canvy0
6880 global xspc1 xspc2 lthickness
6882 set linespc [font metrics mainfont -linespace]
6883 set charspc [font measure mainfont "m"]
6884 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6885 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6886 set lthickness [expr {int($linespc / 9) + 1}]
6887 set xspc1(0) $linespc
6888 set xspc2 $linespc
6891 proc redisplay {} {
6892 global canv
6893 global selectedline
6895 set ymax [lindex [$canv cget -scrollregion] 3]
6896 if {$ymax eq {} || $ymax == 0} return
6897 set span [$canv yview]
6898 clear_display
6899 setcanvscroll
6900 allcanvs yview moveto [lindex $span 0]
6901 drawvisible
6902 if {$selectedline ne {}} {
6903 selectline $selectedline 0
6904 allcanvs yview moveto [lindex $span 0]
6908 proc parsefont {f n} {
6909 global fontattr
6911 set fontattr($f,family) [lindex $n 0]
6912 set s [lindex $n 1]
6913 if {$s eq {} || $s == 0} {
6914 set s 10
6915 } elseif {$s < 0} {
6916 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6918 set fontattr($f,size) $s
6919 set fontattr($f,weight) normal
6920 set fontattr($f,slant) roman
6921 foreach style [lrange $n 2 end] {
6922 switch -- $style {
6923 "normal" -
6924 "bold" {set fontattr($f,weight) $style}
6925 "roman" -
6926 "italic" {set fontattr($f,slant) $style}
6931 proc fontflags {f {isbold 0}} {
6932 global fontattr
6934 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6935 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6936 -slant $fontattr($f,slant)]
6939 proc fontname {f} {
6940 global fontattr
6942 set n [list $fontattr($f,family) $fontattr($f,size)]
6943 if {$fontattr($f,weight) eq "bold"} {
6944 lappend n "bold"
6946 if {$fontattr($f,slant) eq "italic"} {
6947 lappend n "italic"
6949 return $n
6952 proc incrfont {inc} {
6953 global mainfont textfont ctext canv cflist showrefstop
6954 global stopped entries fontattr
6956 unmarkmatches
6957 set s $fontattr(mainfont,size)
6958 incr s $inc
6959 if {$s < 1} {
6960 set s 1
6962 set fontattr(mainfont,size) $s
6963 font config mainfont -size $s
6964 font config mainfontbold -size $s
6965 set mainfont [fontname mainfont]
6966 set s $fontattr(textfont,size)
6967 incr s $inc
6968 if {$s < 1} {
6969 set s 1
6971 set fontattr(textfont,size) $s
6972 font config textfont -size $s
6973 font config textfontbold -size $s
6974 set textfont [fontname textfont]
6975 setcoords
6976 settabs
6977 redisplay
6980 proc clearsha1 {} {
6981 global sha1entry sha1string
6982 if {[string length $sha1string] == 40} {
6983 $sha1entry delete 0 end
6987 proc sha1change {n1 n2 op} {
6988 global sha1string currentid sha1but
6989 if {$sha1string == {}
6990 || ([info exists currentid] && $sha1string == $currentid)} {
6991 set state disabled
6992 } else {
6993 set state normal
6995 if {[$sha1but cget -state] == $state} return
6996 if {$state == "normal"} {
6997 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6998 } else {
6999 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7003 proc gotocommit {} {
7004 global sha1string tagids headids curview varcid
7006 if {$sha1string == {}
7007 || ([info exists currentid] && $sha1string == $currentid)} return
7008 if {[info exists tagids($sha1string)]} {
7009 set id $tagids($sha1string)
7010 } elseif {[info exists headids($sha1string)]} {
7011 set id $headids($sha1string)
7012 } else {
7013 set id [string tolower $sha1string]
7014 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7015 set matches [array names varcid "$curview,$id*"]
7016 if {$matches ne {}} {
7017 if {[llength $matches] > 1} {
7018 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7019 return
7021 set id [lindex [split [lindex $matches 0] ","] 1]
7025 if {[commitinview $id $curview]} {
7026 selectline [rowofcommit $id] 1
7027 return
7029 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7030 set msg [mc "SHA1 id %s is not known" $sha1string]
7031 } else {
7032 set msg [mc "Tag/Head %s is not known" $sha1string]
7034 error_popup $msg
7037 proc lineenter {x y id} {
7038 global hoverx hovery hoverid hovertimer
7039 global commitinfo canv
7041 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7042 set hoverx $x
7043 set hovery $y
7044 set hoverid $id
7045 if {[info exists hovertimer]} {
7046 after cancel $hovertimer
7048 set hovertimer [after 500 linehover]
7049 $canv delete hover
7052 proc linemotion {x y id} {
7053 global hoverx hovery hoverid hovertimer
7055 if {[info exists hoverid] && $id == $hoverid} {
7056 set hoverx $x
7057 set hovery $y
7058 if {[info exists hovertimer]} {
7059 after cancel $hovertimer
7061 set hovertimer [after 500 linehover]
7065 proc lineleave {id} {
7066 global hoverid hovertimer canv
7068 if {[info exists hoverid] && $id == $hoverid} {
7069 $canv delete hover
7070 if {[info exists hovertimer]} {
7071 after cancel $hovertimer
7072 unset hovertimer
7074 unset hoverid
7078 proc linehover {} {
7079 global hoverx hovery hoverid hovertimer
7080 global canv linespc lthickness
7081 global commitinfo
7083 set text [lindex $commitinfo($hoverid) 0]
7084 set ymax [lindex [$canv cget -scrollregion] 3]
7085 if {$ymax == {}} return
7086 set yfrac [lindex [$canv yview] 0]
7087 set x [expr {$hoverx + 2 * $linespc}]
7088 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7089 set x0 [expr {$x - 2 * $lthickness}]
7090 set y0 [expr {$y - 2 * $lthickness}]
7091 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7092 set y1 [expr {$y + $linespc + 2 * $lthickness}]
7093 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7094 -fill \#ffff80 -outline black -width 1 -tags hover]
7095 $canv raise $t
7096 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7097 -font mainfont]
7098 $canv raise $t
7101 proc clickisonarrow {id y} {
7102 global lthickness
7104 set ranges [rowranges $id]
7105 set thresh [expr {2 * $lthickness + 6}]
7106 set n [expr {[llength $ranges] - 1}]
7107 for {set i 1} {$i < $n} {incr i} {
7108 set row [lindex $ranges $i]
7109 if {abs([yc $row] - $y) < $thresh} {
7110 return $i
7113 return {}
7116 proc arrowjump {id n y} {
7117 global canv
7119 # 1 <-> 2, 3 <-> 4, etc...
7120 set n [expr {(($n - 1) ^ 1) + 1}]
7121 set row [lindex [rowranges $id] $n]
7122 set yt [yc $row]
7123 set ymax [lindex [$canv cget -scrollregion] 3]
7124 if {$ymax eq {} || $ymax <= 0} return
7125 set view [$canv yview]
7126 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7127 set yfrac [expr {$yt / $ymax - $yspan / 2}]
7128 if {$yfrac < 0} {
7129 set yfrac 0
7131 allcanvs yview moveto $yfrac
7134 proc lineclick {x y id isnew} {
7135 global ctext commitinfo children canv thickerline curview
7137 if {![info exists commitinfo($id)] && ![getcommit $id]} return
7138 unmarkmatches
7139 unselectline
7140 normalline
7141 $canv delete hover
7142 # draw this line thicker than normal
7143 set thickerline $id
7144 drawlines $id
7145 if {$isnew} {
7146 set ymax [lindex [$canv cget -scrollregion] 3]
7147 if {$ymax eq {}} return
7148 set yfrac [lindex [$canv yview] 0]
7149 set y [expr {$y + $yfrac * $ymax}]
7151 set dirn [clickisonarrow $id $y]
7152 if {$dirn ne {}} {
7153 arrowjump $id $dirn $y
7154 return
7157 if {$isnew} {
7158 addtohistory [list lineclick $x $y $id 0]
7160 # fill the details pane with info about this line
7161 $ctext conf -state normal
7162 clear_ctext
7163 settabs 0
7164 $ctext insert end "[mc "Parent"]:\t"
7165 $ctext insert end $id link0
7166 setlink $id link0
7167 set info $commitinfo($id)
7168 $ctext insert end "\n\t[lindex $info 0]\n"
7169 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7170 set date [formatdate [lindex $info 2]]
7171 $ctext insert end "\t[mc "Date"]:\t$date\n"
7172 set kids $children($curview,$id)
7173 if {$kids ne {}} {
7174 $ctext insert end "\n[mc "Children"]:"
7175 set i 0
7176 foreach child $kids {
7177 incr i
7178 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7179 set info $commitinfo($child)
7180 $ctext insert end "\n\t"
7181 $ctext insert end $child link$i
7182 setlink $child link$i
7183 $ctext insert end "\n\t[lindex $info 0]"
7184 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7185 set date [formatdate [lindex $info 2]]
7186 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7189 $ctext conf -state disabled
7190 init_flist {}
7193 proc normalline {} {
7194 global thickerline
7195 if {[info exists thickerline]} {
7196 set id $thickerline
7197 unset thickerline
7198 drawlines $id
7202 proc selbyid {id} {
7203 global curview
7204 if {[commitinview $id $curview]} {
7205 selectline [rowofcommit $id] 1
7209 proc mstime {} {
7210 global startmstime
7211 if {![info exists startmstime]} {
7212 set startmstime [clock clicks -milliseconds]
7214 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7217 proc rowmenu {x y id} {
7218 global rowctxmenu selectedline rowmenuid curview
7219 global nullid nullid2 fakerowmenu mainhead
7221 stopfinding
7222 set rowmenuid $id
7223 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7224 set state disabled
7225 } else {
7226 set state normal
7228 if {$id ne $nullid && $id ne $nullid2} {
7229 set menu $rowctxmenu
7230 if {$mainhead ne {}} {
7231 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7232 } else {
7233 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7235 } else {
7236 set menu $fakerowmenu
7238 $menu entryconfigure [mc "Diff this -> selected"] -state $state
7239 $menu entryconfigure [mc "Diff selected -> this"] -state $state
7240 $menu entryconfigure [mc "Make patch"] -state $state
7241 tk_popup $menu $x $y
7244 proc diffvssel {dirn} {
7245 global rowmenuid selectedline
7247 if {$selectedline eq {}} return
7248 if {$dirn} {
7249 set oldid [commitonrow $selectedline]
7250 set newid $rowmenuid
7251 } else {
7252 set oldid $rowmenuid
7253 set newid [commitonrow $selectedline]
7255 addtohistory [list doseldiff $oldid $newid]
7256 doseldiff $oldid $newid
7259 proc doseldiff {oldid newid} {
7260 global ctext
7261 global commitinfo
7263 $ctext conf -state normal
7264 clear_ctext
7265 init_flist [mc "Top"]
7266 $ctext insert end "[mc "From"] "
7267 $ctext insert end $oldid link0
7268 setlink $oldid link0
7269 $ctext insert end "\n "
7270 $ctext insert end [lindex $commitinfo($oldid) 0]
7271 $ctext insert end "\n\n[mc "To"] "
7272 $ctext insert end $newid link1
7273 setlink $newid link1
7274 $ctext insert end "\n "
7275 $ctext insert end [lindex $commitinfo($newid) 0]
7276 $ctext insert end "\n"
7277 $ctext conf -state disabled
7278 $ctext tag remove found 1.0 end
7279 startdiff [list $oldid $newid]
7282 proc mkpatch {} {
7283 global rowmenuid currentid commitinfo patchtop patchnum
7285 if {![info exists currentid]} return
7286 set oldid $currentid
7287 set oldhead [lindex $commitinfo($oldid) 0]
7288 set newid $rowmenuid
7289 set newhead [lindex $commitinfo($newid) 0]
7290 set top .patch
7291 set patchtop $top
7292 catch {destroy $top}
7293 toplevel $top
7294 label $top.title -text [mc "Generate patch"]
7295 grid $top.title - -pady 10
7296 label $top.from -text [mc "From:"]
7297 entry $top.fromsha1 -width 40 -relief flat
7298 $top.fromsha1 insert 0 $oldid
7299 $top.fromsha1 conf -state readonly
7300 grid $top.from $top.fromsha1 -sticky w
7301 entry $top.fromhead -width 60 -relief flat
7302 $top.fromhead insert 0 $oldhead
7303 $top.fromhead conf -state readonly
7304 grid x $top.fromhead -sticky w
7305 label $top.to -text [mc "To:"]
7306 entry $top.tosha1 -width 40 -relief flat
7307 $top.tosha1 insert 0 $newid
7308 $top.tosha1 conf -state readonly
7309 grid $top.to $top.tosha1 -sticky w
7310 entry $top.tohead -width 60 -relief flat
7311 $top.tohead insert 0 $newhead
7312 $top.tohead conf -state readonly
7313 grid x $top.tohead -sticky w
7314 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7315 grid $top.rev x -pady 10
7316 label $top.flab -text [mc "Output file:"]
7317 entry $top.fname -width 60
7318 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7319 incr patchnum
7320 grid $top.flab $top.fname -sticky w
7321 frame $top.buts
7322 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7323 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7324 grid $top.buts.gen $top.buts.can
7325 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7326 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7327 grid $top.buts - -pady 10 -sticky ew
7328 focus $top.fname
7331 proc mkpatchrev {} {
7332 global patchtop
7334 set oldid [$patchtop.fromsha1 get]
7335 set oldhead [$patchtop.fromhead get]
7336 set newid [$patchtop.tosha1 get]
7337 set newhead [$patchtop.tohead get]
7338 foreach e [list fromsha1 fromhead tosha1 tohead] \
7339 v [list $newid $newhead $oldid $oldhead] {
7340 $patchtop.$e conf -state normal
7341 $patchtop.$e delete 0 end
7342 $patchtop.$e insert 0 $v
7343 $patchtop.$e conf -state readonly
7347 proc mkpatchgo {} {
7348 global patchtop nullid nullid2
7350 set oldid [$patchtop.fromsha1 get]
7351 set newid [$patchtop.tosha1 get]
7352 set fname [$patchtop.fname get]
7353 set cmd [diffcmd [list $oldid $newid] -p]
7354 # trim off the initial "|"
7355 set cmd [lrange $cmd 1 end]
7356 lappend cmd >$fname &
7357 if {[catch {eval exec $cmd} err]} {
7358 error_popup "[mc "Error creating patch:"] $err"
7360 catch {destroy $patchtop}
7361 unset patchtop
7364 proc mkpatchcan {} {
7365 global patchtop
7367 catch {destroy $patchtop}
7368 unset patchtop
7371 proc mktag {} {
7372 global rowmenuid mktagtop commitinfo
7374 set top .maketag
7375 set mktagtop $top
7376 catch {destroy $top}
7377 toplevel $top
7378 label $top.title -text [mc "Create tag"]
7379 grid $top.title - -pady 10
7380 label $top.id -text [mc "ID:"]
7381 entry $top.sha1 -width 40 -relief flat
7382 $top.sha1 insert 0 $rowmenuid
7383 $top.sha1 conf -state readonly
7384 grid $top.id $top.sha1 -sticky w
7385 entry $top.head -width 60 -relief flat
7386 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7387 $top.head conf -state readonly
7388 grid x $top.head -sticky w
7389 label $top.tlab -text [mc "Tag name:"]
7390 entry $top.tag -width 60
7391 grid $top.tlab $top.tag -sticky w
7392 frame $top.buts
7393 button $top.buts.gen -text [mc "Create"] -command mktaggo
7394 button $top.buts.can -text [mc "Cancel"] -command mktagcan
7395 grid $top.buts.gen $top.buts.can
7396 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7397 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7398 grid $top.buts - -pady 10 -sticky ew
7399 focus $top.tag
7402 proc domktag {} {
7403 global mktagtop env tagids idtags
7405 set id [$mktagtop.sha1 get]
7406 set tag [$mktagtop.tag get]
7407 if {$tag == {}} {
7408 error_popup [mc "No tag name specified"]
7409 return
7411 if {[info exists tagids($tag)]} {
7412 error_popup [mc "Tag \"%s\" already exists" $tag]
7413 return
7415 if {[catch {
7416 exec git tag $tag $id
7417 } err]} {
7418 error_popup "[mc "Error creating tag:"] $err"
7419 return
7422 set tagids($tag) $id
7423 lappend idtags($id) $tag
7424 redrawtags $id
7425 addedtag $id
7426 dispneartags 0
7427 run refill_reflist
7430 proc redrawtags {id} {
7431 global canv linehtag idpos currentid curview cmitlisted
7432 global canvxmax iddrawn circleitem mainheadid circlecolors
7434 if {![commitinview $id $curview]} return
7435 if {![info exists iddrawn($id)]} return
7436 set row [rowofcommit $id]
7437 if {$id eq $mainheadid} {
7438 set ofill yellow
7439 } else {
7440 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7442 $canv itemconf $circleitem($row) -fill $ofill
7443 $canv delete tag.$id
7444 set xt [eval drawtags $id $idpos($id)]
7445 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7446 set text [$canv itemcget $linehtag($row) -text]
7447 set font [$canv itemcget $linehtag($row) -font]
7448 set xr [expr {$xt + [font measure $font $text]}]
7449 if {$xr > $canvxmax} {
7450 set canvxmax $xr
7451 setcanvscroll
7453 if {[info exists currentid] && $currentid == $id} {
7454 make_secsel $row
7458 proc mktagcan {} {
7459 global mktagtop
7461 catch {destroy $mktagtop}
7462 unset mktagtop
7465 proc mktaggo {} {
7466 domktag
7467 mktagcan
7470 proc writecommit {} {
7471 global rowmenuid wrcomtop commitinfo wrcomcmd
7473 set top .writecommit
7474 set wrcomtop $top
7475 catch {destroy $top}
7476 toplevel $top
7477 label $top.title -text [mc "Write commit to file"]
7478 grid $top.title - -pady 10
7479 label $top.id -text [mc "ID:"]
7480 entry $top.sha1 -width 40 -relief flat
7481 $top.sha1 insert 0 $rowmenuid
7482 $top.sha1 conf -state readonly
7483 grid $top.id $top.sha1 -sticky w
7484 entry $top.head -width 60 -relief flat
7485 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7486 $top.head conf -state readonly
7487 grid x $top.head -sticky w
7488 label $top.clab -text [mc "Command:"]
7489 entry $top.cmd -width 60 -textvariable wrcomcmd
7490 grid $top.clab $top.cmd -sticky w -pady 10
7491 label $top.flab -text [mc "Output file:"]
7492 entry $top.fname -width 60
7493 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7494 grid $top.flab $top.fname -sticky w
7495 frame $top.buts
7496 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7497 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7498 grid $top.buts.gen $top.buts.can
7499 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7500 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7501 grid $top.buts - -pady 10 -sticky ew
7502 focus $top.fname
7505 proc wrcomgo {} {
7506 global wrcomtop
7508 set id [$wrcomtop.sha1 get]
7509 set cmd "echo $id | [$wrcomtop.cmd get]"
7510 set fname [$wrcomtop.fname get]
7511 if {[catch {exec sh -c $cmd >$fname &} err]} {
7512 error_popup "[mc "Error writing commit:"] $err"
7514 catch {destroy $wrcomtop}
7515 unset wrcomtop
7518 proc wrcomcan {} {
7519 global wrcomtop
7521 catch {destroy $wrcomtop}
7522 unset wrcomtop
7525 proc mkbranch {} {
7526 global rowmenuid mkbrtop
7528 set top .makebranch
7529 catch {destroy $top}
7530 toplevel $top
7531 label $top.title -text [mc "Create new branch"]
7532 grid $top.title - -pady 10
7533 label $top.id -text [mc "ID:"]
7534 entry $top.sha1 -width 40 -relief flat
7535 $top.sha1 insert 0 $rowmenuid
7536 $top.sha1 conf -state readonly
7537 grid $top.id $top.sha1 -sticky w
7538 label $top.nlab -text [mc "Name:"]
7539 entry $top.name -width 40
7540 grid $top.nlab $top.name -sticky w
7541 frame $top.buts
7542 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7543 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7544 grid $top.buts.go $top.buts.can
7545 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7546 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7547 grid $top.buts - -pady 10 -sticky ew
7548 focus $top.name
7551 proc mkbrgo {top} {
7552 global headids idheads
7554 set name [$top.name get]
7555 set id [$top.sha1 get]
7556 if {$name eq {}} {
7557 error_popup [mc "Please specify a name for the new branch"]
7558 return
7560 catch {destroy $top}
7561 nowbusy newbranch
7562 update
7563 if {[catch {
7564 exec git branch $name $id
7565 } err]} {
7566 notbusy newbranch
7567 error_popup $err
7568 } else {
7569 set headids($name) $id
7570 lappend idheads($id) $name
7571 addedhead $id $name
7572 notbusy newbranch
7573 redrawtags $id
7574 dispneartags 0
7575 run refill_reflist
7579 proc cherrypick {} {
7580 global rowmenuid curview
7581 global mainhead mainheadid
7583 set oldhead [exec git rev-parse HEAD]
7584 set dheads [descheads $rowmenuid]
7585 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7586 set ok [confirm_popup [mc "Commit %s is already\
7587 included in branch %s -- really re-apply it?" \
7588 [string range $rowmenuid 0 7] $mainhead]]
7589 if {!$ok} return
7591 nowbusy cherrypick [mc "Cherry-picking"]
7592 update
7593 # Unfortunately git-cherry-pick writes stuff to stderr even when
7594 # no error occurs, and exec takes that as an indication of error...
7595 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7596 notbusy cherrypick
7597 error_popup $err
7598 return
7600 set newhead [exec git rev-parse HEAD]
7601 if {$newhead eq $oldhead} {
7602 notbusy cherrypick
7603 error_popup [mc "No changes committed"]
7604 return
7606 addnewchild $newhead $oldhead
7607 if {[commitinview $oldhead $curview]} {
7608 insertrow $newhead $oldhead $curview
7609 if {$mainhead ne {}} {
7610 movehead $newhead $mainhead
7611 movedhead $newhead $mainhead
7613 set mainheadid $newhead
7614 redrawtags $oldhead
7615 redrawtags $newhead
7616 selbyid $newhead
7618 notbusy cherrypick
7621 proc resethead {} {
7622 global mainhead rowmenuid confirm_ok resettype
7624 set confirm_ok 0
7625 set w ".confirmreset"
7626 toplevel $w
7627 wm transient $w .
7628 wm title $w [mc "Confirm reset"]
7629 message $w.m -text \
7630 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7631 -justify center -aspect 1000
7632 pack $w.m -side top -fill x -padx 20 -pady 20
7633 frame $w.f -relief sunken -border 2
7634 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7635 grid $w.f.rt -sticky w
7636 set resettype mixed
7637 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7638 -text [mc "Soft: Leave working tree and index untouched"]
7639 grid $w.f.soft -sticky w
7640 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7641 -text [mc "Mixed: Leave working tree untouched, reset index"]
7642 grid $w.f.mixed -sticky w
7643 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7644 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7645 grid $w.f.hard -sticky w
7646 pack $w.f -side top -fill x
7647 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7648 pack $w.ok -side left -fill x -padx 20 -pady 20
7649 button $w.cancel -text [mc Cancel] -command "destroy $w"
7650 pack $w.cancel -side right -fill x -padx 20 -pady 20
7651 bind $w <Visibility> "grab $w; focus $w"
7652 tkwait window $w
7653 if {!$confirm_ok} return
7654 if {[catch {set fd [open \
7655 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7656 error_popup $err
7657 } else {
7658 dohidelocalchanges
7659 filerun $fd [list readresetstat $fd]
7660 nowbusy reset [mc "Resetting"]
7661 selbyid $rowmenuid
7665 proc readresetstat {fd} {
7666 global mainhead mainheadid showlocalchanges rprogcoord
7668 if {[gets $fd line] >= 0} {
7669 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7670 set rprogcoord [expr {1.0 * $m / $n}]
7671 adjustprogress
7673 return 1
7675 set rprogcoord 0
7676 adjustprogress
7677 notbusy reset
7678 if {[catch {close $fd} err]} {
7679 error_popup $err
7681 set oldhead $mainheadid
7682 set newhead [exec git rev-parse HEAD]
7683 if {$newhead ne $oldhead} {
7684 movehead $newhead $mainhead
7685 movedhead $newhead $mainhead
7686 set mainheadid $newhead
7687 redrawtags $oldhead
7688 redrawtags $newhead
7690 if {$showlocalchanges} {
7691 doshowlocalchanges
7693 return 0
7696 # context menu for a head
7697 proc headmenu {x y id head} {
7698 global headmenuid headmenuhead headctxmenu mainhead
7700 stopfinding
7701 set headmenuid $id
7702 set headmenuhead $head
7703 set state normal
7704 if {$head eq $mainhead} {
7705 set state disabled
7707 $headctxmenu entryconfigure 0 -state $state
7708 $headctxmenu entryconfigure 1 -state $state
7709 tk_popup $headctxmenu $x $y
7712 proc cobranch {} {
7713 global headmenuid headmenuhead headids
7714 global showlocalchanges mainheadid
7716 # check the tree is clean first??
7717 nowbusy checkout [mc "Checking out"]
7718 update
7719 dohidelocalchanges
7720 if {[catch {
7721 set fd [open [list | git checkout $headmenuhead 2>@1] r]
7722 } err]} {
7723 notbusy checkout
7724 error_popup $err
7725 if {$showlocalchanges} {
7726 dodiffindex
7728 } else {
7729 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7733 proc readcheckoutstat {fd newhead newheadid} {
7734 global mainhead mainheadid headids showlocalchanges progresscoords
7736 if {[gets $fd line] >= 0} {
7737 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7738 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7739 adjustprogress
7741 return 1
7743 set progresscoords {0 0}
7744 adjustprogress
7745 notbusy checkout
7746 if {[catch {close $fd} err]} {
7747 error_popup $err
7749 set oldmainid $mainheadid
7750 set mainhead $newhead
7751 set mainheadid $newheadid
7752 redrawtags $oldmainid
7753 redrawtags $newheadid
7754 selbyid $newheadid
7755 if {$showlocalchanges} {
7756 dodiffindex
7760 proc rmbranch {} {
7761 global headmenuid headmenuhead mainhead
7762 global idheads
7764 set head $headmenuhead
7765 set id $headmenuid
7766 # this check shouldn't be needed any more...
7767 if {$head eq $mainhead} {
7768 error_popup [mc "Cannot delete the currently checked-out branch"]
7769 return
7771 set dheads [descheads $id]
7772 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7773 # the stuff on this branch isn't on any other branch
7774 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7775 branch.\nReally delete branch %s?" $head $head]]} return
7777 nowbusy rmbranch
7778 update
7779 if {[catch {exec git branch -D $head} err]} {
7780 notbusy rmbranch
7781 error_popup $err
7782 return
7784 removehead $id $head
7785 removedhead $id $head
7786 redrawtags $id
7787 notbusy rmbranch
7788 dispneartags 0
7789 run refill_reflist
7792 # Display a list of tags and heads
7793 proc showrefs {} {
7794 global showrefstop bgcolor fgcolor selectbgcolor
7795 global bglist fglist reflistfilter reflist maincursor
7797 set top .showrefs
7798 set showrefstop $top
7799 if {[winfo exists $top]} {
7800 raise $top
7801 refill_reflist
7802 return
7804 toplevel $top
7805 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7806 text $top.list -background $bgcolor -foreground $fgcolor \
7807 -selectbackground $selectbgcolor -font mainfont \
7808 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7809 -width 30 -height 20 -cursor $maincursor \
7810 -spacing1 1 -spacing3 1 -state disabled
7811 $top.list tag configure highlight -background $selectbgcolor
7812 lappend bglist $top.list
7813 lappend fglist $top.list
7814 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7815 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7816 grid $top.list $top.ysb -sticky nsew
7817 grid $top.xsb x -sticky ew
7818 frame $top.f
7819 label $top.f.l -text "[mc "Filter"]: "
7820 entry $top.f.e -width 20 -textvariable reflistfilter
7821 set reflistfilter "*"
7822 trace add variable reflistfilter write reflistfilter_change
7823 pack $top.f.e -side right -fill x -expand 1
7824 pack $top.f.l -side left
7825 grid $top.f - -sticky ew -pady 2
7826 button $top.close -command [list destroy $top] -text [mc "Close"]
7827 grid $top.close -
7828 grid columnconfigure $top 0 -weight 1
7829 grid rowconfigure $top 0 -weight 1
7830 bind $top.list <1> {break}
7831 bind $top.list <B1-Motion> {break}
7832 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7833 set reflist {}
7834 refill_reflist
7837 proc sel_reflist {w x y} {
7838 global showrefstop reflist headids tagids otherrefids
7840 if {![winfo exists $showrefstop]} return
7841 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7842 set ref [lindex $reflist [expr {$l-1}]]
7843 set n [lindex $ref 0]
7844 switch -- [lindex $ref 1] {
7845 "H" {selbyid $headids($n)}
7846 "T" {selbyid $tagids($n)}
7847 "o" {selbyid $otherrefids($n)}
7849 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7852 proc unsel_reflist {} {
7853 global showrefstop
7855 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7856 $showrefstop.list tag remove highlight 0.0 end
7859 proc reflistfilter_change {n1 n2 op} {
7860 global reflistfilter
7862 after cancel refill_reflist
7863 after 200 refill_reflist
7866 proc refill_reflist {} {
7867 global reflist reflistfilter showrefstop headids tagids otherrefids
7868 global curview commitinterest
7870 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7871 set refs {}
7872 foreach n [array names headids] {
7873 if {[string match $reflistfilter $n]} {
7874 if {[commitinview $headids($n) $curview]} {
7875 lappend refs [list $n H]
7876 } else {
7877 set commitinterest($headids($n)) {run refill_reflist}
7881 foreach n [array names tagids] {
7882 if {[string match $reflistfilter $n]} {
7883 if {[commitinview $tagids($n) $curview]} {
7884 lappend refs [list $n T]
7885 } else {
7886 set commitinterest($tagids($n)) {run refill_reflist}
7890 foreach n [array names otherrefids] {
7891 if {[string match $reflistfilter $n]} {
7892 if {[commitinview $otherrefids($n) $curview]} {
7893 lappend refs [list $n o]
7894 } else {
7895 set commitinterest($otherrefids($n)) {run refill_reflist}
7899 set refs [lsort -index 0 $refs]
7900 if {$refs eq $reflist} return
7902 # Update the contents of $showrefstop.list according to the
7903 # differences between $reflist (old) and $refs (new)
7904 $showrefstop.list conf -state normal
7905 $showrefstop.list insert end "\n"
7906 set i 0
7907 set j 0
7908 while {$i < [llength $reflist] || $j < [llength $refs]} {
7909 if {$i < [llength $reflist]} {
7910 if {$j < [llength $refs]} {
7911 set cmp [string compare [lindex $reflist $i 0] \
7912 [lindex $refs $j 0]]
7913 if {$cmp == 0} {
7914 set cmp [string compare [lindex $reflist $i 1] \
7915 [lindex $refs $j 1]]
7917 } else {
7918 set cmp -1
7920 } else {
7921 set cmp 1
7923 switch -- $cmp {
7924 -1 {
7925 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7926 incr i
7929 incr i
7930 incr j
7933 set l [expr {$j + 1}]
7934 $showrefstop.list image create $l.0 -align baseline \
7935 -image reficon-[lindex $refs $j 1] -padx 2
7936 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7937 incr j
7941 set reflist $refs
7942 # delete last newline
7943 $showrefstop.list delete end-2c end-1c
7944 $showrefstop.list conf -state disabled
7947 # Stuff for finding nearby tags
7948 proc getallcommits {} {
7949 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7950 global idheads idtags idotherrefs allparents tagobjid
7952 if {![info exists allcommits]} {
7953 set nextarc 0
7954 set allcommits 0
7955 set seeds {}
7956 set allcwait 0
7957 set cachedarcs 0
7958 set allccache [file join [gitdir] "gitk.cache"]
7959 if {![catch {
7960 set f [open $allccache r]
7961 set allcwait 1
7962 getcache $f
7963 }]} return
7966 if {$allcwait} {
7967 return
7969 set cmd [list | git rev-list --parents]
7970 set allcupdate [expr {$seeds ne {}}]
7971 if {!$allcupdate} {
7972 set ids "--all"
7973 } else {
7974 set refs [concat [array names idheads] [array names idtags] \
7975 [array names idotherrefs]]
7976 set ids {}
7977 set tagobjs {}
7978 foreach name [array names tagobjid] {
7979 lappend tagobjs $tagobjid($name)
7981 foreach id [lsort -unique $refs] {
7982 if {![info exists allparents($id)] &&
7983 [lsearch -exact $tagobjs $id] < 0} {
7984 lappend ids $id
7987 if {$ids ne {}} {
7988 foreach id $seeds {
7989 lappend ids "^$id"
7993 if {$ids ne {}} {
7994 set fd [open [concat $cmd $ids] r]
7995 fconfigure $fd -blocking 0
7996 incr allcommits
7997 nowbusy allcommits
7998 filerun $fd [list getallclines $fd]
7999 } else {
8000 dispneartags 0
8004 # Since most commits have 1 parent and 1 child, we group strings of
8005 # such commits into "arcs" joining branch/merge points (BMPs), which
8006 # are commits that either don't have 1 parent or don't have 1 child.
8008 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8009 # arcout(id) - outgoing arcs for BMP
8010 # arcids(a) - list of IDs on arc including end but not start
8011 # arcstart(a) - BMP ID at start of arc
8012 # arcend(a) - BMP ID at end of arc
8013 # growing(a) - arc a is still growing
8014 # arctags(a) - IDs out of arcids (excluding end) that have tags
8015 # archeads(a) - IDs out of arcids (excluding end) that have heads
8016 # The start of an arc is at the descendent end, so "incoming" means
8017 # coming from descendents, and "outgoing" means going towards ancestors.
8019 proc getallclines {fd} {
8020 global allparents allchildren idtags idheads nextarc
8021 global arcnos arcids arctags arcout arcend arcstart archeads growing
8022 global seeds allcommits cachedarcs allcupdate
8024 set nid 0
8025 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8026 set id [lindex $line 0]
8027 if {[info exists allparents($id)]} {
8028 # seen it already
8029 continue
8031 set cachedarcs 0
8032 set olds [lrange $line 1 end]
8033 set allparents($id) $olds
8034 if {![info exists allchildren($id)]} {
8035 set allchildren($id) {}
8036 set arcnos($id) {}
8037 lappend seeds $id
8038 } else {
8039 set a $arcnos($id)
8040 if {[llength $olds] == 1 && [llength $a] == 1} {
8041 lappend arcids($a) $id
8042 if {[info exists idtags($id)]} {
8043 lappend arctags($a) $id
8045 if {[info exists idheads($id)]} {
8046 lappend archeads($a) $id
8048 if {[info exists allparents($olds)]} {
8049 # seen parent already
8050 if {![info exists arcout($olds)]} {
8051 splitarc $olds
8053 lappend arcids($a) $olds
8054 set arcend($a) $olds
8055 unset growing($a)
8057 lappend allchildren($olds) $id
8058 lappend arcnos($olds) $a
8059 continue
8062 foreach a $arcnos($id) {
8063 lappend arcids($a) $id
8064 set arcend($a) $id
8065 unset growing($a)
8068 set ao {}
8069 foreach p $olds {
8070 lappend allchildren($p) $id
8071 set a [incr nextarc]
8072 set arcstart($a) $id
8073 set archeads($a) {}
8074 set arctags($a) {}
8075 set archeads($a) {}
8076 set arcids($a) {}
8077 lappend ao $a
8078 set growing($a) 1
8079 if {[info exists allparents($p)]} {
8080 # seen it already, may need to make a new branch
8081 if {![info exists arcout($p)]} {
8082 splitarc $p
8084 lappend arcids($a) $p
8085 set arcend($a) $p
8086 unset growing($a)
8088 lappend arcnos($p) $a
8090 set arcout($id) $ao
8092 if {$nid > 0} {
8093 global cached_dheads cached_dtags cached_atags
8094 catch {unset cached_dheads}
8095 catch {unset cached_dtags}
8096 catch {unset cached_atags}
8098 if {![eof $fd]} {
8099 return [expr {$nid >= 1000? 2: 1}]
8101 set cacheok 1
8102 if {[catch {
8103 fconfigure $fd -blocking 1
8104 close $fd
8105 } err]} {
8106 # got an error reading the list of commits
8107 # if we were updating, try rereading the whole thing again
8108 if {$allcupdate} {
8109 incr allcommits -1
8110 dropcache $err
8111 return
8113 error_popup "[mc "Error reading commit topology information;\
8114 branch and preceding/following tag information\
8115 will be incomplete."]\n($err)"
8116 set cacheok 0
8118 if {[incr allcommits -1] == 0} {
8119 notbusy allcommits
8120 if {$cacheok} {
8121 run savecache
8124 dispneartags 0
8125 return 0
8128 proc recalcarc {a} {
8129 global arctags archeads arcids idtags idheads
8131 set at {}
8132 set ah {}
8133 foreach id [lrange $arcids($a) 0 end-1] {
8134 if {[info exists idtags($id)]} {
8135 lappend at $id
8137 if {[info exists idheads($id)]} {
8138 lappend ah $id
8141 set arctags($a) $at
8142 set archeads($a) $ah
8145 proc splitarc {p} {
8146 global arcnos arcids nextarc arctags archeads idtags idheads
8147 global arcstart arcend arcout allparents growing
8149 set a $arcnos($p)
8150 if {[llength $a] != 1} {
8151 puts "oops splitarc called but [llength $a] arcs already"
8152 return
8154 set a [lindex $a 0]
8155 set i [lsearch -exact $arcids($a) $p]
8156 if {$i < 0} {
8157 puts "oops splitarc $p not in arc $a"
8158 return
8160 set na [incr nextarc]
8161 if {[info exists arcend($a)]} {
8162 set arcend($na) $arcend($a)
8163 } else {
8164 set l [lindex $allparents([lindex $arcids($a) end]) 0]
8165 set j [lsearch -exact $arcnos($l) $a]
8166 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8168 set tail [lrange $arcids($a) [expr {$i+1}] end]
8169 set arcids($a) [lrange $arcids($a) 0 $i]
8170 set arcend($a) $p
8171 set arcstart($na) $p
8172 set arcout($p) $na
8173 set arcids($na) $tail
8174 if {[info exists growing($a)]} {
8175 set growing($na) 1
8176 unset growing($a)
8179 foreach id $tail {
8180 if {[llength $arcnos($id)] == 1} {
8181 set arcnos($id) $na
8182 } else {
8183 set j [lsearch -exact $arcnos($id) $a]
8184 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8188 # reconstruct tags and heads lists
8189 if {$arctags($a) ne {} || $archeads($a) ne {}} {
8190 recalcarc $a
8191 recalcarc $na
8192 } else {
8193 set arctags($na) {}
8194 set archeads($na) {}
8198 # Update things for a new commit added that is a child of one
8199 # existing commit. Used when cherry-picking.
8200 proc addnewchild {id p} {
8201 global allparents allchildren idtags nextarc
8202 global arcnos arcids arctags arcout arcend arcstart archeads growing
8203 global seeds allcommits
8205 if {![info exists allcommits] || ![info exists arcnos($p)]} return
8206 set allparents($id) [list $p]
8207 set allchildren($id) {}
8208 set arcnos($id) {}
8209 lappend seeds $id
8210 lappend allchildren($p) $id
8211 set a [incr nextarc]
8212 set arcstart($a) $id
8213 set archeads($a) {}
8214 set arctags($a) {}
8215 set arcids($a) [list $p]
8216 set arcend($a) $p
8217 if {![info exists arcout($p)]} {
8218 splitarc $p
8220 lappend arcnos($p) $a
8221 set arcout($id) [list $a]
8224 # This implements a cache for the topology information.
8225 # The cache saves, for each arc, the start and end of the arc,
8226 # the ids on the arc, and the outgoing arcs from the end.
8227 proc readcache {f} {
8228 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8229 global idtags idheads allparents cachedarcs possible_seeds seeds growing
8230 global allcwait
8232 set a $nextarc
8233 set lim $cachedarcs
8234 if {$lim - $a > 500} {
8235 set lim [expr {$a + 500}]
8237 if {[catch {
8238 if {$a == $lim} {
8239 # finish reading the cache and setting up arctags, etc.
8240 set line [gets $f]
8241 if {$line ne "1"} {error "bad final version"}
8242 close $f
8243 foreach id [array names idtags] {
8244 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8245 [llength $allparents($id)] == 1} {
8246 set a [lindex $arcnos($id) 0]
8247 if {$arctags($a) eq {}} {
8248 recalcarc $a
8252 foreach id [array names idheads] {
8253 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8254 [llength $allparents($id)] == 1} {
8255 set a [lindex $arcnos($id) 0]
8256 if {$archeads($a) eq {}} {
8257 recalcarc $a
8261 foreach id [lsort -unique $possible_seeds] {
8262 if {$arcnos($id) eq {}} {
8263 lappend seeds $id
8266 set allcwait 0
8267 } else {
8268 while {[incr a] <= $lim} {
8269 set line [gets $f]
8270 if {[llength $line] != 3} {error "bad line"}
8271 set s [lindex $line 0]
8272 set arcstart($a) $s
8273 lappend arcout($s) $a
8274 if {![info exists arcnos($s)]} {
8275 lappend possible_seeds $s
8276 set arcnos($s) {}
8278 set e [lindex $line 1]
8279 if {$e eq {}} {
8280 set growing($a) 1
8281 } else {
8282 set arcend($a) $e
8283 if {![info exists arcout($e)]} {
8284 set arcout($e) {}
8287 set arcids($a) [lindex $line 2]
8288 foreach id $arcids($a) {
8289 lappend allparents($s) $id
8290 set s $id
8291 lappend arcnos($id) $a
8293 if {![info exists allparents($s)]} {
8294 set allparents($s) {}
8296 set arctags($a) {}
8297 set archeads($a) {}
8299 set nextarc [expr {$a - 1}]
8301 } err]} {
8302 dropcache $err
8303 return 0
8305 if {!$allcwait} {
8306 getallcommits
8308 return $allcwait
8311 proc getcache {f} {
8312 global nextarc cachedarcs possible_seeds
8314 if {[catch {
8315 set line [gets $f]
8316 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8317 # make sure it's an integer
8318 set cachedarcs [expr {int([lindex $line 1])}]
8319 if {$cachedarcs < 0} {error "bad number of arcs"}
8320 set nextarc 0
8321 set possible_seeds {}
8322 run readcache $f
8323 } err]} {
8324 dropcache $err
8326 return 0
8329 proc dropcache {err} {
8330 global allcwait nextarc cachedarcs seeds
8332 #puts "dropping cache ($err)"
8333 foreach v {arcnos arcout arcids arcstart arcend growing \
8334 arctags archeads allparents allchildren} {
8335 global $v
8336 catch {unset $v}
8338 set allcwait 0
8339 set nextarc 0
8340 set cachedarcs 0
8341 set seeds {}
8342 getallcommits
8345 proc writecache {f} {
8346 global cachearc cachedarcs allccache
8347 global arcstart arcend arcnos arcids arcout
8349 set a $cachearc
8350 set lim $cachedarcs
8351 if {$lim - $a > 1000} {
8352 set lim [expr {$a + 1000}]
8354 if {[catch {
8355 while {[incr a] <= $lim} {
8356 if {[info exists arcend($a)]} {
8357 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8358 } else {
8359 puts $f [list $arcstart($a) {} $arcids($a)]
8362 } err]} {
8363 catch {close $f}
8364 catch {file delete $allccache}
8365 #puts "writing cache failed ($err)"
8366 return 0
8368 set cachearc [expr {$a - 1}]
8369 if {$a > $cachedarcs} {
8370 puts $f "1"
8371 close $f
8372 return 0
8374 return 1
8377 proc savecache {} {
8378 global nextarc cachedarcs cachearc allccache
8380 if {$nextarc == $cachedarcs} return
8381 set cachearc 0
8382 set cachedarcs $nextarc
8383 catch {
8384 set f [open $allccache w]
8385 puts $f [list 1 $cachedarcs]
8386 run writecache $f
8390 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8391 # or 0 if neither is true.
8392 proc anc_or_desc {a b} {
8393 global arcout arcstart arcend arcnos cached_isanc
8395 if {$arcnos($a) eq $arcnos($b)} {
8396 # Both are on the same arc(s); either both are the same BMP,
8397 # or if one is not a BMP, the other is also not a BMP or is
8398 # the BMP at end of the arc (and it only has 1 incoming arc).
8399 # Or both can be BMPs with no incoming arcs.
8400 if {$a eq $b || $arcnos($a) eq {}} {
8401 return 0
8403 # assert {[llength $arcnos($a)] == 1}
8404 set arc [lindex $arcnos($a) 0]
8405 set i [lsearch -exact $arcids($arc) $a]
8406 set j [lsearch -exact $arcids($arc) $b]
8407 if {$i < 0 || $i > $j} {
8408 return 1
8409 } else {
8410 return -1
8414 if {![info exists arcout($a)]} {
8415 set arc [lindex $arcnos($a) 0]
8416 if {[info exists arcend($arc)]} {
8417 set aend $arcend($arc)
8418 } else {
8419 set aend {}
8421 set a $arcstart($arc)
8422 } else {
8423 set aend $a
8425 if {![info exists arcout($b)]} {
8426 set arc [lindex $arcnos($b) 0]
8427 if {[info exists arcend($arc)]} {
8428 set bend $arcend($arc)
8429 } else {
8430 set bend {}
8432 set b $arcstart($arc)
8433 } else {
8434 set bend $b
8436 if {$a eq $bend} {
8437 return 1
8439 if {$b eq $aend} {
8440 return -1
8442 if {[info exists cached_isanc($a,$bend)]} {
8443 if {$cached_isanc($a,$bend)} {
8444 return 1
8447 if {[info exists cached_isanc($b,$aend)]} {
8448 if {$cached_isanc($b,$aend)} {
8449 return -1
8451 if {[info exists cached_isanc($a,$bend)]} {
8452 return 0
8456 set todo [list $a $b]
8457 set anc($a) a
8458 set anc($b) b
8459 for {set i 0} {$i < [llength $todo]} {incr i} {
8460 set x [lindex $todo $i]
8461 if {$anc($x) eq {}} {
8462 continue
8464 foreach arc $arcnos($x) {
8465 set xd $arcstart($arc)
8466 if {$xd eq $bend} {
8467 set cached_isanc($a,$bend) 1
8468 set cached_isanc($b,$aend) 0
8469 return 1
8470 } elseif {$xd eq $aend} {
8471 set cached_isanc($b,$aend) 1
8472 set cached_isanc($a,$bend) 0
8473 return -1
8475 if {![info exists anc($xd)]} {
8476 set anc($xd) $anc($x)
8477 lappend todo $xd
8478 } elseif {$anc($xd) ne $anc($x)} {
8479 set anc($xd) {}
8483 set cached_isanc($a,$bend) 0
8484 set cached_isanc($b,$aend) 0
8485 return 0
8488 # This identifies whether $desc has an ancestor that is
8489 # a growing tip of the graph and which is not an ancestor of $anc
8490 # and returns 0 if so and 1 if not.
8491 # If we subsequently discover a tag on such a growing tip, and that
8492 # turns out to be a descendent of $anc (which it could, since we
8493 # don't necessarily see children before parents), then $desc
8494 # isn't a good choice to display as a descendent tag of
8495 # $anc (since it is the descendent of another tag which is
8496 # a descendent of $anc). Similarly, $anc isn't a good choice to
8497 # display as a ancestor tag of $desc.
8499 proc is_certain {desc anc} {
8500 global arcnos arcout arcstart arcend growing problems
8502 set certain {}
8503 if {[llength $arcnos($anc)] == 1} {
8504 # tags on the same arc are certain
8505 if {$arcnos($desc) eq $arcnos($anc)} {
8506 return 1
8508 if {![info exists arcout($anc)]} {
8509 # if $anc is partway along an arc, use the start of the arc instead
8510 set a [lindex $arcnos($anc) 0]
8511 set anc $arcstart($a)
8514 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8515 set x $desc
8516 } else {
8517 set a [lindex $arcnos($desc) 0]
8518 set x $arcend($a)
8520 if {$x == $anc} {
8521 return 1
8523 set anclist [list $x]
8524 set dl($x) 1
8525 set nnh 1
8526 set ngrowanc 0
8527 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8528 set x [lindex $anclist $i]
8529 if {$dl($x)} {
8530 incr nnh -1
8532 set done($x) 1
8533 foreach a $arcout($x) {
8534 if {[info exists growing($a)]} {
8535 if {![info exists growanc($x)] && $dl($x)} {
8536 set growanc($x) 1
8537 incr ngrowanc
8539 } else {
8540 set y $arcend($a)
8541 if {[info exists dl($y)]} {
8542 if {$dl($y)} {
8543 if {!$dl($x)} {
8544 set dl($y) 0
8545 if {![info exists done($y)]} {
8546 incr nnh -1
8548 if {[info exists growanc($x)]} {
8549 incr ngrowanc -1
8551 set xl [list $y]
8552 for {set k 0} {$k < [llength $xl]} {incr k} {
8553 set z [lindex $xl $k]
8554 foreach c $arcout($z) {
8555 if {[info exists arcend($c)]} {
8556 set v $arcend($c)
8557 if {[info exists dl($v)] && $dl($v)} {
8558 set dl($v) 0
8559 if {![info exists done($v)]} {
8560 incr nnh -1
8562 if {[info exists growanc($v)]} {
8563 incr ngrowanc -1
8565 lappend xl $v
8572 } elseif {$y eq $anc || !$dl($x)} {
8573 set dl($y) 0
8574 lappend anclist $y
8575 } else {
8576 set dl($y) 1
8577 lappend anclist $y
8578 incr nnh
8583 foreach x [array names growanc] {
8584 if {$dl($x)} {
8585 return 0
8587 return 0
8589 return 1
8592 proc validate_arctags {a} {
8593 global arctags idtags
8595 set i -1
8596 set na $arctags($a)
8597 foreach id $arctags($a) {
8598 incr i
8599 if {![info exists idtags($id)]} {
8600 set na [lreplace $na $i $i]
8601 incr i -1
8604 set arctags($a) $na
8607 proc validate_archeads {a} {
8608 global archeads idheads
8610 set i -1
8611 set na $archeads($a)
8612 foreach id $archeads($a) {
8613 incr i
8614 if {![info exists idheads($id)]} {
8615 set na [lreplace $na $i $i]
8616 incr i -1
8619 set archeads($a) $na
8622 # Return the list of IDs that have tags that are descendents of id,
8623 # ignoring IDs that are descendents of IDs already reported.
8624 proc desctags {id} {
8625 global arcnos arcstart arcids arctags idtags allparents
8626 global growing cached_dtags
8628 if {![info exists allparents($id)]} {
8629 return {}
8631 set t1 [clock clicks -milliseconds]
8632 set argid $id
8633 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8634 # part-way along an arc; check that arc first
8635 set a [lindex $arcnos($id) 0]
8636 if {$arctags($a) ne {}} {
8637 validate_arctags $a
8638 set i [lsearch -exact $arcids($a) $id]
8639 set tid {}
8640 foreach t $arctags($a) {
8641 set j [lsearch -exact $arcids($a) $t]
8642 if {$j >= $i} break
8643 set tid $t
8645 if {$tid ne {}} {
8646 return $tid
8649 set id $arcstart($a)
8650 if {[info exists idtags($id)]} {
8651 return $id
8654 if {[info exists cached_dtags($id)]} {
8655 return $cached_dtags($id)
8658 set origid $id
8659 set todo [list $id]
8660 set queued($id) 1
8661 set nc 1
8662 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8663 set id [lindex $todo $i]
8664 set done($id) 1
8665 set ta [info exists hastaggedancestor($id)]
8666 if {!$ta} {
8667 incr nc -1
8669 # ignore tags on starting node
8670 if {!$ta && $i > 0} {
8671 if {[info exists idtags($id)]} {
8672 set tagloc($id) $id
8673 set ta 1
8674 } elseif {[info exists cached_dtags($id)]} {
8675 set tagloc($id) $cached_dtags($id)
8676 set ta 1
8679 foreach a $arcnos($id) {
8680 set d $arcstart($a)
8681 if {!$ta && $arctags($a) ne {}} {
8682 validate_arctags $a
8683 if {$arctags($a) ne {}} {
8684 lappend tagloc($id) [lindex $arctags($a) end]
8687 if {$ta || $arctags($a) ne {}} {
8688 set tomark [list $d]
8689 for {set j 0} {$j < [llength $tomark]} {incr j} {
8690 set dd [lindex $tomark $j]
8691 if {![info exists hastaggedancestor($dd)]} {
8692 if {[info exists done($dd)]} {
8693 foreach b $arcnos($dd) {
8694 lappend tomark $arcstart($b)
8696 if {[info exists tagloc($dd)]} {
8697 unset tagloc($dd)
8699 } elseif {[info exists queued($dd)]} {
8700 incr nc -1
8702 set hastaggedancestor($dd) 1
8706 if {![info exists queued($d)]} {
8707 lappend todo $d
8708 set queued($d) 1
8709 if {![info exists hastaggedancestor($d)]} {
8710 incr nc
8715 set tags {}
8716 foreach id [array names tagloc] {
8717 if {![info exists hastaggedancestor($id)]} {
8718 foreach t $tagloc($id) {
8719 if {[lsearch -exact $tags $t] < 0} {
8720 lappend tags $t
8725 set t2 [clock clicks -milliseconds]
8726 set loopix $i
8728 # remove tags that are descendents of other tags
8729 for {set i 0} {$i < [llength $tags]} {incr i} {
8730 set a [lindex $tags $i]
8731 for {set j 0} {$j < $i} {incr j} {
8732 set b [lindex $tags $j]
8733 set r [anc_or_desc $a $b]
8734 if {$r == 1} {
8735 set tags [lreplace $tags $j $j]
8736 incr j -1
8737 incr i -1
8738 } elseif {$r == -1} {
8739 set tags [lreplace $tags $i $i]
8740 incr i -1
8741 break
8746 if {[array names growing] ne {}} {
8747 # graph isn't finished, need to check if any tag could get
8748 # eclipsed by another tag coming later. Simply ignore any
8749 # tags that could later get eclipsed.
8750 set ctags {}
8751 foreach t $tags {
8752 if {[is_certain $t $origid]} {
8753 lappend ctags $t
8756 if {$tags eq $ctags} {
8757 set cached_dtags($origid) $tags
8758 } else {
8759 set tags $ctags
8761 } else {
8762 set cached_dtags($origid) $tags
8764 set t3 [clock clicks -milliseconds]
8765 if {0 && $t3 - $t1 >= 100} {
8766 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8767 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8769 return $tags
8772 proc anctags {id} {
8773 global arcnos arcids arcout arcend arctags idtags allparents
8774 global growing cached_atags
8776 if {![info exists allparents($id)]} {
8777 return {}
8779 set t1 [clock clicks -milliseconds]
8780 set argid $id
8781 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8782 # part-way along an arc; check that arc first
8783 set a [lindex $arcnos($id) 0]
8784 if {$arctags($a) ne {}} {
8785 validate_arctags $a
8786 set i [lsearch -exact $arcids($a) $id]
8787 foreach t $arctags($a) {
8788 set j [lsearch -exact $arcids($a) $t]
8789 if {$j > $i} {
8790 return $t
8794 if {![info exists arcend($a)]} {
8795 return {}
8797 set id $arcend($a)
8798 if {[info exists idtags($id)]} {
8799 return $id
8802 if {[info exists cached_atags($id)]} {
8803 return $cached_atags($id)
8806 set origid $id
8807 set todo [list $id]
8808 set queued($id) 1
8809 set taglist {}
8810 set nc 1
8811 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8812 set id [lindex $todo $i]
8813 set done($id) 1
8814 set td [info exists hastaggeddescendent($id)]
8815 if {!$td} {
8816 incr nc -1
8818 # ignore tags on starting node
8819 if {!$td && $i > 0} {
8820 if {[info exists idtags($id)]} {
8821 set tagloc($id) $id
8822 set td 1
8823 } elseif {[info exists cached_atags($id)]} {
8824 set tagloc($id) $cached_atags($id)
8825 set td 1
8828 foreach a $arcout($id) {
8829 if {!$td && $arctags($a) ne {}} {
8830 validate_arctags $a
8831 if {$arctags($a) ne {}} {
8832 lappend tagloc($id) [lindex $arctags($a) 0]
8835 if {![info exists arcend($a)]} continue
8836 set d $arcend($a)
8837 if {$td || $arctags($a) ne {}} {
8838 set tomark [list $d]
8839 for {set j 0} {$j < [llength $tomark]} {incr j} {
8840 set dd [lindex $tomark $j]
8841 if {![info exists hastaggeddescendent($dd)]} {
8842 if {[info exists done($dd)]} {
8843 foreach b $arcout($dd) {
8844 if {[info exists arcend($b)]} {
8845 lappend tomark $arcend($b)
8848 if {[info exists tagloc($dd)]} {
8849 unset tagloc($dd)
8851 } elseif {[info exists queued($dd)]} {
8852 incr nc -1
8854 set hastaggeddescendent($dd) 1
8858 if {![info exists queued($d)]} {
8859 lappend todo $d
8860 set queued($d) 1
8861 if {![info exists hastaggeddescendent($d)]} {
8862 incr nc
8867 set t2 [clock clicks -milliseconds]
8868 set loopix $i
8869 set tags {}
8870 foreach id [array names tagloc] {
8871 if {![info exists hastaggeddescendent($id)]} {
8872 foreach t $tagloc($id) {
8873 if {[lsearch -exact $tags $t] < 0} {
8874 lappend tags $t
8880 # remove tags that are ancestors of other tags
8881 for {set i 0} {$i < [llength $tags]} {incr i} {
8882 set a [lindex $tags $i]
8883 for {set j 0} {$j < $i} {incr j} {
8884 set b [lindex $tags $j]
8885 set r [anc_or_desc $a $b]
8886 if {$r == -1} {
8887 set tags [lreplace $tags $j $j]
8888 incr j -1
8889 incr i -1
8890 } elseif {$r == 1} {
8891 set tags [lreplace $tags $i $i]
8892 incr i -1
8893 break
8898 if {[array names growing] ne {}} {
8899 # graph isn't finished, need to check if any tag could get
8900 # eclipsed by another tag coming later. Simply ignore any
8901 # tags that could later get eclipsed.
8902 set ctags {}
8903 foreach t $tags {
8904 if {[is_certain $origid $t]} {
8905 lappend ctags $t
8908 if {$tags eq $ctags} {
8909 set cached_atags($origid) $tags
8910 } else {
8911 set tags $ctags
8913 } else {
8914 set cached_atags($origid) $tags
8916 set t3 [clock clicks -milliseconds]
8917 if {0 && $t3 - $t1 >= 100} {
8918 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8919 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8921 return $tags
8924 # Return the list of IDs that have heads that are descendents of id,
8925 # including id itself if it has a head.
8926 proc descheads {id} {
8927 global arcnos arcstart arcids archeads idheads cached_dheads
8928 global allparents
8930 if {![info exists allparents($id)]} {
8931 return {}
8933 set aret {}
8934 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8935 # part-way along an arc; check it first
8936 set a [lindex $arcnos($id) 0]
8937 if {$archeads($a) ne {}} {
8938 validate_archeads $a
8939 set i [lsearch -exact $arcids($a) $id]
8940 foreach t $archeads($a) {
8941 set j [lsearch -exact $arcids($a) $t]
8942 if {$j > $i} break
8943 lappend aret $t
8946 set id $arcstart($a)
8948 set origid $id
8949 set todo [list $id]
8950 set seen($id) 1
8951 set ret {}
8952 for {set i 0} {$i < [llength $todo]} {incr i} {
8953 set id [lindex $todo $i]
8954 if {[info exists cached_dheads($id)]} {
8955 set ret [concat $ret $cached_dheads($id)]
8956 } else {
8957 if {[info exists idheads($id)]} {
8958 lappend ret $id
8960 foreach a $arcnos($id) {
8961 if {$archeads($a) ne {}} {
8962 validate_archeads $a
8963 if {$archeads($a) ne {}} {
8964 set ret [concat $ret $archeads($a)]
8967 set d $arcstart($a)
8968 if {![info exists seen($d)]} {
8969 lappend todo $d
8970 set seen($d) 1
8975 set ret [lsort -unique $ret]
8976 set cached_dheads($origid) $ret
8977 return [concat $ret $aret]
8980 proc addedtag {id} {
8981 global arcnos arcout cached_dtags cached_atags
8983 if {![info exists arcnos($id)]} return
8984 if {![info exists arcout($id)]} {
8985 recalcarc [lindex $arcnos($id) 0]
8987 catch {unset cached_dtags}
8988 catch {unset cached_atags}
8991 proc addedhead {hid head} {
8992 global arcnos arcout cached_dheads
8994 if {![info exists arcnos($hid)]} return
8995 if {![info exists arcout($hid)]} {
8996 recalcarc [lindex $arcnos($hid) 0]
8998 catch {unset cached_dheads}
9001 proc removedhead {hid head} {
9002 global cached_dheads
9004 catch {unset cached_dheads}
9007 proc movedhead {hid head} {
9008 global arcnos arcout cached_dheads
9010 if {![info exists arcnos($hid)]} return
9011 if {![info exists arcout($hid)]} {
9012 recalcarc [lindex $arcnos($hid) 0]
9014 catch {unset cached_dheads}
9017 proc changedrefs {} {
9018 global cached_dheads cached_dtags cached_atags
9019 global arctags archeads arcnos arcout idheads idtags
9021 foreach id [concat [array names idheads] [array names idtags]] {
9022 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9023 set a [lindex $arcnos($id) 0]
9024 if {![info exists donearc($a)]} {
9025 recalcarc $a
9026 set donearc($a) 1
9030 catch {unset cached_dtags}
9031 catch {unset cached_atags}
9032 catch {unset cached_dheads}
9035 proc rereadrefs {} {
9036 global idtags idheads idotherrefs mainheadid
9038 set refids [concat [array names idtags] \
9039 [array names idheads] [array names idotherrefs]]
9040 foreach id $refids {
9041 if {![info exists ref($id)]} {
9042 set ref($id) [listrefs $id]
9045 set oldmainhead $mainheadid
9046 readrefs
9047 changedrefs
9048 set refids [lsort -unique [concat $refids [array names idtags] \
9049 [array names idheads] [array names idotherrefs]]]
9050 foreach id $refids {
9051 set v [listrefs $id]
9052 if {![info exists ref($id)] || $ref($id) != $v} {
9053 redrawtags $id
9056 if {$oldmainhead ne $mainheadid} {
9057 redrawtags $oldmainhead
9058 redrawtags $mainheadid
9060 run refill_reflist
9063 proc listrefs {id} {
9064 global idtags idheads idotherrefs
9066 set x {}
9067 if {[info exists idtags($id)]} {
9068 set x $idtags($id)
9070 set y {}
9071 if {[info exists idheads($id)]} {
9072 set y $idheads($id)
9074 set z {}
9075 if {[info exists idotherrefs($id)]} {
9076 set z $idotherrefs($id)
9078 return [list $x $y $z]
9081 proc showtag {tag isnew} {
9082 global ctext tagcontents tagids linknum tagobjid
9084 if {$isnew} {
9085 addtohistory [list showtag $tag 0]
9087 $ctext conf -state normal
9088 clear_ctext
9089 settabs 0
9090 set linknum 0
9091 if {![info exists tagcontents($tag)]} {
9092 catch {
9093 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9096 if {[info exists tagcontents($tag)]} {
9097 set text $tagcontents($tag)
9098 } else {
9099 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
9101 appendwithlinks $text {}
9102 $ctext conf -state disabled
9103 init_flist {}
9106 proc doquit {} {
9107 global stopped
9108 global gitktmpdir
9110 set stopped 100
9111 savestuff .
9112 destroy .
9114 if {[info exists gitktmpdir]} {
9115 catch {file delete -force $gitktmpdir}
9119 proc mkfontdisp {font top which} {
9120 global fontattr fontpref $font
9122 set fontpref($font) [set $font]
9123 button $top.${font}but -text $which -font optionfont \
9124 -command [list choosefont $font $which]
9125 label $top.$font -relief flat -font $font \
9126 -text $fontattr($font,family) -justify left
9127 grid x $top.${font}but $top.$font -sticky w
9130 proc choosefont {font which} {
9131 global fontparam fontlist fonttop fontattr
9133 set fontparam(which) $which
9134 set fontparam(font) $font
9135 set fontparam(family) [font actual $font -family]
9136 set fontparam(size) $fontattr($font,size)
9137 set fontparam(weight) $fontattr($font,weight)
9138 set fontparam(slant) $fontattr($font,slant)
9139 set top .gitkfont
9140 set fonttop $top
9141 if {![winfo exists $top]} {
9142 font create sample
9143 eval font config sample [font actual $font]
9144 toplevel $top
9145 wm title $top [mc "Gitk font chooser"]
9146 label $top.l -textvariable fontparam(which)
9147 pack $top.l -side top
9148 set fontlist [lsort [font families]]
9149 frame $top.f
9150 listbox $top.f.fam -listvariable fontlist \
9151 -yscrollcommand [list $top.f.sb set]
9152 bind $top.f.fam <<ListboxSelect>> selfontfam
9153 scrollbar $top.f.sb -command [list $top.f.fam yview]
9154 pack $top.f.sb -side right -fill y
9155 pack $top.f.fam -side left -fill both -expand 1
9156 pack $top.f -side top -fill both -expand 1
9157 frame $top.g
9158 spinbox $top.g.size -from 4 -to 40 -width 4 \
9159 -textvariable fontparam(size) \
9160 -validatecommand {string is integer -strict %s}
9161 checkbutton $top.g.bold -padx 5 \
9162 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9163 -variable fontparam(weight) -onvalue bold -offvalue normal
9164 checkbutton $top.g.ital -padx 5 \
9165 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
9166 -variable fontparam(slant) -onvalue italic -offvalue roman
9167 pack $top.g.size $top.g.bold $top.g.ital -side left
9168 pack $top.g -side top
9169 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9170 -background white
9171 $top.c create text 100 25 -anchor center -text $which -font sample \
9172 -fill black -tags text
9173 bind $top.c <Configure> [list centertext $top.c]
9174 pack $top.c -side top -fill x
9175 frame $top.buts
9176 button $top.buts.ok -text [mc "OK"] -command fontok -default active
9177 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9178 grid $top.buts.ok $top.buts.can
9179 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9180 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9181 pack $top.buts -side bottom -fill x
9182 trace add variable fontparam write chg_fontparam
9183 } else {
9184 raise $top
9185 $top.c itemconf text -text $which
9187 set i [lsearch -exact $fontlist $fontparam(family)]
9188 if {$i >= 0} {
9189 $top.f.fam selection set $i
9190 $top.f.fam see $i
9194 proc centertext {w} {
9195 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9198 proc fontok {} {
9199 global fontparam fontpref prefstop
9201 set f $fontparam(font)
9202 set fontpref($f) [list $fontparam(family) $fontparam(size)]
9203 if {$fontparam(weight) eq "bold"} {
9204 lappend fontpref($f) "bold"
9206 if {$fontparam(slant) eq "italic"} {
9207 lappend fontpref($f) "italic"
9209 set w $prefstop.$f
9210 $w conf -text $fontparam(family) -font $fontpref($f)
9212 fontcan
9215 proc fontcan {} {
9216 global fonttop fontparam
9218 if {[info exists fonttop]} {
9219 catch {destroy $fonttop}
9220 catch {font delete sample}
9221 unset fonttop
9222 unset fontparam
9226 proc selfontfam {} {
9227 global fonttop fontparam
9229 set i [$fonttop.f.fam curselection]
9230 if {$i ne {}} {
9231 set fontparam(family) [$fonttop.f.fam get $i]
9235 proc chg_fontparam {v sub op} {
9236 global fontparam
9238 font config sample -$sub $fontparam($sub)
9241 proc doprefs {} {
9242 global maxwidth maxgraphpct
9243 global oldprefs prefstop showneartags showlocalchanges
9244 global bgcolor fgcolor ctext diffcolors selectbgcolor
9245 global tabstop limitdiffs autoselect extdifftool
9247 set top .gitkprefs
9248 set prefstop $top
9249 if {[winfo exists $top]} {
9250 raise $top
9251 return
9253 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9254 limitdiffs tabstop} {
9255 set oldprefs($v) [set $v]
9257 toplevel $top
9258 wm title $top [mc "Gitk preferences"]
9259 label $top.ldisp -text [mc "Commit list display options"]
9260 grid $top.ldisp - -sticky w -pady 10
9261 label $top.spacer -text " "
9262 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9263 -font optionfont
9264 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9265 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9266 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9267 -font optionfont
9268 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9269 grid x $top.maxpctl $top.maxpct -sticky w
9270 frame $top.showlocal
9271 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9272 checkbutton $top.showlocal.b -variable showlocalchanges
9273 pack $top.showlocal.b $top.showlocal.l -side left
9274 grid x $top.showlocal -sticky w
9275 frame $top.autoselect
9276 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9277 checkbutton $top.autoselect.b -variable autoselect
9278 pack $top.autoselect.b $top.autoselect.l -side left
9279 grid x $top.autoselect -sticky w
9281 label $top.ddisp -text [mc "Diff display options"]
9282 grid $top.ddisp - -sticky w -pady 10
9283 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9284 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9285 grid x $top.tabstopl $top.tabstop -sticky w
9286 frame $top.ntag
9287 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9288 checkbutton $top.ntag.b -variable showneartags
9289 pack $top.ntag.b $top.ntag.l -side left
9290 grid x $top.ntag -sticky w
9291 frame $top.ldiff
9292 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9293 checkbutton $top.ldiff.b -variable limitdiffs
9294 pack $top.ldiff.b $top.ldiff.l -side left
9295 grid x $top.ldiff -sticky w
9297 entry $top.extdifft -textvariable extdifftool
9298 frame $top.extdifff
9299 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9300 -padx 10
9301 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9302 -command choose_extdiff
9303 pack $top.extdifff.l $top.extdifff.b -side left
9304 grid x $top.extdifff $top.extdifft -sticky w
9306 label $top.cdisp -text [mc "Colors: press to choose"]
9307 grid $top.cdisp - -sticky w -pady 10
9308 label $top.bg -padx 40 -relief sunk -background $bgcolor
9309 button $top.bgbut -text [mc "Background"] -font optionfont \
9310 -command [list choosecolor bgcolor {} $top.bg background setbg]
9311 grid x $top.bgbut $top.bg -sticky w
9312 label $top.fg -padx 40 -relief sunk -background $fgcolor
9313 button $top.fgbut -text [mc "Foreground"] -font optionfont \
9314 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9315 grid x $top.fgbut $top.fg -sticky w
9316 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9317 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9318 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9319 [list $ctext tag conf d0 -foreground]]
9320 grid x $top.diffoldbut $top.diffold -sticky w
9321 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9322 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9323 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9324 [list $ctext tag conf d1 -foreground]]
9325 grid x $top.diffnewbut $top.diffnew -sticky w
9326 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9327 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9328 -command [list choosecolor diffcolors 2 $top.hunksep \
9329 "diff hunk header" \
9330 [list $ctext tag conf hunksep -foreground]]
9331 grid x $top.hunksepbut $top.hunksep -sticky w
9332 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9333 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9334 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9335 grid x $top.selbgbut $top.selbgsep -sticky w
9337 label $top.cfont -text [mc "Fonts: press to choose"]
9338 grid $top.cfont - -sticky w -pady 10
9339 mkfontdisp mainfont $top [mc "Main font"]
9340 mkfontdisp textfont $top [mc "Diff display font"]
9341 mkfontdisp uifont $top [mc "User interface font"]
9343 frame $top.buts
9344 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9345 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9346 grid $top.buts.ok $top.buts.can
9347 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9348 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9349 grid $top.buts - - -pady 10 -sticky ew
9350 bind $top <Visibility> "focus $top.buts.ok"
9353 proc choose_extdiff {} {
9354 global extdifftool
9356 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9357 if {$prog ne {}} {
9358 set extdifftool $prog
9362 proc choosecolor {v vi w x cmd} {
9363 global $v
9365 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9366 -title [mc "Gitk: choose color for %s" $x]]
9367 if {$c eq {}} return
9368 $w conf -background $c
9369 lset $v $vi $c
9370 eval $cmd $c
9373 proc setselbg {c} {
9374 global bglist cflist
9375 foreach w $bglist {
9376 $w configure -selectbackground $c
9378 $cflist tag configure highlight \
9379 -background [$cflist cget -selectbackground]
9380 allcanvs itemconf secsel -fill $c
9383 proc setbg {c} {
9384 global bglist
9386 foreach w $bglist {
9387 $w conf -background $c
9391 proc setfg {c} {
9392 global fglist canv
9394 foreach w $fglist {
9395 $w conf -foreground $c
9397 allcanvs itemconf text -fill $c
9398 $canv itemconf circle -outline $c
9401 proc prefscan {} {
9402 global oldprefs prefstop
9404 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9405 limitdiffs tabstop} {
9406 global $v
9407 set $v $oldprefs($v)
9409 catch {destroy $prefstop}
9410 unset prefstop
9411 fontcan
9414 proc prefsok {} {
9415 global maxwidth maxgraphpct
9416 global oldprefs prefstop showneartags showlocalchanges
9417 global fontpref mainfont textfont uifont
9418 global limitdiffs treediffs
9420 catch {destroy $prefstop}
9421 unset prefstop
9422 fontcan
9423 set fontchanged 0
9424 if {$mainfont ne $fontpref(mainfont)} {
9425 set mainfont $fontpref(mainfont)
9426 parsefont mainfont $mainfont
9427 eval font configure mainfont [fontflags mainfont]
9428 eval font configure mainfontbold [fontflags mainfont 1]
9429 setcoords
9430 set fontchanged 1
9432 if {$textfont ne $fontpref(textfont)} {
9433 set textfont $fontpref(textfont)
9434 parsefont textfont $textfont
9435 eval font configure textfont [fontflags textfont]
9436 eval font configure textfontbold [fontflags textfont 1]
9438 if {$uifont ne $fontpref(uifont)} {
9439 set uifont $fontpref(uifont)
9440 parsefont uifont $uifont
9441 eval font configure uifont [fontflags uifont]
9443 settabs
9444 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9445 if {$showlocalchanges} {
9446 doshowlocalchanges
9447 } else {
9448 dohidelocalchanges
9451 if {$limitdiffs != $oldprefs(limitdiffs)} {
9452 # treediffs elements are limited by path
9453 catch {unset treediffs}
9455 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9456 || $maxgraphpct != $oldprefs(maxgraphpct)} {
9457 redisplay
9458 } elseif {$showneartags != $oldprefs(showneartags) ||
9459 $limitdiffs != $oldprefs(limitdiffs)} {
9460 reselectline
9464 proc formatdate {d} {
9465 global datetimeformat
9466 if {$d ne {}} {
9467 set d [clock format $d -format $datetimeformat]
9469 return $d
9472 # This list of encoding names and aliases is distilled from
9473 # http://www.iana.org/assignments/character-sets.
9474 # Not all of them are supported by Tcl.
9475 set encoding_aliases {
9476 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9477 ISO646-US US-ASCII us IBM367 cp367 csASCII }
9478 { ISO-10646-UTF-1 csISO10646UTF1 }
9479 { ISO_646.basic:1983 ref csISO646basic1983 }
9480 { INVARIANT csINVARIANT }
9481 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9482 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9483 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9484 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9485 { NATS-DANO iso-ir-9-1 csNATSDANO }
9486 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9487 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9488 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9489 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9490 { ISO-2022-KR csISO2022KR }
9491 { EUC-KR csEUCKR }
9492 { ISO-2022-JP csISO2022JP }
9493 { ISO-2022-JP-2 csISO2022JP2 }
9494 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9495 csISO13JISC6220jp }
9496 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9497 { IT iso-ir-15 ISO646-IT csISO15Italian }
9498 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9499 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9500 { greek7-old iso-ir-18 csISO18Greek7Old }
9501 { latin-greek iso-ir-19 csISO19LatinGreek }
9502 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9503 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9504 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9505 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9506 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9507 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9508 { INIS iso-ir-49 csISO49INIS }
9509 { INIS-8 iso-ir-50 csISO50INIS8 }
9510 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9511 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9512 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9513 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9514 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9515 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9516 csISO60Norwegian1 }
9517 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9518 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9519 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9520 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9521 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9522 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9523 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9524 { greek7 iso-ir-88 csISO88Greek7 }
9525 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9526 { iso-ir-90 csISO90 }
9527 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9528 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9529 csISO92JISC62991984b }
9530 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9531 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9532 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9533 csISO95JIS62291984handadd }
9534 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9535 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9536 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9537 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9538 CP819 csISOLatin1 }
9539 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9540 { T.61-7bit iso-ir-102 csISO102T617bit }
9541 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9542 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9543 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9544 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9545 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9546 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9547 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9548 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9549 arabic csISOLatinArabic }
9550 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9551 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9552 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9553 greek greek8 csISOLatinGreek }
9554 { T.101-G2 iso-ir-128 csISO128T101G2 }
9555 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9556 csISOLatinHebrew }
9557 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9558 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9559 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9560 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9561 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9562 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9563 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9564 csISOLatinCyrillic }
9565 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9566 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9567 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9568 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9569 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9570 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9571 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9572 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9573 { ISO_10367-box iso-ir-155 csISO10367Box }
9574 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9575 { latin-lap lap iso-ir-158 csISO158Lap }
9576 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9577 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9578 { us-dk csUSDK }
9579 { dk-us csDKUS }
9580 { JIS_X0201 X0201 csHalfWidthKatakana }
9581 { KSC5636 ISO646-KR csKSC5636 }
9582 { ISO-10646-UCS-2 csUnicode }
9583 { ISO-10646-UCS-4 csUCS4 }
9584 { DEC-MCS dec csDECMCS }
9585 { hp-roman8 roman8 r8 csHPRoman8 }
9586 { macintosh mac csMacintosh }
9587 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9588 csIBM037 }
9589 { IBM038 EBCDIC-INT cp038 csIBM038 }
9590 { IBM273 CP273 csIBM273 }
9591 { IBM274 EBCDIC-BE CP274 csIBM274 }
9592 { IBM275 EBCDIC-BR cp275 csIBM275 }
9593 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9594 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9595 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9596 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9597 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9598 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9599 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9600 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9601 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9602 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9603 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9604 { IBM437 cp437 437 csPC8CodePage437 }
9605 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9606 { IBM775 cp775 csPC775Baltic }
9607 { IBM850 cp850 850 csPC850Multilingual }
9608 { IBM851 cp851 851 csIBM851 }
9609 { IBM852 cp852 852 csPCp852 }
9610 { IBM855 cp855 855 csIBM855 }
9611 { IBM857 cp857 857 csIBM857 }
9612 { IBM860 cp860 860 csIBM860 }
9613 { IBM861 cp861 861 cp-is csIBM861 }
9614 { IBM862 cp862 862 csPC862LatinHebrew }
9615 { IBM863 cp863 863 csIBM863 }
9616 { IBM864 cp864 csIBM864 }
9617 { IBM865 cp865 865 csIBM865 }
9618 { IBM866 cp866 866 csIBM866 }
9619 { IBM868 CP868 cp-ar csIBM868 }
9620 { IBM869 cp869 869 cp-gr csIBM869 }
9621 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9622 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9623 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9624 { IBM891 cp891 csIBM891 }
9625 { IBM903 cp903 csIBM903 }
9626 { IBM904 cp904 904 csIBBM904 }
9627 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9628 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9629 { IBM1026 CP1026 csIBM1026 }
9630 { EBCDIC-AT-DE csIBMEBCDICATDE }
9631 { EBCDIC-AT-DE-A csEBCDICATDEA }
9632 { EBCDIC-CA-FR csEBCDICCAFR }
9633 { EBCDIC-DK-NO csEBCDICDKNO }
9634 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9635 { EBCDIC-FI-SE csEBCDICFISE }
9636 { EBCDIC-FI-SE-A csEBCDICFISEA }
9637 { EBCDIC-FR csEBCDICFR }
9638 { EBCDIC-IT csEBCDICIT }
9639 { EBCDIC-PT csEBCDICPT }
9640 { EBCDIC-ES csEBCDICES }
9641 { EBCDIC-ES-A csEBCDICESA }
9642 { EBCDIC-ES-S csEBCDICESS }
9643 { EBCDIC-UK csEBCDICUK }
9644 { EBCDIC-US csEBCDICUS }
9645 { UNKNOWN-8BIT csUnknown8BiT }
9646 { MNEMONIC csMnemonic }
9647 { MNEM csMnem }
9648 { VISCII csVISCII }
9649 { VIQR csVIQR }
9650 { KOI8-R csKOI8R }
9651 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9652 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9653 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9654 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9655 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9656 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9657 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9658 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9659 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9660 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9661 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9662 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9663 { IBM1047 IBM-1047 }
9664 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9665 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9666 { UNICODE-1-1 csUnicode11 }
9667 { CESU-8 csCESU-8 }
9668 { BOCU-1 csBOCU-1 }
9669 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9670 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9671 l8 }
9672 { ISO-8859-15 ISO_8859-15 Latin-9 }
9673 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9674 { GBK CP936 MS936 windows-936 }
9675 { JIS_Encoding csJISEncoding }
9676 { Shift_JIS MS_Kanji csShiftJIS }
9677 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9678 EUC-JP }
9679 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9680 { ISO-10646-UCS-Basic csUnicodeASCII }
9681 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9682 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9683 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9684 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9685 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9686 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9687 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9688 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9689 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9690 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9691 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9692 { Ventura-US csVenturaUS }
9693 { Ventura-International csVenturaInternational }
9694 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9695 { PC8-Turkish csPC8Turkish }
9696 { IBM-Symbols csIBMSymbols }
9697 { IBM-Thai csIBMThai }
9698 { HP-Legal csHPLegal }
9699 { HP-Pi-font csHPPiFont }
9700 { HP-Math8 csHPMath8 }
9701 { Adobe-Symbol-Encoding csHPPSMath }
9702 { HP-DeskTop csHPDesktop }
9703 { Ventura-Math csVenturaMath }
9704 { Microsoft-Publishing csMicrosoftPublishing }
9705 { Windows-31J csWindows31J }
9706 { GB2312 csGB2312 }
9707 { Big5 csBig5 }
9710 proc tcl_encoding {enc} {
9711 global encoding_aliases
9712 set names [encoding names]
9713 set lcnames [string tolower $names]
9714 set enc [string tolower $enc]
9715 set i [lsearch -exact $lcnames $enc]
9716 if {$i < 0} {
9717 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9718 if {[regsub {^iso[-_]} $enc iso encx]} {
9719 set i [lsearch -exact $lcnames $encx]
9722 if {$i < 0} {
9723 foreach l $encoding_aliases {
9724 set ll [string tolower $l]
9725 if {[lsearch -exact $ll $enc] < 0} continue
9726 # look through the aliases for one that tcl knows about
9727 foreach e $ll {
9728 set i [lsearch -exact $lcnames $e]
9729 if {$i < 0} {
9730 if {[regsub {^iso[-_]} $e iso ex]} {
9731 set i [lsearch -exact $lcnames $ex]
9734 if {$i >= 0} break
9736 break
9739 if {$i >= 0} {
9740 return [lindex $names $i]
9742 return {}
9745 # First check that Tcl/Tk is recent enough
9746 if {[catch {package require Tk 8.4} err]} {
9747 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9748 Gitk requires at least Tcl/Tk 8.4."]
9749 exit 1
9752 # defaults...
9753 set wrcomcmd "git diff-tree --stdin -p --pretty"
9755 set gitencoding {}
9756 catch {
9757 set gitencoding [exec git config --get i18n.commitencoding]
9759 if {$gitencoding == ""} {
9760 set gitencoding "utf-8"
9762 set tclencoding [tcl_encoding $gitencoding]
9763 if {$tclencoding == {}} {
9764 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9767 set mainfont {Helvetica 9}
9768 set textfont {Courier 9}
9769 set uifont {Helvetica 9 bold}
9770 set tabstop 8
9771 set findmergefiles 0
9772 set maxgraphpct 50
9773 set maxwidth 16
9774 set revlistorder 0
9775 set fastdate 0
9776 set uparrowlen 5
9777 set downarrowlen 5
9778 set mingaplen 100
9779 set cmitmode "patch"
9780 set wrapcomment "none"
9781 set showneartags 1
9782 set maxrefs 20
9783 set maxlinelen 200
9784 set showlocalchanges 1
9785 set limitdiffs 1
9786 set datetimeformat "%Y-%m-%d %H:%M:%S"
9787 set autoselect 1
9789 set extdifftool "meld"
9791 set colors {green red blue magenta darkgrey brown orange}
9792 set bgcolor white
9793 set fgcolor black
9794 set diffcolors {red "#00a000" blue}
9795 set diffcontext 3
9796 set ignorespace 0
9797 set selectbgcolor gray85
9799 set circlecolors {white blue gray blue blue}
9801 ## For msgcat loading, first locate the installation location.
9802 if { [info exists ::env(GITK_MSGSDIR)] } {
9803 ## Msgsdir was manually set in the environment.
9804 set gitk_msgsdir $::env(GITK_MSGSDIR)
9805 } else {
9806 ## Let's guess the prefix from argv0.
9807 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9808 set gitk_libdir [file join $gitk_prefix share gitk lib]
9809 set gitk_msgsdir [file join $gitk_libdir msgs]
9810 unset gitk_prefix
9813 ## Internationalization (i18n) through msgcat and gettext. See
9814 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9815 package require msgcat
9816 namespace import ::msgcat::mc
9817 ## And eventually load the actual message catalog
9818 ::msgcat::mcload $gitk_msgsdir
9820 catch {source ~/.gitk}
9822 font create optionfont -family sans-serif -size -12
9824 parsefont mainfont $mainfont
9825 eval font create mainfont [fontflags mainfont]
9826 eval font create mainfontbold [fontflags mainfont 1]
9828 parsefont textfont $textfont
9829 eval font create textfont [fontflags textfont]
9830 eval font create textfontbold [fontflags textfont 1]
9832 parsefont uifont $uifont
9833 eval font create uifont [fontflags uifont]
9835 setoptions
9837 # check that we can find a .git directory somewhere...
9838 if {[catch {set gitdir [gitdir]}]} {
9839 show_error {} . [mc "Cannot find a git repository here."]
9840 exit 1
9842 if {![file isdirectory $gitdir]} {
9843 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9844 exit 1
9847 set revtreeargs {}
9848 set cmdline_files {}
9849 set i 0
9850 set revtreeargscmd {}
9851 foreach arg $argv {
9852 switch -glob -- $arg {
9853 "" { }
9854 "--" {
9855 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9856 break
9858 "--argscmd=*" {
9859 set revtreeargscmd [string range $arg 10 end]
9861 default {
9862 lappend revtreeargs $arg
9865 incr i
9868 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9869 # no -- on command line, but some arguments (other than --argscmd)
9870 if {[catch {
9871 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9872 set cmdline_files [split $f "\n"]
9873 set n [llength $cmdline_files]
9874 set revtreeargs [lrange $revtreeargs 0 end-$n]
9875 # Unfortunately git rev-parse doesn't produce an error when
9876 # something is both a revision and a filename. To be consistent
9877 # with git log and git rev-list, check revtreeargs for filenames.
9878 foreach arg $revtreeargs {
9879 if {[file exists $arg]} {
9880 show_error {} . [mc "Ambiguous argument '%s': both revision\
9881 and filename" $arg]
9882 exit 1
9885 } err]} {
9886 # unfortunately we get both stdout and stderr in $err,
9887 # so look for "fatal:".
9888 set i [string first "fatal:" $err]
9889 if {$i > 0} {
9890 set err [string range $err [expr {$i + 6}] end]
9892 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9893 exit 1
9897 set nullid "0000000000000000000000000000000000000000"
9898 set nullid2 "0000000000000000000000000000000000000001"
9899 set nullfile "/dev/null"
9901 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9903 set runq {}
9904 set history {}
9905 set historyindex 0
9906 set fh_serial 0
9907 set nhl_names {}
9908 set highlight_paths {}
9909 set findpattern {}
9910 set searchdirn -forwards
9911 set boldrows {}
9912 set boldnamerows {}
9913 set diffelide {0 0}
9914 set markingmatches 0
9915 set linkentercount 0
9916 set need_redisplay 0
9917 set nrows_drawn 0
9918 set firsttabstop 0
9920 set nextviewnum 1
9921 set curview 0
9922 set selectedview 0
9923 set selectedhlview [mc "None"]
9924 set highlight_related [mc "None"]
9925 set highlight_files {}
9926 set viewfiles(0) {}
9927 set viewperm(0) 0
9928 set viewargs(0) {}
9929 set viewargscmd(0) {}
9931 set selectedline {}
9932 set numcommits 0
9933 set loginstance 0
9934 set cmdlineok 0
9935 set stopped 0
9936 set stuffsaved 0
9937 set patchnum 0
9938 set lserial 0
9939 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9940 setcoords
9941 makewindow
9942 # wait for the window to become visible
9943 tkwait visibility .
9944 wm title . "[file tail $argv0]: [file tail [pwd]]"
9945 readrefs
9947 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9948 # create a view for the files/dirs specified on the command line
9949 set curview 1
9950 set selectedview 1
9951 set nextviewnum 2
9952 set viewname(1) [mc "Command line"]
9953 set viewfiles(1) $cmdline_files
9954 set viewargs(1) $revtreeargs
9955 set viewargscmd(1) $revtreeargscmd
9956 set viewperm(1) 0
9957 set vdatemode(1) 0
9958 addviewmenu 1
9959 .bar.view entryconf [mc "Edit view..."] -state normal
9960 .bar.view entryconf [mc "Delete view"] -state normal
9963 if {[info exists permviews]} {
9964 foreach v $permviews {
9965 set n $nextviewnum
9966 incr nextviewnum
9967 set viewname($n) [lindex $v 0]
9968 set viewfiles($n) [lindex $v 1]
9969 set viewargs($n) [lindex $v 2]
9970 set viewargscmd($n) [lindex $v 3]
9971 set viewperm($n) 1
9972 addviewmenu $n
9975 getcommits